From 61ccbc81a2f3b4662ed4a2bad9d07d2003dda3a2 Mon Sep 17 00:00:00 2001 From: glondu Date: Thu, 17 Sep 2009 15:58:14 +0000 Subject: Delete trailing whitespaces in all *.{v,ml*} files git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@12337 85f007b7-540e-0410-9357-904b9bb8a0f7 --- checker/check.ml | 34 +- checker/check_stat.ml | 4 +- checker/checker.ml | 80 +- checker/closure.ml | 36 +- checker/closure.mli | 4 +- checker/declarations.ml | 170 +-- checker/declarations.mli | 24 +- checker/environ.ml | 50 +- checker/indtypes.ml | 100 +- checker/inductive.ml | 146 +-- checker/mod_checking.ml | 78 +- checker/modops.ml | 128 +- checker/modops.mli | 10 +- checker/reduction.ml | 40 +- checker/reduction.mli | 2 +- checker/safe_typing.ml | 24 +- checker/subtyping.ml | 102 +- checker/term.ml | 72 +- checker/type_errors.ml | 4 +- checker/type_errors.mli | 12 +- checker/typeops.ml | 62 +- dev/ocamlweb-doc/ast.ml | 4 +- dev/ocamlweb-doc/lex.mll | 4 +- dev/ocamlweb-doc/parse.ml | 2 +- dev/printers.mllib | 14 +- dev/top_printers.ml | 80 +- dev/vm_printers.ml | 18 +- doc/RecTutorial/RecTutorial.v | 202 ++-- doc/faq/interval_discr.v | 24 +- ide/command_windows.ml | 64 +- ide/config_lexer.mll | 8 +- ide/coq.ml | 124 +- ide/coq.mli | 8 +- ide/coq_commands.ml | 16 +- ide/coqide.ml | 1276 ++++++++++---------- ide/coqide.mli | 2 +- ide/gtk_parsing.ml | 38 +- ide/highlight.mll | 54 +- ide/ideutils.ml | 122 +- ide/preferences.ml | 254 ++-- ide/tags.ml | 2 +- ide/typed_notebook.ml | 2 +- ide/undo.ml | 66 +- ide/undo_lablgtk_ge212.mli | 2 +- ide/undo_lablgtk_ge26.mli | 2 +- ide/undo_lablgtk_lt26.mli | 2 +- ide/utf8_convert.mll | 10 +- ide/utils/configwin.mli | 2 +- ide/utils/configwin_ihm.ml | 24 +- ide/utils/configwin_keys.ml | 50 +- ide/utils/configwin_types.ml | 6 +- ide/utils/editable_cells.ml | 92 +- ide/utils/okey.mli | 64 +- interp/constrextern.ml | 92 +- interp/constrextern.mli | 4 +- interp/constrintern.ml | 252 ++-- interp/constrintern.mli | 24 +- interp/coqlib.ml | 12 +- interp/dumpglob.ml | 36 +- interp/genarg.ml | 2 +- interp/genarg.mli | 22 +- interp/implicit_quantifiers.ml | 136 +-- interp/interp.mllib | 6 +- interp/modintern.ml | 32 +- interp/modintern.mli | 2 +- interp/notation.ml | 68 +- interp/notation.mli | 20 +- interp/ppextend.ml | 2 +- interp/ppextend.mli | 2 +- interp/reserve.ml | 12 +- interp/smartlocate.ml | 4 +- interp/syntax_def.mli | 2 +- interp/topconstr.ml | 146 +-- interp/topconstr.mli | 24 +- kernel/cbytecodes.ml | 60 +- kernel/cbytecodes.mli | 50 +- kernel/cbytegen.ml | 292 ++--- kernel/cbytegen.mli | 12 +- kernel/cemitcodes.ml | 52 +- kernel/cemitcodes.mli | 16 +- kernel/closure.ml | 30 +- kernel/closure.mli | 4 +- kernel/cooking.ml | 22 +- kernel/cooking.mli | 4 +- kernel/csymtable.ml | 68 +- kernel/csymtable.mli | 2 +- kernel/declarations.ml | 42 +- kernel/declarations.mli | 24 +- kernel/entries.ml | 8 +- kernel/entries.mli | 6 +- kernel/environ.ml | 194 +-- kernel/environ.mli | 26 +- kernel/esubst.ml | 2 +- kernel/esubst.mli | 2 +- kernel/indtypes.ml | 142 +-- kernel/inductive.ml | 160 +-- kernel/inductive.mli | 2 +- kernel/mod_subst.ml | 132 +- kernel/mod_subst.mli | 14 +- kernel/mod_typing.ml | 144 +-- kernel/mod_typing.mli | 2 +- kernel/modops.ml | 196 +-- kernel/modops.mli | 24 +- kernel/names.ml | 48 +- kernel/names.mli | 12 +- kernel/pre_env.ml | 26 +- kernel/pre_env.mli | 14 +- kernel/reduction.ml | 50 +- kernel/reduction.mli | 6 +- kernel/retroknowledge.ml | 28 +- kernel/retroknowledge.mli | 38 +- kernel/safe_typing.ml | 200 +-- kernel/safe_typing.mli | 30 +- kernel/subtyping.ml | 122 +- kernel/term.ml | 212 ++-- kernel/term.mli | 38 +- kernel/term_typing.ml | 20 +- kernel/term_typing.mli | 8 +- kernel/type_errors.ml | 4 +- kernel/type_errors.mli | 12 +- kernel/typeops.ml | 78 +- kernel/typeops.mli | 16 +- kernel/univ.ml | 122 +- kernel/univ.mli | 6 +- kernel/vconv.ml | 74 +- kernel/vm.ml | 172 +-- kernel/vm.mli | 24 +- lib/bigint.ml | 26 +- lib/bstack.ml | 6 +- lib/compat.ml4 | 8 +- lib/dnet.ml | 58 +- lib/dnet.mli | 18 +- lib/dyn.ml | 2 +- lib/edit.ml | 16 +- lib/envars.ml | 50 +- lib/explore.ml | 18 +- lib/explore.mli | 8 +- lib/flags.ml | 4 +- lib/gmapl.ml | 2 +- lib/hashcons.ml | 6 +- lib/heap.ml | 54 +- lib/heap.mli | 20 +- lib/lib.mllib | 12 +- lib/option.ml | 28 +- lib/option.mli | 14 +- lib/pp.ml4 | 22 +- lib/pp.mli | 2 +- lib/pp_control.ml | 14 +- lib/pp_control.mli | 4 +- lib/predicate.ml | 2 +- lib/profile.ml | 54 +- lib/profile.mli | 6 +- lib/refutpat.ml4 | 2 +- lib/rtree.ml | 12 +- lib/rtree.mli | 4 +- lib/system.ml | 60 +- lib/system.mli | 8 +- lib/tlm.ml | 26 +- lib/util.ml | 340 +++--- lib/util.mli | 20 +- library/decl_kinds.ml | 2 +- library/decl_kinds.mli | 2 +- library/declare.ml | 16 +- library/declare.mli | 4 +- library/declaremods.ml | 334 ++--- library/declaremods.mli | 22 +- library/decls.ml | 2 +- library/decls.mli | 2 +- library/dischargedhypsmap.ml | 4 +- library/global.ml | 20 +- library/global.mli | 8 +- library/goptions.ml | 74 +- library/goptions.mli | 10 +- library/heads.ml | 22 +- library/impargs.ml | 96 +- library/impargs.mli | 8 +- library/lib.ml | 172 +-- library/lib.mli | 12 +- library/libnames.ml | 30 +- library/libnames.mli | 8 +- library/libobject.ml | 50 +- library/libobject.mli | 20 +- library/library.ml | 80 +- library/library.mllib | 2 +- library/nameops.ml | 32 +- library/nametab.ml | 132 +- library/nametab.mli | 22 +- library/states.ml | 4 +- library/states.mli | 4 +- library/summary.ml | 10 +- myocamlbuild.ml | 6 +- parsing/argextend.ml4 | 22 +- parsing/egrammar.ml | 32 +- parsing/egrammar.mli | 6 +- parsing/g_constr.ml4 | 80 +- parsing/g_decl_mode.ml4 | 96 +- parsing/g_ltac.ml4 | 22 +- parsing/g_prim.ml4 | 4 +- parsing/g_proofs.ml4 | 18 +- parsing/g_tactic.ml4 | 70 +- parsing/g_vernac.ml4 | 182 +-- parsing/g_xml.ml4 | 16 +- parsing/grammar.mllib | 6 +- parsing/lexer.ml4 | 64 +- parsing/pcoq.ml4 | 34 +- parsing/pcoq.mli | 22 +- parsing/ppconstr.ml | 76 +- parsing/ppconstr.mli | 18 +- parsing/ppdecl_proof.ml | 116 +- parsing/ppdecl_proof.mli | 2 +- parsing/pptactic.ml | 146 +-- parsing/pptactic.mli | 16 +- parsing/ppvernac.ml | 196 +-- parsing/ppvernac.mli | 2 +- parsing/prettyp.ml | 214 ++-- parsing/printer.ml | 118 +- parsing/printer.mli | 4 +- parsing/printmod.ml | 76 +- parsing/q_constr.ml4 | 34 +- parsing/q_coqast.ml4 | 46 +- parsing/q_util.ml4 | 2 +- parsing/tacextend.ml4 | 10 +- parsing/tactic_printer.ml | 72 +- parsing/vernacextend.ml4 | 2 +- plugins/cc/ccalgo.ml | 390 +++--- plugins/cc/ccalgo.mli | 62 +- plugins/cc/ccproof.ml | 56 +- plugins/cc/ccproof.mli | 8 +- plugins/cc/cctac.ml | 184 +-- plugins/cc/cctac.mli | 2 +- plugins/cc/g_congruence.ml4 | 4 +- plugins/dp/Dp.v | 4 +- plugins/dp/dp.ml | 292 ++--- plugins/dp/dp_why.ml | 40 +- plugins/dp/dp_why.mli | 2 +- plugins/dp/dp_zenon.mll | 44 +- plugins/dp/fol.mli | 12 +- plugins/dp/g_dp.ml4 | 2 +- plugins/dp/test2.v | 6 +- plugins/dp/tests.v | 22 +- plugins/extraction/extraction.ml | 2 +- plugins/extraction/g_extraction.ml4 | 2 +- plugins/extraction/haskell.ml | 2 +- plugins/extraction/miniml.mli | 2 +- plugins/extraction/modutil.ml | 2 +- plugins/extraction/scheme.ml | 2 +- plugins/field/LegacyField_Compl.v | 4 +- plugins/field/LegacyField_Tactic.v | 10 +- plugins/field/LegacyField_Theory.v | 30 +- plugins/field/field.ml4 | 10 +- plugins/firstorder/formula.ml | 84 +- plugins/firstorder/formula.mli | 26 +- plugins/firstorder/g_ground.ml4 | 46 +- plugins/firstorder/ground.ml | 58 +- plugins/firstorder/ground_plugin.mllib | 2 +- plugins/firstorder/instances.ml | 72 +- plugins/firstorder/instances.mli | 4 +- plugins/firstorder/rules.ml | 56 +- plugins/firstorder/rules.mli | 2 +- plugins/firstorder/sequent.ml | 82 +- plugins/firstorder/sequent.mli | 6 +- plugins/firstorder/unify.ml | 72 +- plugins/fourier/Fourier_util.v | 50 +- plugins/fourier/fourier.ml | 20 +- plugins/fourier/fourierR.ml | 106 +- plugins/funind/Recdef.v | 12 +- plugins/funind/functional_principles_proofs.ml | 1168 +++++++++--------- plugins/funind/functional_principles_proofs.mli | 4 +- plugins/funind/functional_principles_types.ml | 480 ++++---- plugins/funind/functional_principles_types.mli | 16 +- plugins/funind/g_indfun.ml4 | 202 ++-- plugins/funind/indfun.ml | 600 ++++----- plugins/funind/indfun_common.ml | 232 ++-- plugins/funind/indfun_common.mli | 52 +- plugins/funind/invfun.ml | 670 +++++----- plugins/funind/merge.ml | 330 ++--- plugins/funind/rawterm_to_relation.ml | 1118 ++++++++--------- plugins/funind/rawterm_to_relation.mli | 4 +- plugins/funind/rawtermops.ml | 592 ++++----- plugins/funind/rawtermops.mli | 60 +- plugins/funind/recdef.ml | 744 ++++++------ plugins/groebner/GroebnerR.v | 72 +- plugins/groebner/GroebnerZ.v | 4 +- plugins/groebner/groebner.ml4 | 42 +- plugins/groebner/ideal.ml4 | 136 +-- plugins/groebner/polynom.ml | 128 +- plugins/groebner/utile.ml | 20 +- plugins/interface/blast.ml | 282 ++--- plugins/interface/centaur.ml4 | 58 +- plugins/interface/coqparser.ml | 70 +- plugins/interface/dad.ml | 32 +- plugins/interface/debug_tac.ml4 | 46 +- plugins/interface/depends.ml | 4 +- plugins/interface/history.ml | 50 +- plugins/interface/line_parser.ml4 | 24 +- plugins/interface/name_to_ast.ml | 46 +- plugins/interface/paths.ml | 2 +- plugins/interface/pbp.ml | 120 +- plugins/interface/showproof.ml | 264 ++-- plugins/interface/showproof_ct.ml | 24 +- plugins/interface/translate.ml | 12 +- plugins/interface/xlate.ml | 368 +++--- plugins/micromega/Env.v | 24 +- plugins/micromega/EnvRing.v | 26 +- plugins/micromega/OrderedRing.v | 2 +- plugins/micromega/Psatz.v | 30 +- plugins/micromega/QMicromega.v | 4 +- plugins/micromega/RMicromega.v | 2 +- plugins/micromega/Refl.v | 2 +- plugins/micromega/RingMicromega.v | 118 +- plugins/micromega/Tauto.v | 30 +- plugins/micromega/VarMap.v | 36 +- plugins/micromega/ZCoeff.v | 2 +- plugins/micromega/ZMicromega.v | 132 +- plugins/micromega/certificate.ml | 358 +++--- plugins/micromega/coq_micromega.ml | 736 +++++------ plugins/micromega/csdpcert.ml | 92 +- plugins/micromega/mfourier.ml | 516 ++++---- plugins/micromega/micromega.ml | 10 +- plugins/micromega/mutils.ml | 126 +- plugins/micromega/persistent_cache.ml | 76 +- plugins/micromega/sos.ml | 14 +- plugins/micromega/sos.mli | 2 +- plugins/micromega/sos_lib.ml | 10 +- plugins/omega/OmegaLemmas.v | 38 +- plugins/omega/PreOmega.v | 204 ++-- plugins/omega/coq_omega.ml | 622 +++++----- plugins/omega/g_omega.ml4 | 10 +- plugins/omega/omega.ml | 250 ++-- plugins/ring/LegacyArithRing.v | 4 +- plugins/ring/LegacyRing_theory.v | 20 +- plugins/ring/Ring_abstract.v | 14 +- plugins/ring/Ring_normalize.v | 28 +- plugins/ring/Setoid_ring_normalize.v | 22 +- plugins/ring/Setoid_ring_theory.v | 10 +- plugins/ring/g_ring.ml4 | 28 +- plugins/ring/ring.ml | 346 +++--- plugins/romega/ReflOmegaCore.v | 416 +++---- plugins/romega/const_omega.ml | 60 +- plugins/romega/const_omega.mli | 2 +- plugins/romega/g_romega.ml4 | 16 +- plugins/romega/refl_omega.ml | 498 ++++---- plugins/rtauto/Bintree.v | 72 +- plugins/rtauto/Rtauto.v | 92 +- plugins/rtauto/proof_search.ml | 166 +-- plugins/rtauto/proof_search.mli | 4 +- plugins/rtauto/refl_tauto.ml | 132 +- plugins/setoid_ring/ArithRing.v | 8 +- plugins/setoid_ring/BinList.v | 10 +- plugins/setoid_ring/Field_tac.v | 102 +- plugins/setoid_ring/Field_theory.v | 228 ++-- plugins/setoid_ring/InitialRing.v | 126 +- plugins/setoid_ring/RealField.v | 14 +- plugins/setoid_ring/Ring_polynom.v | 386 +++--- plugins/setoid_ring/Ring_tac.v | 54 +- plugins/setoid_ring/Ring_theory.v | 72 +- plugins/setoid_ring/ZArithRing.v | 10 +- plugins/setoid_ring/newring.ml4 | 98 +- plugins/subtac/equations.ml4 | 354 +++--- plugins/subtac/eterm.ml | 94 +- plugins/subtac/eterm.mli | 8 +- plugins/subtac/g_eterm.ml4 | 2 +- plugins/subtac/g_subtac.ml4 | 30 +- plugins/subtac/subtac.ml | 82 +- plugins/subtac/subtac_cases.ml | 324 ++--- plugins/subtac/subtac_classes.ml | 58 +- plugins/subtac/subtac_classes.mli | 2 +- plugins/subtac/subtac_coercion.ml | 142 +-- plugins/subtac/subtac_command.ml | 132 +- plugins/subtac/subtac_command.mli | 2 +- plugins/subtac/subtac_errors.ml | 6 +- plugins/subtac/subtac_obligations.ml | 208 ++-- plugins/subtac/subtac_obligations.mli | 14 +- plugins/subtac/subtac_pretyping.ml | 22 +- plugins/subtac/subtac_pretyping_F.ml | 130 +- plugins/subtac/subtac_utils.ml | 112 +- plugins/subtac/subtac_utils.mli | 4 +- plugins/subtac/test/ListDep.v | 8 +- plugins/subtac/test/ListsTest.v | 18 +- plugins/subtac/test/Mutind.v | 4 +- plugins/subtac/test/Test1.v | 2 +- plugins/subtac/test/euclid.v | 4 +- plugins/subtac/test/take.v | 2 +- plugins/subtac/test/wf.v | 2 +- plugins/syntax/ascii_syntax.ml | 8 +- plugins/syntax/nat_syntax.ml | 12 +- plugins/syntax/numbers_syntax.ml | 60 +- plugins/syntax/r_syntax.ml | 4 +- plugins/syntax/string_syntax.ml | 8 +- plugins/syntax/z_syntax.ml | 28 +- plugins/xml/acic.ml | 8 +- plugins/xml/acic2Xml.ml4 | 2 +- plugins/xml/cic2Xml.ml | 2 +- plugins/xml/cic2acic.ml | 26 +- plugins/xml/doubleTypeInference.ml | 44 +- plugins/xml/doubleTypeInference.mli | 2 +- plugins/xml/dumptree.ml4 | 22 +- plugins/xml/proof2aproof.ml | 20 +- plugins/xml/proofTree2Xml.ml4 | 6 +- plugins/xml/xmlcommand.ml | 32 +- pretyping/cases.ml | 174 +-- pretyping/cases.mli | 2 +- pretyping/cbv.ml | 20 +- pretyping/classops.ml | 58 +- pretyping/classops.mli | 18 +- pretyping/clenv.ml | 46 +- pretyping/clenv.mli | 4 +- pretyping/coercion.ml | 64 +- pretyping/coercion.mli | 18 +- pretyping/detyping.ml | 152 +-- pretyping/detyping.mli | 6 +- pretyping/evarconv.ml | 80 +- pretyping/evarconv.mli | 6 +- pretyping/evarutil.ml | 194 +-- pretyping/evarutil.mli | 10 +- pretyping/evd.ml | 114 +- pretyping/evd.mli | 18 +- pretyping/indrec.ml | 250 ++-- pretyping/indrec.mli | 4 +- pretyping/inductiveops.ml | 36 +- pretyping/inductiveops.mli | 2 +- pretyping/matching.ml | 22 +- pretyping/matching.mli | 6 +- pretyping/pattern.ml | 24 +- pretyping/pattern.mli | 2 +- pretyping/pretype_errors.ml | 8 +- pretyping/pretype_errors.mli | 14 +- pretyping/pretyping.ml | 178 +-- pretyping/pretyping.mli | 52 +- pretyping/rawterm.ml | 76 +- pretyping/rawterm.mli | 10 +- pretyping/recordops.ml | 68 +- pretyping/recordops.mli | 14 +- pretyping/reductionops.ml | 226 ++-- pretyping/reductionops.mli | 10 +- pretyping/retyping.ml | 6 +- pretyping/retyping.mli | 4 +- pretyping/tacred.ml | 150 +-- pretyping/tacred.mli | 6 +- pretyping/term_dnet.ml | 102 +- pretyping/term_dnet.mli | 14 +- pretyping/termops.ml | 208 ++-- pretyping/termops.mli | 26 +- pretyping/typeclasses.ml | 108 +- pretyping/typeclasses.mli | 14 +- pretyping/typeclasses_errors.ml | 6 +- pretyping/typeclasses_errors.mli | 2 +- pretyping/typing.ml | 40 +- pretyping/typing.mli | 4 +- pretyping/unification.ml | 222 ++-- pretyping/unification.mli | 4 +- pretyping/vnorm.ml | 96 +- proofs/clenvtac.ml | 24 +- proofs/decl_expr.mli | 22 +- proofs/decl_mode.ml | 40 +- proofs/decl_mode.mli | 6 +- proofs/evar_refiner.ml | 12 +- proofs/evar_refiner.mli | 4 +- proofs/logic.ml | 166 +-- proofs/logic.mli | 4 +- proofs/pfedit.ml | 78 +- proofs/pfedit.mli | 4 +- proofs/proof_trees.ml | 16 +- proofs/proof_type.ml | 6 +- proofs/proof_type.mli | 18 +- proofs/redexpr.ml | 20 +- proofs/refiner.ml | 248 ++-- proofs/refiner.mli | 12 +- proofs/tacexpr.ml | 28 +- proofs/tacmach.ml | 44 +- proofs/tacmach.mli | 4 +- proofs/tactic_debug.ml | 6 +- scripts/coqc.ml | 44 +- scripts/coqmktop.ml | 52 +- tactics/auto.ml | 370 +++--- tactics/auto.mli | 36 +- tactics/autorewrite.ml | 92 +- tactics/autorewrite.mli | 2 +- tactics/btermdn.ml | 54 +- tactics/btermdn.mli | 2 +- tactics/class_tactics.ml4 | 220 ++-- tactics/contradiction.ml | 6 +- tactics/decl_interp.ml | 226 ++-- tactics/decl_proof_instr.ml | 822 ++++++------- tactics/decl_proof_instr.mli | 26 +- tactics/dhyp.ml | 40 +- tactics/dhyp.mli | 2 +- tactics/dn.ml | 36 +- tactics/dn.mli | 4 +- tactics/eauto.ml4 | 172 +-- tactics/eauto.mli | 2 +- tactics/elim.ml | 42 +- tactics/elim.mli | 2 +- tactics/eqdecide.ml4 | 54 +- tactics/equality.ml | 244 ++-- tactics/equality.mli | 24 +- tactics/evar_tactics.ml | 22 +- tactics/evar_tactics.mli | 2 +- tactics/extraargs.ml4 | 108 +- tactics/extratactics.ml4 | 54 +- tactics/hiddentac.ml | 10 +- tactics/hiddentac.mli | 30 +- tactics/hipattern.ml4 | 114 +- tactics/hipattern.mli | 40 +- tactics/inv.ml | 68 +- tactics/inv.mli | 2 +- tactics/leminv.ml | 86 +- tactics/leminv.mli | 2 +- tactics/nbtermdn.ml | 24 +- tactics/nbtermdn.mli | 2 +- tactics/refine.ml | 62 +- tactics/rewrite.ml4 | 472 ++++---- tactics/tacinterp.ml | 350 +++--- tactics/tacinterp.mli | 18 +- tactics/tacticals.ml | 70 +- tactics/tacticals.mli | 30 +- tactics/tactics.ml | 710 +++++------ tactics/tactics.mli | 50 +- tactics/tauto.ml4 | 22 +- tactics/termdn.ml | 22 +- tactics/termdn.mli | 4 +- test-suite/bugs/closed/1519.v | 2 +- test-suite/bugs/closed/1780.v | 4 +- test-suite/bugs/closed/shouldfail/2006.v | 4 +- test-suite/bugs/closed/shouldsucceed/1100.v | 2 +- test-suite/bugs/closed/shouldsucceed/1322.v | 2 +- test-suite/bugs/closed/shouldsucceed/1411.v | 2 +- test-suite/bugs/closed/shouldsucceed/1414.v | 22 +- test-suite/bugs/closed/shouldsucceed/1425.v | 2 +- test-suite/bugs/closed/shouldsucceed/1446.v | 8 +- test-suite/bugs/closed/shouldsucceed/1507.v | 12 +- test-suite/bugs/closed/shouldsucceed/1568.v | 2 +- test-suite/bugs/closed/shouldsucceed/1576.v | 6 +- test-suite/bugs/closed/shouldsucceed/1582.v | 6 +- test-suite/bugs/closed/shouldsucceed/1618.v | 2 +- test-suite/bugs/closed/shouldsucceed/1634.v | 2 +- test-suite/bugs/closed/shouldsucceed/1683.v | 2 +- test-suite/bugs/closed/shouldsucceed/1738.v | 6 +- test-suite/bugs/closed/shouldsucceed/1740.v | 2 +- test-suite/bugs/closed/shouldsucceed/1775.v | 2 +- test-suite/bugs/closed/shouldsucceed/1776.v | 2 +- test-suite/bugs/closed/shouldsucceed/1784.v | 12 +- test-suite/bugs/closed/shouldsucceed/1791.v | 2 +- test-suite/bugs/closed/shouldsucceed/1844.v | 2 +- test-suite/bugs/closed/shouldsucceed/1901.v | 6 +- test-suite/bugs/closed/shouldsucceed/1905.v | 2 +- test-suite/bugs/closed/shouldsucceed/1918.v | 30 +- test-suite/bugs/closed/shouldsucceed/1925.v | 10 +- test-suite/bugs/closed/shouldsucceed/1931.v | 4 +- test-suite/bugs/closed/shouldsucceed/1935.v | 4 +- test-suite/bugs/closed/shouldsucceed/1939.v | 2 +- test-suite/bugs/closed/shouldsucceed/1944.v | 2 +- test-suite/bugs/closed/shouldsucceed/1951.v | 2 +- test-suite/bugs/closed/shouldsucceed/1981.v | 2 +- test-suite/bugs/closed/shouldsucceed/2001.v | 8 +- test-suite/bugs/closed/shouldsucceed/2017.v | 6 +- test-suite/bugs/closed/shouldsucceed/2083.v | 4 +- test-suite/bugs/closed/shouldsucceed/2117.v | 2 +- test-suite/bugs/closed/shouldsucceed/2139.v | 16 +- test-suite/bugs/closed/shouldsucceed/38.v | 2 +- test-suite/bugs/closed/shouldsucceed/846.v | 10 +- test-suite/bugs/opened/shouldnotfail/1416.v | 4 +- test-suite/bugs/opened/shouldnotfail/1501.v | 12 +- test-suite/bugs/opened/shouldnotfail/1596.v | 16 +- test-suite/bugs/opened/shouldnotfail/1671.v | 2 +- test-suite/complexity/injection.v | 6 +- test-suite/failure/Case5.v | 2 +- test-suite/failure/Case9.v | 2 +- test-suite/failure/guard.v | 2 +- test-suite/failure/inductive3.v | 2 +- test-suite/failure/proofirrelevance.v | 2 +- test-suite/failure/rewrite_in_hyp2.v | 2 +- test-suite/failure/subtyping.v | 6 +- test-suite/failure/subtyping2.v | 8 +- test-suite/failure/univ_include.v | 4 +- test-suite/failure/universes-buraliforti-redef.v | 8 +- test-suite/failure/universes-buraliforti.v | 8 +- test-suite/failure/universes3.v | 2 +- test-suite/ideal-features/Case9.v | 2 +- test-suite/ideal-features/complexity/evars_subst.v | 6 +- test-suite/ideal-features/eapply_evar.v | 4 +- test-suite/ideal-features/evars_subst.v | 6 +- test-suite/ideal-features/implicit_binders.v | 22 +- test-suite/ideal-features/universes.v | 4 +- test-suite/interactive/Evar.v | 2 +- test-suite/micromega/example.v | 22 +- test-suite/micromega/heap3_vcgen_25.v | 2 +- test-suite/micromega/qexample.v | 4 +- test-suite/micromega/rexample.v | 4 +- test-suite/micromega/square.v | 4 +- test-suite/micromega/zomicron.v | 4 +- test-suite/modules/PO.v | 8 +- test-suite/modules/Przyklad.v | 24 +- test-suite/modules/Tescik.v | 6 +- test-suite/modules/fun_objects.v | 2 +- .../modules/injection_discriminate_inversion.v | 20 +- test-suite/modules/mod_decl.v | 10 +- test-suite/modules/modeq.v | 2 +- test-suite/modules/modul.v | 2 +- test-suite/modules/obj.v | 2 +- test-suite/modules/objects.v | 2 +- test-suite/modules/objects2.v | 2 +- test-suite/modules/sig.v | 4 +- test-suite/modules/sub_objects.v | 2 +- test-suite/modules/subtyping.v | 8 +- test-suite/output/Cases.v | 2 +- test-suite/output/Fixpoint.v | 2 +- test-suite/output/Notations.v | 12 +- test-suite/output/reduction.v | 2 +- test-suite/success/Abstract.v | 2 +- test-suite/success/AdvancedCanonicalStructure.v | 26 +- test-suite/success/AdvancedTypeClasses.v | 12 +- test-suite/success/Case12.v | 4 +- test-suite/success/Case15.v | 6 +- test-suite/success/Case17.v | 12 +- test-suite/success/Cases.v | 28 +- test-suite/success/CasesDep.v | 58 +- test-suite/success/Discriminate.v | 4 +- test-suite/success/Equations.v | 16 +- test-suite/success/Field.v | 10 +- test-suite/success/Fixpoint.v | 2 +- test-suite/success/Fourier.v | 4 +- test-suite/success/Funind.v | 98 +- test-suite/success/Hints.v | 4 +- test-suite/success/Inductive.v | 6 +- test-suite/success/Injection.v | 2 +- test-suite/success/Inversion.v | 14 +- test-suite/success/LegacyField.v | 10 +- test-suite/success/LetPat.v | 12 +- test-suite/success/Notations.v | 2 +- test-suite/success/Omega0.v | 44 +- test-suite/success/Omega2.v | 2 +- test-suite/success/OmegaPre.v | 2 +- test-suite/success/ProgramWf.v | 18 +- test-suite/success/Projection.v | 6 +- test-suite/success/ROmega.v | 2 +- test-suite/success/ROmega0.v | 44 +- test-suite/success/ROmega2.v | 4 +- test-suite/success/ROmegaPre.v | 2 +- test-suite/success/RecTutorial.v | 204 ++-- test-suite/success/Record.v | 16 +- test-suite/success/Simplify_eq.v | 4 +- test-suite/success/TestRefine.v | 8 +- test-suite/success/apply.v | 24 +- test-suite/success/cc.v | 19 +- test-suite/success/clear.v | 2 +- test-suite/success/coercions.v | 2 +- test-suite/success/conv_pbs.v | 48 +- test-suite/success/decl_mode.v | 40 +- test-suite/success/dependentind.v | 6 +- test-suite/success/destruct.v | 2 +- test-suite/success/eauto.v | 2 +- test-suite/success/evars.v | 18 +- test-suite/success/extraction.v | 106 +- test-suite/success/fix.v | 4 +- test-suite/success/hyps_inclusion.v | 6 +- test-suite/success/implicit.v | 4 +- test-suite/success/import_lib.v | 50 +- test-suite/success/induct.v | 2 +- test-suite/success/ltac.v | 10 +- test-suite/success/mutual_ind.v | 6 +- test-suite/success/parsing.v | 2 +- test-suite/success/refine.v | 12 +- test-suite/success/replace.v | 2 +- test-suite/success/setoid_ring_module.v | 4 +- test-suite/success/setoid_test.v | 2 +- test-suite/success/setoid_test2.v | 4 +- test-suite/success/setoid_test_function_space.v | 8 +- test-suite/success/simpl.v | 8 +- test-suite/success/specialize.v | 2 +- test-suite/success/unification.v | 18 +- test-suite/success/univers.v | 6 +- test-suite/typeclasses/clrewrite.v | 20 +- theories/Arith/Between.v | 6 +- theories/Arith/Compare_dec.v | 2 +- theories/Arith/Div2.v | 4 +- theories/Arith/Even.v | 20 +- theories/Arith/Lt.v | 2 +- theories/Arith/Max.v | 4 +- theories/Arith/Min.v | 2 +- theories/Arith/Minus.v | 4 +- theories/Arith/Mult.v | 12 +- theories/Arith/Plus.v | 10 +- theories/Arith/Wf_nat.v | 12 +- theories/Bool/Bool.v | 42 +- theories/Bool/Bvector.v | 28 +- theories/Bool/Sumbool.v | 8 +- theories/Classes/EquivDec.v | 24 +- theories/Classes/Equivalence.v | 20 +- theories/Classes/Functions.v | 2 +- theories/Classes/Init.v | 4 +- theories/Classes/Morphisms.v | 78 +- theories/Classes/Morphisms_Prop.v | 30 +- theories/Classes/Morphisms_Relations.v | 4 +- theories/Classes/RelationClasses.v | 50 +- theories/Classes/SetoidAxioms.v | 2 +- theories/Classes/SetoidClass.v | 12 +- theories/Classes/SetoidDec.v | 12 +- theories/Classes/SetoidTactics.v | 54 +- theories/FSets/FMapAVL.v | 670 +++++----- theories/FSets/FMapFacts.v | 208 ++-- theories/FSets/FMapFullAVL.v | 264 ++-- theories/FSets/FMapInterface.v | 154 +-- theories/FSets/FMapList.v | 454 +++---- theories/FSets/FMapPositive.v | 142 +-- theories/FSets/FMapWeakList.v | 326 ++--- theories/FSets/FSetAVL.v | 626 +++++----- theories/FSets/FSetBridge.v | 302 ++--- theories/FSets/FSetDecide.v | 42 +- theories/FSets/FSetEqProperties.v | 270 ++--- theories/FSets/FSetFacts.v | 62 +- theories/FSets/FSetFullAVL.v | 322 ++--- theories/FSets/FSetInterface.v | 100 +- theories/FSets/FSetList.v | 300 ++--- theories/FSets/FSetProperties.v | 160 +-- theories/FSets/FSetToFiniteSet.v | 24 +- theories/FSets/FSetWeakList.v | 230 ++-- theories/FSets/OrderedType.v | 192 +-- theories/FSets/OrderedTypeAlt.v | 34 +- theories/FSets/OrderedTypeEx.v | 34 +- theories/Init/Datatypes.v | 10 +- theories/Init/Logic_Type.v | 2 +- theories/Init/Specif.v | 14 +- theories/Init/Tactics.v | 40 +- theories/Init/Wf.v | 12 +- theories/Lists/List.v | 422 +++---- theories/Lists/ListSet.v | 24 +- theories/Lists/ListTactics.v | 6 +- theories/Lists/SetoidList.v | 110 +- theories/Lists/StreamMemo.v | 44 +- theories/Lists/Streams.v | 4 +- theories/Lists/TheoryList.v | 4 +- theories/Logic/Berardi.v | 6 +- theories/Logic/ChoiceFacts.v | 94 +- theories/Logic/ClassicalDescription.v | 8 +- theories/Logic/ClassicalEpsilon.v | 16 +- theories/Logic/ClassicalFacts.v | 48 +- theories/Logic/ClassicalUniqueChoice.v | 2 +- theories/Logic/Classical_Pred_Type.v | 2 +- theories/Logic/Classical_Prop.v | 8 +- theories/Logic/Decidable.v | 24 +- theories/Logic/DecidableType.v | 26 +- theories/Logic/DecidableTypeEx.v | 24 +- theories/Logic/Description.v | 2 +- theories/Logic/Diaconescu.v | 36 +- theories/Logic/Epsilon.v | 10 +- theories/Logic/EqdepFacts.v | 50 +- theories/Logic/Eqdep_dec.v | 24 +- theories/Logic/FunctionalExtensionality.v | 14 +- theories/Logic/IndefiniteDescription.v | 4 +- theories/Logic/JMeq.v | 6 +- theories/Logic/ProofIrrelevanceFacts.v | 4 +- theories/Logic/RelationalChoice.v | 2 +- theories/NArith/BinNat.v | 14 +- theories/NArith/BinPos.v | 86 +- theories/NArith/Ndec.v | 20 +- theories/NArith/Ndigits.v | 94 +- theories/NArith/Ndist.v | 18 +- theories/NArith/Nnat.v | 38 +- theories/NArith/Pnat.v | 28 +- theories/Numbers/BigNumPrelude.v | 68 +- theories/Numbers/Cyclic/Abstract/CyclicAxioms.v | 46 +- theories/Numbers/Cyclic/Abstract/NZCyclic.v | 8 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v | 70 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v | 90 +- .../Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v | 164 +-- theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v | 306 ++--- theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v | 140 +-- theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v | 62 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v | 110 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v | 84 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v | 72 +- theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v | 14 +- theories/Numbers/Cyclic/Int31/Cyclic31.v | 422 +++---- theories/Numbers/Cyclic/Int31/Int31.v | 126 +- theories/Numbers/Cyclic/ZModulo/ZModulo.v | 222 ++-- theories/Numbers/Integer/BigZ/ZMake.v | 68 +- theories/Numbers/Integer/SpecViaZ/ZSig.v | 8 +- theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v | 6 +- theories/Numbers/NaryFunctions.v | 66 +- theories/Numbers/NatInt/NZAxioms.v | 2 +- theories/Numbers/Natural/Abstract/NOrder.v | 2 +- theories/Numbers/Natural/BigN/NMake_gen.ml | 186 +-- theories/Numbers/Natural/BigN/Nbasic.v | 62 +- theories/Numbers/Natural/SpecViaZ/NSig.v | 4 +- theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v | 4 +- theories/Numbers/Rational/BigQ/QMake.v | 202 ++-- theories/Numbers/Rational/SpecViaQ/QSig.v | 6 +- theories/Program/Basics.v | 6 +- theories/Program/Combinators.v | 2 +- theories/Program/Equality.v | 154 +-- theories/Program/Subset.v | 26 +- theories/Program/Tactics.v | 48 +- theories/Program/Wf.v | 40 +- theories/QArith/QArith_base.v | 4 +- theories/QArith/Qcanon.v | 50 +- theories/QArith/Qfield.v | 10 +- theories/QArith/Qpower.v | 8 +- theories/QArith/Qreals.v | 6 +- theories/QArith/Qreduction.v | 18 +- theories/Reals/Alembert.v | 24 +- theories/Reals/AltSeries.v | 14 +- theories/Reals/ArithProp.v | 10 +- theories/Reals/Binomial.v | 2 +- theories/Reals/Cauchy_prod.v | 4 +- theories/Reals/Cos_plus.v | 94 +- theories/Reals/Cos_rel.v | 250 ++-- theories/Reals/DiscrR.v | 8 +- theories/Reals/Exp_prop.v | 6 +- theories/Reals/Integration.v | 2 +- theories/Reals/MVT.v | 24 +- theories/Reals/NewtonInt.v | 14 +- theories/Reals/PSeries_reg.v | 14 +- theories/Reals/PartSum.v | 16 +- theories/Reals/RIneq.v | 42 +- theories/Reals/RList.v | 30 +- theories/Reals/R_Ifp.v | 124 +- theories/Reals/R_sqr.v | 28 +- theories/Reals/R_sqrt.v | 16 +- theories/Reals/Ranalysis.v | 24 +- theories/Reals/Ranalysis1.v | 54 +- theories/Reals/Ranalysis2.v | 20 +- theories/Reals/Ranalysis3.v | 12 +- theories/Reals/Ranalysis4.v | 26 +- theories/Reals/Raxioms.v | 12 +- theories/Reals/Rbasic_fun.v | 88 +- theories/Reals/Rdefinitions.v | 4 +- theories/Reals/Rderiv.v | 106 +- theories/Reals/Reals.v | 2 +- theories/Reals/Rfunctions.v | 14 +- theories/Reals/Rgeom.v | 6 +- theories/Reals/RiemannInt.v | 210 ++-- theories/Reals/RiemannInt_SF.v | 274 ++--- theories/Reals/Rlimit.v | 56 +- theories/Reals/Rlogic.v | 4 +- theories/Reals/Rpower.v | 30 +- theories/Reals/Rprod.v | 22 +- theories/Reals/Rseries.v | 28 +- theories/Reals/Rsqrt_def.v | 10 +- theories/Reals/Rtopology.v | 194 +-- theories/Reals/Rtrigo.v | 128 +- theories/Reals/Rtrigo_alt.v | 28 +- theories/Reals/Rtrigo_calc.v | 14 +- theories/Reals/Rtrigo_def.v | 12 +- theories/Reals/Rtrigo_fun.v | 16 +- theories/Reals/Rtrigo_reg.v | 10 +- theories/Reals/SeqSeries.v | 10 +- theories/Reals/Sqrt_reg.v | 16 +- theories/Relations/Operators_Properties.v | 44 +- theories/Relations/Relation_Definitions.v | 26 +- theories/Relations/Relation_Operators.v | 14 +- theories/Setoids/Setoid.v | 18 +- theories/Sets/Classical_sets.v | 4 +- theories/Sets/Constructive_sets.v | 12 +- theories/Sets/Cpo.v | 10 +- theories/Sets/Ensembles.v | 36 +- theories/Sets/Finite_sets.v | 2 +- theories/Sets/Finite_sets_facts.v | 8 +- theories/Sets/Image.v | 24 +- theories/Sets/Infinite_sets.v | 12 +- theories/Sets/Integers.v | 20 +- theories/Sets/Multiset.v | 26 +- theories/Sets/Partial_Order.v | 12 +- theories/Sets/Permut.v | 10 +- theories/Sets/Powerset_Classical_facts.v | 30 +- theories/Sets/Powerset_facts.v | 40 +- theories/Sets/Relations_1.v | 24 +- theories/Sets/Relations_2_facts.v | 2 +- theories/Sets/Relations_3.v | 16 +- theories/Sets/Uniset.v | 10 +- theories/Sorting/Heap.v | 20 +- theories/Sorting/PermutEq.v | 40 +- theories/Sorting/PermutSetoid.v | 34 +- theories/Sorting/Permutation.v | 50 +- theories/Sorting/Sorting.v | 4 +- theories/Strings/Ascii.v | 24 +- theories/Strings/String.v | 40 +- theories/Unicode/Utf8.v | 4 +- theories/Wellfounded/Disjoint_Union.v | 8 +- theories/Wellfounded/Inclusion.v | 2 +- theories/Wellfounded/Inverse_Image.v | 4 +- .../Wellfounded/Lexicographic_Exponentiation.v | 78 +- theories/Wellfounded/Lexicographic_Product.v | 26 +- theories/Wellfounded/Transitive_Closure.v | 2 +- theories/Wellfounded/Union.v | 10 +- theories/Wellfounded/Well_Ordering.v | 6 +- theories/ZArith/BinInt.v | 54 +- theories/ZArith/Int.v | 178 +-- theories/ZArith/Wf_Z.v | 8 +- theories/ZArith/ZArith_base.v | 2 +- theories/ZArith/ZArith_dec.v | 8 +- theories/ZArith/ZOdiv.v | 196 +-- theories/ZArith/ZOdiv_def.v | 32 +- theories/ZArith/Zabs.v | 20 +- theories/ZArith/Zbinary.v | 64 +- theories/ZArith/Zcompare.v | 30 +- theories/ZArith/Zcomplements.v | 30 +- theories/ZArith/Zdiv.v | 130 +- theories/ZArith/Zeven.v | 36 +- theories/ZArith/Zgcd_alt.v | 54 +- theories/ZArith/Zhints.v | 134 +- theories/ZArith/Zlogarithm.v | 20 +- theories/ZArith/Zmax.v | 12 +- theories/ZArith/Zmin.v | 10 +- theories/ZArith/Zminmax.v | 12 +- theories/ZArith/Zmisc.v | 14 +- theories/ZArith/Znat.v | 22 +- theories/ZArith/Znumtheory.v | 214 ++-- theories/ZArith/Zorder.v | 38 +- theories/ZArith/Zpow_def.v | 8 +- theories/ZArith/Zpow_facts.v | 56 +- theories/ZArith/Zpower.v | 28 +- theories/ZArith/Zsqrt.v | 4 +- theories/ZArith/Zwf.v | 2 +- theories/ZArith/auxiliary.v | 4 +- tools/coq_makefile.ml4 | 86 +- tools/coq_tex.ml4 | 34 +- tools/coqdep.ml | 34 +- tools/coqdep_common.ml | 64 +- tools/coqdep_lexer.mll | 32 +- tools/coqdoc/alpha.ml | 4 +- tools/coqdoc/cdglobals.ml | 2 +- tools/coqdoc/cpretty.mll | 432 +++---- tools/coqdoc/index.mli | 8 +- tools/coqdoc/index.mll | 222 ++-- tools/coqdoc/main.ml | 148 +-- tools/coqdoc/output.ml | 234 ++-- tools/coqwc.mll | 72 +- tools/gallina.ml | 22 +- tools/gallina_lexer.mll | 32 +- toplevel/auto_ind_decl.ml | 390 +++--- toplevel/auto_ind_decl.mli | 10 +- toplevel/autoinstance.ml | 70 +- toplevel/cerrors.ml | 68 +- toplevel/class.ml | 36 +- toplevel/class.mli | 2 +- toplevel/classes.ml | 102 +- toplevel/classes.mli | 8 +- toplevel/command.ml | 252 ++-- toplevel/command.mli | 16 +- toplevel/coqinit.ml | 58 +- toplevel/coqtop.ml | 44 +- toplevel/coqtop.mli | 6 +- toplevel/discharge.ml | 14 +- toplevel/discharge.mli | 2 +- toplevel/himsg.ml | 68 +- toplevel/himsg.mli | 4 +- toplevel/ind_tables.ml | 20 +- toplevel/ind_tables.mli | 12 +- toplevel/libtypes.ml | 38 +- toplevel/libtypes.mli | 6 +- toplevel/line_oriented_parser.ml | 2 +- toplevel/metasyntax.ml | 80 +- toplevel/metasyntax.mli | 4 +- toplevel/mltop.ml4 | 32 +- toplevel/mltop.mli | 4 +- toplevel/protectedtoplevel.ml | 20 +- toplevel/record.ml | 64 +- toplevel/record.mli | 8 +- toplevel/search.ml | 62 +- toplevel/search.mli | 6 +- toplevel/toplevel.ml | 92 +- toplevel/toplevel.mli | 2 +- toplevel/usage.ml | 10 +- toplevel/vernac.ml | 32 +- toplevel/vernac.mli | 2 +- toplevel/vernacentries.ml | 254 ++-- toplevel/vernacentries.mli | 2 +- toplevel/vernacexpr.ml | 44 +- toplevel/vernacinterp.ml | 12 +- toplevel/vernacinterp.mli | 4 +- toplevel/whelp.ml4 | 34 +- toplevel/whelp.mli | 2 +- 973 files changed, 29073 insertions(+), 29074 deletions(-) diff --git a/checker/check.ml b/checker/check.ml index 82df62b4c2..0a75f01375 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -24,10 +24,10 @@ type section_path = { basename : string } let dir_of_path p = make_dirpath (List.map id_of_string p.dirpath) -let path_of_dirpath dir = +let path_of_dirpath dir = match repr_dirpath dir with [] -> failwith "path_of_dirpath" - | l::dir -> + | l::dir -> {dirpath=List.map string_of_id dir;basename=string_of_id l} let pr_dirlist dp = prlist_with_sep (fun _ -> str".") str (List.rev dp) @@ -40,7 +40,7 @@ type library_objects type compilation_unit_name = dir_path -type library_disk = { +type library_disk = { md_name : compilation_unit_name; md_compiled : Safe_typing.compiled_library; md_objects : library_objects; @@ -48,7 +48,7 @@ type library_disk = { md_imports : compilation_unit_name list } (************************************************************************) -(*s Modules on disk contain the following informations (after the magic +(*s Modules on disk contain the following informations (after the magic number, and before the digest). *) (*s Modules loaded in memory contain the following informations. They are @@ -61,7 +61,7 @@ type library_t = { library_deps : (compilation_unit_name * Digest.t) list; library_digest : Digest.t } -module LibraryOrdered = +module LibraryOrdered = struct type t = dir_path let compare d1 d2 = @@ -121,7 +121,7 @@ let load_paths = ref ([],[] : System.physical_path list * logical_path list) let get_load_paths () = fst !load_paths (* Hints to partially detects if two paths refer to the same repertory *) -let rec remove_path_dot p = +let rec remove_path_dot p = let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) let n = String.length curdir in if String.length p > n && String.sub p 0 n = curdir then @@ -139,7 +139,7 @@ let strip_path p = let canonical_path_name p = let current = Sys.getcwd () in - try + try Sys.chdir p; let p' = Sys.getcwd () in Sys.chdir current; @@ -148,7 +148,7 @@ let canonical_path_name p = (* We give up to find a canonical name and just simplify it... *) strip_path p -let find_logical_path phys_dir = +let find_logical_path phys_dir = let phys_dir = canonical_path_name phys_dir in match list_filter2 (fun p d -> p = phys_dir) !load_paths with | _,[dir] -> dir @@ -159,7 +159,7 @@ let is_in_load_paths phys_dir = let dir = canonical_path_name phys_dir in let lp = get_load_paths () in let check_p = fun p -> (String.compare dir p) == 0 in - List.exists check_p lp + List.exists check_p lp let remove_load_path dir = load_paths := list_filter2 (fun p d -> p <> dir) !load_paths @@ -171,7 +171,7 @@ let add_load_path (phys_path,coq_path) = let phys_path = canonical_path_name phys_path in match list_filter2 (fun p d -> p = phys_path) !load_paths with | _,[dir] -> - if coq_path <> dir + if coq_path <> dir (* If this is not the default -I . to coqtop *) && not (phys_path = canonical_path_name Filename.current_dir_name @@ -195,7 +195,7 @@ let physical_paths (dp,lp) = dp let load_paths_of_dir_path dir = fst (list_filter2 (fun p d -> d = dir) !load_paths) - + let get_full_load_paths () = List.combine (fst !load_paths) (snd !load_paths) (************************************************************************) @@ -235,8 +235,8 @@ let locate_qualified_library qid = let dir = extend_dirpath (find_logical_path path) (id_of_string qid.basename) in (* Look if loaded *) - try - (dir, library_full_filename dir) + try + (dir, library_full_filename dir) with Not_found -> (dir, file) with Not_found -> raise LibNotFound @@ -245,7 +245,7 @@ let explain_locate_library_error qid = function | LibUnmappedDir -> let prefix = qid.dirpath in errorlabstrm "load_absolute_library_from" - (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ + (str "Cannot load " ++ pr_path qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirlist prefix ++ fnl ()) | LibNotFound -> errorlabstrm "load_absolute_library_from" @@ -261,7 +261,7 @@ let try_locate_absolute_library dir = let try_locate_qualified_library qid = try locate_qualified_library qid - with e -> + with e -> explain_locate_library_error qid e (************************************************************************) @@ -300,7 +300,7 @@ let depgraph = ref LibraryMap.empty let intern_from_file (dir, f) = Flags.if_verbose msg (str"[intern "++str f++str" ..."); - let (md,digest) = + let (md,digest) = try let ch = with_magic_number_check raw_intern_library f in let (md:library_disk) = System.marshal_in ch in @@ -312,7 +312,7 @@ let intern_from_file (dir, f) = Flags.if_verbose msgnl(str" done]"); md,digest with e -> Flags.if_verbose msgnl(str" failed!]"); raise e in - depgraph := LibraryMap.add md.md_name md.md_deps !depgraph; + depgraph := LibraryMap.add md.md_name md.md_deps !depgraph; mk_library md f digest let get_deps (dir, f) = diff --git a/checker/check_stat.ml b/checker/check_stat.ml index 6ea153a3a9..290e6ff8e0 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -17,7 +17,7 @@ open Environ let memory_stat = ref false -let print_memory_stat () = +let print_memory_stat () = if !memory_stat then begin Format.printf "total heap size = %d kbytes\n" (heap_size_kb ()); Format.print_newline(); @@ -37,7 +37,7 @@ let cst_filter f csts = (fun c ce acc -> if f c ce then c::acc else acc) csts [] -let is_ax _ cb = cb.const_body = None +let is_ax _ cb = cb.const_body = None let pr_ax csts = let axs = cst_filter is_ax csts in diff --git a/checker/checker.ml b/checker/checker.ml index 85ad129c9f..1df1873281 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -23,14 +23,14 @@ let parse_dir s = if n>=len then dirs else let pos = try - String.index_from s n '.' + String.index_from s n '.' with Not_found -> len in let dir = String.sub s n (pos-n) in - decoupe_dirs (dir::dirs) (pos+1) + decoupe_dirs (dir::dirs) (pos+1) in decoupe_dirs [] 0 -let dirpath_of_string s = +let dirpath_of_string s = match parse_dir s with [] -> invalid_arg "dirpath_of_string" | dir -> make_dirpath (List.map id_of_string dir) @@ -43,7 +43,7 @@ let (/) = Filename.concat let get_version_date () = try - let coqlib = Envars.coqlib () in + let coqlib = Envars.coqlib () in let ch = open_in (Filename.concat coqlib "revision") in let ver = input_line ch in let rev = input_line ch in @@ -67,8 +67,8 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = let convert_string d = try id_of_string d - with _ -> - if_verbose warning + with _ -> + if_verbose warning ("Directory "^d^" cannot be used as a Coq identifier (skipped)"); flush_all (); failwith "caught" @@ -108,20 +108,20 @@ let init_load_path () = let user_contrib = coqlib/"user-contrib" in let plugins = coqlib/"plugins" in (* first user-contrib *) - if Sys.file_exists user_contrib then + if Sys.file_exists user_contrib then add_rec_path user_contrib Check.default_root_prefix; (* then plugins *) add_rec_path plugins (Names.make_dirpath [coq_root]); (* then standard library *) -(* List.iter +(* List.iter (fun (s,alias) -> - add_rec_path (coqlib/s) ([alias; coq_root])) + add_rec_path (coqlib/s) ([alias; coq_root])) theories_dirs_map;*) add_rec_path (coqlib/"theories") (Names.make_dirpath[coq_root]); (* then current directory *) add_path "." Check.default_root_prefix; (* additional loadpath, given with -I -include -R options *) - List.iter + List.iter (fun (s,alias,reci) -> if reci then add_rec_path s alias else add_path s alias) (List.rev !includes); @@ -156,7 +156,7 @@ let compile_files () = Check.recheck_library ~norec:(List.rev !norec_list) ~admit:(List.rev !admit_list) - ~check:(List.rev !compile_list) + ~check:(List.rev !compile_list) let version () = Printf.printf "The Coq Proof Checker, version %s (%s)\n" @@ -173,7 +173,7 @@ let print_usage_channel co command = " -I dir -as coqdir map physical dir to logical coqdir -I dir map directory dir to the empty logical path -include dir (idem) - -R dir -as coqdir recursively map physical dir to logical coqdir + -R dir -as coqdir recursively map physical dir to logical coqdir -R dir coqdir (idem) -admit module load module and dependencies without checking @@ -184,7 +184,7 @@ let print_usage_channel co command = -boot boot mode -o print the list of assumptions -m print the maximum heap size - + -impredicative-set set sort Set impredicative -h, --help print this list of options @@ -210,9 +210,9 @@ let anomaly_string () = str "Anomaly: " let report () = (str "." ++ spc () ++ str "Please report.") let print_loc loc = - if loc = dummy_loc then + if loc = dummy_loc then (str"") - else + else let loc = unloc loc in (int (fst loc) ++ str"-" ++ int (snd loc)) let guill s = "\""^s^"\"" @@ -221,41 +221,41 @@ let where s = if !Flags.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) let rec explain_exn = function - | Stream.Failure -> + | Stream.Failure -> hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.") - | Stream.Error txt -> + | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt) - | Token.Error txt -> + | Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt) - | Sys_error msg -> + | Sys_error msg -> hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report() ) - | UserError(s,pps) -> + | UserError(s,pps) -> hov 1 (str "User error: " ++ where s ++ pps) - | Out_of_memory -> + | Out_of_memory -> hov 0 (str "Out of memory") - | Stack_overflow -> + | Stack_overflow -> hov 0 (str "Stack overflow") - | Anomaly (s,pps) -> + | Anomaly (s,pps) -> hov 1 (anomaly_string () ++ where s ++ pps ++ report ()) | Match_failure(filename,pos1,pos2) -> - hov 1 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ + hov 1 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ if Sys.ocaml_version = "3.06" then - (str " from character " ++ int pos1 ++ + (str " from character " ++ int pos1 ++ str " to " ++ int pos2) else (str " at line " ++ int pos1 ++ str " character " ++ int pos2) ++ report ()) - | Not_found -> + | Not_found -> hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report ()) - | Failure s -> + | Failure s -> hov 0 (str "Failure: " ++ str s ++ report ()) - | Invalid_argument s -> + | Invalid_argument s -> hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report ()) - | Sys.Break -> + | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") | Univ.UniverseInconsistency (o,u,v) -> - let msg = + let msg = if !Flags.debug (*!Constrextern.print_universes*) then spc() ++ str "(cannot enforce" ++ spc() ++ (*Univ.pr_uni u ++*) spc() ++ str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=") @@ -263,12 +263,12 @@ let rec explain_exn = function else mt() in hov 0 (str "Error: Universe inconsistency" ++ msg ++ str ".") - | TypeError(ctx,te) -> + | TypeError(ctx,te) -> (* hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx *) (* te)*) hov 0 (str "Type error") - | Indtypes.InductiveError e -> + | Indtypes.InductiveError e -> hov 0 (str "Error related to inductive types") (* let ctx = Check.get_env() in hov 0 @@ -279,9 +279,9 @@ let rec explain_exn = function ++ explain_exn exc) | Assert_failure (s,b,e) -> hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ - (if s <> "" then + (if s <> "" then if Sys.ocaml_version = "3.06" then - (str ("(file \"" ^ s ^ "\", characters ") ++ + (str ("(file \"" ^ s ^ "\", characters ") ++ int b ++ str "-" ++ int e ++ str ")") else (str ("(file \"" ^ s ^ "\", line ") ++ int b ++ @@ -291,13 +291,13 @@ let rec explain_exn = function (mt ())) ++ report ()) | reraise -> - hov 0 (anomaly_string () ++ str "Uncaught exception " ++ + hov 0 (anomaly_string () ++ str "Uncaught exception " ++ str (Printexc.to_string reraise)++report()) let parse_args() = let rec parse = function | [] -> () - | "-impredicative-set" :: rem -> + | "-impredicative-set" :: rem -> set_engagement Declarations.ImpredicativeSet; parse rem | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem @@ -318,7 +318,7 @@ let parse_args() = | ("-?"|"-h"|"-H"|"-help"|"--help") :: _ -> usage () | ("-v"|"--version") :: _ -> version () - | "-boot" :: rem -> boot := true; parse rem + | "-boot" :: rem -> boot := true; parse rem | ("-m" | "--memory") :: rem -> Check_stat.memory_stat := true; parse rem | ("-o" | "--output-context") :: rem -> Check_stat.output_context := true; parse rem @@ -340,7 +340,7 @@ let parse_args() = in try parse (List.tl (Array.to_list Sys.argv)) - with + with | UserError(_,s) as e -> begin try Stream.empty s; exit 1 @@ -370,12 +370,12 @@ let init() = end let run () = - try + try compile_files (); flush_all() with e -> (Pp.ppnl(explain_exn e); - flush_all(); + flush_all(); exit 1) let start () = init(); run(); Check_stat.stats(); exit 0 diff --git a/checker/closure.ml b/checker/closure.ml index 591b353db1..b55c5848eb 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -38,7 +38,7 @@ let incr_cnt red cnt = if red then begin if !stats then incr cnt; true - end else + end else false let with_stats c = @@ -127,13 +127,13 @@ module RedFlags = (struct { red with r_const = Idpred.remove id l1, l2 } let red_add_transparent red tr = - { red with r_const = tr } + { red with r_const = tr } let mkflags = List.fold_left red_add no_red let red_set red = function | BETA -> incr_cnt red.r_beta beta - | CONST kn -> + | CONST kn -> let (_,l) = red.r_const in let c = Cpred.mem kn l in incr_cnt c delta @@ -165,7 +165,7 @@ let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA] let betaiota = mkflags [fBETA;fIOTA] let beta = mkflags [fBETA] let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] -let unfold_red kn = +let unfold_red kn = let flag = match kn with | EvalVarRef id -> fVAR id | EvalConstRef kn -> fCONST kn @@ -187,7 +187,7 @@ let betadeltaiota_red = { r_const = true,[],[]; r_zeta = true; r_evar = true; - r_iota = true } + r_iota = true } let betaiota_red = { r_beta = true; @@ -195,7 +195,7 @@ let betaiota_red = { r_zeta = false; r_evar = false; r_iota = true } - + let beta_red = { r_beta = true; r_const = false,[],[]; @@ -231,7 +231,7 @@ let unfold_red kn = (* Sets of reduction kinds. Main rule: delta implies all consts (both global (= by kernel_name) and local (= by Rel or Var)), all evars, and zeta (= letin's). - Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of + Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) type red_kind = @@ -278,7 +278,7 @@ let red_local_const = red_delta_set (* to know if a redex is allowed, only a subset of red_kind is used ... *) let red_set red = function | BETA -> incr_cnt red.r_beta beta - | CONST [kn] -> + | CONST [kn] -> let (b,l,_) = red.r_const in let c = List.mem kn l in incr_cnt ((b & not c) or (c & not b)) delta @@ -339,7 +339,7 @@ type 'a infos = { let info_flags info = info.i_flags let ref_value_cache info ref = - try + try Some (Hashtbl.find info.i_tab ref) with Not_found -> try @@ -360,7 +360,7 @@ let ref_value_cache info ref = let defined_vars flags env = (* if red_local_const (snd flags) then*) - fold_named_context + fold_named_context (fun (id,b,_) e -> match b with | None -> e @@ -370,7 +370,7 @@ let defined_vars flags env = let defined_rels flags env = (* if red_local_const (snd flags) then*) - fold_rel_context + fold_rel_context (fun (id,b,t) (i,subs) -> match b with | None -> (i+1, subs) @@ -417,8 +417,8 @@ let neutr = function | (Whnf|Norm) -> Whnf | (Red|Cstr) -> Red -type fconstr = { - mutable norm: red_state; +type fconstr = { + mutable norm: red_state; mutable term: fterm } and fterm = @@ -456,7 +456,7 @@ let update v1 (no,t) = else {norm=no;term=t} (**********************************************************************) -(* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) +(* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) type stack_member = | Zapp of fconstr array @@ -504,7 +504,7 @@ let array_of_stack s = in Array.concat (stackrec s) let rec stack_assign s p c = match s with | Zapp args :: s -> - let q = Array.length args in + let q = Array.length args in if p >= q then Zapp args :: stack_assign s (p-q) c else @@ -512,7 +512,7 @@ let rec stack_assign s p c = match s with nargs.(p) <- c; Zapp nargs :: s) | _ -> s -let rec stack_tail p s = +let rec stack_tail p s = if p = 0 then s else match s with | Zapp args :: s -> @@ -775,7 +775,7 @@ let term_of_fconstr = (* fstrong applies unfreeze_fun recursively on the (freeze) term and * yields a term. Assumes that the unfreeze_fun never returns a - * FCLOS term. + * FCLOS term. let rec fstrong unfreeze_fun lfts v = to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v) *) @@ -968,7 +968,7 @@ let rec knr info m stk = | FLambda(n,tys,f,e) when red_set info.i_flags fBETA -> (match get_args n tys f e stk with Inl e', s -> knit info e' f s - | Inr lam, s -> (lam,s)) + | Inr lam, s -> (lam,s)) | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) -> (match ref_value_cache info (ConstKey kn) with Some v -> kni info v stk diff --git a/checker/closure.mli b/checker/closure.mli index fa302de640..260d159b3d 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -24,7 +24,7 @@ val with_stats: 'a Lazy.t -> 'a (*s Delta implies all consts (both global (= by [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's. - Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of + Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) type transparent_state = Idpred.t * Cpred.t @@ -102,7 +102,7 @@ type fconstr type fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) - | FCast of fconstr * cast_kind * fconstr + | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive | FConstruct of constructor diff --git a/checker/declarations.ml b/checker/declarations.ml index 8cbc964f44..0066e78489 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -30,15 +30,15 @@ let val_cst_type = val_sum "constant_type" 0 [|[|val_constr|];[|val_rctxt;val_pol_arity|]|] -type substitution_domain = - MSI of mod_self_id +type substitution_domain = + MSI of mod_self_id | MBI of mod_bound_id | MPI of module_path let val_subst_dom = val_sum "substitution_domain" 0 [|[|val_uid|];[|val_uid|];[|val_mp|]|] -module Umap = Map.Make(struct +module Umap = Map.Make(struct type t = substitution_domain let compare = Pervasives.compare end) @@ -79,7 +79,7 @@ let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with - | MPself sid -> + | MPself sid -> let mp',resolve = Umap.find (MSI sid) sub in mp',resolve | MPbound bid -> @@ -87,17 +87,17 @@ let subst_mp0 sub mp = (* 's like subst *) mp',resolve | MPdot (mp1,l) as mp2 -> begin - try + try let mp',resolve = Umap.find (MPI mp2) sub in mp',resolve - with Not_found -> + with Not_found -> let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve end | _ -> raise Not_found in try - Some (aux mp) + Some (aux mp) with Not_found -> None @@ -148,84 +148,84 @@ let subst_con0 sub con = let con' = make_con mp' dir l in Some (Const con') -let rec map_kn f f' c = +let rec map_kn f f' c = let func = map_kn f f' in match c with - | Const kn -> + | Const kn -> (match f' kn with None -> c | Some const ->const) - | Ind (kn,i) -> + | Ind (kn,i) -> (match f kn with None -> c | Some kn' -> Ind (kn',i)) - | Construct ((kn,i),j) -> + | Construct ((kn,i),j) -> (match f kn with None -> c | Some kn' -> Construct ((kn',i),j)) - | Case (ci,p,ct,l) -> + | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in let p' = func p in let ct' = func ct in let l' = array_smartmap func l in - if (ci.ci_ind==ci_ind && p'==p + if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c - else + else Case ({ci with ci_ind = ci_ind}, - p',ct', l') - | Cast (ct,k,t) -> + p',ct', l') + | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in - if (t'==t && ct'==ct) then c + if (t'==t && ct'==ct) then c else Cast (ct', k, t') - | Prod (na,t,ct) -> + | Prod (na,t,ct) -> let ct' = func ct in let t'= func t in - if (t'==t && ct'==ct) then c + if (t'==t && ct'==ct) then c else Prod (na, t', ct') - | Lambda (na,t,ct) -> + | Lambda (na,t,ct) -> let ct' = func ct in let t'= func t in - if (t'==t && ct'==ct) then c + if (t'==t && ct'==ct) then c else Lambda (na, t', ct') - | LetIn (na,b,t,ct) -> + | LetIn (na,b,t,ct) -> let ct' = func ct in let t'= func t in let b'= func b in - if (t'==t && ct'==ct && b==b') then c + if (t'==t && ct'==ct && b==b') then c else LetIn (na, b', t', ct') - | App (ct,l) -> + | App (ct,l) -> let ct' = func ct in let l' = array_smartmap func l in if (ct'== ct && l'==l) then c else App (ct',l') - | Evar (e,l) -> + | Evar (e,l) -> let l' = array_smartmap func l in if (l'==l) then c else Evar (e,l') | Fix (ln,(lna,tl,bl)) -> let tl' = array_smartmap func tl in let bl' = array_smartmap func bl in - if (bl == bl'&& tl == tl') then c + if (bl == bl'&& tl == tl') then c else Fix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = array_smartmap func tl in let bl' = array_smartmap func bl in - if (bl == bl'&& tl == tl') then c + if (bl == bl'&& tl == tl') then c else CoFix (ln,(lna,tl',bl')) | _ -> c -let subst_mps sub = +let subst_mps sub = map_kn (subst_kn0 sub) (subst_con0 sub) let rec replace_mp_in_mp mpfrom mpto mp = match mp with | _ when mp = mpfrom -> mpto - | MPdot (mp1,l) -> + | MPdot (mp1,l) -> let mp1' = replace_mp_in_mp mpfrom mpto mp1 in if mp1==mp1' then mp else MPdot (mp1',l) @@ -240,18 +240,18 @@ let replace_mp_in_con mpfrom mpto kn = type 'a lazy_subst = | LSval of 'a | LSlazy of substitution * 'a - + type 'a substituted = 'a lazy_subst ref - + let from_val a = ref (LSval a) - -let force fsubst r = + +let force fsubst r = match !r with | LSval a -> a - | LSlazy(s,a) -> + | LSlazy(s,a) -> let a' = fsubst s a in r := LSval a'; - a' + a' @@ -265,9 +265,9 @@ let join (subst1 : substitution) (subst2 : substitution) = let subst_key subst1 subst2 = let replace_in_key key mp sub= - let newkey = + let newkey = match key with - | MPI mp1 -> + | MPI mp1 -> begin match subst_mp0 subst1 mp1 with | None -> None @@ -283,24 +283,24 @@ let subst_key subst1 subst2 = let update_subst_alias subst1 subst2 = let subst_inv key (mp,_) sub = - let newmp = - match key with + let newmp = + match key with | MBI msid -> Some (MPbound msid) | MSI msid -> Some (MPself msid) | _ -> None in match newmp with | None -> sub - | Some mpi -> match mp with + | Some mpi -> match mp with | MPbound mbid -> Umap.add (MBI mbid) (mpi,None) sub | MPself msid -> Umap.add (MSI msid) (mpi,None) sub | _ -> Umap.add (MPI mp) (mpi,None) sub - in + in let subst_mbi = Umap.fold subst_inv subst2 empty_subst in let alias_subst key (mp,_) sub= - let newkey = + let newkey = match key with - | MPI mp1 -> + | MPI mp1 -> begin match subst_mp0 subst_mbi mp1 with | None -> None @@ -319,28 +319,28 @@ let join_alias (subst1 : substitution) (subst2 : substitution) = match subst_mp0 sub mp with None -> mp,None | Some mp' -> mp',None in - Umap.mapi (apply_subst subst2) subst1 + Umap.mapi (apply_subst subst2) subst1 let update_subst subst1 subst2 = let subst_inv key (mp,_) l = - let newmp = - match key with + let newmp = + match key with | MBI msid -> MPbound msid | MSI msid -> MPself msid | MPI mp -> mp in - match mp with + match mp with | MPbound mbid -> ((MBI mbid),newmp)::l | MPself msid -> ((MSI msid),newmp)::l | _ -> ((MPI mp),newmp)::l - in + in let subst_mbi = Umap.fold subst_inv subst2 [] in let alias_subst key (mp,_) sub= - let newsetkey = + let newsetkey = match key with - | MPI mp1 -> - let compute_set_newkey l (k,mp') = + | MPI mp1 -> + let compute_set_newkey l (k,mp') = let mp_from_key = match k with | MBI msid -> MPbound msid | MSI msid -> MPself msid @@ -358,7 +358,7 @@ let update_subst subst1 subst2 = in match newsetkey with | None -> sub - | Some l -> + | Some l -> List.fold_left (fun s k -> Umap.add k (mp,None) s) sub l in @@ -372,7 +372,7 @@ let subst_substituted s r = let s'' = join s' s in ref (LSlazy(s'',a)) -let force_constr = force subst_mps +let force_constr = force subst_mps type constr_substituted = constr substituted @@ -390,7 +390,7 @@ type constant_body = { const_body_code : to_patch_substituted; (* const_type_code : Cemitcodes.to_patch; *) const_constraints : Univ.constraints; - const_opaque : bool; + const_opaque : bool; const_inline : bool} let val_cb = val_tuple "constant_body" @@ -405,9 +405,9 @@ let subst_rel_declaration sub (id,copt,t as x) = let subst_rel_context sub = list_smartmap (subst_rel_declaration sub) -type recarg = - | Norec - | Mrec of int +type recarg = + | Norec + | Mrec of int | Imbr of inductive let val_recarg = val_sum "recarg" 1 (* Norec *) [|[|val_int|] (* Mrec *);[|val_ind|] (* Imbr *)|] @@ -419,7 +419,7 @@ let subst_recarg sub r = match r with type wf_paths = recarg Rtree.t let val_wfp = val_rec_sum "wf_paths" 0 - (fun val_wfp -> + (fun val_wfp -> [|[|val_int;val_int|]; (* Rtree.Param *) [|val_recarg;val_array val_wfp|]; (* Rtree.Node *) [|val_int;val_array val_wfp|] (* Rtree.Rec *) @@ -454,7 +454,7 @@ type monomorphic_inductive_arity = { let val_mono_ind_arity = val_tuple"monomorphic_inductive_arity"[|val_constr;val_sort|] -type inductive_arity = +type inductive_arity = | Monomorphic of monomorphic_inductive_arity | Polymorphic of polymorphic_arity let val_ind_arity = val_sum "inductive_arity" 0 @@ -509,7 +509,7 @@ type one_inductive_body = { (* number of no constant constructor *) mind_nb_args : int; - mind_reloc_tbl : reloc_table; + mind_reloc_tbl : reloc_table; } let val_one_ind = val_tuple "one_inductive_body" @@ -568,7 +568,7 @@ let subst_const_body sub cb = { (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*) const_constraints = cb.const_constraints; const_opaque = cb.const_opaque; - const_inline = cb.const_inline} + const_inline = cb.const_inline} let subst_arity sub = function | Monomorphic s -> @@ -578,7 +578,7 @@ let subst_arity sub = function } | Polymorphic s as x -> x -let subst_mind_packet sub mbp = +let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_consnrealdecls = mbp.mind_consnrealdecls; mind_typename = mbp.mind_typename; @@ -589,20 +589,20 @@ let subst_mind_packet sub mbp = mind_nrealargs = mbp.mind_nrealargs; mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt; mind_kelim = mbp.mind_kelim; - mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); mind_nb_constant = mbp.mind_nb_constant; mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } -let subst_mind sub mib = - { mind_record = mib.mind_record ; +let subst_mind sub mib = + { mind_record = mib.mind_record ; mind_finite = mib.mind_finite ; mind_ntypes = mib.mind_ntypes ; mind_hyps = (assert (mib.mind_hyps=[]); []) ; mind_nparams = mib.mind_nparams; mind_nparams_rec = mib.mind_nparams_rec; - mind_params_ctxt = + mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt; mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; mind_constraints = mib.mind_constraints ; @@ -612,7 +612,7 @@ let subst_mind sub mib = (* Whenever you change these types, please do update the validation functions below *) -type structure_field_body = +type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body @@ -623,7 +623,7 @@ and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path - | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body + | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body | SEBstruct of mod_self_id * structure_body | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints @@ -633,15 +633,15 @@ and with_declaration_body = With_module_body of identifier list * module_path * struct_expr_body option * Univ.constraints | With_definition_body of identifier list * constant_body - -and module_body = + +and module_body = { mod_expr : struct_expr_body option; mod_type : struct_expr_body option; mod_constraints : Univ.constraints; mod_alias : substitution; mod_retroknowledge : action list} -and module_type_body = +and module_type_body = { typ_expr : struct_expr_body; typ_strength : module_path option; typ_alias : substitution} @@ -670,7 +670,7 @@ and val_module o = val_tuple "module_body" and val_modtype o = val_tuple "module_type_body" [|val_seb;val_opt val_mp;val_subst|] o - + let rec subst_with_body sub = function | With_module_body(id,mp,typ_opt,cst) -> With_module_body(id,subst_mp sub mp, @@ -683,18 +683,18 @@ and subst_modtype sub mtb = if typ_expr'==mtb.typ_expr then mtb else - { mtb with + { mtb with typ_expr = typ_expr'} - -and subst_structure sub sign = + +and subst_structure sub sign = let subst_body = function - SFBconst cb -> + SFBconst cb -> SFBconst (subst_const_body sub cb) - | SFBmind mib -> + | SFBmind mib -> SFBmind (subst_mind sub mib) - | SFBmodule mb -> + | SFBmodule mb -> SFBmodule (subst_module sub mb) - | SFBmodtype mtb -> + | SFBmodtype mtb -> SFBmodtype (subst_modtype sub mtb) | SFBalias (mp,typ_opt ,cst) -> SFBalias (subst_mp sub mp, @@ -710,11 +710,11 @@ and subst_module sub mb = M' with some M''. *) let me' = Option.smartmap (subst_struct_expr sub) mb.mod_expr in let mb_alias = join_alias mb.mod_alias sub in - if mtb'==mb.mod_type && mb.mod_expr == me' + if mtb'==mb.mod_type && mb.mod_expr == me' && mb_alias == mb.mod_alias then mb else { mod_expr = me'; - mod_type=mtb'; + mod_type=mtb'; mod_constraints=mb.mod_constraints; mod_alias = mb_alias; mod_retroknowledge=mb.mod_retroknowledge} @@ -722,7 +722,7 @@ and subst_module sub mb = and subst_struct_expr sub = function | SEBident mp -> SEBident (subst_mp sub mp) - | SEBfunctor (msid, mtb, meb') -> + | SEBfunctor (msid, mtb, meb') -> SEBfunctor(msid,subst_modtype sub mtb,subst_struct_expr sub meb') | SEBstruct (msid,str)-> SEBstruct(msid, subst_structure sub str) @@ -730,10 +730,10 @@ and subst_struct_expr sub = function SEBapply(subst_struct_expr sub meb1, subst_struct_expr sub meb2, cst) - | SEBwith (meb,wdb)-> + | SEBwith (meb,wdb)-> SEBwith(subst_struct_expr sub meb, subst_with_body sub wdb) - -let subst_signature_msid msid mp = + +let subst_signature_msid msid mp = subst_structure (map_msid msid mp) diff --git a/checker/declarations.mli b/checker/declarations.mli index c5b676bda4..3d061b4c2c 100644 --- a/checker/declarations.mli +++ b/checker/declarations.mli @@ -25,7 +25,7 @@ type constant_type = | NonPolymorphicType of constr | PolymorphicArity of rel_context * polymorphic_arity -type constr_substituted +type constr_substituted val force_constr : constr_substituted -> constr val from_val : constr -> constr_substituted @@ -35,14 +35,14 @@ type constant_body = { const_type : constant_type; const_body_code : to_patch_substituted; const_constraints : Univ.constraints; - const_opaque : bool; + const_opaque : bool; const_inline : bool} (* Mutual inductives *) -type recarg = - | Norec - | Mrec of int +type recarg = + | Norec + | Mrec of int | Imbr of inductive type wf_paths = recarg Rtree.t @@ -56,7 +56,7 @@ type monomorphic_inductive_arity = { mind_sort : sorts; } -type inductive_arity = +type inductive_arity = | Monomorphic of monomorphic_inductive_arity | Polymorphic of polymorphic_arity @@ -109,7 +109,7 @@ type one_inductive_body = { (* number of no constant constructor *) mind_nb_args : int; - mind_reloc_tbl : reloc_table; + mind_reloc_tbl : reloc_table; } type mutual_inductive_body = { @@ -149,7 +149,7 @@ type mutual_inductive_body = { type substitution -type structure_field_body = +type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body @@ -160,7 +160,7 @@ and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path - | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body + | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body | SEBstruct of mod_self_id * structure_body | SEBapply of struct_expr_body * struct_expr_body * Univ.constraints @@ -170,15 +170,15 @@ and with_declaration_body = With_module_body of identifier list * module_path * struct_expr_body option * Univ.constraints | With_definition_body of identifier list * constant_body - -and module_body = + +and module_body = { mod_expr : struct_expr_body option; mod_type : struct_expr_body option; mod_constraints : Univ.constraints; mod_alias : substitution; mod_retroknowledge : action list} -and module_type_body = +and module_type_body = { typ_expr : struct_expr_body; typ_strength : module_path option; typ_alias : substitution} diff --git a/checker/environ.ml b/checker/environ.ml index 4bdbeee66a..2d5ff3e43f 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -71,17 +71,17 @@ let push_rel d env = env_rel_context = d :: env.env_rel_context } let push_rel_context ctxt x = fold_rel_context push_rel ctxt ~init:x - + let push_rec_types (lna,typarray,_) env = let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt (* Named context *) -let push_named d env = +let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) - { env with + { env with env_named_context = d :: env.env_named_context } let lookup_named id env = @@ -98,11 +98,11 @@ let named_type id env = (* Universe constraints *) let add_constraints c env = - if c == Constraint.empty then - env + if c == Constraint.empty then + env else let s = env.env_stratification in - { env with env_stratification = + { env with env_stratification = { s with env_universes = merge_constraints c s.env_universes } } (* Global constants *) @@ -111,17 +111,17 @@ let lookup_constant kn env = Cmap.find kn env.env_globals.env_constants let add_constant kn cs env = - let new_constants = + let new_constants = Cmap.add kn cs env.env_globals.env_constants in - let new_globals = - { env.env_globals with - env_constants = new_constants } in + let new_globals = + { env.env_globals with + env_constants = new_constants } in { env with env_globals = new_globals } (* constant_type gives the type of a constant *) let constant_type env kn = let cb = lookup_constant kn env in - cb.const_type + cb.const_type type const_evaluation_result = NoBody | Opaque @@ -147,15 +147,15 @@ let evaluable_constant cst env = let lookup_mind kn env = KNmap.find kn env.env_globals.env_inductives -let rec scrape_mind env kn = +let rec scrape_mind env kn = match (lookup_mind kn env).mind_equiv with | None -> kn | Some kn' -> scrape_mind env kn' let add_mind kn mib env = let new_inds = KNmap.add kn mib env.env_globals.env_inductives in - let new_globals = - { env.env_globals with + let new_globals = + { env.env_globals with env_inductives = new_inds } in { env with env_globals = new_globals } @@ -168,36 +168,36 @@ let rec mind_equiv env (kn1,i1) (kn2,i2) = (* Modules *) -let add_modtype ln mtb env = +let add_modtype ln mtb env = let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in - let new_globals = - { env.env_globals with + let new_globals = + { env.env_globals with env_modtypes = new_modtypes } in { env with env_globals = new_globals } -let shallow_add_module mp mb env = +let shallow_add_module mp mb env = let new_mods = MPmap.add mp mb env.env_globals.env_modules in - let new_globals = - { env.env_globals with + let new_globals = + { env.env_globals with env_modules = new_mods } in { env with env_globals = new_globals } let register_alias mp1 mp2 env = let new_alias = MPmap.add mp1 mp2 env.env_globals.env_alias in - let new_globals = - { env.env_globals with + let new_globals = + { env.env_globals with env_alias = new_alias } in { env with env_globals = new_globals } -let rec scrape_alias mp env = +let rec scrape_alias mp env = try let mp1 = MPmap.find mp env.env_globals.env_alias in scrape_alias mp1 env with Not_found -> mp -let lookup_module mp env = +let lookup_module mp env = MPmap.find mp env.env_globals.env_modules -let lookup_modtype ln env = +let lookup_modtype ln env = MPmap.find ln env.env_globals.env_modtypes diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 9ff21bc3ff..3d4f6be79e 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -119,17 +119,17 @@ let is_small_constr infos = List.for_all (fun s -> is_small_sort s) infos let is_logic_constr infos = List.for_all (fun s -> is_logic_sort s) infos (* An inductive definition is a "unit" if it has only one constructor - and that all arguments expected by this constructor are - logical, this is the case for equality, conjunction of logical properties + and that all arguments expected by this constructor are + logical, this is the case for equality, conjunction of logical properties *) let is_unit constrsinfos = match constrsinfos with (* One info = One constructor *) - | [|constrinfos|] -> is_logic_constr constrinfos + | [|constrinfos|] -> is_logic_constr constrinfos | [||] -> (* type without constructors *) true | _ -> false let small_unit constrsinfos = - let issmall = array_for_all is_small_constr constrsinfos + let issmall = array_for_all is_small_constr constrsinfos and isunit = is_unit constrsinfos in issmall, isunit @@ -278,20 +278,20 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum -let explain_ind_err ntyp env0 nbpar c err = +let explain_ind_err ntyp env0 nbpar c err = let (lpar,c') = mind_extract_params nbpar c in let env = push_rel_context lpar env0 in match err with - | LocalNonPos kt -> + | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',Rel (kt+nbpar)))) - | LocalNotEnoughArgs kt -> - raise (InductiveError + | LocalNotEnoughArgs kt -> + raise (InductiveError (NotEnoughArgs (env,c',Rel (kt+nbpar)))) | LocalNotConstructor -> - raise (InductiveError + raise (InductiveError (NotConstructor (env,c',Rel (ntyp+nbpar)))) | LocalNonPar (n,l) -> - raise (InductiveError + raise (InductiveError (NonPar (env,c',n,Rel (nbpar-n+1), Rel (l+nbpar)))) let failwith_non_pos n ntypes c = @@ -312,7 +312,7 @@ let failwith_non_pos_list n ntypes l = let check_correct_par (env,n,ntypes,_) hyps l largs = let nparams = rel_context_nhyps hyps in let largs = Array.of_list largs in - if Array.length largs < nparams then + if Array.length largs < nparams then raise (IllFormedInd (LocalNotEnoughArgs l)); let (lpar,largs') = array_chop nparams largs in let nhyps = List.length hyps in @@ -324,18 +324,18 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = | Rel w when w = index -> check (k-1) (index+1) hyps | _ -> raise (IllFormedInd (LocalNonPar (k+1,l))) in check (nparams-1) (n-nhyps) hyps; - if not (array_for_all (noccur_between n ntypes) largs') then + if not (array_for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' (* Arguments of constructor: check the number of recursive parameters nrecp. - the first parameters which are constant in recursive arguments - n is the current depth, nmr is the maximum number of possible + the first parameters which are constant in recursive arguments + n is the current depth, nmr is the maximum number of possible recursive parameters *) -let check_rec_par (env,n,_,_) hyps nrecp largs = +let check_rec_par (env,n,_,_) hyps nrecp largs = let (lpar,_) = list_chop nrecp largs in - let rec find index = - function + let rec find index = + function | ([],_) -> () | (_,[]) -> failwith "number of recursive parameters cannot be greater than the number of parameters." @@ -352,14 +352,14 @@ let lambda_implicit_lift n a = (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) -let abstract_mind_lc env ntyps npars lc = - if npars = 0 then +let abstract_mind_lc env ntyps npars lc = + if npars = 0 then lc - else - let make_abs = + else + let make_abs = list_tabulate - (function i -> lambda_implicit_lift npars (Rel (i+1))) ntyps - in + (function i -> lambda_implicit_lift npars (Rel (i+1))) ntyps + in Array.map (substl make_abs) lc (* [env] is the typing environment @@ -367,7 +367,7 @@ let abstract_mind_lc env ntyps npars lc = [ntypes] is the number of inductive types in the definition (i.e. range of inductives is [n; n+ntypes-1]) [lra] is the list of recursive tree of each variable - *) + *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) @@ -377,7 +377,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = let env' = push_rel (Anonymous,None, hnf_prod_applist env (type_of_inductive env specif) lpar) env in - let ra_env' = + let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in (* New index of the inductive types *) @@ -389,7 +389,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc = let lparams = rel_context_length hyps in (* check the inductive types occur positively in [c] *) - let rec check_pos (env, n, ntypes, ra_env as ienv) c = + let rec check_pos (env, n, ntypes, ra_env as ienv) c = let x,largs = decompose_app (whd_betadeltaiota env c) in match x with | Prod (na,b,d) -> @@ -400,7 +400,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc = check_pos (ienv_push_var ienv (na, b, mk_norec)) d) | Rel k -> (try - let (ra,rarg) = List.nth ra_env (k-1) in + let (ra,rarg) = List.nth ra_env (k-1) in (match ra with Mrec _ -> check_rec_par ienv hyps nrecp largs | _ -> ()); @@ -413,9 +413,9 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc = parameter, then we have an imbricated type *) if List.for_all (noccur_between n ntypes) largs then mk_norec else check_positive_imbr ienv (ind_kn, largs) - | err -> + | err -> if noccur_between n ntypes x && - List.for_all (noccur_between n ntypes) largs + List.for_all (noccur_between n ntypes) largs then mk_norec else failwith_non_pos_list n ntypes (x::largs) @@ -424,14 +424,14 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc = let (mib,mip) = lookup_mind_specif env mi in let auxnpar = mib.mind_nparams_rec in let (lpar,auxlargs) = - try list_chop auxnpar largs - with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in + try list_chop auxnpar largs + with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in (* If the inductive appears in the args (non params) then the definition is not positive. *) if not (List.for_all (noccur_between n ntypes) auxlargs) then raise (IllFormedInd (LocalNonPos n)); (* We do not deal with imbricated mutual inductive types *) - let auxntyp = mib.mind_ntypes in + let auxntyp = mib.mind_ntypes in if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n)); (* The nested inductive type with parameters removed *) let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in @@ -440,30 +440,30 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc = let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in - let irecargs = + let irecargs = (* fails if the inductive type occurs non positively *) - (* when substituted *) - Array.map - (function c -> - let c' = hnf_prod_applist env' c lpar' in - check_constructors ienv' false c') - auxlcvect in + (* when substituted *) + Array.map + (function c -> + let c' = hnf_prod_applist env' c lpar' in + check_constructors ienv' false c') + auxlcvect in (Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0) - + (* check the inductive types occur positively in the products of C, if check_head=true, also check the head corresponds to a constructor of - the ith type *) - - and check_constructors ienv check_head c = - let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = + the ith type *) + + and check_constructors ienv check_head c = + let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = let x,largs = decompose_app (whd_betadeltaiota env c) in match x with - | Prod (na,b,d) -> + | Prod (na,b,d) -> assert (largs = []); - let recarg = check_pos ienv b in + let recarg = check_pos ienv b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' (recarg::lrec) d - + | hd -> if check_head then if hd = Rel (n+ntypes-i-1) then @@ -482,7 +482,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp i indlc = let _,rawc = mind_extract_params lparams c in try check_constructors ienv true rawc - with IllFormedInd err -> + with IllFormedInd err -> explain_ind_err (ntypes-i) env lparams c err) indlc in mk_paths (Mrec i) irecargs @@ -505,9 +505,9 @@ let check_positivity env_ar params nrecp inds = let ra_env = list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in let ienv = (env_ar, 1+lparams, ntypes, ra_env) in - check_positivity_one ienv params nrecp i mip.mind_nf_lc + check_positivity_one ienv params nrecp i mip.mind_nf_lc in - let irecargs = Array.mapi check_one inds in + let irecargs = Array.mapi check_one inds in let wfp = Rtree.mk_rec irecargs in array_iter2 (fun ind wfpi -> check_subtree ind.mind_recargs wfpi) inds wfp diff --git a/checker/inductive.ml b/checker/inductive.ml index f1c8bea2a5..e08efbe5b6 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -58,7 +58,7 @@ let inductive_params (mib,_) = mib.mind_nparams (* inductives *) let ind_subst mind mib = let ntypes = mib.mind_ntypes in - let make_Ik k = Ind (mind,ntypes-k-1) in + let make_Ik k = Ind (mind,ntypes-k-1) in list_tabulate make_Ik ntypes (* Instantiate inductives in constructor type *) @@ -67,7 +67,7 @@ let constructor_instantiate mind mib c = substl s c let instantiate_params full t args sign = - let fail () = + let fail () = anomaly "instantiate_params: type, ctxt and args mismatch" in let (rem_args, subs, ty) = fold_rel_context @@ -78,7 +78,7 @@ let instantiate_params full t args sign = | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) sign - ~init:(args,[],t) + ~init:(args,[],t) in if rem_args <> [] then fail(); substl subs ty @@ -104,11 +104,11 @@ let full_constructor_instantiate ((mind,_),(mib,_),params) = let number_of_inductives mib = Array.length mib.mind_packets let number_of_constructors mip = Array.length mip.mind_consnames -(* +(* Computing the actual sort of an applied or partially applied inductive type: I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a) -uniformargs : utyps +uniformargs : utyps otherargs : otyps I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj s'_k = max(..s_kj..) @@ -221,7 +221,7 @@ let type_of_constructor cstr (mib,mip) = if i > nconstr then error "Not enough constructors in the type"; constructor_instantiate (fst ind) mib specif.(i-1) -let arities_of_specif kn (mib,mip) = +let arities_of_specif kn (mib,mip) = let specif = mip.mind_nf_lc in Array.map (constructor_instantiate kn mib) specif @@ -241,7 +241,7 @@ let error_elim_expln kp ki = let inductive_sort_family mip = match mip.mind_arity with - | Monomorphic s -> family_of_sort s.mind_sort + | Monomorphic s -> family_of_sort s.mind_sort | Polymorphic _ -> InType let mind_arity mip = @@ -258,12 +258,12 @@ let extended_rel_list n hyps = | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps | (_,Some _,_) :: hyps -> reln l (p+1) hyps | [] -> l - in + in reln [] 1 hyps let build_dependent_inductive ind (_,mip) params = let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in - applist + applist (Ind ind, List.map (lift mip.mind_nrealargs_ctxt) params @ extended_rel_list 0 realargs) @@ -272,11 +272,11 @@ let build_dependent_inductive ind (_,mip) params = exception LocalArity of (sorts_family * sorts_family * arity_error) option let check_allowed_sort ksort specif = - if not (List.exists ((=) ksort) (elim_sorts specif)) then + if not (List.exists ((=) ksort) (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in raise (LocalArity (Some(ksort,s,error_elim_expln ksort s))) -let is_correct_arity env c (p,pj) ind specif params = +let is_correct_arity env c (p,pj) ind specif params = let arsign,_ = get_instantiated_arity specif params in let rec srec env pt ar = let pt' = whd_betadeltaiota env pt in @@ -287,9 +287,9 @@ let is_correct_arity env c (p,pj) ind specif params = srec (push_rel (na1,None,a1) env) t ar' | Prod (_,a1,a2), [] -> (* whnf of t was not needed here! *) let ksort = match (whd_betadeltaiota env a2) with - | Sort s -> family_of_sort s + | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in - let dep_ind = build_dependent_inductive ind specif params in + let dep_ind = build_dependent_inductive ind specif params in (try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None)); check_allowed_sort ksort specif; @@ -299,7 +299,7 @@ let is_correct_arity env c (p,pj) ind specif params = false | _ -> raise (LocalArity None) - in + in try srec env pj (List.rev arsign) with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c (p,pj) kinds @@ -336,7 +336,7 @@ let build_case_type dep p c realargs = beta_appvect p (Array.of_list args) let type_case_branches env (ind,largs) (p,pj) c = - let specif = lookup_mind_specif env ind in + let specif = lookup_mind_specif env ind in let nparams = inductive_params specif in let (params,realargs) = list_chop nparams largs in let dep = is_correct_arity env c (p,pj) ind specif params in @@ -361,7 +361,7 @@ let check_case_info env indsp ci = (* Guard conditions for fix and cofix-points *) -(* Check if t is a subterm of Rel n, and gives its specification, +(* Check if t is a subterm of Rel n, and gives its specification, assuming lst already gives index of subterms with corresponding specifications of recursive arguments *) @@ -419,7 +419,7 @@ let subterm_spec_glb = (* branches do not return objects with same spec *) else Not_subterm in Array.fold_left glb2 Dead_code - + type guard_env = { env : env; (* dB of last fixpoint *) @@ -443,7 +443,7 @@ let make_renv env minds recarg (kn,tyi) = genv = [Subterm(Large,mind_recvec.(tyi))] } let push_var renv (x,ty,spec) = - { renv with + { renv with env = push_rel (x,None,ty) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } @@ -455,7 +455,7 @@ let push_var_renv renv (x,ty) = push_var renv (x,ty,Not_subterm) (* Fetch recursive information about a variable p *) -let subterm_var p renv = +let subterm_var p renv = try List.nth renv.genv (p-1) with Failure _ | Invalid_argument _ -> Not_subterm @@ -465,7 +465,7 @@ let add_subterm renv (x,a,spec) = let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in - { renv with + { renv with env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> Not_subterm::ge) n renv.genv } @@ -504,8 +504,8 @@ let lookup_subterms env ind = associated to its own subterms. Rq: if branch is not eta-long, then the recursive information is not propagated to the missing abstractions *) -let case_branches_specif renv c_spec ind lbr = - let rec push_branch_args renv lrec c = +let case_branches_specif renv c_spec ind lbr = + let rec push_branch_args renv lrec c = match lrec with ra::lr -> let c' = whd_betadeltaiota renv.env c in @@ -521,7 +521,7 @@ let case_branches_specif renv c_spec ind lbr = let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in assert (Array.length sub_spec = Array.length lbr); array_map2 (push_branch_args renv) sub_spec lbr - | Dead_code -> + | Dead_code -> let t = dest_subterms (lookup_subterms renv.env ind) in let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in assert (Array.length sub_spec = Array.length lbr); @@ -534,10 +534,10 @@ let case_branches_specif renv c_spec ind lbr = about variables. *) -let rec subterm_specif renv t = +let rec subterm_specif renv t = (* maybe reduction is not always necessary! *) let f,l = decompose_app (whd_betadeltaiota renv.env t) in - match f with + match f with | Rel k -> subterm_var k renv | Case (ci,_,c,lbr) -> @@ -549,7 +549,7 @@ let rec subterm_specif renv t = Array.map (fun (renv',br') -> subterm_specif renv' br') lbr_spec in subterm_spec_glb stl - + | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> (* when proving that the fixpoint f(x)=e is less than n, it is enough to prove that e is less than n assuming f is less than n @@ -572,7 +572,7 @@ let rec subterm_specif renv t = (* Why Strict here ? To be general, it could also be Large... *) assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in - let decrArg = recindxs.(i) in + let decrArg = recindxs.(i) in let theBody = bodies.(i) in let nbOfAbst = decrArg+1 in let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in @@ -586,7 +586,7 @@ let rec subterm_specif renv t = assign_var_spec renv'' (1, arg_spec) in subterm_specif renv'' strippedBody) - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> assert (l=[]); subterm_specif (push_var_renv renv (x,a)) b @@ -598,7 +598,7 @@ let rec subterm_specif renv t = (* Check term c can be applied to one of the mutual fixpoints. *) -let check_is_subterm renv c = +let check_is_subterm renv c = match subterm_specif renv c with Subterm (Strict,_) | Dead_code -> true | _ -> false @@ -626,21 +626,21 @@ let error_partial_apply renv fx = given [recpos], the decreasing arguments of each mutually defined fixpoint. *) let check_one_fix renv recpos def = - let nfi = Array.length recpos in + let nfi = Array.length recpos in (* Checks if [t] only make valid recursive calls *) - let rec check_rec_call renv t = + let rec check_rec_call renv t = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in match f with - | Rel p -> - (* Test if [p] is a fixpoint (recursive call) *) + | Rel p -> + (* Test if [p] is a fixpoint (recursive call) *) if renv.rel_min <= p & p < renv.rel_min+nfi then begin List.iter (check_rec_call renv) l; - (* the position of the invoked fixpoint: *) + (* the position of the invoked fixpoint: *) let glob = renv.rel_min+nfi-1-p in (* the decreasing arg of the rec call: *) let np = recpos.(glob) in @@ -672,9 +672,9 @@ let check_one_fix renv recpos def = (* Enables to traverse Fixpoint definitions in a more intelligent way, ie, the rule : if - g = Fix g/p := [y1:T1]...[yp:Tp]e & - - f is guarded with respect to the set of pattern variables S + - f is guarded with respect to the set of pattern variables S in a1 ... am & - - f is guarded with respect to the set of pattern variables S + - f is guarded with respect to the set of pattern variables S in T1 ... Tp & - ap is a sub-term of the formal argument of f & - f is guarded with respect to the set of pattern variables @@ -686,10 +686,10 @@ let check_one_fix renv recpos def = List.iter (check_rec_call renv) l; Array.iter (check_rec_call renv) typarray; let decrArg = recindxs.(i) in - let renv' = push_fix_renv renv recdef in + let renv' = push_fix_renv renv recdef in if (List.length l < (decrArg+1)) then Array.iter (check_rec_call renv') bodies - else + else Array.iteri (fun j body -> if i=j then @@ -699,8 +699,8 @@ let check_one_fix renv recpos def = else check_rec_call renv' body) bodies - | Const kn -> - if evaluable_constant kn renv.env then + | Const kn -> + if evaluable_constant kn renv.env then try List.iter (check_rec_call renv) l with (FixGuardError _ ) -> check_rec_call renv(applist(constant_value renv.env kn, l)) @@ -708,14 +708,14 @@ let check_one_fix renv recpos def = (* The cases below simply check recursively the condition on the subterms *) - | Cast (a,_, b) -> + | Cast (a,_, b) -> List.iter (check_rec_call renv) (a::b::l) | Lambda (x,a,b) -> List.iter (check_rec_call renv) (a::l); check_rec_call (push_var_renv renv (x,a)) b - | Prod (x,a,b) -> + | Prod (x,a,b) -> List.iter (check_rec_call renv) (a::l); check_rec_call (push_var_renv renv (x,a)) b @@ -759,9 +759,9 @@ let check_one_fix renv recpos def = let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = - let nbfix = Array.length bodies in + let nbfix = Array.length bodies in if nbfix = 0 - or Array.length nvect <> nbfix + or Array.length nvect <> nbfix or Array.length types <> nbfix or Array.length names <> nbfix or bodynum < 0 @@ -771,18 +771,18 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = let raise_err env i err = error_ill_formed_rec_body env err names i in (* Check the i-th definition with recarg k *) - let find_ind i k def = - (* check fi does not appear in the k+1 first abstractions, + let find_ind i k def = + (* check fi does not appear in the k+1 first abstractions, gives the type of the k+1-eme abstraction (must be an inductive) *) - let rec check_occur env n def = + let rec check_occur env n def = match (whd_betadeltaiota env def) with - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in if n = k+1 then (* get the inductive type of the fixpoint *) - let (mind, _) = - try find_inductive env a + let (mind, _) = + try find_inductive env a with Not_found -> raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) @@ -822,17 +822,17 @@ let rec codomain_is_coind env c = let b = whd_betadeltaiota env c in match b with | Prod (x,a,b) -> - codomain_is_coind (push_rel (x, None, a) env) b - | _ -> + codomain_is_coind (push_rel (x, None, a) env) b + | _ -> (try find_coinductive env b with Not_found -> raise (CoFixGuardError (env, CodomainNotInductiveType b))) -let check_one_cofix env nbfix def deftype = +let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n vlra t = if not (noccur_with_meta n nbfix t) then let c,args = decompose_app (whd_betadeltaiota env t) in - match c with + match c with | Rel p when n <= p && p < n+nbfix -> (* recursive call: must be guarded and no nested recursive call allowed *) @@ -840,14 +840,14 @@ let check_one_cofix env nbfix def deftype = raise (CoFixGuardError (env,UnguardedRecursiveCall t)) else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) - + | Construct (_,i as cstr_kn) -> - let lra = vlra.(i-1) in + let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in let realargs = list_skipn mib.mind_nparams args in let rec process_args_of_constr = function - | (t::lr), (rar::lrar) -> + | (t::lr), (rar::lrar) -> if rar = mk_norec then if noccur_with_meta n nbfix t then process_args_of_constr (lr, lrar) @@ -858,26 +858,26 @@ let check_one_cofix env nbfix def deftype = check_rec_call env true n spec t; process_args_of_constr (lr, lrar) | [],_ -> () - | _ -> anomaly_ill_typed () + | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) - + | Lambda (x,a,b) -> assert (args = []); if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in check_rec_call env' alreadygrd (n+1) vlra b - else + else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) - + | CoFix (j,(_,varit,vdefs as recdef)) -> if (List.for_all (noccur_with_meta n nbfix) args) - then + then let nbfix = Array.length vdefs in if (array_for_all (noccur_with_meta n nbfix) varit) then let env' = push_rec_types recdef env in (Array.iter (check_rec_call env' alreadygrd (n+1) vlra) vdefs; List.iter (check_rec_call env alreadygrd n vlra) args) - else + else raise (CoFixGuardError (env,RecCallInTypeOfDef c)) else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) @@ -887,31 +887,31 @@ let check_one_cofix env nbfix def deftype = if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then Array.iter (check_rec_call env alreadygrd n vlra) vrest - else + else raise (CoFixGuardError (env,RecCallInCaseFun c)) - else + else raise (CoFixGuardError (env,RecCallInCaseArg c)) - else + else raise (CoFixGuardError (env,RecCallInCasePred c)) - + | Meta _ -> () | Evar _ -> List.iter (check_rec_call env alreadygrd n vlra) args - - | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in + + | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let (mind, _) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in check_rec_call env false 1 (dest_subterms vlra) def -(* The function which checks that the whole block of definitions +(* The function which checks that the whole block of definitions satisfies the guarded condition *) -let check_cofix env (bodynum,(names,types,bodies as recdef)) = - let nbfix = Array.length bodies in +let check_cofix env (bodynum,(names,types,bodies as recdef)) = + let nbfix = Array.length bodies in for i = 0 to nbfix-1 do let fixenv = push_rec_types recdef env in try check_one_cofix fixenv nbfix bodies.(i) types.(i) - with CoFixGuardError (errenv,err) -> + with CoFixGuardError (errenv,err) -> error_ill_formed_rec_body errenv err names i done diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 9e7a233633..99babe6322 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -31,7 +31,7 @@ let check_constant_declaration env kn cb = (match cb.const_type with NonPolymorphicType ty -> let ty, cu = refresh_arity ty in - let envty = add_constraints cu env' in + let envty = add_constraints cu env' in let _ = infer_type envty ty in (match cb.const_body with | Some bd -> @@ -58,9 +58,9 @@ let rec list_split_assoc k rev_before = function | (k',b)::after when k=k' -> rev_before,b,after | h::tail -> list_split_assoc k (h::rev_before) tail -let rec list_fold_map2 f e = function +let rec list_fold_map2 f e = function | [] -> (e,[],[]) - | h::t -> + | h::t -> let e',h1',h2' = f e h in let e'',t1',t2' = list_fold_map2 f e' t in e'',h1'::t1',h2'::t2' @@ -70,7 +70,7 @@ let check_alias (s1:substitution) s2 = if s1 <> s2 then failwith "Incorrect alias" let check_definition_sub env cb1 cb2 = - let check_type env t1 t2 = + let check_type env t1 t2 = (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion @@ -81,7 +81,7 @@ let check_definition_sub env cb1 cb2 = Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). Hence they don't have to be checked again *) - let t1,t2 = + let t1,t2 = if isArity t2 then let (ctx2,s2) = destArity t2 in match s2 with @@ -136,21 +136,21 @@ let lookup_modtype mp env = failwith ("Unknown module type: "^string_of_mp mp) -let rec check_with env mtb with_decl = +let rec check_with env mtb with_decl = match with_decl with - | With_definition_body _ -> + | With_definition_body _ -> check_with_aux_def env mtb with_decl; empty_subst - | With_module_body _ -> + | With_module_body _ -> check_with_aux_mod env mtb with_decl -and check_with_aux_def env mtb with_decl = - let msid,sig_b = match (eval_struct env mtb) with +and check_with_aux_def env mtb with_decl = + let msid,sig_b = match (eval_struct env mtb) with | SEBstruct(msid,sig_b) -> msid,sig_b | _ -> error_signature_expected mtb in - let id,idl = match with_decl with + let id,idl = match with_decl with | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false @@ -162,11 +162,11 @@ and check_with_aux_def env mtb with_decl = let env' = Modops.add_signature (MPself msid) before env in match with_decl with | With_definition_body ([],_) -> assert false - | With_definition_body ([id],c) -> + | With_definition_body ([id],c) -> let cb = match spec with SFBconst cb -> cb | _ -> error_not_a_constant l - in + in check_definition_sub env' c cb | With_definition_body (_::_,_) -> let old = match spec with @@ -180,7 +180,7 @@ and check_with_aux_def env mtb with_decl = With_definition_body (_,c) -> With_definition_body (idl,c) | With_module_body (_,c,t,cst) -> - With_module_body (idl,c,t,cst) in + With_module_body (idl,c,t,cst) in check_with_aux_def env' (type_of_mb env old) new_with_decl | Some msb -> error_a_generative_module_expected l @@ -190,14 +190,14 @@ and check_with_aux_def env mtb with_decl = Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l -and check_with_aux_mod env mtb with_decl = +and check_with_aux_mod env mtb with_decl = let initmsid,msid,sig_b = - match eval_struct env mtb with + match eval_struct env mtb with | SEBstruct(msid,sig_b) -> let msid'=(refresh_msid msid) in msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b) | _ -> error_signature_expected mtb in - let id,idl = match with_decl with + let id,idl = match with_decl with | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false @@ -209,7 +209,7 @@ and check_with_aux_mod env mtb with_decl = let rec mp_rec = function | [] -> MPself initmsid | i::r -> MPdot(mp_rec r,label_of_id i) - in + in let env' = Modops.add_signature (MPself msid) before env in match with_decl with | With_module_body ([],_,_,_) -> assert false @@ -229,7 +229,7 @@ and check_with_aux_mod env mtb with_decl = anomaly "Mod_typing:no implementation and no alias" in join (map_mp (mp_rec [id]) mp) mtb'.typ_alias - | With_module_body (_::_,mp,_,_) -> + | With_module_body (_::_,mp,_,_) -> let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l @@ -238,12 +238,12 @@ and check_with_aux_mod env mtb with_decl = match old.mod_expr with None -> let new_with_decl = match with_decl with - With_definition_body (_,c) -> + With_definition_body (_,c) -> With_definition_body (idl,c) | With_module_body (_,c,t,cst) -> With_module_body (idl,c,t,cst) in let sub = - check_with_aux_mod env' + check_with_aux_mod env' (type_of_mb env old) new_with_decl in join (map_mp (mp_rec idl) mp) sub | Some msb -> @@ -263,15 +263,15 @@ and check_module_type env mty = and check_module env mb = let sub = match mb.mod_expr, mb.mod_type with - | None, None -> + | None, None -> anomaly "Mod_typing.translate_module: empty type and expr in module entry" | None, Some mtb -> check_modexpr env mtb - | Some mexpr, _ -> + | Some mexpr, _ -> let sub1 = check_modexpr env mexpr in (match mb.mod_type with | None -> sub1 - | Some mte -> + | Some mte -> let sub2 = check_modexpr env mte in check_subtypes env {typ_expr = mexpr; @@ -333,8 +333,8 @@ and check_modexpr env mse = match mse with let mtb = lookup_modtype mp env in check_subtypes env mtb farg_b; let sub2 = match eval_struct env m with - | SEBstruct (msid,sign) -> - join_alias + | SEBstruct (msid,sign) -> + join_alias (subst_key (map_msid msid mp) mtb.typ_alias) (map_msid msid mp) | _ -> mtb.typ_alias in @@ -356,12 +356,12 @@ and check_modexpr env mse = match mse with let rec add_struct_expr_constraints env = function | SEBident _ -> env - | SEBfunctor (_,mtb,meb) -> - add_struct_expr_constraints + | SEBfunctor (_,mtb,meb) -> + add_struct_expr_constraints (add_modtype_constraints env mtb) meb | SEBstruct (_,structure_body) -> - List.fold_left + List.fold_left (fun env (l,item) -> add_struct_elem_constraints env item) env structure_body @@ -369,20 +369,20 @@ let rec add_struct_expr_constraints env = function | SEBapply (meb1,meb2,cst) -> (* let g = Univ.merge_constraints cst Univ.initial_universes in msgnl(str"ADDING FUNCTOR APPLICATION CONSTRAINTS:"++fnl()++ - Univ.pr_universes g++str"============="++fnl()); + Univ.pr_universes g++str"============="++fnl()); *) - Environ.add_constraints cst - (add_struct_expr_constraints - (add_struct_expr_constraints env meb1) + Environ.add_constraints cst + (add_struct_expr_constraints + (add_struct_expr_constraints env meb1) meb2) | SEBwith(meb,With_definition_body(_,cb))-> Environ.add_constraints cb.const_constraints (add_struct_expr_constraints env meb) | SEBwith(meb,With_module_body(_,_,cst))-> Environ.add_constraints cst - (add_struct_expr_constraints env meb) - -and add_struct_elem_constraints env = function + (add_struct_expr_constraints env meb) + +and add_struct_elem_constraints env = function | SFBconst cb -> Environ.add_constraints cb.const_constraints env | SFBmind mib -> Environ.add_constraints mib.mind_constraints env | SFBmodule mb -> add_module_constraints env mb @@ -390,18 +390,18 @@ and add_struct_elem_constraints env = function | SFBalias (mp,None) -> env | SFBmodtype mtb -> add_modtype_constraints env mtb -and add_module_constraints env mb = +and add_module_constraints env mb = let env = match mb.mod_expr with | None -> env | Some meb -> add_struct_expr_constraints env meb in let env = match mb.mod_type with | None -> env - | Some mtb -> + | Some mtb -> add_struct_expr_constraints env mtb in Environ.add_constraints mb.mod_constraints env -and add_modtype_constraints env mtb = +and add_modtype_constraints env mtb = add_struct_expr_constraints env mtb.typ_expr *) diff --git a/checker/modops.ml b/checker/modops.ml index 498bd7753f..a986e18981 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -18,7 +18,7 @@ open Declarations open Environ (*i*) -let error_not_a_constant l = +let error_not_a_constant l = error ("\""^(string_of_label l)^"\" is not a constant") let error_not_a_functor _ = error "Application of not a functor" @@ -38,7 +38,7 @@ let error_no_such_label_sub l l1 l2 = error (l1^" is not a subtype of "^l2^".\nThe field "^ string_of_label l^" is missing (or invisible) in "^l1^".") -let error_not_a_module_loc loc s = +let error_not_a_module_loc loc s = user_err_loc (loc,"",str ("\""^string_of_label s^"\" is not a module")) let error_not_a_module s = error_not_a_module_loc dummy_loc s @@ -57,7 +57,7 @@ let error_signature_expected mtb = let error_application_to_not_path _ = error "Application to not path" -let module_body_of_type mtb = +let module_body_of_type mtb = { mod_type = Some mtb.typ_expr; mod_expr = None; mod_constraints = Constraint.empty; @@ -65,12 +65,12 @@ let module_body_of_type mtb = mod_retroknowledge = []} let module_type_of_module mp mb = - {typ_expr = + {typ_expr = (match mb.mod_type with | Some expr -> expr | None -> (match mb.mod_expr with | Some expr -> expr - | None -> + | None -> anomaly "Modops: empty expr and type")); typ_alias = mb.mod_alias; typ_strength = mp @@ -95,24 +95,24 @@ let destr_functor env mtb = | _ -> error_not_a_functor mtb -let rec check_modpath_equiv env mp1 mp2 = +let rec check_modpath_equiv env mp1 mp2 = if mp1=mp2 then () else let mp1 = scrape_alias mp1 env in let mp2 = scrape_alias mp2 env in if mp1=mp2 then () - else + else error_not_equal mp1 mp2 -let strengthen_const env mp l cb = +let strengthen_const env mp l cb = match cb.const_opaque, cb.const_body with | false, Some _ -> cb - | true, Some _ - | _, None -> - let const = Const (make_con mp empty_dirpath l) in + | true, Some _ + | _, None -> + let const = Const (make_con mp empty_dirpath l) in let const_subs = Some (Declarations.from_val const) in - {cb with + {cb with const_body = const_subs; const_opaque = false } @@ -122,8 +122,8 @@ let strengthen_mind env mp l mib = match mib.mind_equiv with | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)} -let rec eval_struct env = function - | SEBident mp -> +let rec eval_struct env = function + | SEBident mp -> begin let mp = scrape_alias mp env in let mtb =lookup_modtype mp env in @@ -131,7 +131,7 @@ let rec eval_struct env = function mtb,None -> eval_struct env mtb | mtb,Some mp -> strengthen_mtb env mp (eval_struct env mtb) end - | SEBapply (seb1,seb2,_) -> + | SEBapply (seb1,seb2,_) -> let svb1 = eval_struct env seb1 in let farg_id, farg_b, fbody_b = destr_functor env svb1 in let mp = path_of_seb seb2 in @@ -140,9 +140,9 @@ let rec eval_struct env = function let sub_alias = match eval_struct env (SEBident mp) with | SEBstruct (msid,sign) -> subst_key (map_msid msid mp) sub_alias | _ -> sub_alias in - let sub_alias = update_subst_alias sub_alias + let sub_alias = update_subst_alias sub_alias (map_mbid farg_id mp) in - eval_struct env (subst_struct_expr + eval_struct env (subst_struct_expr (join sub_alias (map_mbid farg_id mp)) fbody_b) | SEBwith (mtb,(With_definition_body _ as wdb)) -> merge_with env mtb wdb empty_subst @@ -150,24 +150,24 @@ let rec eval_struct env = function let alias_in_mp = (lookup_modtype mp env).typ_alias in merge_with env mtb wdb alias_in_mp -(* | SEBfunctor(mbid,mtb,body) -> +(* | SEBfunctor(mbid,mtb,body) -> let env = add_module (MPbound mbid) (module_body_of_type mtb) env in SEBfunctor(mbid,mtb,eval_struct env body) *) | mtb -> mtb - + and type_of_mb env mb = match mb.mod_type,mb.mod_expr with None,Some b -> eval_struct env b | Some t, _ -> eval_struct env t - | _,_ -> anomaly - "Modops: empty type and empty expr" - -and merge_with env mtb with_decl alias= - let msid,sig_b = match (eval_struct env mtb) with + | _,_ -> anomaly + "Modops: empty type and empty expr" + +and merge_with env mtb with_decl alias= + let msid,sig_b = match (eval_struct env mtb) with | SEBstruct(msid,sig_b) -> msid,sig_b | _ -> error_signature_expected mtb in - let id,idl = match with_decl with + let id,idl = match with_decl with | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false in @@ -178,35 +178,35 @@ and merge_with env mtb with_decl alias= let rec mp_rec = function | [] -> MPself msid | i::r -> MPdot(mp_rec r,label_of_id i) - in + in let new_spec,subst = match with_decl with | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false - | With_definition_body ([id],c) -> + | With_definition_body ([id],c) -> SFBconst c,None | With_module_body ([id], mp,typ_opt,cst) -> let mp' = scrape_alias mp env in SFBalias (mp,typ_opt,Some cst), Some(join (map_mp (mp_rec [id]) mp') alias) - | With_definition_body (_::_,_) - | With_module_body (_::_,_,_,_) -> + | With_definition_body (_::_,_) + | With_module_body (_::_,_,_,_) -> let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module l in - let new_with_decl,subst1 = + let new_with_decl,subst1 = match with_decl with With_definition_body (_,c) -> With_definition_body (idl,c),None - | With_module_body (idc,mp,t,cst) -> + | With_module_body (idc,mp,t,cst) -> With_module_body (idl,mp,t,cst), - Some(map_mp (mp_rec idc) mp) + Some(map_mp (mp_rec idc) mp) in let subst = Option.fold_right join subst1 alias in - let modtype = + let modtype = merge_with env (type_of_mb env old) new_with_decl alias in let msb = { mod_expr = None; - mod_type = Some modtype; + mod_type = Some modtype; mod_constraints = old.mod_constraints; mod_alias = subst; mod_retroknowledge = old.mod_retroknowledge} @@ -218,35 +218,35 @@ and merge_with env mtb with_decl alias= with Not_found -> error_no_such_label l -and add_signature mp sign env = +and add_signature mp sign env = let add_one env (l,elem) = let kn = make_kn mp empty_dirpath l in let con = make_con mp empty_dirpath l in match elem with | SFBconst cb -> Environ.add_constant con cb env | SFBmind mib -> Environ.add_mind kn mib env - | SFBmodule mb -> - add_module (MPdot (mp,l)) mb env + | SFBmodule mb -> + add_module (MPdot (mp,l)) mb env (* adds components as well *) - | SFBalias (mp1,_,cst) -> + | SFBalias (mp1,_,cst) -> Environ.register_alias (MPdot(mp,l)) mp1 env - | SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) + | SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) mtb env in List.fold_left add_one env sign -and add_module mp mb env = +and add_module mp mb env = let env = Environ.shallow_add_module mp mb env in let env = Environ.add_modtype mp (module_type_of_module (Some mp) mb) env in let mod_typ = type_of_mb env mb in match mod_typ with - | SEBstruct (msid,sign) -> + | SEBstruct (msid,sign) -> add_signature mp (subst_signature_msid msid mp sign) env | SEBfunctor _ -> env | _ -> anomaly "Modops:the evaluation of the structure failed " - + and constants_of_specification env mp sign = @@ -255,30 +255,30 @@ and constants_of_specification env mp sign = | SFBconst cb -> env,((make_con mp empty_dirpath l),cb)::res | SFBmind _ -> env,res | SFBmodule mb -> - let new_env = add_module (MPdot (mp,l)) mb env in + let new_env = add_module (MPdot (mp,l)) mb env in new_env,(constants_of_modtype env (MPdot (mp,l)) (type_of_mb env mb)) @ res | SFBalias (mp1,_,cst) -> - let new_env = register_alias (MPdot (mp,l)) mp1 env in + let new_env = register_alias (MPdot (mp,l)) mp1 env in new_env,(constants_of_modtype env (MPdot (mp,l)) (eval_struct env (SEBident mp1))) @ res - | SFBmodtype mtb -> - (* module type dans un module type. - Il faut au moins mettre mtb dans l'environnement (avec le bon - kn pour pouvoir continuer aller deplier les modules utilisant ce + | SFBmodtype mtb -> + (* module type dans un module type. + Il faut au moins mettre mtb dans l'environnement (avec le bon + kn pour pouvoir continuer aller deplier les modules utilisant ce mtb - ex: - Module Type T1. + ex: + Module Type T1. Module Type T2. .... End T2. ..... Declare Module M : T2. - End T2 - si on ne rajoute pas T2 dans l'environement de typage + End T2 + si on ne rajoute pas T2 dans l'environement de typage on va exploser au moment du Declare Module *) - let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in + let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in new_env, (constants_of_modtype env (MPdot(mp,l)) mtb.typ_expr) @ res in snd (List.fold_left aux (env,[]) sign) @@ -290,23 +290,23 @@ and constants_of_modtype env mp modtype = (subst_signature_msid msid mp sign) | SEBfunctor _ -> [] | _ -> anomaly "Modops:the evaluation of the structure failed " - + and strengthen_mtb env mp mtb = - let mtb1 = eval_struct env mtb in + let mtb1 = eval_struct env mtb in match mtb1 with | SEBfunctor _ -> mtb1 - | SEBstruct (msid,sign) -> + | SEBstruct (msid,sign) -> SEBstruct (msid,strengthen_sig env msid sign mp) | _ -> anomaly "Modops:the evaluation of the structure failed " -and strengthen_mod env mp mb = +and strengthen_mod env mp mb = let mod_typ = type_of_mb env mb in { mod_expr = mb.mod_expr; mod_type = Some (strengthen_mtb env mp mod_typ); mod_constraints = mb.mod_constraints; mod_alias = mb.mod_alias; mod_retroknowledge = mb.mod_retroknowledge} - + and strengthen_sig env msid sign mp = match sign with | [] -> [] | (l,SFBconst cb) :: rest -> @@ -320,7 +320,7 @@ and strengthen_sig env msid sign mp = match sign with | (l,SFBmodule mb) :: rest -> let mp' = MPdot (mp,l) in let item' = l,SFBmodule (strengthen_mod env mp' mb) in - let env' = add_module + let env' = add_module (MPdot (MPself msid,l)) mb env in let rest' = strengthen_sig env' msid rest mp in item':: rest' @@ -328,21 +328,21 @@ and strengthen_sig env msid sign mp = match sign with let env' = register_alias (MPdot(MPself msid,l)) mp1 env in let rest' = strengthen_sig env' msid rest mp in item::rest' - | (l,SFBmodtype mty as item) :: rest -> - let env' = add_modtype - (MPdot((MPself msid),l)) + | (l,SFBmodtype mty as item) :: rest -> + let env' = add_modtype + (MPdot((MPself msid),l)) mty env in let rest' = strengthen_sig env' msid rest mp in item::rest' - + let strengthen env mtb mp = strengthen_mtb env mp mtb let update_subst env mb mp = match type_of_mb env mb with - | SEBstruct(msid,str) -> false, join_alias + | SEBstruct(msid,str) -> false, join_alias (subst_key (map_msid msid mp) mb.mod_alias) (map_msid msid mp) | _ -> true, mb.mod_alias diff --git a/checker/modops.mli b/checker/modops.mli index 17b063e2aa..d5c9f4de6d 100644 --- a/checker/modops.mli +++ b/checker/modops.mli @@ -22,10 +22,10 @@ open Environ (* make the environment entry out of type *) val module_body_of_type : module_type_body -> module_body -val module_type_of_module : module_path option -> module_body -> - module_type_body +val module_type_of_module : module_path option -> module_body -> + module_type_body -val destr_functor : +val destr_functor : env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body (* Evaluation functions *) @@ -47,7 +47,7 @@ val strengthen : env -> struct_expr_body -> module_path -> struct_expr_body val update_subst : env -> module_body -> module_path -> bool * substitution -val error_incompatible_modtypes : +val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a val error_not_match : label -> structure_field_body -> 'a @@ -63,7 +63,7 @@ val error_signature_expected : struct_expr_body -> 'a val error_not_a_constant : label -> 'a -val error_not_a_module : label -> 'a +val error_not_a_module : label -> 'a val error_a_generative_module_expected : label -> 'a diff --git a/checker/reduction.ml b/checker/reduction.ml index d81cfe352a..612e7562fa 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -86,13 +86,13 @@ let whd_betaiotazeta env x = Prod _|Lambda _|Fix _|CoFix _) -> x | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x) -let whd_betadeltaiota env t = +let whd_betadeltaiota env t = match t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> t | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t) -let whd_betadeltaiota_nolet env t = +let whd_betadeltaiota_nolet env t = match t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t @@ -148,8 +148,8 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 = (* Convertibility of sorts *) -type conv_pb = - | CONV +type conv_pb = + | CONV | CUMUL let sort_cmp univ pb s0 s1 = @@ -211,7 +211,7 @@ let oracle_order fl1 fl2 = | _ -> false (* Conversion between [lft1]term1 and [lft2]term2 *) -let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = +let rec ccnv univ cv_pb infos lft1 lft2 term1 term2 = eqappr univ cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) @@ -233,7 +233,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = (* case of leaves *) | (FAtom a1, FAtom a2) -> (match a1, a2 with - | (Sort s1, Sort s2) -> + | (Sort s1, Sort s2) -> assert (is_empty_stack v1 && is_empty_stack v2); sort_cmp univ cv_pb s1 s2 | (Meta n, Meta m) -> @@ -281,15 +281,15 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = (* only one constant, defined var or defined rel *) | (FFlex fl1, _) -> (match unfold_reference infos fl1 with - | Some def1 -> + | Some def1 -> eqappr univ cv_pb infos (lft1, whd_stack infos def1 v1) appr2 | None -> raise NotConvertible) | (_, FFlex fl2) -> (match unfold_reference infos fl2 with - | Some def2 -> + | Some def2 -> eqappr univ cv_pb infos appr1 (lft2, whd_stack infos def2 v2) | None -> raise NotConvertible) - + (* other constructors *) | (FLambda _, FLambda _) -> assert (is_empty_stack v1 && is_empty_stack v2); @@ -327,7 +327,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in convert_vect univ infos el1 el2 fty1 fty2; - convert_vect univ infos + convert_vect univ infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2; convert_stacks univ infos lft1 lft2 v1 v2 else raise NotConvertible @@ -350,7 +350,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false - + (* In all other cases, terms are not convertible *) | _ -> raise NotConvertible @@ -377,9 +377,9 @@ let conv = fconv CONV let conv_leq = fconv CUMUL let conv_leq_vecti env v1 v2 = - array_fold_left2_i + array_fold_left2_i (fun i _ t1 t2 -> - (try conv_leq env t1 t2 + (try conv_leq env t1 t2 with (NotConvertible|Invalid_argument _) -> raise (NotConvertibleVect i)); ()) @@ -391,13 +391,13 @@ let conv_leq_vecti env v1 v2 = let vm_conv = ref fconv let set_vm_conv f = vm_conv := f -let vm_conv cv_pb env t1 t2 = - try +let vm_conv cv_pb env t1 t2 = + try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> (* If compilation fails, fall-back to closure conversion *) clos_fconv cv_pb env t1 t2 - + (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) @@ -413,12 +413,12 @@ let hnf_prod_app env t n = | Prod (_,_,b) -> subst1 n b | _ -> anomaly "hnf_prod_app: Need a product" -let hnf_prod_applist env t nl = +let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl (* Dealing with arities *) -let dest_prod env = +let dest_prod env = let rec decrec env m c = let t = whd_betadeltaiota env c in match t with @@ -426,11 +426,11 @@ let dest_prod env = let d = (n,None,a) in decrec (push_rel d env) (d::m) c0 | _ -> m,t - in + in decrec env empty_rel_context (* The same but preserving lets *) -let dest_prod_assum env = +let dest_prod_assum env = let rec prodec_rec env l ty = let rty = whd_betadeltaiota_nolet env ty in match rty with diff --git a/checker/reduction.mli b/checker/reduction.mli index 47590edb3d..81c93ee53f 100644 --- a/checker/reduction.mli +++ b/checker/reduction.mli @@ -37,7 +37,7 @@ val vm_conv : conv_pb -> constr conversion_function (************************************************************************) -(* Builds an application node, reducing beta redexes it may produce. *) +(* Builds an application node, reducing beta redexes it may produce. *) val beta_appvect : constr -> constr array -> constr (* Builds an application node, reducing the [n] first beta-zeta redexes. *) diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index f4ffb302c4..b0d683ff3e 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -58,7 +58,7 @@ let check_imports f caller env needed = try let actual_stamp = lookup_digest env dp in if stamp <> actual_stamp then report_clash f caller dp - with Not_found -> + with Not_found -> error ("Reference to unknown module " ^ (string_of_dirpath dp)) in List.iter check needed @@ -72,21 +72,21 @@ let rec lighten_module mb = mod_expr = Option.map lighten_modexpr mb.mod_expr; mod_type = Option.map lighten_modexpr mb.mod_type } -and lighten_struct struc = +and lighten_struct struc = let lighten_body (l,body) = (l,match body with | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None} | (SFBconst _ | SFBmind _ | SFBalias _) as x -> x | SFBmodule m -> SFBmodule (lighten_module m) - | SFBmodtype m -> SFBmodtype - ({m with + | SFBmodtype m -> SFBmodtype + ({m with typ_expr = lighten_modexpr m.typ_expr})) in List.map lighten_body struc and lighten_modexpr = function | SEBfunctor (mbid,mty,mexpr) -> - SEBfunctor (mbid, - ({mty with + SEBfunctor (mbid, + ({mty with typ_expr = lighten_modexpr mty.typ_expr}), lighten_modexpr mexpr) | SEBident mp as x -> x @@ -95,17 +95,17 @@ and lighten_modexpr = function | SEBapply (mexpr,marg,u) -> SEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u) | SEBwith (seb,wdcl) -> - SEBwith (lighten_modexpr seb,wdcl) - + SEBwith (lighten_modexpr seb,wdcl) + let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s) -type compiled_library = +type compiled_library = dir_path * module_body * (dir_path * Digest.t) list * engagement option - + open Validate let val_deps = val_list (val_tuple"dep"[|val_dp;no_val|]) let val_vo = val_tuple "vo" [|val_dp;val_module;val_deps;val_opt val_eng|] @@ -119,7 +119,7 @@ let stamp_library file digest = () (* When the module is checked, digests do not need to match, but a warning is issued in case of mismatch *) -let import file (dp,mb,depends,engmt as vo) digest = +let import file (dp,mb,depends,engmt as vo) digest = Validate.apply !Flags.debug val_vo vo; Flags.if_verbose msgnl (str "*** vo structure validated ***"); let env = !genv in @@ -132,7 +132,7 @@ let import file (dp,mb,depends,engmt as vo) digest = full_add_module dp mb digest (* When the module is admitted, digests *must* match *) -let unsafe_import file (dp,mb,depends,engmt) digest = +let unsafe_import file (dp,mb,depends,engmt) digest = let env = !genv in check_imports (errorlabstrm"unsafe_import") dp env depends; check_engagement env engmt; diff --git a/checker/subtyping.ml b/checker/subtyping.ml index edf119c664..88989b32eb 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -19,14 +19,14 @@ open Reduction open Inductive open Modops (*i*) -open Pp +open Pp (* This local type is used to subtype a constant with a constructor or an inductive type. It can also be useful to allow reorderings in inductive types *) -type namedobject = +type namedobject = | Constant of constant_body | IndType of inductive * mutual_inductive_body | IndConstr of constructor * mutual_inductive_body @@ -37,11 +37,11 @@ type namedobject = (* adds above information about one mutual inductive: all types and constructors *) -let add_nameobjects_of_mib ln mib map = +let add_nameobjects_of_mib ln mib map = let add_nameobjects_of_one j oib map = let ip = (ln,j) in - let map = - array_fold_right_i + let map = + array_fold_right_i (fun i id map -> Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map) oib.mind_consnames @@ -54,8 +54,8 @@ let add_nameobjects_of_mib ln mib map = (* creates namedobject map for the whole signature *) -let make_label_map mp list = - let add_one (l,e) map = +let make_label_map mp list = + let add_one (l,e) map = let add_map obj = Labmap.add l obj map in match e with | SFBconst cb -> add_map (Constant cb) @@ -74,11 +74,11 @@ let check_conv_error error f env a1 a2 = NotConvertible -> error () (* for now we do not allow reorderings *) -let check_inductive env msid1 l info1 mib2 spec2 = +let check_inductive env msid1 l info1 mib2 spec2 = let kn = make_kn (MPself msid1) empty_dirpath l in let error () = error_not_match l spec2 in let check_conv f = check_conv_error error f in - let mib1 = + let mib1 = match info1 with | IndType ((_,0), mib) -> mib | _ -> error () @@ -87,7 +87,7 @@ let check_inductive env msid1 l info1 mib2 spec2 = (* Due to sort-polymorphism in inductive types, the conclusions of t1 and t2, if in Type, are generated as the least upper bounds - of the types of the constructors. + of the types of the constructors. By monotonicity of the infered l.u.b. wrt subtyping (i.e. if X:U |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each @@ -114,7 +114,7 @@ let check_inductive env msid1 l info1 mib2 spec2 = | Type _, Type _ -> (* shortcut here *) Prop Null, Prop Null | (Prop _, Type _) | (Type _,Prop _) -> error () | _ -> (s1, s2) in - check_conv conv_leq env + check_conv conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in @@ -145,7 +145,7 @@ let check_inductive env msid1 l info1 mib2 spec2 = check (fun mib -> mib.mind_finite); check (fun mib -> mib.mind_ntypes); assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]); - assert (Array.length mib1.mind_packets >= 1 + assert (Array.length mib1.mind_packets >= 1 && Array.length mib2.mind_packets >= 1); (* Check that the expected numbers of uniform parameters are the same *) @@ -155,10 +155,10 @@ let check_inductive env msid1 l info1 mib2 spec2 = (* the inductive types and constructors types have to be convertible *) check (fun mib -> mib.mind_nparams); - begin + begin match mib2.mind_equiv with | None -> () - | Some kn2' -> + | Some kn2' -> let kn2 = scrape_mind env kn2' in let kn1 = match mib1.mind_equiv with None -> kn @@ -168,17 +168,17 @@ let check_inductive env msid1 l info1 mib2 spec2 = end; (* we check that records and their field names are preserved. *) check (fun mib -> mib.mind_record); - if mib1.mind_record then begin - let rec names_prod_letin t = match t with + if mib1.mind_record then begin + let rec names_prod_letin t = match t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t | _ -> [] - in + in assert (Array.length mib1.mind_packets = 1); assert (Array.length mib2.mind_packets = 1); - assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); - assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); + assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); + assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0)); end; (* we first check simple things *) @@ -187,10 +187,10 @@ let check_inductive env msid1 l info1 mib2 spec2 = let _ = array_map2_i check_cons_types mib1.mind_packets mib2.mind_packets in () -let check_constant env msid1 l info1 cb2 spec2 = +let check_constant env msid1 l info1 cb2 spec2 = let error () = error_not_match l spec2 in let check_conv f = check_conv_error error f in - let check_type env t1 t2 = + let check_type env t1 t2 = (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion @@ -201,7 +201,7 @@ let check_constant env msid1 l info1 cb2 spec2 = Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). Hence they don't have to be checked again *) - let t1,t2 = + let t1,t2 = if isArity t2 then let (ctx2,s2) = destArity t2 in match s2 with @@ -283,32 +283,32 @@ let rec check_modules env msid1 l msb1 msb2 = let mty1 = module_type_of_module (Some mp) msb1 in let mty2 = module_type_of_module None msb2 in check_modtypes env mty1 mty2 false - -and check_signatures env (msid1,sig1) alias (msid2,sig2') = + +and check_signatures env (msid1,sig1) alias (msid2,sig2') = let mp1 = MPself msid1 in - let env = add_signature mp1 sig1 env in + let env = add_signature mp1 sig1 env in let alias = update_subst_alias alias (map_msid msid2 mp1) in let sig2 = subst_structure alias sig2' in let sig2 = subst_signature_msid msid2 mp1 sig2 in let map1 = make_label_map mp1 sig1 in - let check_one_body (l,spec2) = - let info1 = - try - Labmap.find l map1 - with + let check_one_body (l,spec2) = + let info1 = + try + Labmap.find l map1 + with Not_found -> error_no_such_label_sub l msid1 msid2 in match spec2 with | SFBconst cb2 -> check_constant env msid1 l info1 cb2 spec2 - | SFBmind mib2 -> + | SFBmind mib2 -> check_inductive env msid1 l info1 mib2 spec2 - | SFBmodule msb2 -> + | SFBmodule msb2 -> begin match info1 with | Module msb -> check_modules env msid1 l msb msb2 - | Alias (mp,typ_opt) ->let msb = + | Alias (mp,typ_opt) ->let msb = {mod_expr = Some (SEBident mp); mod_type = typ_opt; mod_constraints = Constraint.empty; @@ -318,11 +318,11 @@ and check_signatures env (msid1,sig1) alias (msid2,sig2') = | _ -> error_not_match l spec2 end | SFBalias (mp,typ_opt,_) -> - begin + begin match info1 with | Alias (mp1,_) -> check_modpath_equiv env mp mp1 - | Module msb -> - let msb1 = + | Module msb -> + let msb1 = {mod_expr = Some (SEBident mp); mod_type = typ_opt; mod_constraints = Constraint.empty; @@ -332,7 +332,7 @@ and check_signatures env (msid1,sig1) alias (msid2,sig2') = | _ -> error_not_match l spec2 end | SFBmodtype mtb2 -> - let mtb1 = + let mtb1 = match info1 with | Modtype mtb -> mtb | _ -> error_not_match l spec2 @@ -341,7 +341,7 @@ and check_signatures env (msid1,sig1) alias (msid2,sig2') = in List.iter check_one_body sig2 -and check_modtypes env mtb1 mtb2 equiv = +and check_modtypes env mtb1 mtb2 equiv = if mtb1==mtb2 then () else (* just in case :) *) let mtb1',mtb2'= (match mtb1.typ_strength with @@ -349,23 +349,23 @@ and check_modtypes env mtb1 mtb2 equiv = eval_struct env mtb2.typ_expr | Some mp -> strengthen env mtb1.typ_expr mp, eval_struct env mtb2.typ_expr) in - let rec check_structure env str1 str2 equiv = + let rec check_structure env str1 str2 equiv = match str1, str2 with - | SEBstruct (msid1,list1), - SEBstruct (msid2,list2) -> + | SEBstruct (msid1,list1), + SEBstruct (msid2,list2) -> check_signatures env (msid1,list1) mtb1.typ_alias (msid2,list2); if equiv then - check_signatures env - (msid2,list2) mtb2.typ_alias (msid1,list1) - | SEBfunctor (arg_id1,arg_t1,body_t1), + check_signatures env + (msid2,list2) mtb2.typ_alias (msid1,list1) + | SEBfunctor (arg_id1,arg_t1,body_t1), SEBfunctor (arg_id2,arg_t2,body_t2) -> check_modtypes env arg_t2 arg_t1 equiv; (* contravariant *) - let env = - add_module (MPbound arg_id2) (module_body_of_type arg_t2) env + let env = + add_module (MPbound arg_id2) (module_body_of_type arg_t2) env in - let body_t1' = + let body_t1' = (* since we are just checking well-typedness we do not need to expand any constant. Hence the identity resolver. *) subst_struct_expr @@ -375,14 +375,14 @@ and check_modtypes env mtb1 mtb2 equiv = check_structure env (eval_struct env body_t1') (eval_struct env body_t2) equiv | _ , _ -> error_incompatible_modtypes mtb1 mtb2 - in + in if mtb1'== mtb2' then () else check_structure env mtb1' mtb2' equiv -let check_subtypes env sup super = +let check_subtypes env sup super = (*if sup<>super then*) check_modtypes env sup super false - -let check_equal env sup super = + +let check_equal env sup super = (*if sup<>super then*) check_modtypes env sup super true diff --git a/checker/term.ml b/checker/term.ml index f5b2496c85..92d898b318 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -81,7 +81,7 @@ let val_fix f = [|val_tuple"fix2"[|val_array val_int;val_int|];val_prec f|] let val_cofix f = val_tuple"pcofixpoint"[|val_int;val_prec f|] -type cast_kind = VMcast | DEFAULTcast +type cast_kind = VMcast | DEFAULTcast let val_cast = val_enum "cast_kind" 2 (*s*******************************************************************) @@ -135,7 +135,7 @@ let rec strip_outer_cast c = match c with | _ -> c let rec collapse_appl c = match c with - | App (f,cl) -> + | App (f,cl) -> let rec collapse_rec f cl2 = match (strip_outer_cast f) with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) @@ -171,7 +171,7 @@ let iter_constr_with_binders g f n c = match c with | App (c,l) -> f n c; Array.iter (f n) l | Evar (_,l) -> Array.iter (f n) l | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl - | Fix (_,(_,tl,bl)) -> + | Fix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl | CoFix (_,(_,tl,bl)) -> @@ -183,11 +183,11 @@ exception LocalOccur (* (closedn n M) raises FreeVar if a variable of height greater than n occurs in M, returns () otherwise *) -let closedn n c = +let closedn n c = let rec closed_rec n c = match c with | Rel m -> if m>n then raise LocalOccur | _ -> iter_constr_with_binders succ closed_rec n c - in + in try closed_rec n c; true with LocalOccur -> false (* [closed0 M] is true iff [M] is a (deBruijn) closed term *) @@ -196,21 +196,21 @@ let closed0 = closedn 0 (* (noccurn n M) returns true iff (Rel n) does NOT occur in term M *) -let noccurn n term = +let noccurn n term = let rec occur_rec n c = match c with | Rel m -> if m = n then raise LocalOccur | _ -> iter_constr_with_binders succ occur_rec n c - in + in try occur_rec n term; true with LocalOccur -> false -(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M +(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M for n <= p < n+m *) -let noccur_between n m term = +let noccur_between n m term = let rec occur_rec n c = match c with | Rel(p) -> if n<=p && p iter_constr_with_binders succ occur_rec n c - in + in try occur_rec n term; true with LocalOccur -> false (* Checking function for terms containing existential variables. @@ -220,7 +220,7 @@ let noccur_between n m term = which may contain the CoFix variables. These occurrences of CoFix variables are not considered *) -let noccur_with_meta n m term = +let noccur_with_meta n m term = let rec occur_rec n c = match c with | Rel p -> if n<=p & p @@ -261,18 +261,18 @@ let rec exliftn el c = match c with (* Lifting the binding depth across k bindings *) -let liftn k n = +let liftn k n = match el_liftn (pred n) (el_shft k ELID) with | ELID -> (fun c -> c) | el -> exliftn el - + let lift k = liftn k 1 (*********************) (* Substituting *) (*********************) -(* (subst1 M c) substitutes M for Rel(1) in c +(* (subst1 M c) substitutes M for Rel(1) in c we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel M1,...,Mn for respectively Rel(1),...,Rel(n) in c *) @@ -291,15 +291,15 @@ let rec lift_substituend depth s = let make_substituend c = { sinfo=Unknown; sit=c } let substn_many lamv n c = - let lv = Array.length lamv in + let lv = Array.length lamv in if lv = 0 then c - else + else let rec substrec depth c = match c with | Rel k -> if k<=depth then c else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1) else Rel (k-lv) - | _ -> map_constr_with_binders succ substrec depth c in + | _ -> map_constr_with_binders succ substrec depth c in substrec n c let substnl laml n = @@ -362,7 +362,7 @@ let extended_rel_list n hyps = | (_,None,_) :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps | (_,Some _,_) :: hyps -> reln l (p+1) hyps | [] -> l - in + in reln [] 1 hyps (* Iterate lambda abstractions *) @@ -372,17 +372,17 @@ let compose_lam l b = let rec lamrec = function | ([], b) -> b | ((v,t)::l, b) -> lamrec (l, Lambda (v,t,b)) - in + in lamrec (l,b) (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) -let decompose_lam = +let decompose_lam = let rec lamdec_rec l c = match c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c - in + in lamdec_rec [] (* Decompose lambda abstractions and lets, until finding n @@ -390,15 +390,15 @@ let decompose_lam = let decompose_lam_n_assum n = if n < 0 then error "decompose_lam_n_assum: integer parameter must be positive"; - let rec lamdec_rec l n c = - if n=0 then l,c - else match c with + let rec lamdec_rec l n c = + if n=0 then l,c + else match c with | Lambda (x,t,c) -> lamdec_rec ((x,None,t) :: l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec ((x,Some b,t) :: l) n c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" - in - lamdec_rec empty_rel_context n + in + lamdec_rec empty_rel_context n (* Iterate products, with or without lets *) @@ -410,27 +410,27 @@ let mkProd_or_LetIn (na,body,t) c = let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) -let decompose_prod_assum = +let decompose_prod_assum = let rec prodec_rec l c = match c with | Prod (x,t,c) -> prodec_rec ((x,None,t) :: l) c | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c - in + in prodec_rec empty_rel_context let decompose_prod_n_assum n = if n < 0 then error "decompose_prod_n_assum: integer parameter must be positive"; - let rec prodec_rec l n c = + let rec prodec_rec l n c = if n=0 then l,c - else match c with + else match c with | Prod (x,t,c) -> prodec_rec ((x,None,t) :: l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t) :: l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" - in + in prodec_rec empty_rel_context n @@ -443,7 +443,7 @@ let val_arity = val_tuple"arity"[|val_rctxt;val_constr|] let mkArity (sign,s) = it_mkProd_or_LetIn (Sort s) sign -let destArity = +let destArity = let rec prodec_rec l c = match c with | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c @@ -451,7 +451,7 @@ let destArity = | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly "destArity: not an arity" - in + in prodec_rec [] let rec isArity c = @@ -463,7 +463,7 @@ let rec isArity c = | _ -> false (*******************************) -(* alpha conversion functions *) +(* alpha conversion functions *) (*******************************) (* alpha conversion : ignore print names and casts *) @@ -483,7 +483,7 @@ let compare_constr f t1 t2 = if Array.length l1 = Array.length l2 then f c1 c2 & array_for_all2 f l1 l2 else - let (h1,l1) = decompose_app t1 in + let (h1,l1) = decompose_app t1 in let (h2,l2) = decompose_app t2 in if List.length l1 = List.length l2 then f h1 h2 & List.for_all2 f l1 l2 @@ -500,7 +500,7 @@ let compare_constr f t1 t2 = ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 | _ -> false -let rec eq_constr m n = +let rec eq_constr m n = (m==n) or compare_constr eq_constr m n diff --git a/checker/type_errors.ml b/checker/type_errors.ml index a96bba6a44..7c01410559 100644 --- a/checker/type_errors.ml +++ b/checker/type_errors.ml @@ -81,10 +81,10 @@ let error_assumption env j = let error_reference_variables env id = raise (TypeError (env, ReferenceVariables id)) -let error_elim_arity env ind aritylst c pj okinds = +let error_elim_arity env ind aritylst c pj okinds = raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds))) -let error_case_not_inductive env j = +let error_case_not_inductive env j = raise (TypeError (env, CaseNotInductive j)) let error_number_branches env cj expn = diff --git a/checker/type_errors.mli b/checker/type_errors.mli index 2d8f8ff226..0482f2f2a8 100644 --- a/checker/type_errors.mli +++ b/checker/type_errors.mli @@ -73,11 +73,11 @@ val error_unbound_var : env -> variable -> 'a val error_not_type : env -> unsafe_judgment -> 'a val error_assumption : env -> unsafe_judgment -> 'a - + val error_reference_variables : env -> constr -> 'a -val error_elim_arity : - env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> +val error_elim_arity : + env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a @@ -90,11 +90,11 @@ val error_generalization : env -> name * constr -> unsafe_judgment -> 'a val error_actual_type : env -> unsafe_judgment -> constr -> 'a -val error_cant_apply_not_functional : +val error_cant_apply_not_functional : env -> unsafe_judgment -> unsafe_judgment array -> 'a -val error_cant_apply_bad_type : - env -> int * constr * constr -> +val error_cant_apply_bad_type : + env -> int * constr * constr -> unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : diff --git a/checker/typeops.ml b/checker/typeops.ml index 1832ebec4d..3a4f2f825d 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -21,9 +21,9 @@ open Environ let inductive_of_constructor = fst let conv_leq_vecti env v1 v2 = - array_fold_left2_i + array_fold_left2_i (fun i _ t1 t2 -> - (try conv_leq env t1 t2 + (try conv_leq env t1 t2 with NotConvertible -> raise (NotConvertibleVect i)); ()) () v1 @@ -57,18 +57,18 @@ let judge_of_prop = Sort (Type type1_univ) let judge_of_type u = Sort (Type (super u)) (*s Type of a de Bruijn index. *) - -let judge_of_relative env n = + +let judge_of_relative env n = try let (_,_,typ) = lookup_rel n env in lift n typ - with Not_found -> + with Not_found -> error_unbound_rel env n (* Type of variables *) let judge_of_variable env id = try named_type id env - with Not_found -> + with Not_found -> error_unbound_var env id (* Management of context of variables. *) @@ -115,7 +115,7 @@ let extract_context_levels env = let make_polymorphic_if_arity env t = let params, ccl = dest_prod_assum env t in match ccl with - | Sort (Type u) -> + | Sort (Type u) -> let param_ccls = extract_context_levels env params in let s = { poly_param_levels = param_ccls; poly_level = u} in PolymorphicArity (params,s) @@ -141,10 +141,10 @@ let type_of_constant env cst = let judge_of_constant_knowing_parameters env cst paramstyp = let c = Const cst in let cb = - try lookup_constant cst env + try lookup_constant cst env with Not_found -> failwith ("Cannot find constant: "^string_of_con cst) in - let _ = check_args env c cb.const_hyps in + let _ = check_args env c cb.const_hyps in type_of_constant_knowing_parameters env cb.const_type paramstyp let judge_of_constant env cst = @@ -159,19 +159,19 @@ let judge_of_apply env (f,funj) argjv = (match whd_betadeltaiota env typ with | Prod (_,c1,c2) -> (try conv_leq env hj c1 - with NotConvertible -> + with NotConvertible -> error_cant_apply_bad_type env (n,c1, hj) (f,funj) argjv); apply_rec (n+1) (subst1 h c2) restjl | _ -> error_cant_apply_not_functional env (f,funj) argjv) - in + in apply_rec 1 funj (Array.to_list argjv) (* Type of product *) let sort_of_product env domsort rangsort = match (domsort, rangsort) with - (* Product rule (s,Prop,Prop) *) + (* Product rule (s,Prop,Prop) *) | (_, Prop Null) -> rangsort (* Product rule (Prop/Set,Set,Set) *) | (Prop _, Prop Pos) -> rangsort @@ -187,7 +187,7 @@ let sort_of_product env domsort rangsort = | (Prop Pos, Type u2) -> Type (sup type0_univ u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort - (* Product rule (Type_i,Type_i,Type_i) *) + (* Product rule (Type_i,Type_i,Type_i) *) | (Type u1, Type u2) -> Type (sup u1 u2) (* Type of a type cast *) @@ -204,7 +204,7 @@ let judge_of_cast env (c,cj) k tj = match k with | VMcast -> vm_conv CUMUL | DEFAULTcast -> conv_leq in - try + try conversion env cj tj with NotConvertible -> error_actual_type env (c,cj) tj @@ -241,17 +241,17 @@ let judge_of_constructor env c = let constr = Construct c in let _ = let ((kn,_),_) = c in - let mib = + let mib = try lookup_mind kn env with Not_found -> failwith ("Cannot find inductive: "^string_of_kn (fst (fst c))) in - check_args env constr mib.mind_hyps in + check_args env constr mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in type_of_constructor c specif (* Case. *) -let check_branch_types env (c,cj) (lfj,explft) = +let check_branch_types env (c,cj) (lfj,explft) = try conv_leq_vecti env lfj explft with NotConvertibleVect i -> @@ -321,22 +321,22 @@ let rec execute env cstr = | Ind ind -> (* Sort-polymorphism of inductive types *) judge_of_inductive_knowing_parameters env ind jl - | Const cst -> + | Const cst -> (* Sort-polymorphism of constant *) judge_of_constant_knowing_parameters env cst jl - | _ -> + | _ -> (* No sort-polymorphism *) execute env f in let jl = array_map2 (fun c ty -> c,ty) args jl in judge_of_apply env (f,j) jl - - | Lambda (name,c1,c2) -> + + | Lambda (name,c1,c2) -> let _ = execute_type env c1 in let env1 = push_rel (name,None,c1) env in - let j' = execute env1 c2 in + let j' = execute env1 c2 in Prod(name,c1,j') - + | Prod (name,c1,c2) -> let varj = execute_type env c1 in let env1 = push_rel (name,None,c1) env in @@ -354,7 +354,7 @@ let rec execute env cstr = let env1 = push_rel (name,Some c1,c2) env in let j' = execute env1 c3 in subst1 c1 j' - + | Cast (c,k,t) -> let cj = execute env c in let _ = execute_type env t in @@ -371,13 +371,13 @@ let rec execute env cstr = let pj = execute env p in let lfj = execute_array env lf in judge_of_case env ci (p,pj) (c,cj) lfj - + | Fix ((_,i as vni),recdef) -> let fix_ty = execute_recdef env recdef i in let fix = (vni,recdef) in check_fix env fix; fix_ty - + | CoFix (i,recdef) -> let fix_ty = execute_recdef env recdef i in let cofix = (i,recdef) in @@ -391,10 +391,10 @@ let rec execute env cstr = | Evar _ -> anomaly "the kernel does not support existential variables" -and execute_type env constr = +and execute_type env constr = let j = execute env constr in snd (type_judgment env (constr,j)) - + and execute_recdef env (names,lar,vdef) i = let larj = execute_array env lar in let larj = array_map2 (fun c ty -> c,ty) lar larj in @@ -406,7 +406,7 @@ and execute_recdef env (names,lar,vdef) i = and execute_array env = Array.map (execute env) -and execute_list env = List.map (execute env) +and execute_list env = List.map (execute env) (* Derived functions *) let infer env constr = execute env constr @@ -418,7 +418,7 @@ let infer_v env cv = execute_array env cv let check_ctxt env rels = fold_rel_context (fun d env -> match d with - (_,None,ty) -> + (_,None,ty) -> let _ = infer_type env ty in push_rel d env | (_,Some bd,ty) -> @@ -436,7 +436,7 @@ let check_named_ctxt env ctxt = failwith ("variable "^string_of_id id^" defined twice") with Not_found -> () in match d with - (_,None,ty) -> + (_,None,ty) -> let _ = infer_type env ty in push_named d env | (_,Some bd,ty) -> diff --git a/dev/ocamlweb-doc/ast.ml b/dev/ocamlweb-doc/ast.ml index 2153ef47c0..4eb135d83c 100644 --- a/dev/ocamlweb-doc/ast.ml +++ b/dev/ocamlweb-doc/ast.ml @@ -22,7 +22,7 @@ type constr_ast = (string * binder list * constr_ast * string option * constr_ast) list * string | Match of case_item list * constr_ast option * - (pattern list * constr_ast) list + (pattern list * constr_ast) list and red_fun = Simpl @@ -34,7 +34,7 @@ and fix_kind = Fix | CoFix and case_item = constr_ast * (string option * constr_ast option) -and pattern = +and pattern = PatAs of pattern * string | PatType of pattern * constr_ast | PatConstr of string * pattern list diff --git a/dev/ocamlweb-doc/lex.mll b/dev/ocamlweb-doc/lex.mll index 617163e7e7..059526d9bf 100644 --- a/dev/ocamlweb-doc/lex.mll +++ b/dev/ocamlweb-doc/lex.mll @@ -7,7 +7,7 @@ let comment_depth = ref 0 let print s = output_string !chan_out s - + exception Fin_fichier } @@ -77,5 +77,5 @@ and comment = parse | "(*" (*"*)"*) { incr comment_depth; comment lexbuf } | (*"(*"*) "*)" { decr comment_depth; if !comment_depth > 0 then comment lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { comment lexbuf } diff --git a/dev/ocamlweb-doc/parse.ml b/dev/ocamlweb-doc/parse.ml index e537b1f2f4..b145fffda6 100644 --- a/dev/ocamlweb-doc/parse.ml +++ b/dev/ocamlweb-doc/parse.ml @@ -82,7 +82,7 @@ let rec str_stack = function | Term (t,s) -> str_stack s ^ " (" ^ str_ast t ^ ")" | Oper(ops,lop,t,s) -> str_stack (Term(t,s)) ^ " " ^ lop ^ " " ^ - String.concat " " (List.rev ops) + String.concat " " (List.rev ops) let pps s = prerr_endline (str_stack s) let err s stk = failwith (s^": "^str_stack stk) diff --git a/dev/printers.mllib b/dev/printers.mllib index f4b3d7f6c3..107b2904aa 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -6,17 +6,17 @@ Compat Flags Util Bigint -Hashcons +Hashcons Dyn System -Envars -Bstack +Envars +Bstack Edit -Gset +Gset Gmap -Tlm +Tlm Gmapl -Profile +Profile Explore Predicate Rtree @@ -107,7 +107,7 @@ Proof_type Logic Refiner Evar_refiner -Pfedit +Pfedit Tactic_debug Decl_mode Ppconstr diff --git a/dev/top_printers.ml b/dev/top_printers.ml index b35d5d4899..d5ebde7cb0 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -71,11 +71,11 @@ let ppidset l = pp (prset pr_id (Idset.elements l)) let pP s = pp (hov 0 s) -let safe_pr_global = function +let safe_pr_global = function | ConstRef kn -> pp (str "CONSTREF(" ++ pr_con kn ++ str ")") - | IndRef (kn,i) -> pp (str "INDREF(" ++ pr_kn kn ++ str "," ++ + | IndRef (kn,i) -> pp (str "INDREF(" ++ pr_kn kn ++ str "," ++ int i ++ str ")") - | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ pr_kn kn ++ str "," ++ + | ConstructRef ((kn,i),j) -> pp (str "INDREF(" ++ pr_kn kn ++ str "," ++ int i ++ str "," ++ int j ++ str ")") | VarRef id -> pp (str "VARREF(" ++ pr_id id ++ str ")") @@ -135,7 +135,7 @@ let ppobj obj = Format.print_string (Libobject.object_tag obj) let cnt = ref 0 -let cast_kind_display k = +let cast_kind_display k = match k with | VMcast -> "VMcast" | DEFAULTcast -> "DEFAULTcast" @@ -146,7 +146,7 @@ let constr_display csr = | Meta n -> "Meta("^(string_of_int n)^")" | Var id -> "Var("^(string_of_id id)^")" | Sort s -> "Sort("^(sort_display s)^")" - | Cast (c,k, t) -> + | Cast (c,k, t) -> "Cast("^(term_display c)^","^(cast_kind_display k)^","^(term_display t)^")" | Prod (na,t,c) -> "Prod("^(name_display na)^","^(term_display t)^","^(term_display c)^")\n" @@ -213,25 +213,25 @@ let print_pure_constr csr = print_string "::"; (term_display t); print_string ")"; close_box() | Prod (Name(id),t,c) -> open_hovbox 1; - print_string"("; print_string (string_of_id id); - print_string ":"; box_display t; - print_string ")"; print_cut(); + print_string"("; print_string (string_of_id id); + print_string ":"; box_display t; + print_string ")"; print_cut(); box_display c; close_box() | Prod (Anonymous,t,c) -> print_string"("; box_display t; print_cut(); print_string "->"; - box_display c; print_string ")"; + box_display c; print_string ")"; | Lambda (na,t,c) -> print_string "["; name_display na; print_string ":"; box_display t; print_string "]"; - print_cut(); box_display c; + print_cut(); box_display c; | LetIn (na,b,t,c) -> - print_string "["; name_display na; print_string "="; + print_string "["; name_display na; print_string "="; box_display b; print_cut(); print_string ":"; box_display t; print_string "]"; - print_cut(); box_display c; - | App (c,l) -> - print_string "("; - box_display c; + print_cut(); box_display c; + | App (c,l) -> + print_string "("; + box_display c; Array.iter (fun x -> print_space (); box_display x) l; print_string ")" | Evar (e,l) -> print_string "Evar#"; print_int e; print_string "{"; @@ -258,25 +258,25 @@ let print_pure_constr csr = open_vbox 0; Array.iter (fun x -> print_cut(); box_display x) bl; close_box(); - print_cut(); - print_string "end"; + print_cut(); + print_string "end"; close_box() | Fix ((t,i),(lna,tl,bl)) -> - print_string "Fix("; print_int i; print_string ")"; + print_string "Fix("; print_int i; print_string ")"; print_cut(); open_vbox 0; let rec print_fix () = for k = 0 to (Array.length tl) - 1 do open_vbox 0; - name_display lna.(k); print_string "/"; + name_display lna.(k); print_string "/"; print_int t.(k); print_cut(); print_string ":"; box_display tl.(k) ; print_cut(); print_string ":="; box_display bl.(k); close_box (); print_cut() done - in print_string"{"; print_fix(); print_string"}" + in print_string"{"; print_fix(); print_string"}" | CoFix(i,(lna,tl,bl)) -> - print_string "CoFix("; print_int i; print_string ")"; + print_string "CoFix("; print_int i; print_string ")"; print_cut(); open_vbox 0; let rec print_fix () = @@ -301,27 +301,27 @@ let print_pure_constr csr = | Name id -> print_string (string_of_id id) | Anonymous -> print_string "_" (* Remove the top names for library and Scratch to avoid long names *) - and sp_display sp = + and sp_display sp = (* let dir,l = decode_kn sp in - let ls = - match List.rev (List.map string_of_id (repr_dirpath dir)) with + let ls = + match List.rev (List.map string_of_id (repr_dirpath dir)) with ("Top"::l)-> l - | ("Coq"::_::l) -> l + | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) print_string (string_of_kn sp) - and sp_con_display sp = + and sp_con_display sp = (* let dir,l = decode_kn sp in - let ls = - match List.rev (List.map string_of_id (repr_dirpath dir)) with + let ls = + match List.rev (List.map string_of_id (repr_dirpath dir)) with ("Top"::l)-> l - | ("Coq"::_::l) -> l + | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) print_string (string_of_con sp) in - try + try box_display csr; print_flush() with e -> print_string (Printexc.to_string e);print_flush (); @@ -370,7 +370,7 @@ let pp_generic_argument arg = (* Vernac-level debugging commands *) let in_current_context f c = - let (evmap,sign) = + let (evmap,sign) = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) in f (Constrintern.interp_constr evmap sign c) @@ -431,26 +431,26 @@ open Libnames let encode_path loc prefix mpdir suffix id = let dir = match mpdir with | None -> [] - | Some (mp,dir) -> + | Some (mp,dir) -> (repr_dirpath (dirpath_of_string (string_of_mp mp))@ repr_dirpath dir) in - Qualid (loc, make_qualid + Qualid (loc, make_qualid (make_dirpath (List.rev (id_of_string prefix::dir@suffix))) id) let raw_string_of_ref loc = function - | ConstRef cst -> + | ConstRef cst -> let (mp,dir,id) = repr_con cst in encode_path loc "CST" (Some (mp,dir)) [] (id_of_label id) | IndRef (kn,i) -> let (mp,dir,id) = repr_kn kn in - encode_path loc "IND" (Some (mp,dir)) [id_of_label id] + encode_path loc "IND" (Some (mp,dir)) [id_of_label id] (id_of_string ("_"^string_of_int i)) - | ConstructRef ((kn,i),j) -> + | ConstructRef ((kn,i),j) -> let (mp,dir,id) = repr_kn kn in encode_path loc "CSTR" (Some (mp,dir)) - [id_of_label id;id_of_string ("_"^string_of_int i)] + [id_of_label id;id_of_string ("_"^string_of_int i)] (id_of_string ("_"^string_of_int j)) - | VarRef id -> + | VarRef id -> encode_path loc "SECVAR" None [] id let short_string_of_ref loc = function @@ -460,8 +460,8 @@ let short_string_of_ref loc = function | IndRef (kn,i) -> encode_path loc "IND" None [id_of_label (pi3 (repr_kn kn))] (id_of_string ("_"^string_of_int i)) - | ConstructRef ((kn,i),j) -> - encode_path loc "CSTR" None + | ConstructRef ((kn,i),j) -> + encode_path loc "CSTR" None [id_of_label (pi3 (repr_kn kn));id_of_string ("_"^string_of_int i)] (id_of_string ("_"^string_of_int j)) diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 1e1144895f..266bd1043c 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -7,9 +7,9 @@ open Vm let ppripos (ri,pos) = (match ri with - | Reloc_annot a -> + | Reloc_annot a -> let sp,i = a.ci.ci_ind in - print_string + print_string ("annot : MutInd("^(string_of_kn sp)^","^(string_of_int i)^")\n") | Reloc_const _ -> print_string "structured constant\n" @@ -29,8 +29,8 @@ let ppsort = function let print_idkey idk = - match idk with - | ConstKey sp -> + match idk with + | ConstKey sp -> print_string "Cons("; print_string (string_of_con sp); print_string ")" @@ -38,8 +38,8 @@ let print_idkey idk = | RelKey i -> print_string "~";print_int i let rec ppzipper z = - match z with - | Zapp args -> + match z with + | Zapp args -> let n = nargs args in open_hbox (); for i = 0 to n-2 do @@ -50,7 +50,7 @@ let rec ppzipper z = | Zfix _ -> print_string "Zfix" | Zswitch _ -> print_string "Zswitch" -and ppstack s = +and ppstack s = open_hovbox 0; print_string "["; List.iter (fun z -> ppzipper z;print_string " | ") s; @@ -67,14 +67,14 @@ and ppatom a = print_string ")" and ppwhd whd = - match whd with + match whd with | Vsort s -> ppsort s | Vprod _ -> print_string "product" | Vfun _ -> print_string "function" | Vfix _ -> print_vfix() | Vcofix _ -> print_string "cofix" | Vconstr_const i -> print_string "C(";print_int i;print_string")" - | Vconstr_block b -> ppvblock b + | Vconstr_block b -> ppvblock b | Vatom_stk(a,s) -> open_hbox();ppatom a;close_box(); print_string"@";ppstack s diff --git a/doc/RecTutorial/RecTutorial.v b/doc/RecTutorial/RecTutorial.v index 7bede1737e..28aaf75204 100644 --- a/doc/RecTutorial/RecTutorial.v +++ b/doc/RecTutorial/RecTutorial.v @@ -2,8 +2,8 @@ Check (forall A:Type, (exists x:A, forall (y:A), x <> y) -> 2 = 3). -Inductive nat : Set := - | O : nat +Inductive nat : Set := + | O : nat | S : nat->nat. Check nat. Check O. @@ -18,8 +18,8 @@ Print le. Theorem zero_leq_three: 0 <= 3. Proof. - constructor 2. - constructor 2. + constructor 2. + constructor 2. constructor 2. constructor 1. @@ -35,7 +35,7 @@ Qed. Lemma zero_lt_three : 0 < 3. Proof. - repeat constructor. + repeat constructor. Qed. Print zero_lt_three. @@ -134,7 +134,7 @@ Require Import Compare_dec. Check le_lt_dec. -Definition max (n p :nat) := match le_lt_dec n p with +Definition max (n p :nat) := match le_lt_dec n p with | left _ => p | right _ => n end. @@ -154,9 +154,9 @@ Extraction max. Inductive tree(A:Type) : Type := - node : A -> forest A -> tree A + node : A -> forest A -> tree A with - forest (A: Type) : Type := + forest (A: Type) : Type := nochild : forest A | addchild : tree A -> forest A -> forest A. @@ -164,7 +164,7 @@ with -Inductive +Inductive even : nat->Prop := evenO : even O | evenS : forall n, odd n -> even (S n) @@ -178,11 +178,11 @@ Qed. -Definition nat_case := +Definition nat_case := fun (Q : Type)(g0 : Q)(g1 : nat -> Q)(n:nat) => match n return Q with - | 0 => g0 - | S p => g1 p + | 0 => g0 + | S p => g1 p end. Eval simpl in (nat_case nat 0 (fun p => p) 34). @@ -202,7 +202,7 @@ Eval simpl in fun p => pred (S p). Definition xorb (b1 b2:bool) := -match b1, b2 with +match b1, b2 with | false, true => true | true, false => true | _ , _ => false @@ -210,7 +210,7 @@ end. Definition pred_spec (n:nat) := {m:nat | n=0 /\ m=0 \/ n = S m}. - + Definition predecessor : forall n:nat, pred_spec n. intro n;case n. @@ -222,7 +222,7 @@ Print predecessor. Extraction predecessor. -Theorem nat_expand : +Theorem nat_expand : forall n:nat, n = match n with 0 => 0 | S p => S p end. intro n;case n;simpl;auto. Qed. @@ -230,7 +230,7 @@ Qed. Check (fun p:False => match p return 2=3 with end). Theorem fromFalse : False -> 0=1. - intro absurd. + intro absurd. contradiction. Qed. @@ -246,12 +246,12 @@ Section equality_elimination. End equality_elimination. - + Theorem trans : forall n m p:nat, n=m -> m=p -> n=p. Proof. - intros n m p eqnm. + intros n m p eqnm. case eqnm. - trivial. + trivial. Qed. Lemma Rw : forall x y: nat, y = y * x -> y * x * x = y. @@ -284,7 +284,7 @@ Lemma four_n : forall n:nat, n+n+n+n = 4*n. Undo. intro n; pattern n at 1. - + rewrite <- mult_1_l. repeat rewrite mult_distr_S. @@ -316,7 +316,7 @@ Proof. intros m Hm; exists m;trivial. Qed. -Definition Vtail_total +Definition Vtail_total (A : Type) (n : nat) (v : vector A n) : vector A (pred n):= match v in (vector _ n0) return (vector A (pred n0)) with | Vnil => Vnil A @@ -324,7 +324,7 @@ match v in (vector _ n0) return (vector A (pred n0)) with end. Definition Vtail' (A:Type)(n:nat)(v:vector A n) : vector A (pred n). - intros A n v; case v. + intros A n v; case v. simpl. exact (Vnil A). simpl. @@ -333,7 +333,7 @@ Defined. (* Inductive Lambda : Set := - lambda : (Lambda -> False) -> Lambda. + lambda : (Lambda -> False) -> Lambda. Error: Non strictly positive occurrence of "Lambda" in @@ -349,7 +349,7 @@ Section Paradox. (* understand matchL Q l (fun h : Lambda -> False => t) - as match l return Q with lambda h => t end + as match l return Q with lambda h => t end *) Definition application (f x: Lambda) :False := @@ -379,26 +379,26 @@ Definition isingle l := inode l (fun i => ileaf). Definition t1 := inode 0 (fun n => isingle (Z_of_nat (2*n))). -Definition t2 := inode 0 - (fun n : nat => +Definition t2 := inode 0 + (fun n : nat => inode (Z_of_nat n) (fun p => isingle (Z_of_nat (n*p)))). Inductive itree_le : itree-> itree -> Prop := | le_leaf : forall t, itree_le ileaf t - | le_node : forall l l' s s', - Zle l l' -> - (forall i, exists j:nat, itree_le (s i) (s' j)) -> + | le_node : forall l l' s s', + Zle l l' -> + (forall i, exists j:nat, itree_le (s i) (s' j)) -> itree_le (inode l s) (inode l' s'). -Theorem itree_le_trans : +Theorem itree_le_trans : forall t t', itree_le t t' -> forall t'', itree_le t' t'' -> itree_le t t''. induction t. constructor 1. - + intros t'; case t'. inversion 1. intros z0 i0 H0. @@ -411,20 +411,20 @@ Theorem itree_le_trans : inversion_clear H0. intro i2; case (H4 i2). intros. - generalize (H i2 _ H0). + generalize (H i2 _ H0). intros. case (H3 x);intros. generalize (H5 _ H6). exists x0;auto. Qed. - + Inductive itree_le' : itree-> itree -> Prop := | le_leaf' : forall t, itree_le' ileaf t - | le_node' : forall l l' s s' g, - Zle l l' -> - (forall i, itree_le' (s i) (s' (g i))) -> + | le_node' : forall l l' s s' g, + Zle l l' -> + (forall i, itree_le' (s i) (s' (g i))) -> itree_le' (inode l s) (inode l' s'). @@ -436,7 +436,7 @@ Lemma t1_le_t2 : itree_le t1 t2. constructor. auto with zarith. intro i; exists (2 * i). - unfold isingle. + unfold isingle. constructor. auto with zarith. exists i;constructor. @@ -457,7 +457,7 @@ Qed. Require Import List. -Inductive ltree (A:Set) : Set := +Inductive ltree (A:Set) : Set := lnode : A -> list (ltree A) -> ltree A. Inductive prop : Prop := @@ -482,8 +482,8 @@ Qed. Check (fun (P:Prop->Prop)(p: ex_Prop P) => match p with exP_intro X HX => X end). Error: -Incorrect elimination of "p" in the inductive type -"ex_Prop", the return type has sort "Type" while it should be +Incorrect elimination of "p" in the inductive type +"ex_Prop", the return type has sort "Type" while it should be "Prop" Elimination of an inductive object of sort "Prop" @@ -493,11 +493,11 @@ because proofs can be eliminated only to build proofs *) -Inductive typ : Type := - typ_intro : Type -> typ. +Inductive typ : Type := + typ_intro : Type -> typ. Definition typ_inject: typ. -split. +split. exact typ. (* Defined. @@ -543,13 +543,13 @@ Reset comes_from_the_left. Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop := match H with - | or_introl p => True + | or_introl p => True | or_intror q => False end. Error: -Incorrect elimination of "H" in the inductive type -"or", the return type has sort "Type" while it should be +Incorrect elimination of "H" in the inductive type +"or", the return type has sort "Type" while it should be "Prop" Elimination of an inductive object of sort "Prop" @@ -561,41 +561,41 @@ because proofs can be eliminated only to build proofs Definition comes_from_the_left_sumbool (P Q:Prop)(x:{P}+{Q}): Prop := match x with - | left p => True + | left p => True | right q => False end. - + Close Scope Z_scope. -Theorem S_is_not_O : forall n, S n <> 0. +Theorem S_is_not_O : forall n, S n <> 0. -Definition Is_zero (x:nat):= match x with - | 0 => True +Definition Is_zero (x:nat):= match x with + | 0 => True | _ => False end. Lemma O_is_zero : forall m, m = 0 -> Is_zero m. Proof. intros m H; subst m. - (* + (* ============================ Is_zero 0 *) simpl;trivial. Qed. - + red; intros n Hn. apply O_is_zero with (m := S n). assumption. Qed. -Theorem disc2 : forall n, S (S n) <> 1. +Theorem disc2 : forall n, S (S n) <> 1. Proof. intros n Hn; discriminate. Qed. @@ -611,7 +611,7 @@ Qed. Theorem inj_succ : forall n m, S n = S m -> n = m. Proof. - + Lemma inj_pred : forall n m, n = m -> pred n = pred m. Proof. @@ -645,9 +645,9 @@ Proof. intros n p H; case H ; intros; discriminate. Qed. - + eapply not_le_Sn_0_with_constraints; eauto. -Qed. +Qed. Theorem not_le_Sn_0' : forall n:nat, ~ (S n <= 0). @@ -660,7 +660,7 @@ Check le_Sn_0_inv. Theorem le_Sn_0'' : forall n p : nat, ~ S n <= 0 . Proof. - intros n p H; + intros n p H; inversion H using le_Sn_0_inv. Qed. @@ -668,9 +668,9 @@ Derive Inversion_clear le_Sn_0_inv' with (forall n :nat, S n <= 0). Check le_Sn_0_inv'. -Theorem le_reverse_rules : - forall n m:nat, n <= m -> - n = m \/ +Theorem le_reverse_rules : + forall n m:nat, n <= m -> + n = m \/ exists p, n <= p /\ m = S p. Proof. intros n m H; inversion H. @@ -683,21 +683,21 @@ Restart. Qed. Inductive ArithExp : Set := - Zero : ArithExp + Zero : ArithExp | Succ : ArithExp -> ArithExp | Plus : ArithExp -> ArithExp -> ArithExp. Inductive RewriteRel : ArithExp -> ArithExp -> Prop := RewSucc : forall e1 e2 :ArithExp, - RewriteRel e1 e2 -> RewriteRel (Succ e1) (Succ e2) + RewriteRel e1 e2 -> RewriteRel (Succ e1) (Succ e2) | RewPlus0 : forall e:ArithExp, - RewriteRel (Plus Zero e) e + RewriteRel (Plus Zero e) e | RewPlusS : forall e1 e2:ArithExp, RewriteRel e1 e2 -> RewriteRel (Plus (Succ e1) e2) (Succ (Plus e1 e2)). - + Fixpoint plus (n p:nat) {struct n} : nat := match n with | 0 => p @@ -718,7 +718,7 @@ Fixpoint plus'' (n p:nat) {struct n} : nat := Fixpoint even_test (n:nat) : bool := - match n + match n with 0 => true | 1 => false | S (S p) => even_test p @@ -728,20 +728,20 @@ Fixpoint even_test (n:nat) : bool := Reset even_test. Fixpoint even_test (n:nat) : bool := - match n - with + match n + with | 0 => true | S p => odd_test p end with odd_test (n:nat) : bool := match n - with + with | 0 => false | S p => even_test p end. - + Eval simpl in even_test. @@ -758,11 +758,11 @@ Section Principle_of_Induction. Variable P : nat -> Prop. Hypothesis base_case : P 0. Hypothesis inductive_step : forall n:nat, P n -> P (S n). -Fixpoint nat_ind (n:nat) : (P n) := +Fixpoint nat_ind (n:nat) : (P n) := match n return P n with | 0 => base_case | S m => inductive_step m (nat_ind m) - end. + end. End Principle_of_Induction. @@ -782,9 +782,9 @@ Variable P : nat -> nat ->Prop. Hypothesis base_case1 : forall x:nat, P 0 x. Hypothesis base_case2 : forall x:nat, P (S x) 0. Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). -Fixpoint nat_double_ind (n m:nat){struct n} : P n m := - match n, m return P n m with - | 0 , x => base_case1 x +Fixpoint nat_double_ind (n m:nat){struct n} : P n m := + match n, m return P n m with + | 0 , x => base_case1 x | (S x), 0 => base_case2 x | (S x), (S y) => inductive_step x y (nat_double_ind x y) end. @@ -795,15 +795,15 @@ Variable P : nat -> nat -> Type. Hypothesis base_case1 : forall x:nat, P 0 x. Hypothesis base_case2 : forall x:nat, P (S x) 0. Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). -Fixpoint nat_double_rect (n m:nat){struct n} : P n m := - match n, m return P n m with - | 0 , x => base_case1 x +Fixpoint nat_double_rect (n m:nat){struct n} : P n m := + match n, m return P n m with + | 0 , x => base_case1 x | (S x), 0 => base_case2 x | (S x), (S y) => inductive_step x y (nat_double_rect x y) end. End Principle_of_Double_Recursion. -Definition min : nat -> nat -> nat := +Definition min : nat -> nat -> nat := nat_double_rect (fun (x y:nat) => nat) (fun (x:nat) => 0) (fun (y:nat) => 0) @@ -855,11 +855,11 @@ Qed. Hint Resolve le'_n_Sp. - + Lemma le_le' : forall n p, n<=p -> le' n p. Proof. induction 1;auto with arith. -Qed. +Qed. Print Acc. @@ -869,7 +869,7 @@ Require Import Minus. (* Fixpoint div (x y:nat){struct x}: nat := - if eq_nat_dec x 0 + if eq_nat_dec x 0 then 0 else if eq_nat_dec y 0 then x @@ -902,18 +902,18 @@ Qed. Lemma minus_smaller_positive : forall x y:nat, x <>0 -> y <> 0 -> x - y < x. Proof. - destruct x; destruct y; - ( simpl;intros; apply minus_smaller_S || + destruct x; destruct y; + ( simpl;intros; apply minus_smaller_S || intros; absurd (0=0); auto). Qed. -Definition minus_decrease : forall x y:nat, Acc lt x -> - x <> 0 -> +Definition minus_decrease : forall x y:nat, Acc lt x -> + x <> 0 -> y <> 0 -> Acc lt (x-y). Proof. intros x y H; case H. - intros Hz posz posy. + intros Hz posz posy. apply Hz; apply minus_smaller_positive; assumption. Defined. @@ -924,18 +924,18 @@ Print minus_decrease. Definition div_aux (x y:nat)(H: Acc lt x):nat. fix 3. intros. - refine (if eq_nat_dec x 0 - then 0 - else if eq_nat_dec y 0 + refine (if eq_nat_dec x 0 + then 0 + else if eq_nat_dec y 0 then y else div_aux (x-y) y _). - apply (minus_decrease x y H);assumption. + apply (minus_decrease x y H);assumption. Defined. Print div_aux. (* -div_aux = +div_aux = (fix div_aux (x y : nat) (H : Acc lt x) {struct H} : nat := match eq_nat_dec x 0 with | left _ => 0 @@ -949,7 +949,7 @@ div_aux = *) Require Import Wf_nat. -Definition div x y := div_aux x y (lt_wf x). +Definition div x y := div_aux x y (lt_wf x). Extraction div. (* @@ -975,7 +975,7 @@ Proof. Abort. (* - Lemma vector0_is_vnil_aux : forall (A:Type)(n:nat)(v:vector A n), + Lemma vector0_is_vnil_aux : forall (A:Type)(n:nat)(v:vector A n), n= 0 -> v = Vnil A. Toplevel input, characters 40281-40287 @@ -994,7 +994,7 @@ The term "Vnil A" has type "vector A 0" while it is expected to have type (* On devrait changer Set en Type ? *) -Lemma vector0_is_vnil_aux : forall (A:Type)(n:nat)(v:vector A n), +Lemma vector0_is_vnil_aux : forall (A:Type)(n:nat)(v:vector A n), n= 0 -> JMeq v (Vnil A). Proof. destruct v. @@ -1030,7 +1030,7 @@ Eval simpl in (fun (A:Type)(v:vector A 0) => v). Lemma Vid_eq : forall (n:nat) (A:Type)(v:vector A n), v=(Vid _ n v). Proof. - destruct v. + destruct v. reflexivity. reflexivity. Defined. @@ -1038,7 +1038,7 @@ Defined. Theorem zero_nil : forall A (v:vector A 0), v = Vnil. Proof. intros. - change (Vnil (A:=A)) with (Vid _ 0 v). + change (Vnil (A:=A)) with (Vid _ 0 v). apply Vid_eq. Defined. @@ -1054,7 +1054,7 @@ Defined. -Definition vector_double_rect : +Definition vector_double_rect : forall (A:Type) (P: forall (n:nat),(vector A n)->(vector A n) -> Type), P 0 Vnil Vnil -> (forall n (v1 v2 : vector A n) a b, P n v1 v2 -> @@ -1109,7 +1109,7 @@ Qed. | LCons : A -> LList A -> LList A. - + Definition head (A:Type)(s : Stream A) := match s with Cons a s' => a end. @@ -1148,7 +1148,7 @@ Hypothesis bisim2 : forall s1 s2:Stream A, R s1 s2 -> CoFixpoint park_ppl : forall s1 s2:Stream A, R s1 s2 -> EqSt s1 s2 := fun s1 s2 (p : R s1 s2) => - eqst s1 s2 (bisim1 p) + eqst s1 s2 (bisim1 p) (park_ppl (bisim2 p)). End Parks_Principle. @@ -1158,7 +1158,7 @@ Theorem map_iterate : forall (A:Type)(f:A->A)(x:A), Proof. intros A f x. apply park_ppl with - (R:= fun s1 s2 => exists x: A, + (R:= fun s1 s2 => exists x: A, s1 = iterate f (f x) /\ s2 = map f (iterate f x)). intros s1 s2 (x0,(eqs1,eqs2));rewrite eqs1;rewrite eqs2;reflexivity. diff --git a/doc/faq/interval_discr.v b/doc/faq/interval_discr.v index 972300dac2..ed2c0e37ee 100644 --- a/doc/faq/interval_discr.v +++ b/doc/faq/interval_discr.v @@ -69,7 +69,7 @@ Qed. (** Definition of having finite cardinality [n+1] for a set [A] *) Definition card (A:Set) n := - exists f, + exists f, (forall x:A, f x <= n) /\ (forall x y:A, f x = f y -> x = y) /\ (forall m, m <= n -> exists x:A, f x = m). @@ -86,7 +86,7 @@ split. (* bounded *) intro x; apply (proj2_sig x). split. -(* injectivity *) +(* injectivity *) intros (p,Hp) (q,Hq). simpl. intro Hpq. @@ -123,7 +123,7 @@ left. apply eq_S. assumption. right. - intro HeqS. + intro HeqS. injection HeqS; intro Heq. apply Hneq. apply dep_pair_intro. @@ -133,7 +133,7 @@ Qed. (** Showing that the cardinality relation is functional on decidable sets *) Lemma card_inj_aux : - forall (A:Type) f g n, + forall (A:Type) f g n, (forall x:A, f x <= 0) -> (forall x y:A, f x = f y -> x = y) -> (forall m, m <= S n -> exists x:A, g x = m) @@ -175,7 +175,7 @@ lemma by generalizing over a first-order definition of [x<>y], say Qed. Lemma dec_restrict : - forall (A:Set), + forall (A:Set), (forall x y :A, {x=y}+{x<>y}) -> forall z (x y :{a:A|a<>z}), {x=y}+{x<>y}. Proof. @@ -185,7 +185,7 @@ left; apply neq_dep_intro; assumption. right; intro Heq; injection Heq; exact Hneq. Qed. -Lemma pred_inj : forall n m, +Lemma pred_inj : forall n m, 0 <> n -> 0 <> m -> pred m = pred n -> m = n. Proof. destruct n. @@ -242,13 +242,13 @@ destruct (le_lt_or_eq _ _ Hfx). contradiction (lt_not_le (f y) (f z)). Qed. -Theorem card_inj : forall m n (A:Set), +Theorem card_inj : forall m n (A:Set), (forall x y :A, {x=y}+{x<>y}) -> - card A m -> card A n -> m = n. + card A m -> card A n -> m = n. Proof. -induction m; destruct n; +induction m; destruct n; intros A Hdec - (f,(Hfbound,(Hfinj,Hfsurj))) + (f,(Hfbound,(Hfinj,Hfsurj))) (g,(Hgbound,(Hginj,Hgsurj))). (* 0/0 *) reflexivity. @@ -265,7 +265,7 @@ apply dec_restrict. assumption. (* cardinality of {x:A|x<>xSn} is m *) pose (f' := fun x' : {x:A|x<>xSn} => - let (x,Hneq) := x' in + let (x,Hneq) := x' in if le_lt_dec (f xSn) (f x) then pred (f x) else f x). @@ -361,7 +361,7 @@ destruct (le_lt_dec (f xSn) (f x)) as [Hle'|Hlt']. assumption. (* cardinality of {x:A|x<>xSn} is n *) pose (g' := fun x' : {x:A|x<>xSn} => - let (x,Hneq) := x' in + let (x,Hneq) := x' in if Hdec x xSn then 0 else g x). exists g'. split. diff --git a/ide/command_windows.ml b/ide/command_windows.ml index ab65fa1439..ee07b3fb81 100644 --- a/ide/command_windows.ml +++ b/ide/command_windows.ml @@ -8,9 +8,9 @@ (* $Id$ *) -class command_window () = -(* let window = GWindow.window - ~allow_grow:true ~allow_shrink:true +class command_window () = +(* let window = GWindow.window + ~allow_grow:true ~allow_shrink:true ~width:500 ~height:250 ~position:`CENTER ~title:"CoqIde queries" ~show:false () @@ -19,23 +19,23 @@ class command_window () = let _ = frame#misc#hide () in let _ = GtkData.AccelGroup.create () in let hbox = GPack.hbox ~homogeneous:false ~packing:frame#add () in - let toolbar = GButton.toolbar - ~orientation:`VERTICAL + let toolbar = GButton.toolbar + ~orientation:`VERTICAL ~style:`ICONS - ~tooltips:true - ~packing:(hbox#pack + ~tooltips:true + ~packing:(hbox#pack ~expand:false ~fill:false) () in - let notebook = GPack.notebook ~scrollable:true - ~packing:(hbox#pack + let notebook = GPack.notebook ~scrollable:true + ~packing:(hbox#pack ~expand:true ~fill:true - ) + ) () in - let _ = + let _ = toolbar#insert_button ~tooltip:"Hide Commands Pane" ~text:"Hide Pane" @@ -43,7 +43,7 @@ class command_window () = ~callback:frame#misc#hide () in - let new_page_menu = + let new_page_menu = toolbar#insert_button ~tooltip:"New Page" ~text:"New Page" @@ -51,7 +51,7 @@ class command_window () = () in - let _ = + let _ = toolbar#insert_button ~tooltip:"Delete Page" ~text:"Delete Page" @@ -65,10 +65,10 @@ object(self) val new_page_menu = new_page_menu val notebook = notebook - method frame = frame + method frame = frame method new_command ?command ?term () = let appendp x = ignore (notebook#append_page x) in - let frame = GBin.frame + let frame = GBin.frame ~shadow_type:`ETCHED_OUT ~packing:appendp () @@ -84,15 +84,15 @@ object(self) () in combo#disable_activate (); - let on_activate c () = - if List.mem combo#entry#text Coq_commands.state_preserving then c () - else prerr_endline "Not a state preserving command" + let on_activate c () = + if List.mem combo#entry#text Coq_commands.state_preserving then c () + else prerr_endline "Not a state preserving command" in let entry = GEdit.entry ~packing:(hbox#pack ~expand:true) () in entry#misc#set_can_default true; let r_bin = - GBin.scrolled_window - ~vpolicy:`AUTOMATIC + GBin.scrolled_window + ~vpolicy:`AUTOMATIC ~hpolicy:`AUTOMATIC ~packing:(vbox#pack ~fill:true ~expand:true) () in let ok_b = GButton.button ~label:"Ok" ~packing:(hbox#pack ~expand:false) () in @@ -101,13 +101,13 @@ object(self) result#set_editable false; let callback () = let com = combo#entry#text in - let phrase = + let phrase = if String.get com (String.length com - 1) = '.' - then com ^ " " else com ^ " " ^ entry#text ^" . " + then com ^ " " else com ^ " " ^ entry#text ^" . " in try ignore(Coq.interp false phrase); - result#buffer#set_text + result#buffer#set_text ("Result for command " ^ phrase ^ ":\n" ^ Ideutils.read_stdout ()) with e -> let (s,loc) = Coq.process_exn e in @@ -117,16 +117,16 @@ object(self) ignore (combo#entry#connect#activate ~callback:(on_activate callback)); ignore (ok_b#connect#clicked ~callback:(on_activate callback)); - begin match command,term with + begin match command,term with | None,None -> () - | Some c, None -> + | Some c, None -> combo#entry#set_text c; - - | Some c, Some t -> + + | Some c, Some t -> combo#entry#set_text c; entry#set_text t - - | None , Some t -> + + | None , Some t -> entry#set_text t end; on_activate callback (); @@ -134,9 +134,9 @@ object(self) entry#misc#grab_default (); ignore (entry#connect#activate ~callback); ignore (combo#entry#connect#activate ~callback); - self#frame#misc#show () + self#frame#misc#show () - initializer + initializer ignore (new_page_menu#connect#clicked self#new_command); (* ignore (window#event#connect#delete (fun _ -> window#misc#hide(); true));*) end @@ -145,6 +145,6 @@ let command_window = ref None let main () = command_window := Some (new command_window ()) -let command_window () = match !command_window with +let command_window () = match !command_window with | None -> failwith "No command window." | Some c -> c diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll index 8e04331c1b..97aeb2f5a4 100644 --- a/ide/config_lexer.mll +++ b/ide/config_lexer.mll @@ -28,19 +28,19 @@ rule token = parse | '#' [^ '\n']* { token lexbuf } | ident { IDENT (lexeme lexbuf) } | '=' { EQUAL } - | '"' { Buffer.reset string_buffer; + | '"' { Buffer.reset string_buffer; Buffer.add_char string_buffer '"'; string lexbuf; let s = Buffer.contents string_buffer in STRING (Scanf.sscanf s "%S" (fun s -> s)) } | _ { let c = lexeme_start lexbuf in - eprintf ".coqiderc: invalid character (%d)\n@." c; + eprintf ".coqiderc: invalid character (%d)\n@." c; token lexbuf } | eof { EOF } and string = parse | '"' { Buffer.add_char string_buffer '"' } - | '\\' '"' | _ + | '\\' '"' | _ { Buffer.add_string string_buffer (lexeme lexbuf); string lexbuf } | eof { eprintf ".coqiderc: unterminated string\n@." } @@ -60,7 +60,7 @@ and string = parse | [] -> () | s :: sl -> fprintf fmt "%S@ %a" s print_list sl in - Stringmap.iter + Stringmap.iter (fun k s -> fprintf fmt "@[%s = %a@]@\n" k print_list s) m; fprintf fmt "@."; close_out c diff --git a/ide/coq.ml b/ide/coq.ml index 4fd48a3064..a567fb4f54 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -30,16 +30,16 @@ let prerr_endline s = if !debug then prerr_endline s else () let output = ref (Format.formatter_of_out_channel stdout) -let msg m = +let msg m = let b = Buffer.create 103 in Pp.msg_with (Format.formatter_of_buffer b) m; Buffer.contents b -let msgnl m = +let msgnl m = (msg m)^"\n" -let init () = - (* To hide goal in lower window. +let init () = + (* To hide goal in lower window. Problem: should not hide "xx is assumed" messages *) (**) @@ -70,7 +70,7 @@ let short_version () = let version () = let (ver,date) = get_version_date () in - Printf.sprintf + Printf.sprintf "The Coq Proof Assistant, version %s (%s)\ \nArchitecture %s running %s operating system\ \nGtk version is %s\ @@ -79,14 +79,14 @@ let version () = ver date Coq_config.arch Sys.os_type (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z) - (if Mltop.is_native then "native" else "bytecode") - (if Coq_config.best="opt" then "native" else "bytecode") + (if Mltop.is_native then "native" else "bytecode") + (if Coq_config.best="opt" then "native" else "bytecode") -let is_in_coq_lib dir = +let is_in_coq_lib dir = prerr_endline ("Is it a coq theory ? : "^dir); let is_same_file = same_file dir in - List.exists - (fun s -> + List.exists + (fun s -> let fdir = Filename.concat (Envars.coqlib ()) (Filename.concat "theories" s) in prerr_endline (" Comparing to: "^fdir); @@ -97,19 +97,19 @@ let is_in_coq_lib dir = let is_in_loadpath dir = Library.is_in_load_paths (System.physical_path_of_string dir) -let is_in_coq_path f = - try +let is_in_coq_path f = + try let base = Filename.chop_extension (Filename.basename f) in let _ = Library.locate_qualified_library false - (Libnames.make_qualid Names.empty_dirpath + (Libnames.make_qualid Names.empty_dirpath (Names.id_of_string base)) in prerr_endline (f ^ " is in coq path"); true - with _ -> + with _ -> prerr_endline (f ^ " is NOT in coq path"); - false + false -let is_in_proof_mode () = +let is_in_proof_mode () = match Decl_mode.get_current_mode () with Decl_mode.Mode_none -> false | _ -> true @@ -347,13 +347,13 @@ type reset_info = reset_mark * undo_info * bool ref let compute_reset_info () = (match Lib.has_top_frozen_state () with - | Some st -> + | Some st -> prerr_endline ("On top of state "^Libnames.string_of_path (fst st)); st - | None -> + | None -> failwith "FATAL ERROR: NO RESET"), undo_info(), ref true -let reset_initial () = +let reset_initial () = prerr_endline "Reset initial called"; flush stderr; Vernacentries.abort_refine Lib.reset_initial () @@ -361,14 +361,14 @@ let reset_to st = prerr_endline ("Reset called with state "^(Libnames.string_of_path (fst st))); Lib.reset_to_state st -let reset_to_mod id = - prerr_endline ("Reset called to Mod/Sect with "^(string_of_id id)); +let reset_to_mod id = + prerr_endline ("Reset called to Mod/Sect with "^(string_of_id id)); Lib.reset_mod (Util.dummy_loc,id) let raw_interp s = Vernac.raw_do_vernac (Pcoq.Gram.parsable (Stream.of_string s)) -let interp_with_options verbosely options s = +let interp_with_options verbosely options s = prerr_endline "Starting interp..."; prerr_endline s; let pa = Pcoq.Gram.parsable (Stream.of_string s) in @@ -376,7 +376,7 @@ let interp_with_options verbosely options s = (* Temporary hack to make coqide.byte work (WTF???) - now with less screen * pollution *) Pervasives.prerr_string " \r"; Pervasives.flush stderr; - match pe with + match pe with | None -> assert false | Some((loc,vernac) as last) -> if is_vernac_debug_command vernac then @@ -385,7 +385,7 @@ let interp_with_options verbosely options s = user_error_loc loc (str "Use CoqIDE navigation instead"); if is_vernac_known_option_command vernac then user_error_loc loc (str "Use CoqIDE display menu instead"); - if is_vernac_query_command vernac then + if is_vernac_query_command vernac then flash_info "Warning: query commands should not be inserted in scripts"; if not (is_vernac_goal_printing_command vernac) then @@ -402,12 +402,12 @@ let interp_with_options verbosely options s = let interp verbosely phrase = interp_with_options verbosely (make_option_commands ()) phrase -let interp_and_replace s = +let interp_and_replace s = let result = interp false s in let msg = read_stdout () in result,msg -type tried_tactic = +type tried_tactic = | Interrupted | Success of int (* nb of goals after *) | Failed @@ -424,7 +424,7 @@ let print_toplevel_error exc = match exc with | DuringCommandInterp (loc,ie) -> if loc = dummy_loc then (None,ie) else (Some loc, ie) - | _ -> (None, exc) + | _ -> (None, exc) in let (loc,exc) = match exc with @@ -434,19 +434,19 @@ let print_toplevel_error exc = in match exc with | End_of_input -> str "Please report: End of input",None - | Vernacexpr.ProtectedLoop -> + | Vernacexpr.ProtectedLoop -> str "ProtectedLoop not allowed by coqide!",None | Vernacexpr.Drop -> str "Drop is not allowed by coqide!",None | Vernacexpr.Quit -> str "Quit is not allowed by coqide! Use menus.",None - | _ -> - (try Cerrors.explain_exn exc with e -> + | _ -> + (try Cerrors.explain_exn exc with e -> str "Failed to explain error. This is an internal Coq error. Please report.\n" ++ str (Printexc.to_string e)), (if is_pervasive_exn exc then None else loc) let process_exn e = let s,loc= print_toplevel_error e in (msgnl s,loc) -let interp_last last = +let interp_last last = prerr_string "*"; try vernac_com (States.with_heavy_rollback Vernacentries.interp) last; @@ -457,7 +457,7 @@ let interp_last last = type hyp = env * evar_map * - ((identifier * string) * constr option * constr) * + ((identifier * string) * constr option * constr) * (string * string) type concl = env * evar_map * constr * string type meta = env * evar_map * string @@ -465,7 +465,7 @@ type goal = hyp list * concl let prepare_hyp sigma env ((i,c,d) as a) = env, sigma, - ((i,string_of_id i),c,d), + ((i,string_of_id i),c,d), (msg (pr_var_decl env a), msg (pr_ltype_env env d)) let prepare_hyps sigma env = @@ -473,7 +473,7 @@ let prepare_hyps sigma env = let hyps = fold_named_context (fun env d acc -> let hyp = prepare_hyp sigma env d in hyp :: acc) - env ~init:[] + env ~init:[] in List.rev hyps @@ -496,9 +496,9 @@ let get_current_pm_goal () = let gl = sig_it gls in prepare_goal sigma gl -let get_current_goals () = +let get_current_goals () = let pfts = get_pftreestate () in - let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in + let gls = fst (Refiner.frontier (Tacmach.proof_of_pftreestate pfts)) in let sigma = Tacmach.evc_of_pftreestate pfts in List.map (prepare_goal sigma) gls @@ -508,16 +508,16 @@ let print_no_goal () = let hyp_menu (env, sigma, ((coqident,ident),_,ast),(s,pr_ast)) = [("clear "^ident),("clear "^ident^"."); - + ("apply "^ident), ("apply "^ident^"."); - + ("exact "^ident), ("exact "^ident^"."); ("generalize "^ident), ("generalize "^ident^"."); - + ("absurd <"^ident^">"), ("absurd "^ pr_ast @@ -528,34 +528,34 @@ let hyp_menu (env, sigma, ((coqident,ident),_,ast),(s,pr_ast)) = "injection "^ident, "injection "^ident^"." ] else []) @ - + (let _,t = splay_prod env sigma ast in - if is_equality_type t then + if is_equality_type t then [ "rewrite "^ident, "rewrite "^ident^"."; "rewrite <- "^ident, "rewrite <- "^ident^"." ] else []) @ - + [("elim "^ident), ("elim "^ident^"."); - + ("inversion "^ident), ("inversion "^ident^"."); - + ("inversion clear "^ident), - ("inversion_clear "^ident^".")] + ("inversion_clear "^ident^".")] -let concl_menu (_,_,concl,_) = +let concl_menu (_,_,concl,_) = let is_eq = is_equality_type concl in ["intro", "intro."; "intros", "intros."; "intuition","intuition." ] @ - - (if is_eq then + + (if is_eq then ["reflexivity", "reflexivity."; "discriminate", "discriminate."; "symmetry", "symmetry." ] - else + else []) @ ["assumption" ,"assumption."; @@ -577,41 +577,41 @@ let concl_menu (_,_,concl,_) = ] -let id_of_name = function - | Names.Anonymous -> id_of_string "x" +let id_of_name = function + | Names.Anonymous -> id_of_string "x" | Names.Name x -> x -let make_cases s = +let make_cases s = let qualified_name = Libnames.qualid_of_string s in let glob_ref = Nametab.locate qualified_name in match glob_ref with - | Libnames.IndRef i -> + | Libnames.IndRef i -> let {Declarations.mind_nparams = np}, {Declarations.mind_consnames = carr ; - Declarations.mind_nf_lc = tarr } - = Global.lookup_inductive i + Declarations.mind_nf_lc = tarr } + = Global.lookup_inductive i in - Util.array_fold_right2 - (fun n t l -> + Util.array_fold_right2 + (fun n t l -> let (al,_) = Term.decompose_prod t in let al,_ = Util.list_chop (List.length al - np) al in - let rec rename avoid = function + let rec rename avoid = function | [] -> [] - | (n,_)::l -> + | (n,_)::l -> let n' = next_global_ident_away true - (id_of_name n) + (id_of_name n) avoid in (string_of_id n')::(rename (n'::avoid) l) in let al' = rename [] (List.rev al) in (string_of_id n :: al') :: l ) - carr + carr tarr [] | _ -> raise Not_found -let current_status () = +let current_status () = let path = msg (Libnames.pr_dirpath (Lib.cwd ())) in let path = if path = "Top" then "Ready" else "Ready in " ^ String.sub path 4 (String.length path - 4) in try diff --git a/ide/coq.mli b/ide/coq.mli index df369cc18d..c2f96a1fe4 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -42,15 +42,15 @@ val reset_initial : unit -> unit val reset_to : reset_mark -> unit val reset_to_mod : identifier -> unit -val init : unit -> string list +val init : unit -> string list val interp : bool -> string -> reset_info * (Util.loc * Vernacexpr.vernac_expr) val interp_last : Util.loc * Vernacexpr.vernac_expr -> unit -val interp_and_replace : string -> +val interp_and_replace : string -> (reset_info * (Util.loc * Vernacexpr.vernac_expr)) * string (* type hyp = (identifier * constr option * constr) * string *) -type hyp = env * evar_map * +type hyp = env * evar_map * ((identifier*string) * constr option * constr) * (string * string) type meta = env * evar_map * string type concl = env * evar_map * constr * string @@ -74,7 +74,7 @@ val is_in_loadpath : string -> bool val make_cases : string -> string list list -type tried_tactic = +type tried_tactic = | Interrupted | Success of int (* nb of goals after *) | Failed diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index 80ac5a2004..e4a3ae56a5 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -43,7 +43,7 @@ let commands = [ ]; ["End"; "End Silent."; - "Eval"; + "Eval"; "Extract Constant"; "Extract Inductive"; "Extraction Inline"; @@ -84,7 +84,7 @@ let commands = [ ["Parameter"; "Proof."; "Program Definition"; - "Program Fixpoint"; + "Program Fixpoint"; "Program Lemma"; "Program Theorem"; ]; @@ -100,7 +100,7 @@ let commands = [ "Require Export"; "Require Import"; "Reset Extraction Inline"; - "Restore State"; + "Restore State"; ]; [ "Save."; "Scheme"; @@ -166,7 +166,7 @@ let state_preserving = [ "Extraction Module"; "Inspect"; "Locate"; - + "Obligations"; "Print"; "Print All."; @@ -192,7 +192,7 @@ let state_preserving = [ "Print Scope"; "Print Scopes."; "Print Section"; - + "Print Table Printing If."; "Print Table Printing Let."; "Print Tables."; @@ -230,7 +230,7 @@ let state_preserving = [ ] -let tactics = +let tactics = [ [ "abstract"; @@ -317,7 +317,7 @@ let tactics = "generalize"; "generalize dependent"; ]; - + [ "hnf"; ]; @@ -416,7 +416,7 @@ let tactics = "trivial"; "try"; ]; - + [ "unfold"; "unfold __ in"; diff --git a/ide/coqide.ml b/ide/coqide.ml index c0dfb9e6ea..4b08f4b9bd 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -25,7 +25,7 @@ type 'a info = {start:'a; } -class type analyzed_views= +class type analyzed_views= object('self) val mutable act_id : GtkSignal.id option val mutable deact_id : GtkSignal.id option @@ -142,7 +142,7 @@ let notebook_page_of_session {script=script;tab_label=bname;proof_view=proof;mes then img#set_stock `SAVE else img#set_stock `YES) in let _ = - session_paned#misc#connect#size_allocate + session_paned#misc#connect#size_allocate (let old_paned_width = ref 2 in let old_paned_height = ref 2 in (fun {Gtk.width=paned_width;Gtk.height=paned_height} -> @@ -180,12 +180,12 @@ let cb = GData.clipboard Gdk.Atom.primary exception Size of int let update_on_end_of_segment cmd_stk id = - let lookup_section = function + let lookup_section = function | { reset_info = _,_,r } -> r := false in try Stack.iter lookup_section cmd_stk with Exit -> () -let push_phrase cmd_stk reset_info start_of_phrase_mark end_of_phrase_mark ast = +let push_phrase cmd_stk reset_info start_of_phrase_mark end_of_phrase_mark ast = let x = {start = start_of_phrase_mark; stop = end_of_phrase_mark; ast = ast; @@ -193,7 +193,7 @@ let push_phrase cmd_stk reset_info start_of_phrase_mark end_of_phrase_mark ast = } in begin match snd ast with - | VernacEndSegment (_,id) -> + | VernacEndSegment (_,id) -> prerr_endline "Updating on end of segment 1"; update_on_end_of_segment cmd_stk id | _ -> () @@ -240,7 +240,7 @@ let pop_command cmd_stk undos t = let undos = update_proofs undos undo_info in add_backtrack undos (BacktrackToMark state_info) else - begin + begin prerr_endline "In section"; (* An object inside a closed section *) add_backtrack undos BacktrackToNextActiveMark @@ -295,7 +295,7 @@ let rec apply_undos cmd_stk (n,a,b,p,l as undos) = end - + let last_cb_content = ref "" @@ -308,9 +308,9 @@ let update_notebook_pos () = | true , true -> `RIGHT in session_notebook#set_tab_pos pos - - -let set_active_view i = + + +let set_active_view i = prerr_endline "entering set_active_view"; (try on_active_view (fun {tab_label=lbl} -> lbl#set_text lbl#text) with _ -> ()); session_notebook#goto_page i; @@ -323,25 +323,25 @@ let set_active_view i = let to_do_on_page_switch = ref [] - -let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup; - Sys.sigill; Sys.sigpipe; Sys.sigquit; + +let signals_to_crash = [Sys.sigabrt; Sys.sigalrm; Sys.sigfpe; Sys.sighup; + Sys.sigill; Sys.sigpipe; Sys.sigquit; (* Sys.sigsegv; Sys.sigterm;*) Sys.sigusr2] let crash_save i = (* ignore (Unix.sigprocmask Unix.SIG_BLOCK signals_to_crash);*) Pervasives.prerr_endline "Trying to save all buffers in .crashcoqide files"; - let count = ref 0 in - List.iter - (function {script=view; analyzed_view = av } -> - (let filename = match av#filename with - | None -> - incr count; + let count = ref 0 in + List.iter + (function {script=view; analyzed_view = av } -> + (let filename = match av#filename with + | None -> + incr count; "Unnamed_coqscript_"^(string_of_int !count)^".crashcoqide" | Some f -> f^".crashcoqide" in - try + try if try_export filename (view#buffer#get_text ()) then Pervasives.prerr_endline ("Saved "^filename) else Pervasives.prerr_endline ("Could not save "^filename) @@ -365,9 +365,9 @@ let coq_computing = Mutex.create () (* To prevent Coq from interrupting during undoing...*) let coq_may_stop = Mutex.create () -let break () = +let break () = prerr_endline "User break received:"; - if not (Mutex.try_lock coq_computing) then + if not (Mutex.try_lock coq_computing) then begin prerr_endline " trying to stop computation:"; if Mutex.try_lock coq_may_stop then begin @@ -381,7 +381,7 @@ let break () = prerr_endline " ignored (not computing)" end -let do_if_not_computing text f x = +let do_if_not_computing text f x = if Mutex.try_lock coq_computing then let threaded_task () = prerr_endline "Getting lock"; @@ -400,12 +400,12 @@ let do_if_not_computing text f x = then (Mutex.unlock coq_computing; false) else (pbar#pulse (); true))); ignore (Thread.create threaded_task ()) - else - prerr_endline - "Discarded order (computations are ongoing)" + else + prerr_endline + "Discarded order (computations are ongoing)" (* XXX - 1 appel *) -let kill_input_view i = +let kill_input_view i = let v = session_notebook#get_nth_term i in v.analyzed_view#kill_detached_views (); v.script#destroy (); @@ -418,7 +418,7 @@ let kill_input_view i = let get_current_view = focused_session *) -let remove_current_view_page () = +let remove_current_view_page () = let c = session_notebook#current_page in kill_input_view c @@ -426,53 +426,53 @@ let remove_current_view_page () = (* Reset this to None on page change ! *) let (last_completion:(string*int*int*bool) option ref) = ref None -let () = to_do_on_page_switch := +let () = to_do_on_page_switch := (fun i -> last_completion := None)::!to_do_on_page_switch let rec complete input_buffer w (offset:int) = - match !last_completion with + match !last_completion with | Some (lw,loffset,lpos,backward) when lw=w && loffset=offset -> begin let iter = input_buffer#get_iter (`OFFSET lpos) in - if backward then + if backward then match complete_backward w iter with - | None -> - last_completion := + | None -> + last_completion := Some (lw,loffset, - (find_word_end + (find_word_end (input_buffer#get_iter (`OFFSET loffset)))#offset , - false); + false); None - | Some (ss,start,stop) as result -> - last_completion := + | Some (ss,start,stop) as result -> + last_completion := Some (w,offset,ss#offset,true); result else match complete_forward w iter with - | None -> + | None -> last_completion := None; None - | Some (ss,start,stop) as result -> - last_completion := + | Some (ss,start,stop) as result -> + last_completion := Some (w,offset,ss#offset,false); result end | _ -> begin match complete_backward w (input_buffer#get_iter (`OFFSET offset)) with - | None -> - last_completion := + | None -> + last_completion := Some (w,offset,(find_word_end (input_buffer#get_iter (`OFFSET offset)))#offset,false); complete input_buffer w offset - | Some (ss,start,stop) as result -> + | Some (ss,start,stop) as result -> last_completion := Some (w,offset,ss#offset,true); result end - + let get_current_word () = match session_notebook#current_term,cb#text with - | {script=script; analyzed_view=av;},None -> + | {script=script; analyzed_view=av;},None -> prerr_endline "None selected"; let it = av#get_insert in let start = find_word_start it in @@ -484,7 +484,7 @@ let get_current_word () = prerr_endline "Some selected"; prerr_endline t; t - + let input_channel b ic = let buf = String.create 1024 and len = ref 0 in @@ -506,7 +506,7 @@ exception Found exception Stop of int (* XXX *) -let activate_input i = +let activate_input i = prerr_endline "entering activate_input"; (try on_active_view (fun {analyzed_view=a_v} -> a_v#reset_initial; a_v#deactivate ()) with _ -> ()); @@ -514,7 +514,7 @@ let activate_input i = set_active_view i; prerr_endline "exiting activate_input" -let warning msg = +let warning msg = GToolbox.message_box ~title:"Warning" ~icon:(let img = GMisc.image () in img#set_stock `DIALOG_WARNING; @@ -534,7 +534,7 @@ object(self) val cmd_stack = _cs val mutable is_active = false val mutable read_only = false - val mutable filename = None + val mutable filename = None val mutable stats = None val mutable last_modification_time = 0. val mutable last_auto_save_time = 0. @@ -543,7 +543,7 @@ object(self) val mutable auto_complete_on = !current.auto_complete val hidden_proofs = Hashtbl.create 32 - method private toggle_auto_complete = + method private toggle_auto_complete = auto_complete_on <- not auto_complete_on method set_auto_complete t = auto_complete_on <- t method without_auto_complete : 'a 'b. ('a -> 'b) -> 'a -> 'b = fun f x -> @@ -552,30 +552,30 @@ object(self) let y = f x in self#set_auto_complete old; y - method add_detached_view (w:GWindow.window) = + method add_detached_view (w:GWindow.window) = detached_views <- w::detached_views - method remove_detached_view (w:GWindow.window) = + method remove_detached_view (w:GWindow.window) = detached_views <- List.filter (fun e -> w#misc#get_oid<>e#misc#get_oid) detached_views - method kill_detached_views () = + method kill_detached_views () = List.iter (fun w -> w#destroy ()) detached_views; detached_views <- [] method filename = filename method stats = stats - method set_filename f = + method set_filename f = filename <- f; - match f with + match f with | Some f -> stats <- my_stat f | None -> () - method update_stats = - match filename with - | Some f -> stats <- my_stat f + method update_stats = + match filename with + | Some f -> stats <- my_stat f | _ -> () - method revert = - match filename with + method revert = + match filename with | Some f -> begin let do_revert () = begin push_info "Reverting buffer"; @@ -591,17 +591,17 @@ object(self) pop_info (); flash_info "Buffer reverted"; Highlight.highlight_all input_buffer; - with _ -> + with _ -> pop_info (); flash_info "Warning: could not revert buffer"; end in - if input_buffer#modified then - match (GToolbox.question_box + if input_buffer#modified then + match (GToolbox.question_box ~title:"Modified buffer changed on disk" ~buttons:["Revert from File"; "Overwrite File"; - "Disable Auto Revert"] + "Disable Auto Revert"] ~default:0 ~icon:(stock_to_widget `DIALOG_WARNING) "Some unsaved buffers changed on disk" @@ -609,62 +609,62 @@ object(self) with 1 -> do_revert () | 2 -> if self#save f then flash_info "Overwritten" else flash_info "Could not overwrite file" - | _ -> + | _ -> prerr_endline "Auto revert set to false"; !current.global_auto_revert <- false; disconnect_revert_timer () - else do_revert () + else do_revert () end | None -> () - method save f = + method save f = if try_export f (input_buffer#get_text ()) then begin filename <- Some f; input_buffer#set_modified false; stats <- my_stat f; - (match self#auto_save_name with + (match self#auto_save_name with | None -> () | Some fn -> try Sys.remove fn with _ -> ()); true end else false - method private auto_save_name = - match filename with + method private auto_save_name = + match filename with | None -> None - | Some f -> + | Some f -> let dir = Filename.dirname f in - let base = (fst !current.auto_save_name) ^ - (Filename.basename f) ^ - (snd !current.auto_save_name) + let base = (fst !current.auto_save_name) ^ + (Filename.basename f) ^ + (snd !current.auto_save_name) in Some (Filename.concat dir base) - method private need_auto_save = + method private need_auto_save = input_buffer#modified && last_modification_time > last_auto_save_time method auto_save = if self#need_auto_save then begin - match self#auto_save_name with - | None -> () - | Some fn -> - try + match self#auto_save_name with + | None -> () + | Some fn -> + try last_auto_save_time <- Unix.time(); prerr_endline ("Autosave time : "^(string_of_float (Unix.time()))); if try_export fn (input_buffer#get_text ()) then begin flash_info ~delay:1000 "Autosaved" end - else warning + else warning ("Autosave failed (check if " ^ fn ^ " is writable)") - with _ -> + with _ -> warning ("Autosave: unexpected error while writing "^fn) - end + end method save_as f = - if Sys.file_exists f then + if Sys.file_exists f then match (GToolbox.question_box ~title:"File exists on disk" ~buttons:["Overwrite"; - "Cancel";] + "Cancel";] ~default:1 ~icon: (let img = GMisc.image () in @@ -691,30 +691,30 @@ object(self) method clear_message = message_buffer#set_text "" val mutable last_index = true val last_array = [|"";""|] - method get_start_of_input = input_buffer#get_iter_at_mark (`NAME "start_of_input") + method get_start_of_input = input_buffer#get_iter_at_mark (`NAME "start_of_input") method get_insert = get_insert input_buffer - method recenter_insert = - (* BUG : to investigate further: + method recenter_insert = + (* BUG : to investigate further: FIXED : Never call GMain.* in thread ! PLUS : GTK BUG ??? Cannot be called from a thread... ADDITION: using sync instead of async causes deadlock...*) ignore (GtkThread.async ( - input_view#scroll_to_mark + input_view#scroll_to_mark ~use_align:false ~yalign:0.75 ~within_margin:0.25) `INSERT) - method indent_current_line = + method indent_current_line = let get_nb_space it = let it = it#copy in let nb_sep = ref 0 in let continue = ref true in - while !continue do - if it#char = space then begin + while !continue do + if it#char = space then begin incr nb_sep; if not it#nocopy#forward_char then continue := false; end else continue := false @@ -726,64 +726,64 @@ object(self) let previous_line_spaces = get_nb_space previous_line in let current_line_start = self#get_insert#set_line_offset 0 in let current_line_spaces = get_nb_space current_line_start in - if input_buffer#delete_interactive - ~start:current_line_start + if input_buffer#delete_interactive + ~start:current_line_start ~stop:(current_line_start#forward_chars current_line_spaces) () - then + then let current_line_start = self#get_insert#set_line_offset 0 in - input_buffer#insert + input_buffer#insert ~iter:current_line_start (String.make previous_line_spaces ' ') end - method show_pm_goal = - proof_buffer#insert + method show_pm_goal = + proof_buffer#insert (Printf.sprintf " *** Declarative Mode ***\n"); - try + try let (hyps,concl) = get_current_pm_goal () in List.iter - (fun ((_,_,_,(s,_)) as _hyp) -> + (fun ((_,_,_,(s,_)) as _hyp) -> proof_buffer#insert (s^"\n")) hyps; - proof_buffer#insert + proof_buffer#insert (String.make 38 '_' ^ "\n"); - let (_,_,_,s) = concl in + let (_,_,_,s) = concl in proof_buffer#insert ("thesis := \n "^s^"\n"); let my_mark = `NAME "end_of_conclusion" in proof_buffer#move_mark - ~where:((proof_buffer#get_iter_at_mark `INSERT)) + ~where:((proof_buffer#get_iter_at_mark `INSERT)) my_mark; - ignore (proof_view#scroll_to_mark my_mark) - with Not_found -> + ignore (proof_view#scroll_to_mark my_mark) + with Not_found -> match Decl_mode.get_end_command (Pfedit.get_pftreestate ()) with Some endc -> - proof_buffer#insert - ("Subproof completed, now type "^endc^".") + proof_buffer#insert + ("Subproof completed, now type "^endc^".") | None -> proof_buffer#insert "Proof completed." - method show_goals = + method show_goals = try proof_buffer#set_text ""; match Decl_mode.get_current_mode () with Decl_mode.Mode_none -> () - | Decl_mode.Mode_tactic -> + | Decl_mode.Mode_tactic -> begin let s = Coq.get_current_goals () in - match s with + match s with | [] -> proof_buffer#insert (Coq.print_no_goal ()) - | (hyps,concl)::r -> + | (hyps,concl)::r -> let goal_nb = List.length s in - proof_buffer#insert - (Printf.sprintf "%d subgoal%s\n" + proof_buffer#insert + (Printf.sprintf "%d subgoal%s\n" goal_nb (if goal_nb<=1 then "" else "s")); List.iter - (fun ((_,_,_,(s,_)) as _hyp) -> + (fun ((_,_,_,(s,_)) as _hyp) -> proof_buffer#insert (s^"\n")) hyps; - proof_buffer#insert + proof_buffer#insert (String.make 38 '_' ^ "(1/"^ (string_of_int goal_nb)^ ")\n") ; @@ -792,14 +792,14 @@ object(self) proof_buffer#insert "\n"; let my_mark = `NAME "end_of_conclusion" in proof_buffer#move_mark - ~where:((proof_buffer#get_iter_at_mark `INSERT)) + ~where:((proof_buffer#get_iter_at_mark `INSERT)) my_mark; proof_buffer#insert "\n\n"; let i = ref 1 in - List.iter - (function (_,(_,_,_,concl)) -> + List.iter + (function (_,(_,_,_,concl)) -> incr i; - proof_buffer#insert + proof_buffer#insert (String.make 38 '_' ^"("^ (string_of_int !i)^ "/"^ @@ -809,82 +809,82 @@ object(self) proof_buffer#insert "\n\n"; ) r; - ignore (proof_view#scroll_to_mark my_mark) + ignore (proof_view#scroll_to_mark my_mark) end - | Decl_mode.Mode_proof -> + | Decl_mode.Mode_proof -> self#show_pm_goal - with e -> + with e -> prerr_endline ("Don't worry be happy despite: "^Printexc.to_string e) val mutable full_goal_done = true - method show_goals_full = + method show_goals_full = if not full_goal_done then begin try proof_buffer#set_text ""; match Decl_mode.get_current_mode () with Decl_mode.Mode_none -> () - | Decl_mode.Mode_tactic -> + | Decl_mode.Mode_tactic -> begin - match Coq.get_current_goals () with + match Coq.get_current_goals () with [] -> Util.anomaly "show_goals_full" | ((hyps,concl)::r) as s -> let last_shown_area = Tags.Proof.highlight in let goal_nb = List.length s in - proof_buffer#insert (Printf.sprintf "%d subgoal%s\n" + proof_buffer#insert (Printf.sprintf "%d subgoal%s\n" goal_nb (if goal_nb<=1 then "" else "s")); - let coq_menu commands = + let coq_menu commands = let tag = proof_buffer#create_tag [] - in + in ignore (tag#connect#event ~callback: (fun ~origin ev it -> - match GdkEvent.get_type ev with - | `BUTTON_PRESS -> + match GdkEvent.get_type ev with + | `BUTTON_PRESS -> let ev = (GdkEvent.Button.cast ev) in if (GdkEvent.Button.button ev) = 3 then ( let loc_menu = GMenu.menu () in - let factory = + let factory = new GMenu.factory loc_menu in - let add_coq_command (cp,ip) = - ignore - (factory#add_item cp + let add_coq_command (cp,ip) = + ignore + (factory#add_item cp ~callback: (fun () -> ignore - (self#insert_this_phrase_on_success + (self#insert_this_phrase_on_success true - true - false - ("progress "^ip^"\n") + true + false + ("progress "^ip^"\n") (ip^"\n")) ) ) in List.iter add_coq_command commands; - loc_menu#popup + loc_menu#popup ~button:3 ~time:(GdkEvent.Button.time ev); true) else false - | `MOTION_NOTIFY -> + | `MOTION_NOTIFY -> proof_buffer#remove_tag ~start:proof_buffer#start_iter ~stop:proof_buffer#end_iter last_shown_area; prerr_endline "Before find_tag_limits"; - let s,e = find_tag_limits tag - (new GText.iter it) + let s,e = find_tag_limits tag + (new GText.iter it) in prerr_endline "After find_tag_limits"; - proof_buffer#apply_tag - ~start:s - ~stop:e + proof_buffer#apply_tag + ~start:s + ~stop:e last_shown_area; prerr_endline "Applied tag"; @@ -896,14 +896,14 @@ object(self) tag in List.iter - (fun ((_,_,_,(s,_)) as hyp) -> + (fun ((_,_,_,(s,_)) as hyp) -> let tag = coq_menu (hyp_menu hyp) in proof_buffer#insert ~tags:[tag] (s^"\n")) hyps; - proof_buffer#insert + proof_buffer#insert (String.make 38 '_' ^"(1/"^ (string_of_int goal_nb)^ - ")\n") + ")\n") ; let tag = coq_menu (concl_menu concl) in let _,_,_,sconcl = concl in @@ -914,10 +914,10 @@ object(self) ~where:((proof_buffer#get_iter_at_mark `INSERT)) my_mark; proof_buffer#insert "\n\n"; let i = ref 1 in - List.iter - (function (_,(_,_,_,concl)) -> + List.iter + (function (_,(_,_,_,concl)) -> incr i; - proof_buffer#insert + proof_buffer#insert (String.make 38 '_' ^"("^ (string_of_int !i)^ "/"^ @@ -943,33 +943,33 @@ object(self) assert (Glib.Utf8.validate s); self#insert_message s; message_view#misc#draw None; - if localize then - (match Option.map Util.unloc loc with + if localize then + (match Option.map Util.unloc loc with | None -> () | Some (start,stop) -> let convert_pos = byte_offset_to_char_offset phrase in let start = convert_pos start in let stop = convert_pos stop in - let i = self#get_start_of_input in + let i = self#get_start_of_input in let starti = i#forward_chars start in let stopi = i#forward_chars stop in input_buffer#apply_tag Tags.Script.error ~start:starti ~stop:stopi; input_buffer#place_cursor starti) in - try + try full_goal_done <- false; prerr_endline "Send_to_coq starting now"; Decl_mode.clear_daimon_flag (); if replace then begin let r,info = Coq.interp_and_replace ("info " ^ phrase) in - let is_complete = not (Decl_mode.get_daimon_flag ()) in + let is_complete = not (Decl_mode.get_daimon_flag ()) in let msg = read_stdout () in sync display_output msg; - Some (is_complete,r) + Some (is_complete,r) end else begin let r = Coq.interp verbosely phrase in - let is_complete = not (Decl_mode.get_daimon_flag ()) in + let is_complete = not (Decl_mode.get_daimon_flag ()) in let msg = read_stdout () in sync display_output msg; Some (is_complete,r) @@ -978,29 +978,29 @@ object(self) if show_error then sync display_error e; None - method find_phrase_starting_at (start:GText.iter) = + method find_phrase_starting_at (start:GText.iter) = try let end_iter = find_next_sentence start in Some (start,end_iter) with | Not_found -> None - method complete_at_offset (offset:int) = + method complete_at_offset (offset:int) = prerr_endline ("Completion at offset : " ^ string_of_int offset); let it () = input_buffer#get_iter (`OFFSET offset) in let iit = it () in let start = find_word_start iit in - if ends_word iit then - let w = input_buffer#get_text + if ends_word iit then + let w = input_buffer#get_text ~start ~stop:iit () in if String.length w <> 0 then begin prerr_endline ("Completion of prefix : '" ^ w^"'"); - match complete input_buffer w start#offset with + match complete input_buffer w start#offset with | None -> false - | Some (ss,start,stop) -> + | Some (ss,start,stop) -> let completion = input_buffer#get_text ~start ~stop () in ignore (input_buffer#delete_selection ()); ignore (input_buffer#insert_interactive completion); @@ -1009,7 +1009,7 @@ object(self) end else false else false - method process_next_phrase verbosely display_goals do_highlight = + method process_next_phrase verbosely display_goals do_highlight = let get_next_phrase () = self#clear_message; prerr_endline "process_next_phrase starting now"; @@ -1017,7 +1017,7 @@ object(self) push_info "Coq is computing"; input_view#set_editable false; end; - match self#find_phrase_starting_at self#get_start_of_input with + match self#find_phrase_starting_at self#get_start_of_input with | None -> if do_highlight then begin input_view#set_editable true; @@ -1041,9 +1041,9 @@ object(self) let mark_processed reset_info is_complete (start,stop) ast = let b = input_buffer in b#move_mark ~where:stop (`NAME "start_of_input"); - b#apply_tag + b#apply_tag (if is_complete then Tags.Script.processed else Tags.Script.unjustified) ~start ~stop; - if (self#get_insert#compare) stop <= 0 then + if (self#get_insert#compare) stop <= 0 then begin b#place_cursor stop; self#recenter_insert @@ -1052,8 +1052,8 @@ object(self) let end_of_phrase_mark = `MARK (b#create_mark stop) in push_phrase cmd_stack - reset_info - start_of_phrase_mark + reset_info + start_of_phrase_mark end_of_phrase_mark ast; if display_goals then self#show_goals; remove_tag (start,stop) in @@ -1062,42 +1062,42 @@ object(self) None -> false | Some (loc,phrase) -> (match self#send_to_coq verbosely false phrase true true true with - | Some (is_complete,(reset_info,ast)) -> + | Some (is_complete,(reset_info,ast)) -> sync (mark_processed reset_info is_complete) loc ast; true | None -> sync remove_tag loc; false) end - method insert_this_phrase_on_success - show_output show_msg localize coqphrase insertphrase = + method insert_this_phrase_on_success + show_output show_msg localize coqphrase insertphrase = let mark_processed reset_info is_complete ast = let stop = self#get_start_of_input in if stop#starts_line then input_buffer#insert ~iter:stop insertphrase - else input_buffer#insert ~iter:stop ("\n"^insertphrase); + else input_buffer#insert ~iter:stop ("\n"^insertphrase); let start = self#get_start_of_input in input_buffer#move_mark ~where:stop (`NAME "start_of_input"); - input_buffer#apply_tag + input_buffer#apply_tag (if is_complete then Tags.Script.processed else Tags.Script.unjustified) ~start ~stop; - if (self#get_insert#compare) stop <= 0 then + if (self#get_insert#compare) stop <= 0 then input_buffer#place_cursor stop; let start_of_phrase_mark = `MARK (input_buffer#create_mark start) in let end_of_phrase_mark = `MARK (input_buffer#create_mark stop) in push_phrase cmd_stack reset_info start_of_phrase_mark end_of_phrase_mark ast; self#show_goals; - (*Auto insert save on success... - try (match Coq.get_current_goals () with - | [] -> + (*Auto insert save on success... + try (match Coq.get_current_goals () with + | [] -> (match self#send_to_coq "Save.\n" true true true with - | Some ast -> + | Some ast -> begin let stop = self#get_start_of_input in if stop#starts_line then input_buffer#insert ~iter:stop "Save.\n" - else input_buffer#insert ~iter:stop "\nSave.\n"; + else input_buffer#insert ~iter:stop "\nSave.\n"; let start = self#get_start_of_input in input_buffer#move_mark ~where:stop (`NAME"start_of_input"); input_buffer#apply_tag_by_name "processed" ~start ~stop; - if (self#get_insert#compare) stop <= 0 then + if (self#get_insert#compare) stop <= 0 then input_buffer#place_cursor stop; let start_of_phrase_mark = `MARK (input_buffer#create_mark start) in @@ -1134,12 +1134,12 @@ object(self) else begin self#get_start_of_input end - in - (try - while ((stop#compare (get_current())>=0) + in + (try + while ((stop#compare (get_current())>=0) && (self#process_next_phrase false false false)) do Util.check_for_interrupt () done - with Sys.Break -> + with Sys.Break -> prerr_endline "Interrupted during process_until_iter_or_error"); sync (fun _ -> self#show_goals; @@ -1150,13 +1150,13 @@ object(self) input_view#set_editable true) (); pop_info() - method process_until_end_or_error = + method process_until_end_or_error = self#process_until_iter_or_error input_buffer#end_iter method reset_initial = sync (fun _ -> - Stack.iter - (function inf -> + Stack.iter + (function inf -> let start = input_buffer#get_iter_at_mark inf.start in let stop = input_buffer#get_iter_at_mark inf.stop in input_buffer#move_mark ~where:start (`NAME "start_of_input"); @@ -1164,7 +1164,7 @@ object(self) input_buffer#remove_tag Tags.Script.unjustified ~start ~stop; input_buffer#delete_mark inf.start; input_buffer#delete_mark inf.stop; - ) + ) cmd_stack; Stack.clear cmd_stack; self#clear_message)(); @@ -1175,10 +1175,10 @@ object(self) prerr_endline "Backtracking_to iter starts now."; (* pop Coq commands until we reach iterator [i] *) let rec pop_commands done_smthg undos = - if Stack.is_empty cmd_stack then + if Stack.is_empty cmd_stack then done_smthg, undos else - let t = Stack.top cmd_stack in + let t = Stack.top cmd_stack in if i#compare (input_buffer#get_iter_at_mark t.stop) < 0 then begin prerr_endline "Popped top command"; @@ -1191,21 +1191,21 @@ object(self) let done_smthg, undos = pop_commands false undos in prerr_endline "Popped commands"; if done_smthg then - begin - try + begin + try apply_undos cmd_stack undos; sync (fun _ -> let start = - if Stack.is_empty cmd_stack then input_buffer#start_iter + if Stack.is_empty cmd_stack then input_buffer#start_iter else input_buffer#get_iter_at_mark (Stack.top cmd_stack).stop in prerr_endline "Removing (long) processed tag..."; - input_buffer#remove_tag + input_buffer#remove_tag Tags.Script.processed - ~start + ~start ~stop:self#get_start_of_input; - input_buffer#remove_tag + input_buffer#remove_tag Tags.Script.unjustified - ~start + ~start ~stop:self#get_start_of_input; prerr_endline "Moving (long) start_of_input..."; input_buffer#move_mark ~where:start (`NAME "start_of_input"); @@ -1213,14 +1213,14 @@ object(self) clear_stdout (); self#clear_message) (); - with _ -> + with _ -> push_info "WARNING: undo failed badly -> Coq might be in an inconsistent state. Please restart and report NOW."; end else prerr_endline "backtrack_to : discarded (...)" - method backtrack_to i = - if Mutex.try_lock coq_may_stop then + method backtrack_to i = + if Mutex.try_lock coq_may_stop then (push_info "Undoing..."; self#backtrack_to_no_lock i; Mutex.unlock coq_may_stop; pop_info ()) @@ -1233,7 +1233,7 @@ object(self) else self#backtrack_to point method undo_last_step = - if Mutex.try_lock coq_may_stop then + if Mutex.try_lock coq_may_stop then (push_info "Undoing last step..."; (try let last_command = Stack.top cmd_stack in @@ -1268,19 +1268,19 @@ object(self) else prerr_endline "undo_last_step discarded" - method insert_command cp ip = + method insert_command cp ip = async(fun _ -> self#clear_message)(); ignore (self#insert_this_phrase_on_success true false false cp ip) method tactic_wizard l = async(fun _ -> self#clear_message)(); - ignore - (List.exists - (fun p -> - self#insert_this_phrase_on_success true false false + ignore + (List.exists + (fun p -> + self#insert_this_phrase_on_success true false false ("progress "^p^".\n") (p^".\n")) l) - method active_keypress_handler k = + method active_keypress_handler k = let state = GdkEvent.Key.state k in begin match state with @@ -1295,12 +1295,12 @@ object(self) self#process_until_iter_or_error i end); true - | l when List.mem `CONTROL l -> + | l when List.mem `CONTROL l -> let k = GdkEvent.Key.keyval k in if GdkKeysyms._Break=k then break (); false - | l -> + | l -> if GdkEvent.Key.keyval k = GdkKeysyms._Tab then begin prerr_endline "active_kp_handler for Tab"; self#indent_current_line; @@ -1309,9 +1309,9 @@ object(self) end - method disconnected_keypress_handler k = + method disconnected_keypress_handler k = match GdkEvent.Key.state k with - | l when List.mem `CONTROL l -> + | l when List.mem `CONTROL l -> let k = GdkEvent.Key.keyval k in if GdkKeysyms._c=k then break (); @@ -1322,16 +1322,16 @@ object(self) val mutable deact_id = None val mutable act_id = None - method deactivate () = + method deactivate () = is_active <- false; - (match act_id with None -> () + (match act_id with None -> () | Some id -> reset_initial (); input_view#misc#disconnect id; prerr_endline "DISCONNECTED old active : "; print_id id; )(*; - deact_id <- Some + deact_id <- Some (input_view#event#connect#key_press self#disconnected_keypress_handler); prerr_endline "CONNECTED inactive : "; print_id (Option.get deact_id)*) @@ -1339,17 +1339,17 @@ object(self) (* XXX *) method activate () = is_active <- true;(* - (match deact_id with None -> () + (match deact_id with None -> () | Some id -> input_view#misc#disconnect id; prerr_endline "DISCONNECTED old inactive : "; print_id id );*) - act_id <- Some + act_id <- Some (input_view#event#connect#key_press self#active_keypress_handler); prerr_endline "CONNECTED active : "; print_id (Option.get act_id); - match - filename + match + filename with | None -> () | Some f -> let dir = Filename.dirname f in @@ -1359,9 +1359,9 @@ object(self) (Printf.sprintf "Add LoadPath \"%s\". " dir)) end - method electric_handler = + method electric_handler = input_buffer#connect#insert_text ~callback: - (fun it x -> + (fun it x -> begin try if last_index then begin last_array.(0)<-x; @@ -1370,7 +1370,7 @@ object(self) last_array.(1)<-x; if (last_array.(0) ^ last_array.(1) = ".\n") then raise Found end - with Found -> + with Found -> begin ignore (self#process_next_phrase false true true) end; @@ -1387,16 +1387,16 @@ object(self) ~stop:input_buffer#end_iter tag; if x = "" then () else - match x.[String.length x - 1] with - | ')' -> + match x.[String.length x - 1] with + | ')' -> let hit = self#get_insert in let count = ref 0 in - if hit#nocopy#backward_find_char - (fun c -> - if c = oparen_code && !count = 0 then true - else if c = cparen_code then + if hit#nocopy#backward_find_char + (fun c -> + if c = oparen_code && !count = 0 then true + else if c = cparen_code then (incr count;false) - else if c = oparen_code then + else if c = oparen_code then (decr count;false) else false ) @@ -1409,7 +1409,7 @@ object(self) | _ -> ()) ) - method help_for_keyword () = + method help_for_keyword () = browse_keyword (self#insert_message) (get_current_word ()) @@ -1449,9 +1449,9 @@ object(self) input_buffer#remove_tag Tags.Script.hidden ~start:stmt_end ~stop:proof_end; input_buffer#remove_tag Tags.Script.locked ~start:stmt_start ~stop:stmt_end - initializer + initializer ignore (message_buffer#connect#insert_text - ~callback:(fun it s -> ignore + ~callback:(fun it s -> ignore (message_view#scroll_to_mark ~use_align:false ~within_margin:0.49 @@ -1460,18 +1460,18 @@ object(self) ~callback:(fun it s -> if (it#compare self#get_start_of_input)<0 then GtkSignal.stop_emit (); - if String.length s > 1 then + if String.length s > 1 then (prerr_endline "insert_text: Placing cursor";input_buffer#place_cursor it))); ignore (input_buffer#connect#after#apply_tag ~callback:(fun tag ~start ~stop -> if (start#compare self#get_start_of_input)>=0 - then + then begin - input_buffer#remove_tag + input_buffer#remove_tag Tags.Script.processed ~start ~stop; - input_buffer#remove_tag + input_buffer#remove_tag Tags.Script.unjustified ~start ~stop @@ -1480,27 +1480,27 @@ object(self) ); ignore (input_buffer#connect#after#insert_text ~callback:(fun it s -> - if auto_complete_on && - String.length s = 1 && s <> " " && s <> "\n" - then - let v = session_notebook#current_term.analyzed_view - in - let has_completed = - v#complete_at_offset + if auto_complete_on && + String.length s = 1 && s <> " " && s <> "\n" + then + let v = session_notebook#current_term.analyzed_view + in + let has_completed = + v#complete_at_offset ((input_view#buffer#get_iter `SEL_BOUND)#offset) in - if has_completed then + if has_completed then input_buffer#move_mark `SEL_BOUND (input_buffer#get_iter `SEL_BOUND)#forward_char; ) ); ignore (input_buffer#connect#changed - ~callback:(fun () -> + ~callback:(fun () -> last_modification_time <- Unix.time (); let r = input_view#visible_rect in - let stop = - input_view#get_iter_at_location + let stop = + input_view#get_iter_at_location ~x:(Gdk.Rectangle.x r + Gdk.Rectangle.width r) ~y:(Gdk.Rectangle.y r + Gdk.Rectangle.height r) in @@ -1509,7 +1509,7 @@ object(self) ~start:self#get_start_of_input ~stop; Highlight.highlight_around_current_line - input_buffer + input_buffer ) ); ignore (input_buffer#add_selection_clipboard cb); @@ -1517,24 +1517,24 @@ object(self) ignore (message_buffer#add_selection_clipboard cb); let paren_highlight_tag = input_buffer#create_tag ~name:"paren" [`BACKGROUND "purple"] in self#electric_paren paren_highlight_tag; - ignore (input_buffer#connect#after#mark_set + ignore (input_buffer#connect#after#mark_set ~callback:(fun it (m:Gtk.text_mark) -> - !set_location - (Printf.sprintf + !set_location + (Printf.sprintf "Line: %5d Char: %3d" (self#get_insert#line + 1) (self#get_insert#line_offset + 1)); match GtkText.Mark.get_name m with - | Some "insert" -> + | Some "insert" -> input_buffer#remove_tag ~start:input_buffer#start_iter ~stop:input_buffer#end_iter paren_highlight_tag; - | Some s -> + | Some s -> prerr_endline (s^" moved") | None -> () ) ); ignore (input_buffer#connect#insert_text - (fun it s -> + (fun it s -> prerr_endline "Should recenter ?"; if String.contains s '\n' then begin prerr_endline "Should recenter : yes"; @@ -1555,8 +1555,8 @@ let search_next_error () = and b = int_of_string (Str.matched_group 3 !last_make) and e = int_of_string (Str.matched_group 4 !last_make) and msg_index = Str.match_beginning () - in - last_make_index := Str.group_end 4; + in + last_make_index := Str.group_end 4; (f,l,b,e, String.sub !last_make msg_index (String.length !last_make - msg_index)) @@ -1638,7 +1638,7 @@ let create_session () = proof#misc#set_can_focus true; message#misc#set_can_focus true; script#misc#modify_font !current.text_font; - proof#misc#modify_font !current.text_font; + proof#misc#modify_font !current.text_font; message#misc#modify_font !current.text_font; { tab_label=basename; filename=""; @@ -1687,7 +1687,7 @@ let do_open session filename = let do_save session = - try + try if session.script#buffer#modified then save_session session session.filename [session.encoding] with _ -> () @@ -1771,19 +1771,19 @@ let do_print session = if session.filename = "" then flash_info "Cannot print: this buffer has no name" else begin - let cmd = + let cmd = "cd " ^ Filename.quote (Filename.dirname session.filename) ^ "; " ^ - !current.cmd_coqdoc ^ " -ps " ^ Filename.quote (Filename.basename session.filename) ^ + !current.cmd_coqdoc ^ " -ps " ^ Filename.quote (Filename.basename session.filename) ^ " | " ^ !current.cmd_print in let print_window = GWindow.window ~title:"Print" ~modal:true ~position:`CENTER ~wm_class:"CoqIDE" ~wm_name: "CoqIDE" () in let vbox_print = GPack.vbox ~spacing:10 ~border_width:10 ~packing:print_window#add () in let _ = GMisc.label ~justify:`LEFT ~text:"Print using the following command:" ~packing:vbox_print#add () in - let print_entry = GEdit.entry ~text:cmd ~editable:true ~width_chars:80 ~packing:vbox_print#add () in - let hbox_print = GPack.hbox ~spacing:10 ~packing:vbox_print#add () in + let print_entry = GEdit.entry ~text:cmd ~editable:true ~width_chars:80 ~packing:vbox_print#add () in + let hbox_print = GPack.hbox ~spacing:10 ~packing:vbox_print#add () in let print_cancel_button = GButton.button ~stock:`CANCEL ~label:"Cancel" ~packing:hbox_print#add () in let print_button = GButton.button ~stock:`PRINT ~label:"Print" ~packing:hbox_print#add () in - let callback_print () = + let callback_print () = let cmd = print_entry#text in let s,_ = run_command av#insert_message cmd in flash_info (cmd ^ if s = Unix.WEXITED 0 then " succeeded" else " failed"); @@ -1795,15 +1795,15 @@ let do_print session = end -let main files = +let main files = (* Statup preferences *) load_pref (); (* Main window *) - let w = GWindow.window + let w = GWindow.window ~wm_class:"CoqIde" ~wm_name:"CoqIde" - ~allow_grow:true ~allow_shrink:true - ~width:!current.window_width ~height:!current.window_height + ~allow_grow:true ~allow_shrink:true + ~width:!current.window_width ~height:!current.window_height ~title:"CoqIde" () in (try @@ -1819,15 +1819,15 @@ let main files = let menubar = GMenu.menu_bar ~packing:vbox#pack () in (* Toolbar *) - let toolbar = GButton.toolbar - ~orientation:`HORIZONTAL + let toolbar = GButton.toolbar + ~orientation:`HORIZONTAL ~style:`ICONS - ~tooltips:true + ~tooltips:true ~packing:(* handle#add *) (vbox#pack ~expand:false ~fill:false) () in - show_toolbar := + show_toolbar := (fun b -> if b then toolbar#misc#show () else toolbar#misc#hide ()); let factory = new GMenu.factory ~accel_path:"/" menubar in @@ -1840,14 +1840,14 @@ let main files = (* File/Load Menu *) let load_file handler f = - let f = absolute_filename f in + let f = absolute_filename f in try prerr_endline "Loading file starts"; if not (Util.list_fold_left_i (fun i found x -> if found then found else let {analyzed_view=av} = x in - (match av#filename with - | None -> false + (match av#filename with + | None -> false | Some fn -> if same_file f fn then (session_notebook#goto_page i; true) @@ -1861,7 +1861,7 @@ let main files = prerr_endline "Loading: convert content"; let s = do_convert (Buffer.contents b) in prerr_endline "Loading: create view"; - let session = create_session () in + let session = create_session () in session.tab_label#set_text (Glib.Convert.filename_to_utf8 (Filename.basename f)); prerr_endline "Loading: adding view"; let index = session_notebook#append_term session in @@ -1883,82 +1883,82 @@ let main files = session.script#clear_undo; prerr_endline "Loading: success" end - with + with | e -> handler ("Load failed: "^(Printexc.to_string e)) - in + in let load f = load_file flash_info f in - let load_m = file_factory#add_item "_New" + let load_m = file_factory#add_item "_New" ~key:GdkKeysyms._N in - let load_f () = - match select_file_for_save ~title:"Create file" () with + let load_f () = + match select_file_for_save ~title:"Create file" () with | None -> () | Some f -> load f in ignore (load_m#connect#activate (load_f)); - let load_m = file_factory#add_item "_Open" + let load_m = file_factory#add_item "_Open" ~key:GdkKeysyms._O in - let load_f () = - match select_file_for_open ~title:"Load file" () with + let load_f () = + match select_file_for_open ~title:"Load file" () with | None -> () | Some f -> load f in ignore (load_m#connect#activate (load_f)); (* File/Save Menu *) - let save_m = file_factory#add_item "_Save" + let save_m = file_factory#add_item "_Save" ~key:GdkKeysyms._S in - let save_f () = + let save_f () = let current = session_notebook#current_term in try - (match current.analyzed_view#filename with + (match current.analyzed_view#filename with | None -> begin match select_file_for_save ~title:"Save file" () with | None -> () - | Some f -> + | Some f -> if current.analyzed_view#save_as f then begin current.tab_label#set_text (Filename.basename f); flash_info ("File " ^ f ^ " saved") end else warning ("Save Failed (check if " ^ f ^ " is writable)") end - | Some f -> - if current.analyzed_view#save f then + | Some f -> + if current.analyzed_view#save f then flash_info ("File " ^ f ^ " saved") else warning ("Save Failed (check if " ^ f ^ " is writable)") - + ) - with + with | e -> warning "Save: unexpected error" in ignore (save_m#connect#activate save_f); (* File/Save As Menu *) - let saveas_m = file_factory#add_item "S_ave as" + let saveas_m = file_factory#add_item "S_ave as" in - let saveas_f () = + let saveas_f () = let current = session_notebook#current_term in - try (match current.analyzed_view#filename with - | None -> + try (match current.analyzed_view#filename with + | None -> begin match select_file_for_save ~title:"Save file as" () with | None -> () - | Some f -> + | Some f -> if current.analyzed_view#save_as f then begin current.tab_label#set_text (Filename.basename f); flash_info "Saved" end else flash_info "Save Failed" end - | Some f -> - begin match select_file_for_save - ~dir:(ref (Filename.dirname f)) + | Some f -> + begin match select_file_for_save + ~dir:(ref (Filename.dirname f)) ~filename:(Filename.basename f) ~title:"Save file as" () with | None -> () - | Some f -> + | Some f -> if current.analyzed_view#save_as f then begin current.tab_label#set_text (Filename.basename f); flash_info "Saved" @@ -1970,11 +1970,11 @@ let main files = (* XXX *) (* File/Save All Menu *) let saveall_m = file_factory#add_item "Sa_ve all" in - let saveall_f () = + let saveall_f () = List.iter - (function - | {script = view ; analyzed_view = av} -> - begin match av#filename with + (function + | {script = view ; analyzed_view = av} -> + begin match av#filename with | None -> () | Some f -> ignore (av#save f) @@ -1982,26 +1982,26 @@ let main files = ) session_notebook#pages in (* XXX *) - let has_something_to_save () = + let has_something_to_save () = List.exists - (function - | {script=view} -> view#buffer#modified + (function + | {script=view} -> view#buffer#modified ) session_notebook#pages in ignore (saveall_m#connect#activate saveall_f); - (* XXX *) + (* XXX *) (* File/Revert Menu *) let revert_m = file_factory#add_item "_Revert all buffers" in - let revert_f () = - List.iter - (function - {analyzed_view = av} -> - (try - match av#filename,av#stats with - | Some f,Some stats -> + let revert_f () = + List.iter + (function + {analyzed_view = av} -> + (try + match av#filename,av#stats with + | Some f,Some stats -> let new_stats = Unix.stat f in - if new_stats.Unix.st_mtime > stats.Unix.st_mtime + if new_stats.Unix.st_mtime > stats.Unix.st_mtime then av#revert | Some _, None -> av#revert | _ -> () @@ -2009,18 +2009,18 @@ let main files = ) session_notebook#pages in ignore (revert_m#connect#activate revert_f); - + (* File/Close Menu *) let close_m = file_factory#add_item "_Close buffer" ~key:GdkKeysyms._W in - let close_f () = + let close_f () = let v = !active_view in let act = session_notebook#current_page in if v = act then flash_info "Cannot close an active view" else remove_current_view_page () in ignore (close_m#connect#activate close_f); - + (* File/Print Menu *) let _ = file_factory#add_item "_Print..." ~key:GdkKeysyms._P @@ -2031,62 +2031,62 @@ let main files = let v = session_notebook#current_term in let av = v.analyzed_view in match av#filename with - | None -> + | None -> flash_info "Cannot print: this buffer has no name" | Some f -> let basef = Filename.basename f in - let output = + let output = let basef_we = try Filename.chop_extension basef with _ -> basef in match kind with | "latex" -> basef_we ^ ".tex" | "dvi" | "ps" | "pdf" | "html" -> basef_we ^ "." ^ kind | _ -> assert false in - let cmd = + let cmd = "cd " ^ Filename.quote (Filename.dirname f) ^ "; " ^ !current.cmd_coqdoc ^ " --" ^ kind ^ " -o " ^ (Filename.quote output) ^ " " ^ (Filename.quote basef) in let s,_ = run_command av#insert_message cmd in - flash_info (cmd ^ - if s = Unix.WEXITED 0 - then " succeeded" + flash_info (cmd ^ + if s = Unix.WEXITED 0 + then " succeeded" else " failed") in let file_export_m = file_factory#add_submenu "E_xport to" in let file_export_factory = new GMenu.factory ~accel_path:"/Export/" file_export_m ~accel_group in - let _ = - file_export_factory#add_item "_Html" ~callback:(export_f "html") + let _ = + file_export_factory#add_item "_Html" ~callback:(export_f "html") in - let _ = + let _ = file_export_factory#add_item "_LaTeX" ~callback:(export_f "latex") in - let _ = - file_export_factory#add_item "_Dvi" ~callback:(export_f "dvi") + let _ = + file_export_factory#add_item "_Dvi" ~callback:(export_f "dvi") in - let _ = - file_export_factory#add_item "_Pdf" ~callback:(export_f "pdf") + let _ = + file_export_factory#add_item "_Pdf" ~callback:(export_f "pdf") in - let _ = - file_export_factory#add_item "_Ps" ~callback:(export_f "ps") + let _ = + file_export_factory#add_item "_Ps" ~callback:(export_f "ps") in (* File/Rehighlight Menu *) let rehighlight_m = file_factory#add_item "Reh_ighlight" ~key:GdkKeysyms._L in - ignore (rehighlight_m#connect#activate - (fun () -> - Highlight.highlight_all + ignore (rehighlight_m#connect#activate + (fun () -> + Highlight.highlight_all session_notebook#current_term.script#buffer; session_notebook#current_term.analyzed_view#recenter_insert)); (* File/Quit Menu *) let quit_f () = save_pref(); - if has_something_to_save () then + if has_something_to_save () then match (GToolbox.question_box ~title:"Quit" ~buttons:["Save Named Buffers and Quit"; "Quit without Saving"; - "Don't Quit"] + "Don't Quit"] ~default:0 ~icon: (let img = GMisc.image () in @@ -2100,7 +2100,7 @@ let main files = | _ -> () else exit 0 in - let _ = file_factory#add_item "_Quit" ~key:GdkKeysyms._Q + let _ = file_factory#add_item "_Quit" ~key:GdkKeysyms._Q ~callback:quit_f in ignore (w#event#connect#delete (fun _ -> quit_f (); true)); @@ -2110,14 +2110,14 @@ let main files = let edit_f = new GMenu.factory ~accel_path:"/Edit/" edit_menu ~accel_group in ignore(edit_f#add_item "_Undo" ~key:GdkKeysyms._u ~callback: (do_if_not_computing "undo" - (fun () -> + (fun () -> ignore (session_notebook#current_term.analyzed_view# - without_auto_complete + without_auto_complete (fun () -> session_notebook#current_term.script#undo) ())))); - ignore(edit_f#add_item "_Clear Undo Stack" + ignore(edit_f#add_item "_Clear Undo Stack" (* ~key:GdkKeysyms._exclam *) ~callback: - (fun () -> + (fun () -> ignore session_notebook#current_term.script#clear_undo)); ignore(edit_f#add_separator ()); let get_active_view_for_cp () = @@ -2131,31 +2131,31 @@ let main files = in ignore(edit_f#add_item "Cut" ~key:GdkKeysyms._X ~callback: (fun () -> GtkSignal.emit_unit - (get_active_view_for_cp ()) + (get_active_view_for_cp ()) GtkText.View.S.cut_clipboard - )); + )); ignore(edit_f#add_item "Copy" ~key:GdkKeysyms._C ~callback: (fun () -> GtkSignal.emit_unit - (get_active_view_for_cp ()) + (get_active_view_for_cp ()) GtkText.View.S.copy_clipboard)); ignore(edit_f#add_item "Paste" ~key:GdkKeysyms._V ~callback: - (fun () -> + (fun () -> try GtkSignal.emit_unit - session_notebook#current_term.script#as_view + session_notebook#current_term.script#as_view GtkText.View.S.paste_clipboard with _ -> prerr_endline "EMIT PASTE FAILED")); ignore (edit_f#add_separator ()); (* - let toggle_auto_complete_i = - edit_f#add_check_item "_Auto Completion" + let toggle_auto_complete_i = + edit_f#add_check_item "_Auto Completion" ~active:!current.auto_complete ~callback: in *) (* - auto_complete := + auto_complete := (fun b -> match session_notebook#current_term.analyzed_view with | Some av -> av#set_auto_complete b | None -> ()); @@ -2163,7 +2163,7 @@ let main files = let last_found = ref None in let search_backward = ref false in - let find_w = GWindow.window + let find_w = GWindow.window (* ~wm_class:"CoqIde" ~wm_name:"CoqIde" *) (* ~allow_grow:true ~allow_shrink:true *) (* ~width:!current.window_width ~height:!current.window_height *) @@ -2174,28 +2174,28 @@ let main files = ~columns:3 ~rows:5 ~col_spacings:10 ~row_spacings:10 ~border_width:10 ~homogeneous:false ~packing:find_w#add () in - - let _ = + + let _ = GMisc.label ~text:"Find:" ~xalign:1.0 - ~packing:(find_box#attach ~left:0 ~top:0 ~fill:`X) () + ~packing:(find_box#attach ~left:0 ~top:0 ~fill:`X) () in let find_entry = GEdit.entry ~editable: true ~packing: (find_box#attach ~left:1 ~top:0 ~expand:`X) () in - let _ = + let _ = GMisc.label ~text:"Replace with:" ~xalign:1.0 - ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) () + ~packing:(find_box#attach ~left:0 ~top:1 ~fill:`X) () in let replace_entry = GEdit.entry ~editable: true ~packing: (find_box#attach ~left:1 ~top:1 ~expand:`X) () in - (* let _ = + (* let _ = GButton.check_button ~label:"case sensitive" ~active:true @@ -2205,7 +2205,7 @@ let main files = in *) (* - let find_backwards_check = + let find_backwards_check = GButton.check_button ~label:"search backwards" ~active:false @@ -2247,7 +2247,7 @@ let main files = let v = session_notebook#current_term.script in let b = v#buffer in let start,stop = - match !last_found with + match !last_found with | None -> let i = b#get_iter_at_mark `INSERT in (i,i) | Some(start,stop) -> let start = b#get_iter_at_mark start @@ -2262,7 +2262,7 @@ let main files = let do_replace () = let v = session_notebook#current_term.script in let b = v#buffer in - match !last_found with + match !last_found with | None -> () | Some(start,stop) -> let start = b#get_iter_at_mark start @@ -2290,7 +2290,7 @@ let main files = in let do_find () = let (v,b,starti,_) = last_find () in - find_from v b starti find_entry#text + find_from v b starti find_entry#text in let do_replace_find () = do_replace(); @@ -2302,8 +2302,8 @@ let main files = find_w#misc#hide(); v#coerce#misc#grab_focus() in - to_do_on_page_switch := - (fun i -> if find_w#misc#visible then close_find()):: + to_do_on_page_switch := + (fun i -> if find_w#misc#visible then close_find()):: !to_do_on_page_switch; let find_again_forward () = search_backward := false; @@ -2325,12 +2325,12 @@ let main files = find_w#misc#hide(); v#coerce#misc#grab_focus(); true - end + end else if k = GdkKeysyms._Return then begin close_find(); true - end + end else if List.mem `CONTROL s && k = GdkKeysyms._f then begin find_again_forward (); @@ -2343,7 +2343,7 @@ let main files = end else false (* to let default callback execute *) in - let find_f ~backward () = + let find_f ~backward () = search_backward := backward; find_w#show (); find_w#present (); @@ -2377,30 +2377,30 @@ let main files = let complete_i = edit_f#add_item "_Complete" ~key:GdkKeysyms._comma ~callback: - (do_if_not_computing - (fun b -> - let v = session_notebook#current_term.analyzed_view - - in v#complete_at_offset + (do_if_not_computing + (fun b -> + let v = session_notebook#current_term.analyzed_view + + in v#complete_at_offset ((v#view#buffer#get_iter `SEL_BOUND)#offset) )) in complete_i#misc#set_state `INSENSITIVE; *) - + ignore(edit_f#add_item "Complete Word" ~key:GdkKeysyms._slash ~callback: - (fun () -> + (fun () -> ignore ( - let av = session_notebook#current_term.analyzed_view in + let av = session_notebook#current_term.analyzed_view in av#complete_at_offset (av#get_insert)#offset ))); ignore(edit_f#add_separator ()); (* external editor *) - let _ = + let _ = edit_f#add_item "External editor" ~callback: - (fun () -> - let av = session_notebook#current_term.analyzed_view in + (fun () -> + let av = session_notebook#current_term.analyzed_view in match av#filename with | None -> warning "Call to external editor available only on named files" | Some f -> @@ -2413,33 +2413,33 @@ let main files = (* Preferences *) let reset_revert_timer () = disconnect_revert_timer (); - if !current.global_auto_revert then + if !current.global_auto_revert then revert_timer := Some - (GMain.Timeout.add ~ms:!current.global_auto_revert_delay + (GMain.Timeout.add ~ms:!current.global_auto_revert_delay ~callback: - (fun () -> + (fun () -> do_if_not_computing "revert" (sync revert_f) (); true)) in reset_revert_timer (); (* to enable statup preferences timer *) (* XXX *) - let auto_save_f () = - List.iter - (function - {script = view ; analyzed_view = av} -> - (try + let auto_save_f () = + List.iter + (function + {script = view ; analyzed_view = av} -> + (try av#auto_save with _ -> ()) - ) + ) session_notebook#pages in let reset_auto_save_timer () = disconnect_auto_save_timer (); - if !current.auto_save then + if !current.auto_save then auto_save_timer := Some - (GMain.Timeout.add ~ms:!current.auto_save_delay + (GMain.Timeout.add ~ms:!current.auto_save_delay ~callback: - (fun () -> + (fun () -> do_if_not_computing "autosave" (sync auto_save_f) (); true)) in reset_auto_save_timer (); (* to enable statup preferences timer *) @@ -2457,13 +2457,13 @@ let main files = *) (* Navigation Menu *) let navigation_menu = factory#add_submenu "_Navigation" in - let navigation_factory = - new GMenu.factory navigation_menu + let navigation_factory = + new GMenu.factory navigation_menu ~accel_path:"/Navigation/" - ~accel_group - ~accel_modi:!current.modifier_for_navigation + ~accel_group + ~accel_modi:!current.modifier_for_navigation in - let _do_or_activate f () = + let _do_or_activate f () = let current = session_notebook#current_term in let analyzed_view = current.analyzed_view in if analyzed_view#is_active then begin @@ -2478,7 +2478,7 @@ let main files = end in - let do_or_activate f = + let do_or_activate f = do_if_not_computing "do_or_activate" (_do_or_activate (fun av -> f av; @@ -2488,9 +2488,9 @@ let main files = ) in - let add_to_menu_toolbar text ~tooltip ?key ~callback icon = + let add_to_menu_toolbar text ~tooltip ?key ~callback icon = begin - match key with None -> () + match key with None -> () | Some key -> ignore (navigation_factory#add_item text ~key ~callback) end; ignore (toolbar#insert_button @@ -2500,49 +2500,49 @@ let main files = ~callback ()) in - add_to_menu_toolbar - "_Save" - ~tooltip:"Save current buffer" + add_to_menu_toolbar + "_Save" + ~tooltip:"Save current buffer" ~callback:save_f `SAVE; - add_to_menu_toolbar - "_Close" - ~tooltip:"Close current buffer" + add_to_menu_toolbar + "_Close" + ~tooltip:"Close current buffer" ~callback:close_f `CLOSE; - add_to_menu_toolbar - "_Forward" - ~tooltip:"Forward one command" - ~key:GdkKeysyms._Down + add_to_menu_toolbar + "_Forward" + ~tooltip:"Forward one command" + ~key:GdkKeysyms._Down ~callback:(do_or_activate (fun a -> a#process_next_phrase true true true )) - + `GO_DOWN; add_to_menu_toolbar "_Backward" - ~tooltip:"Backward one command" + ~tooltip:"Backward one command" ~key:GdkKeysyms._Up ~callback:(do_or_activate (fun a -> a#undo_last_step)) `GO_UP; - add_to_menu_toolbar - "_Go to" - ~tooltip:"Go to cursor" + add_to_menu_toolbar + "_Go to" + ~tooltip:"Go to cursor" ~key:GdkKeysyms._Right ~callback:(do_or_activate (fun a-> a#go_to_insert)) `JUMP_TO; - add_to_menu_toolbar - "_Start" - ~tooltip:"Go to start" + add_to_menu_toolbar + "_Start" + ~tooltip:"Go to start" ~key:GdkKeysyms._Home ~callback:(do_or_activate (fun a -> a#reset_initial)) `GOTO_TOP; - add_to_menu_toolbar - "_End" - ~tooltip:"Go to end" + add_to_menu_toolbar + "_End" + ~tooltip:"Go to end" ~key:GdkKeysyms._End ~callback:(do_or_activate (fun a -> a#process_until_end_or_error)) `GOTO_BOTTOM; add_to_menu_toolbar "_Interrupt" - ~tooltip:"Interrupt computations" - ~key:GdkKeysyms._Break + ~tooltip:"Interrupt computations" + ~key:GdkKeysyms._Break ~callback:break `STOP; add_to_menu_toolbar "_Hide" @@ -2555,13 +2555,13 @@ let main files = (* Tactics Menu *) let tactics_menu = factory#add_submenu "_Try Tactics" in - let tactics_factory = - new GMenu.factory tactics_menu + let tactics_factory = + new GMenu.factory tactics_menu ~accel_path:"/Tactics/" - ~accel_group + ~accel_group ~accel_modi:!current.modifier_for_tactics in - let do_if_active_raw f () = + let do_if_active_raw f () = let current = session_notebook#current_term in let analyzed_view = current.analyzed_view in if analyzed_view#is_active then ignore (f analyzed_view) @@ -2569,36 +2569,36 @@ let main files = let do_if_active f = do_if_not_computing "do_if_active" (do_if_active_raw f) in - ignore (tactics_factory#add_item "_auto" + ignore (tactics_factory#add_item "_auto" ~key:GdkKeysyms._a ~callback:(do_if_active (fun a -> a#insert_command "progress auto.\n" "auto.\n")) ); ignore (tactics_factory#add_item "_auto with *" ~key:GdkKeysyms._asterisk - ~callback:(do_if_active (fun a -> a#insert_command + ~callback:(do_if_active (fun a -> a#insert_command "progress auto with *.\n" "auto with *.\n"))); ignore (tactics_factory#add_item "_eauto" ~key:GdkKeysyms._e - ~callback:(do_if_active (fun a -> a#insert_command + ~callback:(do_if_active (fun a -> a#insert_command "progress eauto.\n" "eauto.\n")) ); ignore (tactics_factory#add_item "_eauto with *" ~key:GdkKeysyms._ampersand - ~callback:(do_if_active (fun a -> a#insert_command - "progress eauto with *.\n" + ~callback:(do_if_active (fun a -> a#insert_command + "progress eauto with *.\n" "eauto with *.\n")) ); ignore (tactics_factory#add_item "_intuition" ~key:GdkKeysyms._i - ~callback:(do_if_active (fun a -> a#insert_command - "progress intuition.\n" + ~callback:(do_if_active (fun a -> a#insert_command + "progress intuition.\n" "intuition.\n")) ); ignore (tactics_factory#add_item "_omega" ~key:GdkKeysyms._o - ~callback:(do_if_active (fun a -> a#insert_command + ~callback:(do_if_active (fun a -> a#insert_command "omega.\n" "omega.\n")) ); ignore (tactics_factory#add_item "_simpl" @@ -2628,15 +2628,15 @@ let main files = ignore (tactics_factory#add_item "" ~key:GdkKeysyms._dollar - ~callback:(do_if_active (fun a -> a#tactic_wizard + ~callback:(do_if_active (fun a -> a#tactic_wizard !current.automatic_tactics )) ); - + ignore (tactics_factory#add_separator ()); - let add_simple_template (factory: GMenu.menu GMenu.factory) + let add_simple_template (factory: GMenu.menu GMenu.factory) (menu_text, text) = - let text = + let text = let l = String.length text - 1 in if String.get text l = '.' then text ^"\n" @@ -2647,33 +2647,33 @@ let main files = (fun () -> let {script = view } = session_notebook#current_term in ignore (view#buffer#insert_interactive text))) in - List.iter - (fun l -> - match l with + List.iter + (fun l -> + match l with | [] -> () - | [s] -> add_simple_template tactics_factory ("_"^s, s) - | s::_ -> + | [s] -> add_simple_template tactics_factory ("_"^s, s) + | s::_ -> let a = "_@..." in a.[1] <- s.[0]; - let f = tactics_factory#add_submenu a in + let f = tactics_factory#add_submenu a in let ff = new GMenu.factory f ~accel_group in - List.iter - (fun x -> + List.iter + (fun x -> add_simple_template - ff + ff ((String.sub x 0 1)^ "_"^ (String.sub x 1 (String.length x - 1)), x)) l - ) + ) Coq_commands.tactics; - + (* Templates Menu *) let templates_menu = factory#add_submenu "Te_mplates" in - let templates_factory = new GMenu.factory templates_menu + let templates_factory = new GMenu.factory templates_menu ~accel_path:"/Templates/" - ~accel_group + ~accel_group ~accel_modi:!current.modifier_for_templates in let add_complex_template (menu_text, text, offset, len, key) = @@ -2689,19 +2689,19 @@ let main files = end in ignore (templates_factory#add_item menu_text ~callback ?key) in - add_complex_template - ("_Lemma __", "Lemma new_lemma : .\nProof.\n\nSave.\n", + add_complex_template + ("_Lemma __", "Lemma new_lemma : .\nProof.\n\nSave.\n", 19, 9, Some GdkKeysyms._L); - add_complex_template - ("_Theorem __", "Theorem new_theorem : .\nProof.\n\nSave.\n", + add_complex_template + ("_Theorem __", "Theorem new_theorem : .\nProof.\n\nSave.\n", 19, 11, Some GdkKeysyms._T); - add_complex_template + add_complex_template ("_Definition __", "Definition ident := .\n", 6, 5, Some GdkKeysyms._D); - add_complex_template + add_complex_template ("_Inductive __", "Inductive ident : :=\n | : .\n", 14, 5, Some GdkKeysyms._I); - add_complex_template + add_complex_template ("_Fixpoint __", "Fixpoint ident (_ : _) {struct _} : _ :=\n.\n", 29, 5, Some GdkKeysyms._F); add_complex_template("_Scheme __", @@ -2709,14 +2709,14 @@ let main files = with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); (* Template for match *) - let callback () = + let callback () = let w = get_current_word () in - try + try let cases = Coq.make_cases w in let print c = function | [x] -> Format.fprintf c " | %s => _@\n" x - | x::l -> Format.fprintf c " | (%s%a) => _@\n" x + | x::l -> Format.fprintf c " | (%s%a) => _@\n" x (print_list (fun c s -> Format.fprintf c " %s" s)) l | [] -> assert false in @@ -2728,26 +2728,26 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); prerr_endline s; let {script = view } = session_notebook#current_term in ignore (view#buffer#delete_selection ()); - let m = view#buffer#create_mark + let m = view#buffer#create_mark (view#buffer#get_iter `INSERT) in - if view#buffer#insert_interactive s then + if view#buffer#insert_interactive s then let i = view#buffer#get_iter (`MARK m) in let _ = i#nocopy#forward_chars 9 in view#buffer#place_cursor i; view#buffer#move_mark ~where:(i#backward_chars 3) - `SEL_BOUND + `SEL_BOUND with Not_found -> flash_info "Not an inductive type" in ignore (templates_factory#add_item "match ..." ~key:GdkKeysyms._C ~callback ); - + (* - let add_simple_template (factory: GMenu.menu GMenu.factory) + let add_simple_template (factory: GMenu.menu GMenu.factory) (menu_text, text) = - let text = + let text = let l = String.length text - 1 in if String.get text l = '.' then text ^"\n" @@ -2774,100 +2774,100 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); ]; ignore (templates_factory#add_separator ()); *) - List.iter - (fun l -> - match l with + List.iter + (fun l -> + match l with | [] -> () - | [s] -> add_simple_template templates_factory ("_"^s, s) - | s::_ -> + | [s] -> add_simple_template templates_factory ("_"^s, s) + | s::_ -> let a = "_@..." in a.[1] <- s.[0]; - let f = templates_factory#add_submenu a in + let f = templates_factory#add_submenu a in let ff = new GMenu.factory f ~accel_group in - List.iter - (fun x -> - add_simple_template - ff + List.iter + (fun x -> + add_simple_template + ff ((String.sub x 0 1)^ "_"^ (String.sub x 1 (String.length x - 1)), x)) l - ) + ) Coq_commands.commands; - + (* Queries Menu *) let queries_menu = factory#add_submenu "_Queries" in let queries_factory = new GMenu.factory queries_menu ~accel_group ~accel_path:"/Queries" ~accel_modi:[] in - + (* Command/Show commands *) - let _ = + let _ = queries_factory#add_item "_SearchAbout " ~key:GdkKeysyms._F2 ~callback:(fun () -> let term = get_current_word () in (Command_windows.command_window ())#new_command ~command:"SearchAbout" - ~term + ~term ()) in - let _ = + let _ = queries_factory#add_item "_Check " ~key:GdkKeysyms._F3 ~callback:(fun () -> let term = get_current_word () in (Command_windows.command_window ())#new_command ~command:"Check" - ~term + ~term ()) in - let _ = + let _ = queries_factory#add_item "_Print " ~key:GdkKeysyms._F4 ~callback:(fun () -> let term = get_current_word () in (Command_windows.command_window ())#new_command ~command:"Print" - ~term + ~term ()) in - let _ = + let _ = queries_factory#add_item "_About " ~key:GdkKeysyms._F5 ~callback:(fun () -> let term = get_current_word () in (Command_windows.command_window ())#new_command ~command:"About" - ~term + ~term ()) in - let _ = - queries_factory#add_item "_Locate" + let _ = + queries_factory#add_item "_Locate" ~callback:(fun () -> let term = get_current_word () in (Command_windows.command_window ())#new_command ~command:"Locate" - ~term + ~term ()) in - let _ = - queries_factory#add_item "_Whelp Locate" + let _ = + queries_factory#add_item "_Whelp Locate" ~callback:(fun () -> let term = get_current_word () in (Command_windows.command_window ())#new_command ~command:"Whelp Locate" - ~term + ~term ()) in (* Display menu *) - + let display_menu = factory#add_submenu "_Display" in let view_factory = new GMenu.factory display_menu ~accel_path:"/Display/" - ~accel_group + ~accel_group ~accel_modi:!current.modifier_for_display in - let _ = ignore (view_factory#add_check_item - "Display _implicit arguments" + let _ = ignore (view_factory#add_check_item + "Display _implicit arguments" ~key:GdkKeysyms._i ~callback:(fun _ -> printing_state.printing_implicit <- not printing_state.printing_implicit; do_or_activate (fun a -> a#show_goals) ())) in - let _ = ignore (view_factory#add_check_item + let _ = ignore (view_factory#add_check_item "Display _coercions" ~key:GdkKeysyms._c ~callback:(fun _ -> printing_state.printing_coercions <- not printing_state.printing_coercions; do_or_activate (fun a -> a#show_goals) ())) in @@ -2877,51 +2877,51 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); ~key:GdkKeysyms._m ~callback:(fun _ -> printing_state.printing_raw_matching <- not printing_state.printing_raw_matching; do_or_activate (fun a -> a#show_goals) ())) in - let _ = ignore (view_factory#add_check_item + let _ = ignore (view_factory#add_check_item "Deactivate _notations display" ~key:GdkKeysyms._n ~callback:(fun _ -> printing_state.printing_no_notation <- not printing_state.printing_no_notation; do_or_activate (fun a -> a#show_goals) ())) in - let _ = ignore (view_factory#add_check_item + let _ = ignore (view_factory#add_check_item "Display _all basic low-level contents" ~key:GdkKeysyms._a - ~callback:(fun _ -> printing_state.printing_all <- not printing_state.printing_all; do_or_activate (fun a -> a#show_goals) ())) in + ~callback:(fun _ -> printing_state.printing_all <- not printing_state.printing_all; do_or_activate (fun a -> a#show_goals) ())) in - let _ = ignore (view_factory#add_check_item + let _ = ignore (view_factory#add_check_item "Display _existential variable instances" ~key:GdkKeysyms._e ~callback:(fun _ -> printing_state.printing_evar_instances <- not printing_state.printing_evar_instances; do_or_activate (fun a -> a#show_goals) ())) in - let _ = ignore (view_factory#add_check_item + let _ = ignore (view_factory#add_check_item "Display _universe levels" ~key:GdkKeysyms._u ~callback:(fun _ -> printing_state.printing_universes <- not printing_state.printing_universes; do_or_activate (fun a -> a#show_goals) ())) in - let _ = ignore (view_factory#add_check_item + let _ = ignore (view_factory#add_check_item "Display all _low-level contents" ~key:GdkKeysyms._l - ~callback:(fun _ -> printing_state.printing_full_all <- not printing_state.printing_full_all; do_or_activate (fun a -> a#show_goals) ())) in + ~callback:(fun _ -> printing_state.printing_full_all <- not printing_state.printing_full_all; do_or_activate (fun a -> a#show_goals) ())) in + + - - (* Externals *) let externals_menu = factory#add_submenu "_Compile" in - let externals_factory = new GMenu.factory externals_menu + let externals_factory = new GMenu.factory externals_menu ~accel_path:"/Compile/" - ~accel_group + ~accel_group ~accel_modi:[] in - + (* Command/Compile Menu *) let compile_f () = let v = session_notebook#current_term in let av = v.analyzed_view in save_f (); match av#filename with - | None -> + | None -> flash_info "Active buffer has no name" | Some f -> - let cmd = !current.cmd_coqc ^ " -I " + let cmd = !current.cmd_coqc ^ " -I " ^ (Filename.quote (Filename.dirname f)) ^ " " ^ (Filename.quote f) in let s,res = run_command av#insert_message cmd in @@ -2935,8 +2935,8 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); av#insert_message res end in - let _ = - externals_factory#add_item "_Compile Buffer" ~callback:compile_f + let _ = + externals_factory#add_item "_Compile Buffer" ~callback:compile_f in (* Command/Make Menu *) @@ -2944,10 +2944,10 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); let v = session_notebook#current_term in let av = v.analyzed_view in match av#filename with - | None -> + | None -> flash_info "Cannot make: this buffer has no name" | Some f -> - let cmd = + let cmd = "cd " ^ Filename.quote (Filename.dirname f) ^ "; " ^ !current.cmd_make in (* @@ -2959,14 +2959,14 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); last_make_index := 0; flash_info (!current.cmd_make ^ if s = Unix.WEXITED 0 then " succeeded" else " failed") in - let _ = externals_factory#add_item "_Make" + let _ = externals_factory#add_item "_Make" ~key:GdkKeysyms._F6 - ~callback:make_f + ~callback:make_f in - + (* Compile/Next Error *) - let next_error () = + let next_error () = try let file,line,start,stop,error_msg = search_next_error () in load file; @@ -3000,131 +3000,131 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); let av = v.analyzed_view in av#set_message "No more errors.\n" in - let _ = - externals_factory#add_item "_Next error" + let _ = + externals_factory#add_item "_Next error" ~key:GdkKeysyms._F7 ~callback:next_error in - + (* Command/CoqMakefile Menu*) let coq_makefile_f () = let v = session_notebook#current_term in let av = v.analyzed_view in match av#filename with - | None -> + | None -> flash_info "Cannot make makefile: this buffer has no name" | Some f -> - let cmd = + let cmd = "cd " ^ Filename.quote (Filename.dirname f) ^ "; " ^ !current.cmd_coqmakefile in let s,res = run_command av#insert_message cmd in - flash_info + flash_info (!current.cmd_coqmakefile ^ if s = Unix.WEXITED 0 then " succeeded" else " failed") in - let _ = externals_factory#add_item "_Make makefile" ~callback:coq_makefile_f + let _ = externals_factory#add_item "_Make makefile" ~callback:coq_makefile_f in (* Windows Menu *) let configuration_menu = factory#add_submenu "_Windows" in - let configuration_factory = new GMenu.factory configuration_menu + let configuration_factory = new GMenu.factory configuration_menu ~accel_path:"/Windows" ~accel_modi:[] ~accel_group in let _ = - configuration_factory#add_item + configuration_factory#add_item "Show/Hide _Query Pane" ~key:GdkKeysyms._Escape - ~callback:(fun () -> if (Command_windows.command_window ())#frame#misc#visible then + ~callback:(fun () -> if (Command_windows.command_window ())#frame#misc#visible then (Command_windows.command_window ())#frame#misc#hide () else (Command_windows.command_window ())#frame#misc#show ()) - in - let _ = - configuration_factory#add_check_item - "Show/Hide _Toolbar" - ~callback:(fun _ -> - !current.show_toolbar <- not !current.show_toolbar; - !show_toolbar !current.show_toolbar) in - let _ = configuration_factory#add_item + let _ = + configuration_factory#add_check_item + "Show/Hide _Toolbar" + ~callback:(fun _ -> + !current.show_toolbar <- not !current.show_toolbar; + !show_toolbar !current.show_toolbar) + in + let _ = configuration_factory#add_item "Detach _Script Window" ~callback: (do_if_not_computing "detach script window" (sync - (fun () -> + (fun () -> let nb = session_notebook in if nb#misc#toplevel#get_oid=w#coerce#get_oid then - begin - let nw = GWindow.window + begin + let nw = GWindow.window ~width:(!current.window_width*2/3) ~height:(!current.window_height*2/3) ~position:`CENTER ~wm_name:"CoqIde" ~wm_class:"CoqIde" - ~title:"Script" + ~title:"Script" ~show:true () in let parent = Option.get nb#misc#parent in - ignore (nw#connect#destroy + ignore (nw#connect#destroy ~callback: (fun () -> nb#misc#reparent parent)); nw#add_accel_group accel_group; nb#misc#reparent nw#coerce - end + end ))) in - let _ = - configuration_factory#add_item + let _ = + configuration_factory#add_item "Detach _View" ~callback: (do_if_not_computing "detach view" - (fun () -> - match session_notebook#current_term with - | {script=v;analyzed_view=av} -> - let w = GWindow.window ~show:true + (fun () -> + match session_notebook#current_term with + | {script=v;analyzed_view=av} -> + let w = GWindow.window ~show:true ~width:(!current.window_width*2/3) ~height:(!current.window_height*2/3) ~position:`CENTER ~title:(match av#filename with | None -> "*Unnamed*" - | Some f -> f) - () + | Some f -> f) + () in - let sb = GBin.scrolled_window - ~packing:w#add () + let sb = GBin.scrolled_window + ~packing:w#add () in - let nv = GText.view - ~buffer:v#buffer - ~packing:sb#add + let nv = GText.view + ~buffer:v#buffer + ~packing:sb#add () in - nv#misc#modify_font - !current.text_font; - ignore (w#connect#destroy + nv#misc#modify_font + !current.text_font; + ignore (w#connect#destroy ~callback: (fun () -> av#remove_detached_view w)); av#add_detached_view w - + )) in (* Help Menu *) let help_menu = factory#add_submenu "_Help" in - let help_factory = new GMenu.factory help_menu + let help_factory = new GMenu.factory help_menu ~accel_path:"/Help/" ~accel_modi:[] ~accel_group in - let _ = help_factory#add_item "Browse Coq _Manual" + let _ = help_factory#add_item "Browse Coq _Manual" ~callback: - (fun () -> - let av = session_notebook#current_term.analyzed_view in + (fun () -> + let av = session_notebook#current_term.analyzed_view in browse av#insert_message (doc_url ())) in - let _ = help_factory#add_item "Browse Coq _Library" + let _ = help_factory#add_item "Browse Coq _Library" ~callback: - (fun () -> - let av = session_notebook#current_term.analyzed_view in + (fun () -> + let av = session_notebook#current_term.analyzed_view in browse av#insert_message !current.library_url) in - let _ = + let _ = help_factory#add_item "Help for _keyword" ~key:GdkKeysyms._F1 - ~callback:(fun () -> - let av = session_notebook#current_term.analyzed_view in + ~callback:(fun () -> + let av = session_notebook#current_term.analyzed_view in av#help_for_keyword ()) in let _ = help_factory#add_separator () in @@ -3143,13 +3143,13 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); lower_hbox#pack ~expand:true status#coerce; let search_lbl = GMisc.label ~text:"Search:" ~show:false - ~packing:(lower_hbox#pack ~expand:false) () + ~packing:(lower_hbox#pack ~expand:false) () in let search_history = ref [] in let search_input = GEdit.combo ~popdown_strings:!search_history ~enable_arrow_keys:true ~show:false - ~packing:(lower_hbox#pack ~expand:false) () + ~packing:(lower_hbox#pack ~expand:false) () in search_input#disable_activate (); let ready_to_wrap_search = ref false in @@ -3160,10 +3160,10 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); let search_forward = ref true in let matched_word = ref None in - let memo_search () = + let memo_search () = matched_word := Some search_input#entry#text in - let end_search () = + let end_search () = prerr_endline "End Search"; memo_search (); let v = session_notebook#current_term.script in @@ -3173,7 +3173,7 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); search_lbl#misc#hide (); search_input#misc#hide () in - let end_search_focus_out () = + let end_search_focus_out () = prerr_endline "End Search(focus out)"; memo_search (); let v = session_notebook#current_term.script in @@ -3183,67 +3183,67 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); search_input#misc#hide () in ignore (search_input#entry#connect#activate ~callback:end_search); - ignore (search_input#entry#event#connect#key_press + ignore (search_input#entry#event#connect#key_press ~callback:(fun k -> let kv = GdkEvent.Key.keyval k in - if + if kv = GdkKeysyms._Right - || kv = GdkKeysyms._Up + || kv = GdkKeysyms._Up || kv = GdkKeysyms._Left - || (kv = GdkKeysyms._g + || (kv = GdkKeysyms._g && (List.mem `CONTROL (GdkEvent.Key.state k))) - then end_search (); + then end_search (); false)); ignore (search_input#entry#event#connect#focus_out ~callback:(fun _ -> end_search_focus_out (); false)); - to_do_on_page_switch := - (fun i -> + to_do_on_page_switch := + (fun i -> start_of_search := None; ready_to_wrap_search:=false)::!to_do_on_page_switch; (* TODO : make it work !!! *) - let rec search_f () = + let rec search_f () = search_lbl#misc#show (); search_input#misc#show (); prerr_endline "search_f called"; if !start_of_search = None then begin (* A full new search is starting *) - start_of_search := - Some (session_notebook#current_term.script#buffer#create_mark + start_of_search := + Some (session_notebook#current_term.script#buffer#create_mark (session_notebook#current_term.script#buffer#get_iter_at_mark `INSERT)); start_of_found := !start_of_search; end_of_found := !start_of_search; matched_word := Some ""; end; - let txt = search_input#entry#text in + let txt = search_input#entry#text in let v = session_notebook#current_term.script in - let iit = v#buffer#get_iter_at_mark `SEL_BOUND + let iit = v#buffer#get_iter_at_mark `SEL_BOUND and insert_iter = v#buffer#get_iter_at_mark `INSERT in prerr_endline ("SELBOUND="^(string_of_int iit#offset)); prerr_endline ("INSERT="^(string_of_int insert_iter#offset)); - + (match - if !search_forward then iit#forward_search txt + if !search_forward then iit#forward_search txt else let npi = iit#forward_chars (Glib.Utf8.length txt) in - match + match (npi#offset = (v#buffer#get_iter_at_mark `INSERT)#offset), - (let t = iit#get_text ~stop:npi in + (let t = iit#get_text ~stop:npi in flash_info (t^"\n"^txt); t = txt) - with - | true,true -> + with + | true,true -> (flash_info "T,T";iit#backward_search txt) | false,true -> flash_info "F,T";Some (iit,npi) | _,false -> (iit#backward_search txt) - with - | None -> + with + | None -> if !ready_to_wrap_search then begin ready_to_wrap_search := false; flash_info "Search wrapped"; - v#buffer#place_cursor + v#buffer#place_cursor (if !search_forward then v#buffer#start_iter else v#buffer#end_iter); search_f () @@ -3252,7 +3252,7 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); else flash_info "Search at start"; ready_to_wrap_search := true end - | Some (start,stop) -> + | Some (start,stop) -> prerr_endline "search: before moving marks"; prerr_endline ("SELBOUND="^(string_of_int (v#buffer#get_iter_at_mark `SEL_BOUND)#offset)); prerr_endline ("INSERT="^(string_of_int (v#buffer#get_iter_at_mark `INSERT)#offset)); @@ -3265,47 +3265,47 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); v#scroll_to_mark `SEL_BOUND ) in - ignore (search_input#entry#event#connect#key_release + ignore (search_input#entry#event#connect#key_release ~callback: (fun ev -> if GdkEvent.Key.keyval ev = GdkKeysyms._Escape then begin let v = session_notebook#current_term.script in - (match !start_of_search with - | None -> + (match !start_of_search with + | None -> prerr_endline "search_key_rel: Placing sel_bound"; - v#buffer#move_mark - `SEL_BOUND + v#buffer#move_mark + `SEL_BOUND (v#buffer#get_iter_at_mark `INSERT) - | Some mk -> let it = v#buffer#get_iter_at_mark + | Some mk -> let it = v#buffer#get_iter_at_mark (`MARK mk) in prerr_endline "search_key_rel: Placing cursor"; v#buffer#place_cursor it; start_of_search := None ); - search_input#entry#set_text ""; + search_input#entry#set_text ""; v#coerce#misc#grab_focus (); - end; + end; false )); ignore (search_input#entry#connect#changed search_f); push_info "Ready"; (* Location display *) let l = GMisc.label - ~text:"Line: 1 Char: 1" - ~packing:lower_hbox#pack () in + ~text:"Line: 1 Char: 1" + ~packing:lower_hbox#pack () in l#coerce#misc#set_name "location"; set_location := l#set_text; (* Progress Bar *) lower_hbox#pack pbar#coerce; pbar#set_text "CoqIde started"; (* XXX *) - change_font := - (fun fd -> - List.iter + change_font := + (fun fd -> + List.iter (fun {script=view; proof_view=prf_v; message_view=msg_v} -> view#misc#modify_font fd; prf_v#misc#modify_font fd; - msg_v#misc#modify_font fd + msg_v#misc#modify_font fd ) session_notebook#pages; ); @@ -3333,7 +3333,7 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); b#insert ~iter:b#start_iter "\n\n"; if Glib.Utf8.validate ("You are running " ^ coq_version) then b#insert ~iter:b#start_iter ("You are running " ^ coq_version); if Glib.Utf8.validate initial_string then b#insert ~iter:b#start_iter initial_string; - (try + (try let image = lib_ide_file "coq.png" in let startup_image = GdkPixbuf.from_file image in b#insert ~iter:b#start_iter "\n\n"; @@ -3343,7 +3343,7 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); in let about (b:GText.buffer) = - (try + (try let image = lib_ide_file "coq.png" in let startup_image = GdkPixbuf.from_file image in b#insert ~iter:b#start_iter "\n\n"; @@ -3360,27 +3360,27 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); w#add_accel_group accel_group; (* Remove default pango menu for textviews *) w#show (); - ignore (about_m#connect#activate + ignore (about_m#connect#activate ~callback:(fun () -> let prf_v = session_notebook#current_term.proof_view in prf_v#buffer#set_text ""; about prf_v#buffer)); (* - + *) - resize_window := (fun () -> - w#resize + resize_window := (fun () -> + w#resize ~width:!current.window_width ~height:!current.window_height); ignore(nb#connect#switch_page ~callback: - (fun i -> + (fun i -> prerr_endline ("switch_page: starts " ^ string_of_int i); List.iter (function f -> f i) !to_do_on_page_switch; prerr_endline "switch_page: success") ); if List.length files >=1 then begin - List.iter (fun f -> - if Sys.file_exists f then load f else + List.iter (fun f -> + if Sys.file_exists f then load f else let f = if Filename.check_suffix f ".v" then f else f^".v" in load_file (fun s -> print_endline s; exit 1) f) files; @@ -3396,53 +3396,53 @@ with _ := Induction for _ Sort _.\n",61,10, Some GdkKeysyms._S); ;; -(* This function check every half of second if GeoProof has send +(* This function check every half of second if GeoProof has send something on his private clipboard *) -let rec check_for_geoproof_input () = +let rec check_for_geoproof_input () = let cb_Dr = GData.clipboard (Gdk.Atom.intern "_GeoProof") in while true do Thread.delay 0.1; let s = cb_Dr#text in - (match s with - Some s -> + (match s with + Some s -> if s <> "Ack" then session_notebook#current_term.script#buffer#insert (s^"\n"); cb_Dr#set_text "Ack" | None -> () ); (* cb_Dr#clear does not work so i use : *) - (* cb_Dr#set_text "Ack" *) + (* cb_Dr#set_text "Ack" *) done - - -let start () = + + +let start () = let files = Coq.init () in ignore_break (); GtkMain.Rc.add_default_file (lib_ide_file ".coqide-gtk2rc"); - (try + (try GtkMain.Rc.add_default_file (Filename.concat System.home ".coqide-gtk2rc"); with Not_found -> ()); ignore (GtkMain.Main.init ()); - GtkData.AccelGroup.set_default_mod_mask + GtkData.AccelGroup.set_default_mod_mask (Some [`CONTROL;`SHIFT;`MOD1;`MOD3;`MOD4]); ignore ( Glib.Message.set_log_handler ~domain:"Gtk" ~levels:[`ERROR;`FLAG_FATAL; `WARNING;`CRITICAL] - (fun ~level msg -> + (fun ~level msg -> if level land Glib.Message.log_level `WARNING <> 0 then Pp.warning msg else failwith ("Coqide internal error: " ^ msg))); Command_windows.main (); init_stdout (); main files; - if !Coq_config.with_geoproof then ignore (Thread.create check_for_geoproof_input ()); - while true do - try - GtkThread.main () + if !Coq_config.with_geoproof then ignore (Thread.create check_for_geoproof_input ()); + while true do + try + GtkThread.main () with | Sys.Break -> prerr_endline "Interrupted." ; flush stderr - | e -> + | e -> Pervasives.prerr_endline ("CoqIde unexpected error:" ^ (Printexc.to_string e)); flush stderr; crash_save 127 diff --git a/ide/coqide.mli b/ide/coqide.mli index d84158a0b2..4c01e747a1 100644 --- a/ide/coqide.mli +++ b/ide/coqide.mli @@ -9,7 +9,7 @@ (*i $Id$ i*) (* The CoqIde main module. The following function [start] will parse the - command line, initialize the load path, load the input + command line, initialize the load path, load the input state, load the files given on the command line, load the ressource file, produce the output state if any, and finally will launch the interface. *) diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index 8da4d9ddaa..e92a345e33 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -24,38 +24,38 @@ let is_word_char c = Glib.Unichar.isalnum c || c = underscore || c = prime -let starts_word (it:GText.iter) = +let starts_word (it:GText.iter) = prerr_endline ("Starts word ? '"^(Glib.Utf8.from_unichar it#char)^"'"); (not it#copy#nocopy#backward_char || (let c = it#backward_char#char in not (is_word_char c))) -let ends_word (it:GText.iter) = +let ends_word (it:GText.iter) = (not it#copy#nocopy#forward_char || let c = it#forward_char#char in not (is_word_char c) ) -let inside_word (it:GText.iter) = +let inside_word (it:GText.iter) = let c = it#char in not (starts_word it) && not (ends_word it) && is_word_char c -let is_on_word_limit (it:GText.iter) = inside_word it || ends_word it +let is_on_word_limit (it:GText.iter) = inside_word it || ends_word it let find_word_start (it:GText.iter) = let rec step_to_start it = prerr_endline "Find word start"; - if not it#nocopy#backward_char then + if not it#nocopy#backward_char then (prerr_endline "find_word_start: cannot backward"; it) else if is_word_char it#char then step_to_start it - else (it#nocopy#forward_char; + else (it#nocopy#forward_char; prerr_endline ("Word start at: "^(string_of_int it#offset));it) in step_to_start it#copy @@ -64,8 +64,8 @@ let find_word_start (it:GText.iter) = let find_word_end (it:GText.iter) = let rec step_to_end (it:GText.iter) = prerr_endline "Find word end"; - let c = it#char in - if c<>0 && is_word_char c then ( + let c = it#char in + if c<>0 && is_word_char c then ( ignore (it#nocopy#forward_char); step_to_end it ) else ( @@ -75,34 +75,34 @@ let find_word_end (it:GText.iter) = step_to_end it#copy -let get_word_around (it:GText.iter) = +let get_word_around (it:GText.iter) = let start = find_word_start it in let stop = find_word_end it in start,stop -let rec complete_backward w (it:GText.iter) = +let rec complete_backward w (it:GText.iter) = prerr_endline "Complete backward..."; - match it#backward_search w with + match it#backward_search w with | None -> (prerr_endline "backward_search failed";None) - | Some (start,stop) -> + | Some (start,stop) -> prerr_endline ("complete_backward got a match:"^(string_of_int start#offset)^(string_of_int stop#offset)); - if starts_word start then + if starts_word start then let ne = find_word_end stop in if ne#compare stop = 0 then complete_backward w start else Some (start,stop,ne) else complete_backward w start - -let rec complete_forward w (it:GText.iter) = + +let rec complete_forward w (it:GText.iter) = prerr_endline "Complete forward..."; - match it#forward_search w with + match it#forward_search w with | None -> None - | Some (start,stop) -> - if starts_word start then + | Some (start,stop) -> + if starts_word start then let ne = find_word_end stop in - if ne#compare stop = 0 then + if ne#compare stop = 0 then complete_forward w stop else Some (stop,stop,ne) else complete_forward w stop diff --git a/ide/highlight.mll b/ide/highlight.mll index 44018ff09c..21516f7cfe 100644 --- a/ide/highlight.mll +++ b/ide/highlight.mll @@ -24,7 +24,7 @@ let h = Hashtbl.create 97 in List.iter (fun s -> Hashtbl.add h s ()) [ "Add" ; "Check"; "Eval"; "Extraction" ; - "Load" ; "Undo"; "Goal"; + "Load" ; "Undo"; "Goal"; "Proof" ; "Print"; "Qed" ; "Defined" ; "Save" ; "End" ; "Section"; "Chapter"; "Transparent"; "Opaque"; "Comments" ]; @@ -33,9 +33,9 @@ let is_constr_kw = let h = Hashtbl.create 97 in List.iter (fun s -> Hashtbl.add h s ()) - [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for"; + [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "for"; "end"; "as"; "let"; "in"; "dest"; "if"; "then"; "else"; "return"; - "Prop"; "Set"; "Type" ]; + "Prop"; "Set"; "Type" ]; Hashtbl.mem h (* Without this table, the automaton would be too big and @@ -62,11 +62,11 @@ let starting = ref true } -let space = +let space = [' ' '\010' '\013' '\009' '\012'] -let firstchar = +let firstchar = ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'] -let identchar = +let identchar = ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let ident = firstchar identchar* @@ -79,8 +79,8 @@ let multiword_declaration = let locality = ("Local" space+)? let multiword_command = - "Set" (space+ ident)* -| "Unset" (space+ ident)* + "Set" (space+ ident)* +| "Unset" (space+ ident)* | "Open" space+ locality "Scope" | "Close" space+ locality "Scope" | "Bind" space+ "Scope" @@ -109,12 +109,12 @@ rule next_starting_order = parse { starting:=false; lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.decl } | multiword_command { starting:=false; lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd } - | ident as id + | ident as id { if id = "Time" then next_starting_order lexbuf else begin - starting:=false; - if is_one_word_command id then - lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd + starting:=false; + if is_one_word_command id then + lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd else if is_one_word_declaration id then lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.decl else @@ -125,9 +125,9 @@ rule next_starting_order = parse | eof { raise End_of_file } and next_interior_order = parse - | "(*" + | "(*" { comment_start := lexeme_start lexbuf; comment lexbuf } - | ident as id + | ident as id { if is_constr_kw id then lexeme_start lexbuf, lexeme_end lexbuf, Tags.Script.kwd else @@ -154,9 +154,9 @@ and string_in_comment = parse let highlighting = ref false - let highlight_slice (input_buffer:GText.buffer) (start:GText.iter) stop = + let highlight_slice (input_buffer:GText.buffer) (start:GText.iter) stop = starting := true; (* approximation: assume the beginning of a sentence *) - if !highlighting then prerr_endline "Rejected highlight" + if !highlighting then prerr_endline "Rejected highlight" else begin highlighting := true; prerr_endline "Highlighting slice now"; @@ -170,16 +170,16 @@ and string_in_comment = parse let s = start#get_slice ~stop in let convert_pos = byte_offset_to_char_offset s in let lb = Lexing.from_string s in - try + try while true do let b,e,o = if !starting then next_starting_order lb else next_interior_order lb in - + let b,e = convert_pos b,convert_pos e in let start = input_buffer#get_iter_at_char (offset + b) in let stop = input_buffer#get_iter_at_char (offset + e) in - input_buffer#apply_tag ~start ~stop o + input_buffer#apply_tag ~start ~stop o done with End_of_file -> () end @@ -188,22 +188,22 @@ and string_in_comment = parse end let highlight_current_line input_buffer = - try + try let i = get_insert input_buffer in highlight_slice input_buffer (i#set_line_offset 0) i with _ -> () - let highlight_around_current_line input_buffer = - try + let highlight_around_current_line input_buffer = + try let i = get_insert input_buffer in - highlight_slice input_buffer - (i#backward_lines 10) + highlight_slice input_buffer + (i#backward_lines 10) (ignore (i#nocopy#forward_lines 10);i) with _ -> () - - let highlight_all input_buffer = - try + + let highlight_all input_buffer = + try highlight_slice input_buffer input_buffer#start_iter input_buffer#end_iter with _ -> () diff --git a/ide/ideutils.ml b/ide/ideutils.ml index ebf789fb37..14e803899c 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -15,7 +15,7 @@ exception Forbidden (* status bar and locations *) -let status = GMisc.statusbar () +let status = GMisc.statusbar () let push_info,pop_info = let status_context = status#new_context "Messages" in @@ -41,12 +41,12 @@ let prerr_string s = let lib_ide_file f = let coqlib = Envars.coqlib () in Filename.concat (Filename.concat coqlib "ide") f - + let get_insert input_buffer = input_buffer#get_iter_at_mark `INSERT let is_char_start c = let code = Char.code c in code < 0x80 || code >= 0xc0 -let byte_offset_to_char_offset s byte_offset = +let byte_offset_to_char_offset s byte_offset = if (byte_offset < String.length s) then begin let count_delta = ref 0 in for i = 0 to byte_offset do @@ -68,19 +68,19 @@ let print_id id = prerr_endline ("GOT sig id :"^(string_of_int (Obj.magic id))) -let do_convert s = +let do_convert s = Utf8_convert.f (if Glib.Utf8.validate s then begin prerr_endline "Input is UTF-8";s end else - let from_loc () = + let from_loc () = let _,char_set = Glib.Convert.get_charset () in flash_info ("Converting from locale ("^char_set^")"); Glib.Convert.convert_with_fallback ~to_codeset:"UTF-8" ~from_codeset:char_set s in - let from_manual () = - flash_info + let from_manual () = + flash_info ("Converting from "^ !current.encoding_manual); Glib.Convert.convert s ~to_codeset:"UTF-8" ~from_codeset:!current.encoding_manual in @@ -90,30 +90,30 @@ let do_convert s = with _ -> from_manual () end else begin try - from_manual () + from_manual () with _ -> from_loc () end) -let try_convert s = +let try_convert s = try do_convert s - with _ -> + with _ -> "(* Fatal error: wrong encoding in input. Please choose a correct encoding in the preference panel.*)";; -let try_export file_name s = - try let s = +let try_export file_name s = + try let s = try if !current.encoding_use_utf8 then begin (prerr_endline "UTF-8 is enforced" ;s) end else if !current.encoding_use_locale then begin let is_unicode,char_set = Glib.Convert.get_charset () in - if is_unicode then - (prerr_endline "Locale is UTF-8" ;s) + if is_unicode then + (prerr_endline "Locale is UTF-8" ;s) else (prerr_endline ("Locale is "^char_set); Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:char_set s) - end else + end else (prerr_endline ("Manual charset is "^ !current.encoding_manual); Glib.Convert.convert_with_fallback ~from_codeset:"UTF-8" ~to_codeset:!current.encoding_manual s) with e -> (prerr_endline ("Error ("^(Printexc.to_string e)^") in transcoding: falling back to UTF-8") ;s) @@ -137,16 +137,16 @@ let disconnect_auto_save_timer () = match !auto_save_timer with | Some id -> GMain.Timeout.remove id; auto_save_timer := None let highlight_timer = ref None -let set_highlight_timer f = - match !highlight_timer with - | None -> - revert_timer := - Some (GMain.Timeout.add ~ms:2000 +let set_highlight_timer f = + match !highlight_timer with + | None -> + revert_timer := + Some (GMain.Timeout.add ~ms:2000 ~callback:(fun () -> f (); highlight_timer := None; true)) - | Some id -> + | Some id -> GMain.Timeout.remove id; - revert_timer := - Some (GMain.Timeout.add ~ms:2000 + revert_timer := + Some (GMain.Timeout.add ~ms:2000 ~callback:(fun () -> f (); highlight_timer := None; true)) @@ -156,31 +156,31 @@ let init_stdout,read_stdout,clear_stdout = let out_ft = Format.formatter_of_buffer out_buff in let deep_out_ft = Format.formatter_of_buffer out_buff in let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in - (fun () -> + (fun () -> Pp_control.std_ft := out_ft; Pp_control.err_ft := out_ft; Pp_control.deep_ft := deep_out_ft; ), - (fun () -> Format.pp_print_flush out_ft (); + (fun () -> Format.pp_print_flush out_ft (); let r = Buffer.contents out_buff in prerr_endline "Output from Coq is: "; prerr_endline r; Buffer.clear out_buff; r), - (fun () -> + (fun () -> Format.pp_print_flush out_ft (); Buffer.clear out_buff) let last_dir = ref "" -let filter_all_files () = GFile.filter - ~name:"All" - ~patterns:["*"] () - -let filter_coq_files () = GFile.filter - ~name:"Coq source code" +let filter_all_files () = GFile.filter + ~name:"All" + ~patterns:["*"] () + +let filter_coq_files () = GFile.filter + ~name:"Coq source code" ~patterns:[ "*.v"] () let select_file_for_open ~title ?(dir = last_dir) ?(filename="") () = - let file = ref None in + let file = ref None in let file_chooser = GWindow.file_chooser_dialog ~action:`OPEN ~modal:true ~title () in file_chooser#add_button_stock `CANCEL `CANCEL ; file_chooser#add_select_button_stock `OPEN `OPEN ; @@ -189,8 +189,8 @@ let select_file_for_open ~title ?(dir = last_dir) ?(filename="") () = file_chooser#set_default_response `OPEN; ignore (file_chooser#set_current_folder !dir); begin match file_chooser#run () with - | `OPEN -> - begin + | `OPEN -> + begin file := file_chooser#filename; match !file with None -> () @@ -198,27 +198,27 @@ let select_file_for_open ~title ?(dir = last_dir) ?(filename="") () = end | `DELETE_EVENT | `CANCEL -> () end ; - file_chooser#destroy (); + file_chooser#destroy (); !file let select_file_for_save ~title ?(dir = last_dir) ?(filename="") () = - let file = ref None in + let file = ref None in let file_chooser = GWindow.file_chooser_dialog ~action:`SAVE ~modal:true ~title () in file_chooser#add_button_stock `CANCEL `CANCEL ; file_chooser#add_select_button_stock `SAVE `SAVE ; file_chooser#add_filter (filter_coq_files ()); file_chooser#add_filter (filter_all_files ()); - (* this line will be used when a lablgtk >= 2.10.0 is the default on most distributions + (* this line will be used when a lablgtk >= 2.10.0 is the default on most distributions file_chooser#set_do_overwrite_confirmation true; *) file_chooser#set_default_response `SAVE; ignore (file_chooser#set_current_folder !dir); ignore (file_chooser#set_current_name filename); - + begin match file_chooser#run () with - | `SAVE -> - begin + | `SAVE -> + begin file := file_chooser#filename; match !file with None -> () @@ -226,7 +226,7 @@ let select_file_for_save ~title ?(dir = last_dir) ?(filename="") () = end | `DELETE_EVENT | `CANCEL -> () end ; - file_chooser#destroy (); + file_chooser#destroy (); !file let find_tag_start (tag :GText.tag) (it:GText.iter) = @@ -243,7 +243,7 @@ let find_tag_stop (tag :GText.tag) (it:GText.iter) = () done; it -let find_tag_limits (tag :GText.tag) (it:GText.iter) = +let find_tag_limits (tag :GText.tag) (it:GText.iter) = (find_tag_start tag it , find_tag_stop tag it) (* explanations: Win32 threads won't work if events are produced @@ -251,16 +251,16 @@ let find_tag_limits (tag :GText.tag) (it:GText.iter) = case we must use GtkThread.async to push a callback in the main thread. Beware that the synchronus version may produce deadlocks. *) -let async = +let async = if Sys.os_type = "Win32" then GtkThread.async else (fun x -> x) -let sync = +let sync = if Sys.os_type = "Win32" then GtkThread.sync else (fun x -> x) let mutex text f = let m = Mutex.create() in fun x -> if Mutex.try_lock m - then + then (try prerr_endline ("Got lock on "^text); f x; @@ -275,8 +275,8 @@ let mutex text f = ("Discarded call for "^text^": computations ongoing") -let stock_to_widget ?(size=`DIALOG) s = - let img = GMisc.image () +let stock_to_widget ?(size=`DIALOG) s = + let img = GMisc.image () in img#set_stock s; img#coerce @@ -296,12 +296,12 @@ let run_command f c = let ne = ref 0 in while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; !n+ !ne <> 0 do - let r = try_convert (String.sub buff 0 !n) in + let r = try_convert (String.sub buff 0 !n) in f r; Buffer.add_string result r; - let r = try_convert (String.sub buffe 0 !ne) in + let r = try_convert (String.sub buffe 0 !ne) in f r; - Buffer.add_string result r + Buffer.add_string result r done; (Unix.close_process_full (cin,cout,cerr), Buffer.contents result) @@ -313,7 +313,7 @@ let browse f url = "\"\ncheck your preferences for setting a valid browser command\n") let doc_url () = - if !current.doc_url = use_default_doc_url || !current.doc_url = "" then + if !current.doc_url = use_default_doc_url || !current.doc_url = "" then if Sys.file_exists (String.sub Coq_config.localwwwrefman 7 (String.length Coq_config.localwwwrefman - 7)) @@ -327,7 +327,7 @@ let url_for_keyword = let ht = Hashtbl.create 97 in lazy ( begin try - let cin = + let cin = try open_in (lib_ide_file "index_urls.txt") with _ -> let doc_url = doc_url () in @@ -339,7 +339,7 @@ let url_for_keyword = in try while true do let s = input_line cin in - try + try let i = String.index s ',' in let k = String.sub s 0 i in let u = String.sub s (i + 1) (String.length s - i - 1) in @@ -356,16 +356,16 @@ let url_for_keyword = Hashtbl.find ht : string -> string) -let browse_keyword f text = - try let u = Lazy.force url_for_keyword text in browse f (doc_url() ^ u) +let browse_keyword f text = + try let u = Lazy.force url_for_keyword text in browse f (doc_url() ^ u) with Not_found -> f ("No documentation found for \""^text^"\".\n") (* checks if two file names refer to the same (existing) file by - comparing their device and inode. + comparing their device and inode. It seems that under Windows, inode is always 0, so we cannot - accurately check if + accurately check if *) (* Optimised for partial application (in case many candidates must be @@ -377,7 +377,7 @@ let same_file f1 = try let s2 = Unix.stat f2 in s1.Unix.st_dev = s2.Unix.st_dev && - if Sys.os_type = "Win32" then f1 = f2 + if Sys.os_type = "Win32" then f1 = f2 else s1.Unix.st_ino = s2.Unix.st_ino with Unix.Unix_error _ -> false) @@ -385,7 +385,7 @@ let same_file f1 = Unix.Unix_error _ -> (fun _ -> false) let absolute_filename f = - if Filename.is_relative f then + if Filename.is_relative f then Filename.concat (Sys.getcwd ()) f else f - + diff --git a/ide/preferences.ml b/ide/preferences.ml index daa3839e06..bb35ed246c 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -16,7 +16,7 @@ let pref_file = Filename.concat System.home ".coqiderc" let accel_file = Filename.concat System.home ".coqide.keys" -let mod_to_str (m:Gdk.Tags.modifier) = +let mod_to_str (m:Gdk.Tags.modifier) = match m with | `MOD1 -> "MOD1" | `MOD2 -> "MOD2" @@ -34,19 +34,19 @@ let mod_to_str (m:Gdk.Tags.modifier) = let (str_to_mod:string -> Gdk.Tags.modifier) = function - | "MOD1" -> `MOD1 - | "MOD2" -> `MOD2 - | "MOD3" -> `MOD3 - | "MOD4" -> `MOD4 - | "MOD5" -> `MOD5 - | "BUTTON1" -> `BUTTON1 - | "BUTTON2" -> `BUTTON2 - | "BUTTON3" -> `BUTTON3 - | "BUTTON4" -> `BUTTON4 - | "BUTTON5" -> `BUTTON5 - | "CONTROL" -> `CONTROL - | "LOCK" -> `LOCK - | "SHIFT" -> `SHIFT + | "MOD1" -> `MOD1 + | "MOD2" -> `MOD2 + | "MOD3" -> `MOD3 + | "MOD4" -> `MOD4 + | "MOD5" -> `MOD5 + | "BUTTON1" -> `BUTTON1 + | "BUTTON2" -> `BUTTON2 + | "BUTTON3" -> `BUTTON3 + | "BUTTON4" -> `BUTTON4 + | "BUTTON5" -> `BUTTON5 + | "CONTROL" -> `CONTROL + | "LOCK" -> `LOCK + | "SHIFT" -> `SHIFT | s -> `MOD1 type pref = @@ -103,7 +103,7 @@ type pref = let use_default_doc_url = "(automatic)" -let (current:pref ref) = +let (current:pref ref) = ref { cmd_coqc = "coqc"; cmd_make = "make"; @@ -113,38 +113,38 @@ let (current:pref ref) = global_auto_revert = false; global_auto_revert_delay = 10000; - + auto_save = true; auto_save_delay = 10000; auto_save_name = "#","#"; - + encoding_use_locale = true; encoding_use_utf8 = false; encoding_manual = "ISO_8859-1"; automatic_tactics = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ]; - + modifier_for_navigation = [`CONTROL; `MOD1]; modifier_for_templates = [`CONTROL; `SHIFT]; modifier_for_tactics = [`CONTROL; `MOD1]; modifier_for_display = [`MOD1;`SHIFT]; modifiers_valid = [`SHIFT; `CONTROL; `MOD1]; - + cmd_browse = Flags.browser_cmd_fmt; cmd_editor = if Sys.os_type = "Win32" then "NOTEPAD %s" else "emacs %s"; - + (* text_font = Pango.Font.from_string "sans 12";*) text_font = Pango.Font.from_string "Monospace 10"; doc_url = Coq_config.wwwrefman; library_url = Coq_config.wwwstdlib; - + show_toolbar = true; contextual_menus_on_goal = true; window_width = 800; - window_height = 600; + window_height = 600; query_window_width = 600; query_window_height = 400; fold_delay_ms = 400; @@ -170,10 +170,10 @@ let contextual_menus_on_goal = ref (fun x -> ()) let resize_window = ref (fun () -> ()) let save_pref () = - (try GtkData.AccelMap.save accel_file + (try GtkData.AccelMap.save accel_file with _ -> ()); let p = !current in - try + try let add = Stringmap.add in let (++) x f = f x in Stringmap.empty ++ @@ -182,7 +182,7 @@ let save_pref () = add "cmd_coqmakefile" [p.cmd_coqmakefile] ++ add "cmd_coqdoc" [p.cmd_coqdoc] ++ add "global_auto_revert" [string_of_bool p.global_auto_revert] ++ - add "global_auto_revert_delay" + add "global_auto_revert_delay" [string_of_int p.global_auto_revert_delay] ++ add "auto_save" [string_of_bool p.auto_save] ++ add "auto_save_delay" [string_of_int p.auto_save_delay] ++ @@ -194,15 +194,15 @@ let save_pref () = add "automatic_tactics" p.automatic_tactics ++ add "cmd_print" [p.cmd_print] ++ - add "modifier_for_navigation" + add "modifier_for_navigation" (List.map mod_to_str p.modifier_for_navigation) ++ - add "modifier_for_templates" + add "modifier_for_templates" (List.map mod_to_str p.modifier_for_templates) ++ - add "modifier_for_tactics" + add "modifier_for_tactics" (List.map mod_to_str p.modifier_for_tactics) ++ - add "modifier_for_display" + add "modifier_for_display" (List.map mod_to_str p.modifier_for_display) ++ - add "modifiers_valid" + add "modifiers_valid" (List.map mod_to_str p.modifiers_valid) ++ add "cmd_browse" [p.cmd_browse] ++ add "cmd_editor" [p.cmd_editor] ++ @@ -212,7 +212,7 @@ let save_pref () = add "doc_url" [p.doc_url] ++ add "library_url" [p.library_url] ++ add "show_toolbar" [string_of_bool p.show_toolbar] ++ - add "contextual_menus_on_goal" + add "contextual_menus_on_goal" [string_of_bool p.contextual_menus_on_goal] ++ add "window_height" [string_of_int p.window_height] ++ add "window_width" [string_of_int p.window_width] ++ @@ -229,8 +229,8 @@ let save_pref () = let load_pref () = (try GtkData.AccelMap.load accel_file with _ -> ()); - let p = !current in - try + let p = !current in + try let m = Config_lexer.load_file pref_file in let np = { p with cmd_coqc = p.cmd_coqc } in let set k f = try let v = Stringmap.find k m in f v with _ -> () in @@ -238,7 +238,7 @@ let load_pref () = let set_bool k f = set_hd k (fun v -> f (bool_of_string v)) in let set_int k f = set_hd k (fun v -> f (int_of_string v)) in let set_pair k f = set k (function [v1;v2] -> f v1 v2 | _ -> raise Exit) in - let set_command_with_pair_compat k f = + let set_command_with_pair_compat k f = set k (function [v1;v2] -> f (v1^"%s"^v2) | [v] -> f v | _ -> raise Exit) in set_hd "cmd_coqc" (fun v -> np.cmd_coqc <- v); @@ -246,7 +246,7 @@ let load_pref () = set_hd "cmd_coqmakefile" (fun v -> np.cmd_coqmakefile <- v); set_hd "cmd_coqdoc" (fun v -> np.cmd_coqdoc <- v); set_bool "global_auto_revert" (fun v -> np.global_auto_revert <- v); - set_int "global_auto_revert_delay" + set_int "global_auto_revert_delay" (fun v -> np.global_auto_revert_delay <- v); set_bool "auto_save" (fun v -> np.auto_save <- v); set_int "auto_save_delay" (fun v -> np.auto_save_delay <- v); @@ -257,15 +257,15 @@ let load_pref () = set "automatic_tactics" (fun v -> np.automatic_tactics <- v); set_hd "cmd_print" (fun v -> np.cmd_print <- v); - set "modifier_for_navigation" + set "modifier_for_navigation" (fun v -> np.modifier_for_navigation <- List.map str_to_mod v); - set "modifier_for_templates" + set "modifier_for_templates" (fun v -> np.modifier_for_templates <- List.map str_to_mod v); - set "modifier_for_tactics" + set "modifier_for_tactics" (fun v -> np.modifier_for_tactics <- List.map str_to_mod v); - set "modifier_for_display" + set "modifier_for_display" (fun v -> np.modifier_for_display <- List.map str_to_mod v); - set "modifiers_valid" + set "modifiers_valid" (fun v -> np.modifiers_valid <- List.map str_to_mod v); set_command_with_pair_compat "cmd_browse" (fun v -> np.cmd_browse <- v); set_command_with_pair_compat "cmd_editor" (fun v -> np.cmd_editor <- v); @@ -276,7 +276,7 @@ let load_pref () = np.doc_url <- v); set_hd "library_url" (fun v -> np.library_url <- v); set_bool "show_toolbar" (fun v -> np.show_toolbar <- v); - set_bool "contextual_menus_on_goal" + set_bool "contextual_menus_on_goal" (fun v -> np.contextual_menus_on_goal <- v); set_int "window_width" (fun v -> np.window_width <- v); set_int "window_height" (fun v -> np.window_height <- v); @@ -292,38 +292,38 @@ let load_pref () = (* Format.printf "in load_pref: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) - with e -> + with e -> prerr_endline ("Could not load preferences ("^ (Printexc.to_string e)^").") - + let split_string_format s = - try + try let i = Util.string_index_from s 0 "%s" in let pre = (String.sub s 0 i) in let post = String.sub s (i+2) (String.length s - i - 2) in pre,post with Not_found -> s,"" -let configure ?(apply=(fun () -> ())) () = - let cmd_coqc = +let configure ?(apply=(fun () -> ())) () = + let cmd_coqc = string - ~f:(fun s -> !current.cmd_coqc <- s) + ~f:(fun s -> !current.cmd_coqc <- s) " coqc" !current.cmd_coqc in - let cmd_make = - string + let cmd_make = + string ~f:(fun s -> !current.cmd_make <- s) " make" !current.cmd_make in - let cmd_coqmakefile = - string + let cmd_coqmakefile = + string ~f:(fun s -> !current.cmd_coqmakefile <- s) "coqmakefile" !current.cmd_coqmakefile in - let cmd_coqdoc = - string + let cmd_coqdoc = + string ~f:(fun s -> !current.cmd_coqdoc <- s) " coqdoc" !current.cmd_coqdoc in - let cmd_print = - string - ~f:(fun s -> !current.cmd_print <- s) + let cmd_print = + string + ~f:(fun s -> !current.cmd_print <- s) " Print ps" !current.cmd_print in let config_font = @@ -332,15 +332,15 @@ let configure ?(apply=(fun () -> ())) () = w#set_preview_text "Goal (∃n : nat, n ≤ 0)∧(∀x,y,z, x∈y⋃z↔x∈y∨x∈z)."; box#pack w#coerce; - ignore (w#misc#connect#realize - ~callback:(fun () -> w#set_font_name + ignore (w#misc#connect#realize + ~callback:(fun () -> w#set_font_name (Pango.Font.to_string !current.text_font))); custom ~label:"Fonts for text" box - (fun () -> + (fun () -> let fd = w#font_name in - !current.text_font <- (Pango.Font.from_string fd) ; + !current.text_font <- (Pango.Font.from_string fd) ; (* Format.printf "in config_font: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) @@ -348,73 +348,73 @@ let configure ?(apply=(fun () -> ())) () = true in (* - let show_toolbar = - bool - ~f:(fun s -> - !current.show_toolbar <- s; - !show_toolbar s) + let show_toolbar = + bool + ~f:(fun s -> + !current.show_toolbar <- s; + !show_toolbar s) "Show toolbar" !current.show_toolbar in let window_height = string ~f:(fun s -> !current.window_height <- (try int_of_string s with _ -> 600); !resize_window (); - ) - "Window height" + ) + "Window height" (string_of_int !current.window_height) - in + in let window_width = string - ~f:(fun s -> !current.window_width <- - (try int_of_string s with _ -> 800)) - "Window width" + ~f:(fun s -> !current.window_width <- + (try int_of_string s with _ -> 800)) + "Window width" (string_of_int !current.window_width) - in + in *) - let auto_complete = - bool - ~f:(fun s -> - !current.auto_complete <- s; - !auto_complete s) + let auto_complete = + bool + ~f:(fun s -> + !current.auto_complete <- s; + !auto_complete s) "Auto Complete" !current.auto_complete in -(* let use_utf8_notation = - bool - ~f:(fun b -> +(* let use_utf8_notation = + bool + ~f:(fun b -> !current.use_utf8_notation <- b; - ) + ) "Use Unicode Notation: " !current.use_utf8_notation in -*) +*) (* let config_appearance = [show_toolbar; window_width; window_height] in *) - let global_auto_revert = - bool - ~f:(fun s -> !current.global_auto_revert <- s) + let global_auto_revert = + bool + ~f:(fun s -> !current.global_auto_revert <- s) "Enable global auto revert" !current.global_auto_revert in let global_auto_revert_delay = string - ~f:(fun s -> !current.global_auto_revert_delay <- - (try int_of_string s with _ -> 10000)) - "Global auto revert delay (ms)" + ~f:(fun s -> !current.global_auto_revert_delay <- + (try int_of_string s with _ -> 10000)) + "Global auto revert delay (ms)" (string_of_int !current.global_auto_revert_delay) - in + in - let auto_save = - bool - ~f:(fun s -> !current.auto_save <- s) + let auto_save = + bool + ~f:(fun s -> !current.auto_save <- s) "Enable auto save" !current.auto_save in let auto_save_delay = string - ~f:(fun s -> !current.auto_save_delay <- - (try int_of_string s with _ -> 10000)) - "Auto save delay (ms)" + ~f:(fun s -> !current.auto_save_delay <- + (try int_of_string s with _ -> 10000)) + "Auto save delay (ms)" (string_of_int !current.auto_save_delay) - in + in let fold_delay_ms = string @@ -429,7 +429,7 @@ let configure ?(apply=(fun () -> ())) () = ~f:(fun s -> !current.stop_before <- s) "Stop interpreting before the current point" !current.stop_before in - + let lax_syntax = bool ~f:(fun s -> !current.lax_syntax <- s) @@ -448,31 +448,31 @@ let configure ?(apply=(fun () -> ())) () = "Tabs on opposite side" !current.opposite_tabs in - let encodings = - combo + let encodings = + combo "File charset encoding " - ~f:(fun s -> + ~f:(fun s -> match s with - | "UTF-8" -> + | "UTF-8" -> !current.encoding_use_utf8 <- true; !current.encoding_use_locale <- false | "LOCALE" -> !current.encoding_use_utf8 <- false; !current.encoding_use_locale <- true - | _ -> + | _ -> !current.encoding_use_utf8 <- false; !current.encoding_use_locale <- false; !current.encoding_manual <- s; ) ~new_allowed: true ["UTF-8";"LOCALE";!current.encoding_manual] - (if !current.encoding_use_utf8 then "UTF-8" + (if !current.encoding_use_utf8 then "UTF-8" else if !current.encoding_use_locale then "LOCALE" else !current.encoding_manual) in - let help_string = + let help_string = "Press a set of modifiers and an extra key together (needs then a restart to apply!)" in - let modifier_for_tactics = + let modifier_for_tactics = modifiers ~allow:!current.modifiers_valid ~f:(fun l -> !current.modifier_for_tactics <- l) @@ -480,7 +480,7 @@ let configure ?(apply=(fun () -> ())) () = "Modifiers for Tactics Menu" !current.modifier_for_tactics in - let modifier_for_templates = + let modifier_for_templates = modifiers ~allow:!current.modifiers_valid ~f:(fun l -> !current.modifier_for_templates <- l) @@ -488,7 +488,7 @@ let configure ?(apply=(fun () -> ())) () = "Modifiers for Templates Menu" !current.modifier_for_templates in - let modifier_for_navigation = + let modifier_for_navigation = modifiers ~allow:!current.modifiers_valid ~f:(fun l -> !current.modifier_for_navigation <- l) @@ -496,7 +496,7 @@ let configure ?(apply=(fun () -> ())) () = "Modifiers for Navigation Menu" !current.modifier_for_navigation in - let modifier_for_display = + let modifier_for_display = modifiers ~allow:!current.modifiers_valid ~f:(fun l -> !current.modifier_for_display <- l) @@ -504,23 +504,23 @@ let configure ?(apply=(fun () -> ())) () = "Modifiers for Display Menu" !current.modifier_for_display in - let modifiers_valid = + let modifiers_valid = modifiers ~f:(fun l -> !current.modifiers_valid <- l) "Allowed modifiers" !current.modifiers_valid in - let cmd_editor = + let cmd_editor = let predefined = [ "emacs %s"; "vi %s"; "NOTEPAD %s" ] in combo - ~help:"(%s for file name)" + ~help:"(%s for file name)" "External editor" ~f:(fun s -> !current.cmd_editor <- s) ~new_allowed: true (predefined@[if List.mem !current.cmd_editor predefined then "" else !current.cmd_editor]) !current.cmd_editor - in + in let cmd_browse = let predefined = [ Coq_config.browser; @@ -530,15 +530,15 @@ let configure ?(apply=(fun () -> ())) () = "seamonkey -remote \"openURL(%s)\" || seamonkey %s &"; "open -a Safari %s &" ] in - combo - ~help:"(%s for url)" + combo + ~help:"(%s for url)" "Browser" ~f:(fun s -> !current.cmd_browse <- s) ~new_allowed: true (predefined@[if List.mem !current.cmd_browse predefined then "" else !current.cmd_browse]) !current.cmd_browse - in + in let doc_url = let predefined = [ use_default_doc_url @@ -550,7 +550,7 @@ let configure ?(apply=(fun () -> ())) () = (predefined@[if List.mem !current.doc_url predefined then "" else !current.doc_url]) !current.doc_url in - let library_url = + let library_url = let predefined = [ Coq_config.wwwstdlib ] in @@ -561,26 +561,26 @@ let configure ?(apply=(fun () -> ())) () = else !current.library_url]) !current.library_url in - let automatic_tactics = + let automatic_tactics = strings - ~f:(fun l -> !current.automatic_tactics <- l) + ~f:(fun l -> !current.automatic_tactics <- l) ~add:(fun () -> [""]) - "Wizard tactics to try in order" + "Wizard tactics to try in order" !current.automatic_tactics in let contextual_menus_on_goal = - bool - ~f:(fun s -> - !current.contextual_menus_on_goal <- s; - !contextual_menus_on_goal s) + bool + ~f:(fun s -> + !current.contextual_menus_on_goal <- s; + !contextual_menus_on_goal s) "Contextual menus on goal" !current.contextual_menus_on_goal - in + in let misc = [contextual_menus_on_goal;auto_complete;stop_before;lax_syntax; vertical_tabs;opposite_tabs] in - + (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! (shame on Benjamin) *) let cmds = @@ -590,7 +590,7 @@ let configure ?(apply=(fun () -> ())) () = [global_auto_revert;global_auto_revert_delay; auto_save; auto_save_delay; (* auto_save_name*) encodings; - ]); + ]); (* Section("Appearance", config_appearance); @@ -614,6 +614,6 @@ let configure ?(apply=(fun () -> ())) () = (* Format.printf "after edit: current.text_font = %s@." (Pango.Font.to_string !current.text_font); *) - match x with + match x with | Return_apply | Return_ok -> save_pref () | Return_cancel -> () diff --git a/ide/tags.ml b/ide/tags.ml index 89adad2c15..b0b9dc6fb3 100644 --- a/ide/tags.ml +++ b/ide/tags.ml @@ -38,7 +38,7 @@ struct let hypothesis = make_tag table ~name:"hypothesis" [] let goal = make_tag table ~name:"goal" [] end -module Message = +module Message = struct let table = GText.tag_table () let error = make_tag table ~name:"error" [`FOREGROUND "red"] diff --git a/ide/typed_notebook.ml b/ide/typed_notebook.ml index edc5c599c2..39e8155d3f 100644 --- a/ide/typed_notebook.ml +++ b/ide/typed_notebook.ml @@ -12,7 +12,7 @@ class ['a] typed_notebook default_build nb = object(self) inherit GPack.notebook nb as super val mutable term_list = [] - + method append_term ?(build=default_build) (term:'a) = let tab_label,menu_label,page = build term in (* XXX - Temporary hack to compile with archaic lablgtk *) diff --git a/ide/undo.ml b/ide/undo.ml index d2fe81e1df..18c2f7a4da 100644 --- a/ide/undo.ml +++ b/ide/undo.ml @@ -10,16 +10,16 @@ open GText open Ideutils -type action = - | Insert of string * int * int (* content*pos*length *) - | Delete of string * int * int (* content*pos*length *) +type action = + | Insert of string * int * int (* content*pos*length *) + | Delete of string * int * int (* content*pos*length *) let neg act = match act with | Insert (s,i,l) -> Delete (s,i,l) | Delete (s,i,l) -> Insert (s,i,l) class undoable_view (tv:[>Gtk.text_view] Gtk.obj) = - let undo_lock = ref true in + let undo_lock = ref true in object(self) inherit GText.view tv as super val history = (Stack.create () : action Stack.t) @@ -29,25 +29,25 @@ object(self) method private dump_debug = if false (* !debug *) then begin prerr_endline "==========Stack top============="; - Stack.iter + Stack.iter (fun e -> match e with | Insert(s,p,l) -> Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l - | Delete(s,p,l) -> + | Delete(s,p,l) -> Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l) history; Printf.eprintf "Stack size %d\n" (Stack.length history); prerr_endline "==========Stack Bottom=========="; prerr_endline "==========Queue start============="; - Queue.iter + Queue.iter (fun e -> match e with | Insert(s,p,l) -> Printf.eprintf "Insert of '%s' at %d (length %d)\n" s p l - | Delete(s,p,l) -> + | Delete(s,p,l) -> Printf.eprintf "Delete '%s' from %d (length %d)\n" s p l) redo; Printf.eprintf "Stack size %d\n" (Queue.length redo); - prerr_endline "==========Queue End==========" + prerr_endline "==========Queue End==========" end @@ -57,16 +57,16 @@ object(self) undo_lock := false; prerr_endline "UNDO"; try begin - let r = + let r = match Stack.pop history with - | Insert(s,p,l) as act -> + | Insert(s,p,l) as act -> let start = self#buffer#get_iter_at_char p in - (self#buffer#delete_interactive + (self#buffer#delete_interactive ~start ~stop:(start#forward_chars l) ()) or (Stack.push act history; false) - | Delete(s,p,l) as act -> + | Delete(s,p,l) as act -> let iter = self#buffer#get_iter_at_char p in (self#buffer#insert_interactive ~iter s) or (Stack.push act history; false) @@ -75,11 +75,11 @@ object(self) Queue.push act redo; Stack.push act nredo end; - undo_lock := true; + undo_lock := true; r end - with Stack.Empty -> - undo_lock := true; + with Stack.Empty -> + undo_lock := true; false end else (prerr_endline "UNDO DISCARDED"; true) @@ -97,7 +97,7 @@ object(self) end) ); *) - ignore (self#buffer#connect#insert_text + ignore (self#buffer#connect#insert_text ~callback: (fun it s -> if !undo_lock && not (Queue.is_empty redo) then begin @@ -107,18 +107,18 @@ object(self) Queue.clear redo; end; (* let pos = it#offset in - if Stack.is_empty history or + if Stack.is_empty history or s=" " or s="\t" or s="\n" or - (match Stack.top history with - | Insert(old,opos,olen) -> + (match Stack.top history with + | Insert(old,opos,olen) -> opos + olen <> pos | _ -> true) then *) Stack.push (Insert(s,it#offset,Glib.Utf8.length s)) history (*else begin match Stack.pop history with - | Insert(olds,offset,len) -> - Stack.push + | Insert(olds,offset,len) -> + Stack.push (Insert(olds^s, offset, len+(Glib.Utf8.length s))) @@ -129,7 +129,7 @@ object(self) )); ignore (self#buffer#connect#delete_range ~callback: - (fun ~start ~stop -> + (fun ~start ~stop -> if !undo_lock && not (Queue.is_empty redo) then begin Queue.iter (fun e -> Stack.push e history) redo; Queue.clear redo; @@ -138,12 +138,12 @@ object(self) let stop_offset = stop#offset in let s = self#buffer#get_text ~start ~stop () in (* if Stack.is_empty history or (match Stack.top history with - | Delete(old,opos,olen) -> + | Delete(old,opos,olen) -> olen=1 or opos <> start_offset | _ -> true ) then -*) Stack.push +*) Stack.push (Delete(s, start_offset, stop_offset - start_offset @@ -151,27 +151,27 @@ object(self) history (* else begin match Stack.pop history with - | Delete(olds,offset,len) -> - Stack.push + | Delete(olds,offset,len) -> + Stack.push (Delete(olds^s, offset, len+(Glib.Utf8.length s))) history | _ -> assert false - + end*); self#dump_debug )) end let undoable_view ?(buffer:GText.buffer option) = - GtkText.View.make_params [] - ~cont:(GContainer.pack_container + GtkText.View.make_params [] + ~cont:(GContainer.pack_container ~create: - (fun pl -> let w = match buffer with + (fun pl -> let w = match buffer with | None -> GtkText.View.create [] | Some b -> GtkText.View.create_with_buffer b#as_buffer in Gobject.set_params w pl; ((new undoable_view w):undoable_view))) - - + + diff --git a/ide/undo_lablgtk_ge212.mli b/ide/undo_lablgtk_ge212.mli index 916a06e92b..32717fa8e4 100644 --- a/ide/undo_lablgtk_ge212.mli +++ b/ide/undo_lablgtk_ge212.mli @@ -18,7 +18,7 @@ object method clear_undo : unit end -val undoable_view : +val undoable_view : ?buffer:GText.buffer -> ?editable:bool -> ?cursor_visible:bool -> diff --git a/ide/undo_lablgtk_ge26.mli b/ide/undo_lablgtk_ge26.mli index e949daafed..52bd67215c 100644 --- a/ide/undo_lablgtk_ge26.mli +++ b/ide/undo_lablgtk_ge26.mli @@ -18,7 +18,7 @@ object method clear_undo : unit end -val undoable_view : +val undoable_view : ?buffer:GText.buffer -> ?editable:bool -> ?cursor_visible:bool -> diff --git a/ide/undo_lablgtk_lt26.mli b/ide/undo_lablgtk_lt26.mli index 82bcf2384d..46ecfb1d7c 100644 --- a/ide/undo_lablgtk_lt26.mli +++ b/ide/undo_lablgtk_lt26.mli @@ -18,7 +18,7 @@ object method clear_undo : unit end -val undoable_view : +val undoable_view : ?buffer:GText.buffer -> ?editable:bool -> ?cursor_visible:bool -> diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll index c6e4b803b6..82b3053479 100644 --- a/ide/utf8_convert.mll +++ b/ide/utf8_convert.mll @@ -9,7 +9,7 @@ (* $Id$ *) { - open Lexing + open Lexing let b = Buffer.create 127 } @@ -24,16 +24,16 @@ rule entry = parse | "\\x{" (short | long ) '}' { let s = lexeme lexbuf in let n = String.length s in - let code = - try Glib.Utf8.from_unichar - (int_of_string ("0x"^(String.sub s 3 (n - 4)))) + let code = + try Glib.Utf8.from_unichar + (int_of_string ("0x"^(String.sub s 3 (n - 4)))) with _ -> s in let c = if Glib.Utf8.validate code then code else s in Buffer.add_string b c; entry lexbuf } - | _ + | _ { let s = lexeme lexbuf in Buffer.add_string b s; entry lexbuf} diff --git a/ide/utils/configwin.mli b/ide/utils/configwin.mli index 2d4dd4a786..386ef82afa 100644 --- a/ide/utils/configwin.mli +++ b/ide/utils/configwin.mli @@ -248,7 +248,7 @@ val hotkey : ?editable: bool -> ?expand: bool -> ?help: string -> val modifiers : ?editable: bool -> ?expand: bool -> ?help: string -> ?allow:(Gdk.Tags.modifier list) -> - ?f: (Gdk.Tags.modifier list -> unit) -> + ?f: (Gdk.Tags.modifier list -> unit) -> string -> Gdk.Tags.modifier list -> parameter_kind (** [custom box f expand] creates a custom parameter, with diff --git a/ide/utils/configwin_ihm.ml b/ide/utils/configwin_ihm.ml index 3ab3823de3..ff74a3c331 100644 --- a/ide/utils/configwin_ihm.ml +++ b/ide/utils/configwin_ihm.ml @@ -810,13 +810,13 @@ class modifiers_param_box param = () in let value = ref param.md_value in - let _ = + let _ = match param.md_help with None -> () | Some help -> let tooltips = GData.tooltips () in ignore (hbox#connect#destroy ~callback: tooltips#destroy); - tooltips#set_tip wev#coerce ~text: help ~privat: help + tooltips#set_tip wev#coerce ~text: help ~privat: help in let _ = we#set_text (Configwin_types.modifiers_to_string param.md_value) in let mods_we_care = param.md_allow in @@ -830,7 +830,7 @@ class modifiers_param_box param = we#set_text (Configwin_types.modifiers_to_string !value); false in - let _ = + let _ = if param.md_editable then ignore (we#event#connect#key_press capture) else @@ -1093,13 +1093,13 @@ let edit ?(with_apply=true) (fun conf_struct -> new configuration_box tooltips conf_struct wnote) conf_struct_list in - + if with_apply then dialog#add_button Configwin_messages.mApply `APPLY; - + dialog#add_button Configwin_messages.mOk `OK; dialog#add_button Configwin_messages.mCancel `CANCEL; - + let f_apply () = List.iter (fun param_box -> param_box#apply) list_param_box ; apply () @@ -1441,11 +1441,11 @@ let hotkey ?(editable=true) ?(expand=true) ?help ?(f=(fun _ -> ())) label v = hk_expand = expand ; } -let modifiers - ?(editable=true) - ?(expand=true) - ?help - ?(allow=[`CONTROL;`SHIFT;`LOCK;`MOD1;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5]) +let modifiers + ?(editable=true) + ?(expand=true) + ?help + ?(allow=[`CONTROL;`SHIFT;`LOCK;`MOD1;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5]) ?(f=(fun _ -> ())) label v = Modifiers_param { @@ -1456,7 +1456,7 @@ let modifiers md_f_apply = f ; md_expand = expand ; md_allow = allow ; - } + } (** Create a custom param.*) let custom ?label box f expand = diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml index e1d7f33bbd..9f44e5c6be 100644 --- a/ide/utils/configwin_keys.ml +++ b/ide/utils/configwin_keys.ml @@ -25,7 +25,7 @@ (** Key codes - Ce fichier provient de X11/keysymdef.h + Ce fichier provient de X11/keysymdef.h les noms des symboles deviennent : XK_ -> xk_ Thanks to Fabrice Le Fessant. @@ -1334,11 +1334,11 @@ let xk_Thai_khokhai = 0xda2 let xk_Thai_khokhuat = 0xda3 let xk_Thai_khokhwai = 0xda4 let xk_Thai_khokhon = 0xda5 -let xk_Thai_khorakhang = 0xda6 -let xk_Thai_ngongu = 0xda7 -let xk_Thai_chochan = 0xda8 -let xk_Thai_choching = 0xda9 -let xk_Thai_chochang = 0xdaa +let xk_Thai_khorakhang = 0xda6 +let xk_Thai_ngongu = 0xda7 +let xk_Thai_chochan = 0xda8 +let xk_Thai_choching = 0xda9 +let xk_Thai_chochang = 0xdaa let xk_Thai_soso = 0xdab let xk_Thai_chochoe = 0xdac let xk_Thai_yoying = 0xdad @@ -1380,39 +1380,39 @@ let xk_Thai_saraa = 0xdd0 let xk_Thai_maihanakat = 0xdd1 let xk_Thai_saraaa = 0xdd2 let xk_Thai_saraam = 0xdd3 -let xk_Thai_sarai = 0xdd4 -let xk_Thai_saraii = 0xdd5 -let xk_Thai_saraue = 0xdd6 -let xk_Thai_sarauee = 0xdd7 -let xk_Thai_sarau = 0xdd8 -let xk_Thai_sarauu = 0xdd9 +let xk_Thai_sarai = 0xdd4 +let xk_Thai_saraii = 0xdd5 +let xk_Thai_saraue = 0xdd6 +let xk_Thai_sarauee = 0xdd7 +let xk_Thai_sarau = 0xdd8 +let xk_Thai_sarauu = 0xdd9 let xk_Thai_phinthu = 0xdda let xk_Thai_maihanakat_maitho = 0xdde let xk_Thai_baht = 0xddf -let xk_Thai_sarae = 0xde0 +let xk_Thai_sarae = 0xde0 let xk_Thai_saraae = 0xde1 let xk_Thai_sarao = 0xde2 -let xk_Thai_saraaimaimuan = 0xde3 -let xk_Thai_saraaimaimalai = 0xde4 +let xk_Thai_saraaimaimuan = 0xde3 +let xk_Thai_saraaimaimalai = 0xde4 let xk_Thai_lakkhangyao = 0xde5 let xk_Thai_maiyamok = 0xde6 let xk_Thai_maitaikhu = 0xde7 -let xk_Thai_maiek = 0xde8 +let xk_Thai_maiek = 0xde8 let xk_Thai_maitho = 0xde9 let xk_Thai_maitri = 0xdea let xk_Thai_maichattawa = 0xdeb let xk_Thai_thanthakhat = 0xdec let xk_Thai_nikhahit = 0xded -let xk_Thai_leksun = 0xdf0 -let xk_Thai_leknung = 0xdf1 -let xk_Thai_leksong = 0xdf2 +let xk_Thai_leksun = 0xdf0 +let xk_Thai_leknung = 0xdf1 +let xk_Thai_leksong = 0xdf2 let xk_Thai_leksam = 0xdf3 -let xk_Thai_leksi = 0xdf4 -let xk_Thai_lekha = 0xdf5 -let xk_Thai_lekhok = 0xdf6 -let xk_Thai_lekchet = 0xdf7 -let xk_Thai_lekpaet = 0xdf8 -let xk_Thai_lekkao = 0xdf9 +let xk_Thai_leksi = 0xdf4 +let xk_Thai_lekha = 0xdf5 +let xk_Thai_lekhok = 0xdf6 +let xk_Thai_lekchet = 0xdf7 +let xk_Thai_lekpaet = 0xdf8 +let xk_Thai_lekkao = 0xdf9 (* diff --git a/ide/utils/configwin_types.ml b/ide/utils/configwin_types.ml index 0def0b25d2..bf2b74ee63 100644 --- a/ide/utils/configwin_types.ml +++ b/ide/utils/configwin_types.ml @@ -111,7 +111,7 @@ let modifiers_to_string m = ) ^ s) in iter m "" - + let value_to_key v = match v with Raw.String s -> string_to_key s @@ -233,7 +233,7 @@ type hotkey_param = { type modifiers_param = { md_label : string ; (** the label of the parameter *) - mutable md_value : Gdk.Tags.modifier list ; + mutable md_value : Gdk.Tags.modifier list ; (** The value, as a list of modifiers and a key code *) md_editable : bool ; (** indicates if the value can be changed *) md_f_apply : Gdk.Tags.modifier list -> unit ; @@ -241,7 +241,7 @@ type modifiers_param = { md_help : string option ; (** optional help string *) md_expand : bool ; (** expand or not *) md_allow : Gdk.Tags.modifier list - } + } let mk_custom_text_string_param (a : 'a string_param) : string string_param = diff --git a/ide/utils/editable_cells.ml b/ide/utils/editable_cells.ml index 5441f4abe0..1ab107c778 100644 --- a/ide/utils/editable_cells.ml +++ b/ide/utils/editable_cells.ml @@ -1,21 +1,21 @@ open GTree open Gobject -let create l = +let create l = let hbox = GPack.hbox () in - let scw = GBin.scrolled_window - ~hpolicy:`AUTOMATIC - ~vpolicy:`AUTOMATIC + let scw = GBin.scrolled_window + ~hpolicy:`AUTOMATIC + ~vpolicy:`AUTOMATIC ~packing:(hbox#pack ~expand:true) () in let columns = new GTree.column_list in let command_col = columns#add Data.string in let coq_col = columns#add Data.string in let store = GTree.list_store columns - in + in (* populate the store *) - let _ = List.iter (fun (x,y) -> + let _ = List.iter (fun (x,y) -> let row = store#append () in store#set ~row ~column:command_col x; store#set ~row ~column:coq_col y) @@ -27,61 +27,61 @@ let create l = view#set_rules_hint true; let renderer_comm = GTree.cell_renderer_text [`EDITABLE true] in - ignore (renderer_comm#connect#edited - ~callback:(fun (path:Gtk.tree_path) (s:string) -> - store#set - ~row:(store#get_iter path) + ignore (renderer_comm#connect#edited + ~callback:(fun (path:Gtk.tree_path) (s:string) -> + store#set + ~row:(store#get_iter path) ~column:command_col s)); - let first = - GTree.view_column ~title:"Coq Command to try" - ~renderer:(renderer_comm,["text",command_col]) - () + let first = + GTree.view_column ~title:"Coq Command to try" + ~renderer:(renderer_comm,["text",command_col]) + () in ignore (view#append_column first); let renderer_coq = GTree.cell_renderer_text [`EDITABLE true] in ignore(renderer_coq#connect#edited - ~callback:(fun (path:Gtk.tree_path) (s:string) -> - store#set - ~row:(store#get_iter path) + ~callback:(fun (path:Gtk.tree_path) (s:string) -> + store#set + ~row:(store#get_iter path) ~column:coq_col s)); - let second = - GTree.view_column ~title:"Coq Command to insert" - ~renderer:(renderer_coq,["text",coq_col]) - () + let second = + GTree.view_column ~title:"Coq Command to insert" + ~renderer:(renderer_coq,["text",coq_col]) + () in ignore (view#append_column second); - let vbox = GPack.button_box `VERTICAL ~packing:hbox#pack ~layout:`SPREAD () + let vbox = GPack.button_box `VERTICAL ~packing:hbox#pack ~layout:`SPREAD () in let up = GButton.button ~stock:`GO_UP ~label:"Up" ~packing:(vbox#pack ~expand:true ~fill:false) () in - let down = GButton.button - ~stock:`GO_DOWN - ~label:"Down" - ~packing:(vbox#pack ~expand:true ~fill:false) () + let down = GButton.button + ~stock:`GO_DOWN + ~label:"Down" + ~packing:(vbox#pack ~expand:true ~fill:false) () in - let add = GButton.button ~stock:`ADD - ~label:"Add" - ~packing:(vbox#pack ~expand:true ~fill:false) - () + let add = GButton.button ~stock:`ADD + ~label:"Add" + ~packing:(vbox#pack ~expand:true ~fill:false) + () in - let remove = GButton.button ~stock:`REMOVE - ~label:"Remove" - ~packing:(vbox#pack ~expand:true ~fill:false) () + let remove = GButton.button ~stock:`REMOVE + ~label:"Remove" + ~packing:(vbox#pack ~expand:true ~fill:false) () in - ignore (add#connect#clicked - ~callback:(fun b -> + ignore (add#connect#clicked + ~callback:(fun b -> let n = store#append () in view#selection#select_iter n)); - ignore (remove#connect#clicked - ~callback:(fun b -> match view#selection#get_selected_rows with + ignore (remove#connect#clicked + ~callback:(fun b -> match view#selection#get_selected_rows with | [] -> () | path::_ -> let iter = store#get_iter path in ignore (store#remove iter); )); - ignore (up#connect#clicked - ~callback:(fun b -> - match view#selection#get_selected_rows with + ignore (up#connect#clicked + ~callback:(fun b -> + match view#selection#get_selected_rows with | [] -> () | path::_ -> let iter = store#get_iter path in @@ -89,9 +89,9 @@ let create l = let upiter = store#get_iter path in ignore (store#swap iter upiter); )); - ignore (down#connect#clicked - ~callback:(fun b -> - match view#selection#get_selected_rows with + ignore (down#connect#clicked + ~callback:(fun b -> + match view#selection#get_selected_rows with | [] -> () | path::_ -> let iter = store#get_iter path in @@ -100,13 +100,13 @@ let create l = ignore (store#swap iter upiter) with _ -> () )); - let get_data () = + let get_data () = let start_path = GtkTree.TreePath.from_string "0" in let start_iter = store#get_iter start_path in - let rec all acc = + let rec all acc = let new_acc = (store#get ~row:start_iter ~column:command_col, store#get ~row:start_iter ~column:coq_col)::acc - in + in if store#iter_next start_iter then all new_acc else List.rev new_acc in all [] in diff --git a/ide/utils/okey.mli b/ide/utils/okey.mli index c8d48389c2..84ea4df449 100644 --- a/ide/utils/okey.mli +++ b/ide/utils/okey.mli @@ -23,7 +23,7 @@ (* *) (*********************************************************************************) -(** Okey interface. +(** Okey interface. Once the lib is compiled and installed, you can use it by referencing it with the [Okey] module. You must add [okey.cmo] or [okey.cmx] @@ -35,7 +35,7 @@ type modifier = Gdk.Tags.modifier (** Set the default modifier list. The first default value is [[]].*) val set_default_modifiers : modifier list -> unit -(** Set the default modifier mask. The first default value is +(** Set the default modifier mask. The first default value is [[`MOD2 ; `MOD3 ; `MOD4 ; `MOD5 ; `LOCK]]. The mask defines the modifiers not taken into account when looking for the handler of a key press event. @@ -48,67 +48,67 @@ val set_default_mask : modifier list -> unit @param remove when true, the previous handlers for the given key and modifier list are not kept. @param cond this function is a guard: the [callback] function is not called - if the [cond] function returns [false]. + if the [cond] function returns [false]. The default [cond] function always returns [true]. @param mods the list of modifiers. If not given, the default modifiers - are used. + are used. You can set the default modifiers with function {!Okey.set_default_modifiers}. @param mask the list of modifiers which must not be taken into account to trigger the given handler. [mods] and [mask] must not have common modifiers. If not given, the default mask - is used. + is used. You can set the default modifiers mask with function {!Okey.set_default_mask}. *) val add : < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym -> - (unit -> unit) -> + event : GObj.event_ops; get_oid : int; .. > -> + ?cond: (unit -> bool) -> + ?mods: modifier list -> + ?mask: modifier list -> + Gdk.keysym -> + (unit -> unit) -> unit (** It calls {!Okey.add} for each given key.*) -val add_list : +val add_list : < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym list -> - (unit -> unit) -> + event : GObj.event_ops; get_oid : int; .. > -> + ?cond: (unit -> bool) -> + ?mods: modifier list -> + ?mask: modifier list -> + Gdk.keysym list -> + (unit -> unit) -> unit - + (** Like {!Okey.add} but the previous handlers for the given modifiers and key are not kept.*) val set : < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; - event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym -> - (unit -> unit) -> + event : GObj.event_ops; get_oid : int; .. > -> + ?cond: (unit -> bool) -> + ?mods: modifier list -> + ?mask: modifier list -> + Gdk.keysym -> + (unit -> unit) -> unit (** It calls {!Okey.set} for each given key.*) -val set_list : +val set_list : < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; event : GObj.event_ops; get_oid : int; .. > -> - ?cond: (unit -> bool) -> - ?mods: modifier list -> - ?mask: modifier list -> - Gdk.keysym list -> - (unit -> unit) -> + ?cond: (unit -> bool) -> + ?mods: modifier list -> + ?mask: modifier list -> + Gdk.keysym list -> + (unit -> unit) -> unit (** Remove the handlers associated to the given widget. This is automatically done when a widget is destroyed but you can do it yourself. *) -val remove_widget : +val remove_widget : < connect : < destroy : callback: (unit -> unit) -> GtkSignal.id; .. >; event : GObj.event_ops; get_oid : int; .. > -> unit -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 0d2fecfa25..0e61905c7c 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -266,8 +266,8 @@ let rec same_raw c d = | r1, RCast(_,c2,_) -> same_raw r1 c2 | RDynamic(_,d1), RDynamic(_,d2) -> if d1<>d2 then failwith"RDynamic" | _ -> failwith "same_raw" - -let same_rawconstr c d = + +let same_rawconstr c d = try same_raw c d; true with Failure _ | Invalid_argument _ -> false @@ -292,12 +292,12 @@ let expand_curly_brackets loc mknot ntn (l,ll) = function | [] -> [] | a::l -> - let a' = + let a' = let p = List.nth (wildcards !ntn' 0) i - 2 in if p>=0 & p+5 <= String.length !ntn' & String.sub !ntn' p 5 = "{ _ }" then begin - ntn' := - String.sub !ntn' 0 p ^ "_" ^ + ntn' := + String.sub !ntn' 0 p ^ "_" ^ String.sub !ntn' (p+5) (String.length !ntn' -p-5); mknot (loc,"{ _ }",([a],[])) end else a in @@ -316,7 +316,7 @@ let make_notation_gen loc ntn mknot mkprim destprim l = (* Special case to avoid writing "- 3" for e.g. (Zopp 3) *) | "- _", [Some (Numeral p)],[] when Bigint.is_strictly_pos p -> mknot (loc,ntn,([mknot (loc,"( _ )",l)],[])) - | _ -> + | _ -> match decompose_notation_key ntn, l with | [Terminal "-"; Terminal x], ([],[]) -> (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x))) @@ -374,14 +374,14 @@ let match_aconstr_cases_pattern c ((metas_scl,metaslist_scl),pat) = let subst,substlist = match_cases_pattern vars ([],[]) c pat in (* Reorder canonically the substitution *) let find x subst = - try List.assoc x subst + try List.assoc x subst with Not_found -> anomaly "match_aconstr_cases_pattern" in List.map (fun (x,scl) -> (find x subst,scl)) metas_scl, List.map (fun (x,scl) -> (find x substlist,scl)) metaslist_scl (* Better to use extern_rawconstr composed with injection/retraction ?? *) let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = - try + try if !Flags.raw_print or !print_no_symbol then raise No_match; let (na,sc,p) = uninterp_prim_token_cases_pattern pat in match availability_of_prim_token sc scopes with @@ -390,20 +390,20 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = let loc = cases_pattern_loc pat in insert_pat_alias loc (insert_pat_delimiters loc (CPatPrim(loc,p)) key) na with No_match -> - try + try if !Flags.raw_print or !print_no_symbol then raise No_match; extern_symbol_pattern scopes vars pat (uninterp_cases_pattern_notations pat) with No_match -> match pat with | PatVar (loc,Name id) -> CPatAtom (loc,Some (Ident (loc,id))) - | PatVar (loc,Anonymous) -> CPatAtom (loc, None) + | PatVar (loc,Anonymous) -> CPatAtom (loc, None) | PatCstr(loc,cstrsp,args,na) -> let args = List.map (extern_cases_pattern_in_scope scopes vars) args in let p = CPatCstr (loc,extern_reference loc vars (ConstructRef cstrsp),args) in insert_pat_alias loc p na - + and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> @@ -434,7 +434,7 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function let subscope = (scopt,scl@scopes') in List.map (extern_cases_pattern_in_scope subscope vars) c) substlist in - insert_pat_delimiters loc + insert_pat_delimiters loc (make_pat_notation loc ntn (l,ll)) key) | SynDefRule kn -> let qid = shortest_qualid_of_syndef vars kn in @@ -443,7 +443,7 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function with No_match -> extern_symbol_pattern allscopes vars t rules -let extern_cases_pattern vars p = +let extern_cases_pattern vars p = extern_cases_pattern_in_scope (None,[]) vars p (**********************************************************************) @@ -456,7 +456,7 @@ let occur_name na aty = let is_projection nargs = function | Some r when not !Flags.raw_print & !print_projections -> - (try + (try let n = Recordops.find_projection_nparams r + 1 in if n <= nargs then Some n else None with Not_found -> None) @@ -476,13 +476,13 @@ let explicitize loc inctx impl (cf,f) args = let tail = exprec (q+1) (args,impl) in let visible = !Flags.raw_print or - (!print_implicits & !print_implicits_explicit_args) or + (!print_implicits & !print_implicits_explicit_args) or (!print_implicits_defensive & is_significant_implicit a impl tail & not (is_inferable_implicit inctx n imp)) in - if visible then - (a,Some (dummy_loc, ExplByName (name_of_implicit imp))) :: tail + if visible then + (a,Some (dummy_loc, ExplByName (name_of_implicit imp))) :: tail else tail | a::args, _::impl -> (a,None) :: exprec (q+1) (args,impl) @@ -499,7 +499,7 @@ let explicitize loc inctx impl (cf,f) args = let args1 = exprec 1 (args1,impl1) in let args2 = exprec (i+1) (args2,impl2) in CApp (loc,(Some (List.length args1),f),args1@args2) - | None -> + | None -> let args = exprec 1 (args,impl) in if args = [] then f else CApp (loc, (None, f), args) @@ -513,11 +513,11 @@ let extern_app loc inctx impl (cf,f) args = if args = [] (* maybe caused by a hidden coercion *) then extern_global loc impl f else - if + if ((!Flags.raw_print or (!print_implicits & not !print_implicits_explicit_args)) & List.exists is_status_implicit impl) - then + then CAppExpl (loc, (is_projection (List.length args) cf, f), args) else explicitize loc inctx impl (cf,CRef f) args @@ -538,7 +538,7 @@ let rec remove_coercions inctx = function let nargs = List.length args in (try match Classops.hide_coercion r with | Some n when n < nargs && (inctx or n+1 < nargs) -> - (* We skip a coercion *) + (* We skip a coercion *) let l = list_skipn n args in let (a,l) = match l with a::l -> (a,l) | [] -> assert false in (* Recursively remove the head coercions *) @@ -591,11 +591,11 @@ let extern_rawsort = function let rec extern inctx scopes vars r = let r' = remove_coercions inctx r in - try + try if !Flags.raw_print or !print_no_symbol then raise No_match; extern_optimal_prim_token scopes r r' with No_match -> - try + try if !Flags.raw_print or !print_no_symbol then raise No_match; extern_symbol scopes vars r' (uninterp_notations r') with No_match -> match r' with @@ -622,7 +622,7 @@ let rec extern inctx scopes vars r = extern_app loc inctx (implicits_of_global ref) (Some ref,extern_reference rloc vars ref) args - | _ -> + | _ -> explicitize loc inctx [] (None,sub_extern false scopes vars f) (List.map (sub_extern true scopes vars) args)) @@ -643,15 +643,15 @@ let rec extern inctx scopes vars r = let t = extern_typ scopes vars (anonymize_if_reserved na t) in let (idl,c) = factorize_lambda inctx scopes (add_vname vars na) t c in CLambdaN (loc,[(dummy_loc,na)::idl,Default bk,t],c) - + | RCases (loc,sty,rtntypopt,tml,eqns) -> - let vars' = + let vars' = List.fold_right (name_fold Idset.add) (cases_predicate_names tml) vars in let rtntypopt' = Option.map (extern_typ scopes vars') rtntypopt in let tml = List.map (fun (tm,(na,x)) -> let na' = match na,tm with - Anonymous, RVar (_,id) when + Anonymous, RVar (_,id) when rtntypopt<>None & occur_rawconstr id (Option.get rtntypopt) -> Some Anonymous | Anonymous, _ -> None @@ -662,11 +662,11 @@ let rec extern inctx scopes vars r = let params = list_tabulate (fun _ -> RHole (dummy_loc,Evd.InternalHole)) n in let args = List.map (function - | Anonymous -> RHole (dummy_loc,Evd.InternalHole) + | Anonymous -> RHole (dummy_loc,Evd.InternalHole) | Name id -> RVar (dummy_loc,id)) nal in let t = RApp (dummy_loc,RRef (dummy_loc,IndRef ind),params@args) in (extern_typ scopes vars t)) x))) tml in - let eqns = List.map (extern_eqn inctx scopes vars) eqns in + let eqns = List.map (extern_eqn inctx scopes vars) eqns in CCases (loc,sty,rtntypopt',tml,eqns) | RLetTuple (loc,nal,(na,typopt),tm,b) -> @@ -686,23 +686,23 @@ let rec extern inctx scopes vars r = let vars' = Array.fold_right Idset.add idv vars in (match fk with | RFix (nv,n) -> - let listdecl = + let listdecl = Array.mapi (fun i fi -> let (bl,ty,def) = blv.(i), tyv.(i), bv.(i) in let (ids,bl) = extern_local_binder scopes vars bl in let vars0 = List.fold_right (name_fold Idset.add) ids vars in let vars1 = List.fold_right (name_fold Idset.add) ids vars' in - let n = + let n = match fst nv.(i) with | None -> None | Some x -> Some (dummy_loc, out_name (List.nth ids x)) - in + in let ro = extern_recursion_order scopes vars (snd nv.(i)) in ((dummy_loc, fi), (n, ro), bl, extern_typ scopes vars0 ty, extern false scopes vars1 def)) idv - in + in CFix (loc,(loc,idv.(n)),Array.to_list listdecl) - | RCoFix n -> + | RCoFix n -> let listdecl = Array.mapi (fun i fi -> let (ids,bl) = extern_local_binder scopes vars blv.(i) in @@ -724,13 +724,13 @@ let rec extern inctx scopes vars r = | RDynamic (loc,d) -> CDynamic (loc,d) -and extern_typ (_,scopes) = +and extern_typ (_,scopes) = extern true (Some Notation.type_scope,scopes) and sub_extern inctx (_,scopes) = extern inctx (None,scopes) and factorize_prod scopes vars aty c = - try + try if !Flags.raw_print or !print_no_symbol then raise No_match; ([],extern_symbol scopes vars c (uninterp_notations c)) with No_match -> match c with @@ -742,7 +742,7 @@ and factorize_prod scopes vars aty c = | c -> ([],extern_typ scopes vars c) and factorize_lambda inctx scopes vars aty c = - try + try if !Flags.raw_print or !print_no_symbol then raise No_match; ([],extern_symbol scopes vars c (uninterp_notations c)) with No_match -> match c with @@ -761,7 +761,7 @@ and extern_local_binder scopes vars = function extern_local_binder scopes (name_fold Idset.add na vars) l in (na::ids, LocalRawDef((dummy_loc,na), extern false scopes vars bd) :: l) - + | (na,bk,None,ty)::l -> let ty = extern_typ scopes vars (anonymize_if_reserved na ty) in (match extern_local_binder scopes (name_fold Idset.add na vars) l with @@ -822,7 +822,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function subst in let a = CRef (Qualid (loc, shortest_qualid_of_syndef vars kn)) in if l = [] then a else CApp (loc,(None,a),l) in - if args = [] then e + if args = [] then e else (* TODO: compute scopt for the extra args, in case, head is a ref *) explicitize loc false [] (None,e) @@ -833,7 +833,7 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function and extern_recursion_order scopes vars = function RStructRec -> CStructRec | RWfRec c -> CWfRec (extern true scopes vars c) - | RMeasureRec (m,r) -> CMeasureRec (extern true scopes vars m, + | RMeasureRec (m,r) -> CMeasureRec (extern true scopes vars m, Option.map (extern true scopes vars) r) @@ -895,7 +895,7 @@ let rec raw_of_pat env = function | PLambda (na,t,c) -> RLambda (loc,na,Explicit,raw_of_pat env t, raw_of_pat (na::env) c) | PIf (c,b1,b2) -> - RIf (loc, raw_of_pat env c, (Anonymous,None), + RIf (loc, raw_of_pat env c, (Anonymous,None), raw_of_pat env b1, raw_of_pat env b2) | PCase ((LetStyle,[|n|],ind,None),PMeta None,tm,[|b|]) -> let nal,b = it_destRLambda_or_LetIn_names n (raw_of_pat env b) in @@ -910,7 +910,7 @@ let rec raw_of_pat env = function let mat = simple_cases_matrix_of_branches ind brns brs in let indnames,rtn = if p = PMeta None then (Anonymous,None),None - else + else let nparams,n = Option.get ind_nargs in return_type_of_predicate ind nparams n (raw_of_pat env p) in RCases (loc,RegularStyle,rtn,[raw_of_pat env tm,indnames],mat) @@ -926,22 +926,22 @@ and raw_of_eqn env constr construct_nargs branch = in let rec buildrec ids patlist env n b = if n=0 then - (dummy_loc, ids, + (dummy_loc, ids, [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)], raw_of_pat env b) else match b with - | PLambda (x,_,b) -> + | PLambda (x,_,b) -> let pat,new_env,new_ids = make_pat x env b ids in buildrec new_ids (pat::patlist) new_env (n-1) b - | PLetIn (x,_,b) -> + | PLetIn (x,_,b) -> let pat,new_env,new_ids = make_pat x env b ids in buildrec new_ids (pat::patlist) new_env (n-1) b | _ -> error "Unsupported branch in case-analysis while printing pattern." - in + in buildrec [] [] env construct_nargs branch let extern_constr_pattern env pat = diff --git a/interp/constrextern.mli b/interp/constrextern.mli index a56923fe5f..08a74e6147 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -34,7 +34,7 @@ val extern_rawconstr : Idset.t -> rawconstr -> constr_expr val extern_rawtype : Idset.t -> rawconstr -> constr_expr val extern_constr_pattern : names_context -> constr_pattern -> constr_expr -(* If [b=true] in [extern_constr b env c] then the variables in the first +(* If [b=true] in [extern_constr b env c] then the variables in the first level of quantification clashing with the variables in [env] are renamed *) val extern_constr : bool -> env -> constr -> constr_expr @@ -42,7 +42,7 @@ val extern_constr_in_scope : bool -> scope_name -> env -> constr -> constr_expr val extern_reference : loc -> Idset.t -> global_reference -> reference val extern_type : bool -> env -> types -> constr_expr val extern_sort : sorts -> rawsort -val extern_rel_context : constr option -> env -> +val extern_rel_context : constr option -> env -> rel_context -> local_binder list (* Printing options *) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index e4e625205b..e49f219af3 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -75,7 +75,7 @@ let explain_not_a_constructor ref = str "Unknown constructor: " ++ pr_reference ref let explain_unbound_fix_name is_cofix id = - str "The name" ++ spc () ++ pr_id id ++ + str "The name" ++ spc () ++ pr_id id ++ spc () ++ str "is not bound in the corresponding" ++ spc () ++ str (if is_cofix then "co" else "") ++ str "fixpoint definition" @@ -92,13 +92,13 @@ let explain_bad_explicitation_number n po = let s = match po with | None -> str "a regular argument" | Some p -> int p in - str "Bad explicitation number: found " ++ int n ++ + str "Bad explicitation number: found " ++ int n ++ str" but was expecting " ++ s | ExplByName id -> let s = match po with | None -> str "a regular argument" | Some p -> (*pr_id (name_of_position p) in*) failwith "" in - str "Bad explicitation name: found " ++ pr_id id ++ + str "Bad explicitation name: found " ++ pr_id id ++ str" but was expecting " ++ s let explain_internalisation_error e = @@ -114,7 +114,7 @@ let explain_internalisation_error e = pp ++ str "." let error_bad_inductive_type loc = - user_err_loc (loc,"",str + user_err_loc (loc,"",str "This should be an inductive type applied to names or \"_\".") let error_inductive_parameter_not_implicit loc = @@ -135,8 +135,8 @@ and spaces ntn n = let expand_notation_string ntn n = let pos = List.nth (wildcards ntn 0) n in let hd = if pos = 0 then "" else String.sub ntn 0 pos in - let tl = - if pos = String.length ntn then "" + let tl = + if pos = String.length ntn then "" else String.sub ntn (pos+1) (String.length ntn - pos -1) in hd ^ "{ _ }" ^ tl @@ -146,7 +146,7 @@ let contract_notation ntn (l,ll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | CNotation (_,"{ _ }",([a],[])) :: l -> + | CNotation (_,"{ _ }",([a],[])) :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> @@ -159,7 +159,7 @@ let contract_pat_notation ntn (l,ll) = let ntn' = ref ntn in let rec contract_squash n = function | [] -> [] - | CPatNotation (_,"{ _ }",([a],[])) :: l -> + | CPatNotation (_,"{ _ }",([a],[])) :: l -> ntn' := expand_notation_string !ntn' n; contract_squash n (a::l) | a :: l -> @@ -175,7 +175,7 @@ let make_current_scope (tmp_scope,scopes) = Option.List.cons tmp_scope scopes let set_var_scope loc id (_,_,scopt,scopes) varscopes = let idscopes = List.assoc id varscopes in - if !idscopes <> None & + if !idscopes <> None & make_current_scope (Option.get !idscopes) <> make_current_scope (scopt,scopes) then user_err_loc (loc,"set_var_scope", @@ -217,28 +217,28 @@ let rec subst_aconstr_in_rawconstr loc interp (subst,substlist as sub) infos c = begin (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) - try + try let (a,(scopt,subscopes)) = List.assoc id subst in interp (ids,unb,scopt,subscopes@scopes) a - with Not_found -> - try + with Not_found -> + try RVar (loc,List.assoc id renaming) - with Not_found -> + with Not_found -> (* Happens for local notation joint with inductive/fixpoint defs *) RVar (loc,id) end | AList (x,_,iter,terminator,lassoc) -> - (try + (try (* All elements of the list are in scopes (scopt,subscopes) *) let (l,(scopt,subscopes)) = List.assoc x substlist in - let termin = + let termin = subst_aconstr_in_rawconstr loc interp sub subinfos terminator in - List.fold_right (fun a t -> + List.fold_right (fun a t -> subst_iterator ldots_var t - (subst_aconstr_in_rawconstr loc interp + (subst_aconstr_in_rawconstr loc interp ((x,(a,(scopt,subscopes)))::subst,substlist) subinfos iter)) (if lassoc then List.rev l else l) termin - with Not_found -> + with Not_found -> anomaly "Inconsistent substitution of recursive notation") | t -> rawconstr_of_aconstr_with_binders loc (traverse_binder sub) @@ -285,7 +285,7 @@ let intern_var (env,unbound_vars,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) l (* Is [id] an inductive type potentially with implicit *) try let ty,l,impl,argsc = List.assoc id impls in - let l = List.map + let l = List.map (fun id -> CRef (Ident (loc,id)), Some (loc,ExplByName id)) l in let tys = string_of_ty ty in Dumpglob.dump_reference loc "<>" (string_of_id id) tys; @@ -319,7 +319,7 @@ let intern_var (env,unbound_vars,_,_ as genv) (ltacvars,vars2,vars3,(_,impls)) l with _ -> (* [id] a goal variable *) RVar (loc,id), [], [], [] - + let find_appl_head_data (_,_,_,(_,impls)) = function | RRef (_,ref) as x -> x,implicits_of_global ref,find_arguments_scope ref,[] | x -> x,[],[],[] @@ -364,7 +364,7 @@ let intern_applied_reference intern (_, unb, _, _ as env) lvar args = function find_appl_head_data lvar r, args2 | Ident (loc, id) -> try intern_var env lvar loc id, args - with Not_found -> + with Not_found -> let qid = qualid_of_ident id in try let r,args2 = intern_non_secvar_qualid loc qid intern env args in @@ -374,7 +374,7 @@ let intern_applied_reference intern (_, unb, _, _ as env) lvar args = function if !interning_grammar || unb then (RVar (loc,id), [], [], []),args else raise e - + let interp_reference vars r = let (r,_,_,_),_ = intern_applied_reference (fun _ -> error_not_enough_arguments dummy_loc) @@ -415,11 +415,11 @@ let simple_product_of_cases_patterns pl = pl [[],[]] (* Check linearity of pattern-matching *) -let rec has_duplicate = function +let rec has_duplicate = function | [] -> None | x::l -> if List.mem x l then (Some x) else has_duplicate l -let loc_of_lhs lhs = +let loc_of_lhs lhs = join_loc (fst (List.hd lhs)) (fst (list_last lhs)) let check_linearity lhs ids = @@ -436,7 +436,7 @@ let check_number_of_pattern loc n l = let check_or_pat_variables loc ids idsl = if List.exists (fun ids' -> not (list_eq_set ids ids')) idsl then - user_err_loc (loc, "", str + user_err_loc (loc, "", str "The components of this disjunctive pattern must bind the same variables.") let check_constructor_length env loc cstr pl pl0 = @@ -458,7 +458,7 @@ let alias_of = function | (id::_,_) -> Name id let message_redundant_alias (id1,id2) = - if_verbose warning + if_verbose warning ("Alias variable "^(string_of_id id1)^" is merged with "^(string_of_id id2)) (* Expanding notations *) @@ -487,10 +487,10 @@ let subst_cases_pattern loc alias intern fullsubst scopes a = begin (* subst remembers the delimiters stack in the interpretation *) (* of the notations *) - try + try let (a,(scopt,subscopes)) = List.assoc id subst in intern (subscopes@scopes) ([],[]) scopt a - with Not_found -> + with Not_found -> if id = ldots_var then [], [[], PatVar (loc,Name id)] else anomaly ("Unbound pattern notation variable: "^(string_of_id id)) (* @@ -506,30 +506,30 @@ let subst_cases_pattern loc alias intern fullsubst scopes a = let args = chop_aconstr_constructor loc cstr args in let idslpll = List.map (aux Anonymous fullsubst) args in let ids',pll = product_of_cases_patterns [] idslpll in - let pl' = List.map (fun (asubst,pl) -> + let pl' = List.map (fun (asubst,pl) -> asubst,PatCstr (loc,cstr,pl,alias)) pll in ids', pl' | AList (x,_,iter,terminator,lassoc) -> - (try + (try (* All elements of the list are in scopes (scopt,subscopes) *) let (l,(scopt,subscopes)) = List.assoc x substlist in let termin = aux Anonymous fullsubst terminator in let idsl,v = - List.fold_right (fun a (tids,t) -> + List.fold_right (fun a (tids,t) -> let uids,u = aux Anonymous ((x,(a,(scopt,subscopes)))::subst,substlist) iter in let pll = List.map (subst_pat_iterator ldots_var t) u in tids@uids, List.flatten pll) (if lassoc then List.rev l else l) termin in idsl, List.map (fun ((asubst, pl) as x) -> match pl with PatCstr (loc, c, pl, Anonymous) -> (asubst, PatCstr (loc, c, pl, alias)) | _ -> x) v - with Not_found -> + with Not_found -> anomaly "Inconsistent substitution of recursive notation") | t -> error_invalid_pattern_notation loc in aux alias fullsubst a (* Differentiating between constructors and matching variables *) type pattern_qualid_kind = - | ConstrPat of constructor * (identifier list * + | ConstrPat of constructor * (identifier list * ((identifier * identifier) list * cases_pattern) list) list | VarPat of identifier @@ -554,14 +554,14 @@ let find_constructor ref f aliases pats scopes = let idspl1 = List.map (subst_cases_pattern loc (alias_of aliases) f (subst,[]) scopes) args in cstr, idspl1, pats2 | _ -> raise Not_found) - + | TrueGlobal r -> let rec unf = function | ConstRef cst -> let v = Environ.constant_value (Global.env()) cst in unf (global_of_constr v) - | ConstructRef cstr -> - Dumpglob.add_glob loc r; + | ConstructRef cstr -> + Dumpglob.add_glob loc r; cstr, [], pats | _ -> raise Not_found in unf r @@ -584,13 +584,13 @@ let maybe_constructor ref f aliases scopes = str " is understood as a pattern variable"); VarPat (find_pattern_variable ref) -let mustbe_constructor loc ref f aliases patl scopes = +let mustbe_constructor loc ref f aliases patl scopes = try find_constructor ref f aliases patl scopes with (Environ.NotEvaluableConst _ | Not_found) -> raise (InternalisationError (loc,NotAConstructor ref)) let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat= - let intern_pat = intern_cases_pattern genv in + let intern_pat = intern_cases_pattern genv in match pat with | CPatAlias (loc, p, id) -> let aliases' = merge_aliases aliases id in @@ -604,7 +604,7 @@ let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat= let pl' = List.map (fun (asubst,pl) -> (asubst, PatCstr (loc,c,pl,alias_of aliases))) pll in ids',pl' - | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[])) + | CPatNotation (loc,"- _",([CPatPrim(_,Numeral p)],[])) when Bigint.is_strictly_pos p -> intern_pat scopes aliases tmp_scope (CPatPrim(loc,Numeral(Bigint.neg p))) | CPatNotation (_,"( _ )",([a],[])) -> @@ -621,7 +621,7 @@ let rec intern_cases_pattern genv scopes (ids,asubst as aliases) tmp_scope pat= in ids@ids'', pl | CPatPrim (loc, p) -> let a = alias_of aliases in - let (c,df) = Notation.interp_prim_token_cases_pattern loc p a + let (c,df) = Notation.interp_prim_token_cases_pattern loc p a (tmp_scope,scopes) in Dumpglob.dump_notation_location (fst (unloc loc)) df; (ids,[asubst,c]) @@ -660,10 +660,10 @@ let check_capture loc ty = function () let locate_if_isevar loc na = function - | RHole _ -> + | RHole _ -> (try match na with | Name id -> Reserve.find_reserved_type id - | Anonymous -> raise Not_found + | Anonymous -> raise Not_found with Not_found -> RHole (loc, Evd.BinderType na)) | x -> x @@ -674,25 +674,25 @@ let check_hidden_implicit_parameters id (_,_,_,(indnames,_)) = of its constructor.") let push_name_env ?(fail_anonymous=false) lvar (ids,unb,tmpsc,scopes as env) = function - | Anonymous -> + | Anonymous -> if fail_anonymous then errorlabstrm "" (str "Anonymous variables not allowed"); env - | Name id -> + | Name id -> check_hidden_implicit_parameters id lvar; (Idset.add id ids, unb,tmpsc,scopes) let push_loc_name_env ?(fail_anonymous=false) lvar (ids,unb,tmpsc,scopes as env) loc = function - | Anonymous -> + | Anonymous -> if fail_anonymous then user_err_loc (loc,"", str "Anonymous variables not allowed"); env - | Name id -> + | Name id -> check_hidden_implicit_parameters id lvar; Dumpglob.dump_binding loc id; (Idset.add id ids,unb,tmpsc,scopes) let intern_generalized_binder ?(fail_anonymous=false) intern_type lvar (ids,unb,tmpsc,sc as env) bl (loc, na) b b' t ty = - let ty = + let ty = if t then ty else Implicit_quantifiers.implicit_application ids Implicit_quantifiers.combine_params_freevar ty @@ -702,11 +702,11 @@ let intern_generalized_binder ?(fail_anonymous=false) intern_type lvar let env' = List.fold_left (fun env (x, l) -> push_loc_name_env ~fail_anonymous lvar env l (Name x)) env fvs in let bl = List.map (fun (id, loc) -> (Name id, b, None, RHole (loc, Evd.BinderType (Name id)))) fvs in let na = match na with - | Anonymous -> - if fail_anonymous then na + | Anonymous -> + if fail_anonymous then na else - let name = - let id = + let name = + let id = match ty with | CApp (_, (_, CRef (Ident (loc,id))), _) -> id | _ -> id_of_string "H" @@ -736,25 +736,25 @@ let intern_local_binder_aux ?(fail_anonymous=false) intern intern_type lvar ((id let intern_generalization intern (ids,unb,tmp_scope,scopes as env) lvar loc bk ak c = let c = intern (ids,true,tmp_scope,scopes) c in let fvs = Implicit_quantifiers.free_vars_of_rawconstr ~bound:ids c in - let env', c' = - let abs = - let pi = + let env', c' = + let abs = + let pi = match ak with | Some AbsPi -> true - | None when tmp_scope = Some Notation.type_scope + | None when tmp_scope = Some Notation.type_scope || List.mem Notation.type_scope scopes -> true | _ -> false - in + in if pi then (fun (id, loc') acc -> RProd (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc)) else - (fun (id, loc') acc -> + (fun (id, loc') acc -> RLambda (join_loc loc' loc, Name id, bk, RHole (loc', Evd.BinderType (Name id)), acc)) in - List.fold_right (fun (id, loc as lid) (env, acc) -> + List.fold_right (fun (id, loc as lid) (env, acc) -> let env' = push_loc_name_env lvar env loc (Name id) in - (env', abs lid acc)) fvs (env,c) + (env', abs lid acc)) fvs (env,c) in c' (**********************************************************************) @@ -762,20 +762,20 @@ let intern_generalization intern (ids,unb,tmp_scope,scopes as env) lvar loc bk a let merge_impargs l args = List.fold_right (fun a l -> - match a with - | (_,Some (_,(ExplByName id as x))) when + match a with + | (_,Some (_,(ExplByName id as x))) when List.exists (function (_,Some (_,y)) -> x=y | _ -> false) args -> l | _ -> a::l) - l args + l args -let check_projection isproj nargs r = +let check_projection isproj nargs r = match (r,isproj) with | RRef (loc, ref), Some _ -> (try let n = Recordops.find_projection_nparams ref + 1 in if nargs <> n then user_err_loc (loc,"",str "Projection has not the right number of explicit parameters."); - with Not_found -> + with Not_found -> user_err_loc (loc,"",pr_global_env Idset.empty ref ++ str " is not a registered projection.")) | _, Some _ -> user_err_loc (loc_of_rawconstr r, "", str "Not a projection.") @@ -811,7 +811,7 @@ let extract_explicit_arg imps args = id | ExplByPos (p,_id) -> let id = - try + try let imp = List.nth imps (p-1) in if not (is_status_implicit imp) then failwith "imp"; name_of_implicit imp @@ -848,7 +848,7 @@ let internalise sigma globalenv env allow_patvar lvar c = let idl = Array.map (fun (id,(n,order),bl,ty,bd) -> let intern_ro_arg f = - let idx = + let idx = match n with Some (loc, n) -> list_index0 (Name n) (List.map snd (names_of_local_assums bl)) | None -> 0 @@ -856,13 +856,13 @@ let internalise sigma globalenv env allow_patvar lvar c = let before, after = list_chop idx bl in let ((ids',_,_,_) as env',rbefore) = List.fold_left intern_local_binder (env,[]) before in - let ro = f (intern (ids', unb, tmp_scope, scopes)) in + let ro = f (intern (ids', unb, tmp_scope, scopes)) in let n' = Option.map (fun _ -> List.length before) n in n', ro, List.fold_left intern_local_binder (env',rbefore) after in let n, ro, ((ids',_,_,_),rbl) = match order with - | CStructRec -> + | CStructRec -> intern_ro_arg (fun _ -> RStructRec) | CWfRec c -> intern_ro_arg (fun f -> RWfRec (f c)) @@ -870,10 +870,10 @@ let internalise sigma globalenv env allow_patvar lvar c = intern_ro_arg (fun f -> RMeasureRec (f m, Option.map f r)) in let ids'' = List.fold_right Idset.add lf ids' in - ((n, ro), List.rev rbl, + ((n, ro), List.rev rbl, intern_type (ids',unb,tmp_scope,scopes) ty, intern (ids'',unb,None,scopes) bd)) dl in - RRec (loc,RFix + RRec (loc,RFix (Array.map (fun (ro,_,_,_) -> ro) idl,n), Array.of_list lf, Array.map (fun (_,bl,_,_) -> bl) idl, @@ -914,7 +914,7 @@ let internalise sigma globalenv env allow_patvar lvar c = RLetIn (loc, na, intern (reset_tmp_scope env) c1, intern (push_loc_name_env lvar env loc1 na) c2) | CNotation (loc,"- _",([CPrim (_,Numeral p)],[])) - when Bigint.is_strictly_pos p -> + when Bigint.is_strictly_pos p -> intern env (CPrim (loc,Numeral (Bigint.neg p))) | CNotation (_,"( _ )",([a],[])) -> intern env a | CNotation (loc,ntn,args) -> @@ -946,42 +946,42 @@ let internalise sigma globalenv env allow_patvar lvar c = let c = intern_notation intern env loc ntn ([],[]) in find_appl_head_data lvar c, args | x -> (intern env f,[],[],[]), args in - let args = + let args = intern_impargs c env impargs args_scopes (merge_impargs l args) in check_projection isproj (List.length args) c; - (match c with + (match c with (* Now compact "(f args') args" *) | RApp (loc', f', args') -> RApp (join_loc loc' loc, f',args'@args) | _ -> RApp (loc, c, args)) | CRecord (loc, w, fs) -> let id, _ = List.hd fs in - let record = + let record = let (id,_,_,_),_ = intern_applied_reference intern env lvar [] (Ident id) in match id with - | RRef (loc, ref) -> + | RRef (loc, ref) -> (try Recordops.find_projection ref with Not_found -> user_err_loc (loc, "intern", str"Not a projection")) | c -> user_err_loc (loc_of_rawconstr id, "intern", str"Not a projection") in let args = - let pars = list_make record.Recordops.s_EXPECTEDPARAM (CHole (loc, None)) in - let fields, rest = + let pars = list_make record.Recordops.s_EXPECTEDPARAM (CHole (loc, None)) in + let fields, rest = List.fold_left (fun (args, rest as acc) (na, b) -> - if b then - try + if b then + try let id = out_name na in let _, t = List.assoc id rest in t :: args, List.remove_assoc id rest with _ -> CHole (loc, Some (Evd.QuestionMark (Evd.Define true))) :: args, rest else acc) ([], List.map (fun ((loc, id), t) -> id, (loc, t)) fs) record.Recordops.s_PROJKIND - in - if rest <> [] then + in + if rest <> [] then let id, (loc, t) = List.hd rest in user_err_loc (loc,"intern",(str "Unknown field name " ++ pr_id id)) else pars @ List.rev fields in - let constrname = - Qualid (loc, shortest_qualid_of_global Idset.empty (ConstructRef record.Recordops.s_CONST)) + let constrname = + Qualid (loc, shortest_qualid_of_global Idset.empty (ConstructRef record.Recordops.s_CONST)) in let app = CAppExpl (loc, (None, constrname), args) in intern env app @@ -1008,7 +1008,7 @@ let internalise sigma globalenv env allow_patvar lvar c = let env'' = List.fold_left (push_name_env lvar) env ids in let p' = Option.map (intern_type env'') po in RIf (loc, c', (na', p'), intern env b1, intern env b2) - | CHole (loc, k) -> + | CHole (loc, k) -> RHole (loc, match k with Some k -> k | None -> Evd.QuestionMark (Evd.Define true)) | CPatVar (loc, n) when allow_patvar -> RPatVar (loc, n) @@ -1027,12 +1027,12 @@ let internalise sigma globalenv env allow_patvar lvar c = and intern_type env = intern (set_type_scope env) - and intern_local_binder env bind = + and intern_local_binder env bind = intern_local_binder_aux intern intern_type lvar env bind (* Expands a multiple pattern into a disjunction of multiple patterns *) and intern_multiple_pattern scopes n (loc,pl) = - let idsl_pll = + let idsl_pll = List.map (intern_cases_pattern globalenv scopes ([],[]) None) pl in check_number_of_pattern loc n pl; product_of_cases_patterns [] idsl_pll @@ -1061,7 +1061,7 @@ let internalise sigma globalenv env allow_patvar lvar c = and intern_case_item (vars,unb,_,scopes as env) (tm,(na,t)) = let tm' = intern env tm in let ids,typ = match t with - | Some t -> + | Some t -> let tids = ids_of_cases_indtype t in let tids = List.fold_right Idset.add tids Idset.empty in let t = intern_type (tids,unb,None,scopes) t in @@ -1081,14 +1081,14 @@ let internalise sigma globalenv env allow_patvar lvar c = if List.exists ((<>) Anonymous) parnal then error_inductive_parameter_not_implicit loc; realnal, Some (loc,ind,nparams,realnal) - | None -> + | None -> [], None in let na = match tm', na with | RVar (_,id), None when Idset.mem id vars -> Name id | _, None -> Anonymous | _, Some na -> na in (tm',(na,typ)), na::ids - + and iterate_prod loc2 env bk ty body nal = let rec default env bk = function | (loc1,na)::nal -> @@ -1100,14 +1100,14 @@ let internalise sigma globalenv env allow_patvar lvar c = in match bk with | Default b -> default env b nal - | Generalized (b,b',t) -> + | Generalized (b,b',t) -> let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in let body = intern_type env body in it_mkRProd ibind body - - and iterate_lam loc2 env bk ty body nal = - let rec default env bk = function + + and iterate_lam loc2 env bk ty body nal = + let rec default env bk = function | (loc1,na)::nal -> if nal <> [] then check_capture loc1 ty na; let body = default (push_loc_name_env lvar env loc1 na) bk nal in @@ -1116,19 +1116,19 @@ let internalise sigma globalenv env allow_patvar lvar c = | [] -> intern env body in match bk with | Default b -> default env b nal - | Generalized (b, b', t) -> + | Generalized (b, b', t) -> let env, ibind = intern_generalized_binder intern_type lvar env [] (List.hd nal) b b' t ty in let body = intern env body in it_mkRLambda ibind body - + and intern_impargs c env l subscopes args = let eargs, rargs = extract_explicit_arg l args in let rec aux n impl subscopes eargs rargs = let (enva,subscopes') = apply_scope_env env subscopes in match (impl,rargs) with | (imp::impl', rargs) when is_status_implicit imp -> - begin try + begin try let id = name_of_implicit imp in let (_,a) = List.assoc id eargs in let eargs' = List.remove_assoc id eargs in @@ -1139,16 +1139,16 @@ let internalise sigma globalenv env allow_patvar lvar c = (* with implicit arguments if maximal insertion is set *) [] else - RHole (set_hole_implicit (n,get_implicit_name n l) (force_inference_of imp) c) :: + RHole (set_hole_implicit (n,get_implicit_name n l) (force_inference_of imp) c) :: aux (n+1) impl' subscopes' eargs rargs end | (imp::impl', a::rargs') -> intern enva a :: aux (n+1) impl' subscopes' eargs rargs' - | (imp::impl', []) -> - if eargs <> [] then + | (imp::impl', []) -> + if eargs <> [] then (let (id,(loc,_)) = List.hd eargs in user_err_loc (loc,"",str "Not enough non implicit - arguments to accept the argument bound to " ++ + arguments to accept the argument bound to " ++ pr_id id ++ str".")); [] | ([], rargs) -> @@ -1162,8 +1162,8 @@ let internalise sigma globalenv env allow_patvar lvar c = let (enva,subscopes) = apply_scope_env env subscopes in (intern enva a) :: (intern_args env subscopes args) - in - try + in + try intern env c with InternalisationError (loc,e) -> @@ -1175,26 +1175,26 @@ let internalise sigma globalenv env allow_patvar lvar c = (**************************************************************************) let extract_ids env = - List.fold_right Idset.add + List.fold_right Idset.add (Termops.ids_of_rel_context (Environ.rel_context env)) Idset.empty let intern_gen isarity sigma env ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[])) c = - let tmp_scope = + let tmp_scope = if isarity then Some Notation.type_scope else None in internalise sigma env (extract_ids env, false, tmp_scope,[]) allow_patvar (ltacvars,Environ.named_context env, [], impls) c - -let intern_constr sigma env c = intern_gen false sigma env c -let intern_type sigma env c = intern_gen true sigma env c +let intern_constr sigma env c = intern_gen false sigma env c + +let intern_type sigma env c = intern_gen true sigma env c let intern_pattern env patt = try - intern_cases_pattern env [] ([],[]) None patt - with + intern_cases_pattern env [] ([],[]) None patt + with InternalisationError (loc,e) -> user_err_loc (loc,"internalize",explain_internalisation_error e) @@ -1204,7 +1204,7 @@ type manual_implicits = (explicitation * (bool * bool * bool)) list (*********************************************************************) (* Functions to parse and interpret constructions *) -let interp_gen kind sigma env +let interp_gen kind sigma env ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[])) c = let c = intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars sigma env c in @@ -1217,7 +1217,7 @@ let interp_type sigma env ?(impls=([],[])) c = interp_gen IsType sigma env ~impls c let interp_casted_constr sigma env ?(impls=([],[])) c typ = - interp_gen (OfType (Some typ)) sigma env ~impls c + interp_gen (OfType (Some typ)) sigma env ~impls c let interp_open_constr sigma env c = Default.understand_tcc sigma env (intern_constr sigma env c) @@ -1228,8 +1228,8 @@ let interp_open_constr_patvar sigma env c = let evars = ref (Gmap.empty : (identifier,rawconstr) Gmap.t) in let rec patvar_to_evar r = match r with | RPatVar (loc,(_,id)) -> - ( try Gmap.find id !evars - with Not_found -> + ( try Gmap.find id !evars + with Not_found -> let ev = Evarutil.e_new_evar sigma env (Termops.new_Type()) in let ev = Evarutil.e_new_evar sigma env ev in let rev = REvar (loc,(fst (Term.destEvar ev)),None) (*TODO*) in @@ -1253,7 +1253,7 @@ let interp_constr_evars_gen_impls ?evdref ?(fail_evar=true) let c = intern_gen (kind=IsType) ~impls !evdref env c in let imps = Implicit_quantifiers.implicits_of_rawterm c in Default.understand_tcc_evars ~fail_evar evdref env kind c, imps - + let interp_casted_constr_evars_impls ?evdref ?(fail_evar=true) env ?(impls=([],[])) c typ = interp_constr_evars_gen_impls ?evdref ~fail_evar env ~impls (OfType (Some typ)) c @@ -1290,7 +1290,7 @@ let interp_aconstr impls (vars,varslist) a = let a = aconstr_of_rawconstr vars c in (* Returns [a] and the ordered list of variables with their scopes *) (* Variables occurring in binders have no relevant scope since bound *) - let vl = List.map (fun (id,r) -> + let vl = List.map (fun (id,r) -> (id,match !r with None -> None,[] | Some (a,l) -> a,l)) vl in list_chop (List.length vars) vl, a @@ -1320,7 +1320,7 @@ let intern_context fail_anonymous sigma env params = (intern_local_binder_aux ~fail_anonymous (my_intern_constr sigma env lvar) (my_intern_type sigma env lvar) lvar) ((extract_ids env,false,None,[]), []) params) -let interp_context_gen understand_type understand_judgment env bl = +let interp_context_gen understand_type understand_judgment env bl = let (env, par, _, impls) = List.fold_left (fun (env,params,n,impls) (na, k, b, t) -> @@ -1329,7 +1329,7 @@ let interp_context_gen understand_type understand_judgment env bl = let t' = locate_if_isevar (loc_of_rawconstr t) na t in let t = understand_type env t' in let d = (na,None,t) in - let impls = + let impls = if k = Implicit then let na = match na with Name n -> Some n | Anonymous -> None in (ExplByPos (n, na), (true, true, true)) :: impls @@ -1343,34 +1343,34 @@ let interp_context_gen understand_type understand_judgment env bl = (env,[],1,[]) (List.rev bl) in (env, par), impls -let interp_context ?(fail_anonymous=false) sigma env params = +let interp_context ?(fail_anonymous=false) sigma env params = let bl = intern_context fail_anonymous sigma env params in - interp_context_gen (Default.understand_type sigma) + interp_context_gen (Default.understand_type sigma) (Default.understand_judgment sigma) env bl - + let interp_context_evars ?(fail_anonymous=false) evdref env params = let bl = intern_context fail_anonymous !evdref env params in interp_context_gen (fun env t -> Default.understand_tcc_evars evdref env IsType t) (Default.understand_judgment_tcc evdref) env bl - + (**********************************************************************) (* Locating reference, possibly via an abbreviation *) let locate_reference qid = match Nametab.locate_extended qid with | TrueGlobal ref -> ref - | SynDef kn -> + | SynDef kn -> match Syntax_def.search_syntactic_definition dummy_loc kn with | [],ARef ref -> ref | _ -> raise Not_found let is_global id = - try + try let _ = locate_reference (qualid_of_ident id) in true - with Not_found -> + with Not_found -> false -let global_reference id = +let global_reference id = constr_of_global (locate_reference (qualid_of_ident id)) let construct_reference ctx id = @@ -1379,6 +1379,6 @@ let construct_reference ctx id = with Not_found -> global_reference id -let global_reference_in_absolute_module dir id = +let global_reference_in_absolute_module dir id = constr_of_global (Nametab.global_of_path (Libnames.make_path dir id)) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index bfccf03d18..b39f6e18b9 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -39,8 +39,8 @@ open Pretyping argument associates a list of implicit positions and scopes to identifiers declared in the [rel_context] of [env] *) -type var_internalisation_type = Inductive | Recursive | Method - +type var_internalisation_type = Inductive | Recursive | Method + type var_internalisation_data = var_internalisation_type * identifier list * Impargs.implicits_list * scope_name option list @@ -79,22 +79,22 @@ val interp_gen : typing_constraint -> evar_map -> env -> (* Particular instances *) -val interp_constr : evar_map -> env -> +val interp_constr : evar_map -> env -> constr_expr -> constr -val interp_type : evar_map -> env -> ?impls:full_implicits_env -> +val interp_type : evar_map -> env -> ?impls:full_implicits_env -> constr_expr -> types val interp_open_constr : evar_map -> env -> constr_expr -> evar_map * constr val interp_open_constr_patvar : evar_map -> env -> constr_expr -> evar_map * constr -val interp_casted_constr : evar_map -> env -> ?impls:full_implicits_env -> +val interp_casted_constr : evar_map -> env -> ?impls:full_implicits_env -> constr_expr -> types -> constr (* Accepting evars and giving back the manual implicits in addition. *) -val interp_casted_constr_evars_impls : ?evdref:(evar_defs ref) -> ?fail_evar:bool -> env -> +val interp_casted_constr_evars_impls : ?evdref:(evar_defs ref) -> ?fail_evar:bool -> env -> ?impls:full_implicits_env -> constr_expr -> types -> constr * manual_implicits val interp_type_evars_impls : ?evdref:(evar_defs ref) -> ?fail_evar:bool -> @@ -105,7 +105,7 @@ val interp_constr_evars_impls : ?evdref:(evar_defs ref) -> ?fail_evar:bool -> env -> ?impls:full_implicits_env -> constr_expr -> constr * manual_implicits -val interp_casted_constr_evars : evar_defs ref -> env -> +val interp_casted_constr_evars : evar_defs ref -> env -> ?impls:full_implicits_env -> constr_expr -> types -> constr val interp_type_evars : evar_defs ref -> env -> ?impls:full_implicits_env -> @@ -117,8 +117,8 @@ val interp_constr_judgment : evar_map -> env -> constr_expr -> unsafe_judgment (* Interprets constr patterns *) -val intern_constr_pattern : - evar_map -> env -> ?as_type:bool -> ?ltacvars:ltac_sign -> +val intern_constr_pattern : + evar_map -> env -> ?as_type:bool -> ?ltacvars:ltac_sign -> constr_pattern_expr -> patvar list * constr_pattern val interp_reference : ltac_sign -> reference -> rawconstr @@ -131,10 +131,10 @@ val interp_binder_evars : evar_defs ref -> env -> name -> constr_expr -> types (* Interpret contexts: returns extended env and context *) -val interp_context : ?fail_anonymous:bool -> +val interp_context : ?fail_anonymous:bool -> evar_map -> env -> local_binder list -> (env * rel_context) * manual_implicits -val interp_context_evars : ?fail_anonymous:bool -> +val interp_context_evars : ?fail_anonymous:bool -> evar_defs ref -> env -> local_binder list -> (env * rel_context) * manual_implicits (* Locating references of constructions, possibly via a syntactic definition *) @@ -147,7 +147,7 @@ val global_reference_in_absolute_module : dir_path -> identifier -> constr (* Interprets into a abbreviatable constr *) -val interp_aconstr : implicits_env -> identifier list * identifier list +val interp_aconstr : implicits_env -> identifier list * identifier list -> constr_expr -> interpretation (* Globalization leak for Grammar *) diff --git a/interp/coqlib.ml b/interp/coqlib.ml index 6879dc9659..b44cabe8b8 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -55,7 +55,7 @@ let gen_constant_in_modules locstr dirs s = " in module"^(if List.length dirs > 1 then "s " else " ")) ++ prlist_with_sep pr_coma pr_dirpath dirs) | l -> - anomalylabstrm "" + anomalylabstrm "" (str (locstr^": found more than once object of name "^s^ " in module"^(if List.length dirs > 1 then "s " else " ")) ++ prlist_with_sep pr_coma pr_dirpath dirs) @@ -69,7 +69,7 @@ let check_required_library d = if not (Library.library_is_loaded dir) then (* Loading silently ... let m, prefix = list_sep_last d' in - read_library + read_library (dummy_loc,make_qualid (make_dirpath (List.rev prefix)) m) *) (* or failing ...*) @@ -80,9 +80,9 @@ let check_required_library d = let init_reference dir s = gen_reference "Coqlib" ("Init"::dir) s -let init_constant dir s = gen_constant "Coqlib" ("Init"::dir) s +let init_constant dir s = gen_constant "Coqlib" ("Init"::dir) s -let logic_constant dir s = gen_constant "Coqlib" ("Logic"::dir) s +let logic_constant dir s = gen_constant "Coqlib" ("Logic"::dir) s let arith_dir = ["Coq";"Arith"] let arith_modules = [arith_dir] @@ -101,7 +101,7 @@ let init_modules = [ init_dir@["Peano"]; init_dir@["Wf"] ] - + let coq_id = id_of_string "Coq" let init_id = id_of_string "Init" let arith_id = id_of_string "Arith" @@ -178,7 +178,7 @@ type coq_bool_data = { type 'a delayed = unit -> 'a -let build_bool_type () = +let build_bool_type () = { andb = init_constant ["Datatypes"] "andb"; andb_prop = init_constant ["Datatypes"] "andb_prop"; andb_true_intro = init_constant ["Datatypes"] "andb_true_intro" } diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 79b58da84d..9faea54065 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -15,11 +15,11 @@ let glob_file = ref Pervasives.stdout let open_glob_file f = glob_file := Pervasives.open_out f - + let close_glob_file () = Pervasives.close_out !glob_file -type glob_output_t = +type glob_output_t = | NoGlob | StdOut | MultFiles @@ -39,7 +39,7 @@ let dump_to_dotglob f = glob_output := MultFiles let dump_into_file f = glob_output := File f; open_glob_file f -let dump_string s = +let dump_string s = if dump () then Pervasives.output_string !glob_file s @@ -68,7 +68,7 @@ let coqdoc_unfreeze (lt,tn,lp) = open Decl_kinds let type_of_logical_kind = function - | IsDefinition def -> + | IsDefinition def -> (match def with | Definition -> "def" | Coercion -> "coe" @@ -102,7 +102,7 @@ let type_of_global_ref gr = "class" else match gr with - | Libnames.ConstRef cst -> + | Libnames.ConstRef cst -> type_of_logical_kind (Decls.constant_kind cst) | Libnames.VarRef v -> "var" ^ type_of_logical_kind (Decls.variable_kind v) @@ -124,7 +124,7 @@ let remove_sections dir = dir let dump_ref loc filepath modpath ident ty = - dump_string (Printf.sprintf "R%d %s %s %s %s\n" + dump_string (Printf.sprintf "R%d %s %s %s %s\n" (fst (Util.unloc loc)) filepath modpath ident ty) let add_glob_gen loc sp lib_dp ty = @@ -137,16 +137,16 @@ let add_glob_gen loc sp lib_dp ty = let ident = Names.string_of_id id in dump_ref loc filepath modpath ident ty -let add_glob loc ref = +let add_glob loc ref = if dump () && loc <> Util.dummy_loc then let sp = Nametab.path_of_global ref in let lib_dp = Lib.library_part ref in let ty = type_of_global_ref ref in add_glob_gen loc sp lib_dp ty - -let mp_of_kn kn = - let mp,sec,l = Names.repr_kn kn in - Names.MPdot (mp,l) + +let mp_of_kn kn = + let mp,sec,l = Names.repr_kn kn in + Names.MPdot (mp,l) let add_glob_kn loc kn = if dump () && loc <> Util.dummy_loc then @@ -155,13 +155,13 @@ let add_glob_kn loc kn = add_glob_gen loc sp lib_dp "syndef" let dump_binding loc id = () - + let dump_definition (loc, id) sec s = - dump_string (Printf.sprintf "%s %d %s %s\n" s (fst (Util.unloc loc)) + dump_string (Printf.sprintf "%s %d %s %s\n" s (fst (Util.unloc loc)) (Names.string_of_dirpath (Lib.current_dirpath sec)) (Names.string_of_id id)) - + let dump_reference loc modpath ident ty = - dump_string (Printf.sprintf "R%d %s %s %s %s\n" + dump_string (Printf.sprintf "R%d %s %s %s %s\n" (fst (Util.unloc loc)) (Names.string_of_dirpath (Lib.library_dp ())) modpath ident ty) let dump_constraint ((loc, n), _, _) sec ty = @@ -177,7 +177,7 @@ let dump_name (loc, n) sec ty = let dump_local_binder b sec ty = if dump () then match b with - | Topconstr.LocalRawAssum (nl, _, _) -> + | Topconstr.LocalRawAssum (nl, _, _) -> List.iter (fun x -> dump_name x sec ty) nl | Topconstr.LocalRawDef _ -> () @@ -187,7 +187,7 @@ let dump_modref loc mp ty = let l = if l = [] then l else Util.list_drop_last l in let fp = Names.string_of_dirpath dp in let mp = Names.string_of_dirpath (Names.make_dirpath l) in - dump_string (Printf.sprintf "R%d %s %s %s %s\n" + dump_string (Printf.sprintf "R%d %s %s %s %s\n" (fst (Util.unloc loc)) fp mp "<>" ty) let dump_moddef loc mp ty = @@ -197,7 +197,7 @@ let dump_moddef loc mp ty = dump_string (Printf.sprintf "%s %d %s %s\n" ty (fst (Util.unloc loc)) "<>" mp) let dump_libref loc dp ty = - dump_string (Printf.sprintf "R%d %s <> <> %s\n" + dump_string (Printf.sprintf "R%d %s <> <> %s\n" (fst (Util.unloc loc)) (Names.string_of_dirpath dp) ty) let dump_notation_location pos ((path,df),sc) = diff --git a/interp/genarg.ml b/interp/genarg.ml index c6dc12164e..091a5c8731 100644 --- a/interp/genarg.ml +++ b/interp/genarg.ml @@ -170,7 +170,7 @@ let globwit_constr_may_eval = ConstrMayEvalArgType let wit_constr_may_eval = ConstrMayEvalArgType let rawwit_open_constr_gen b = OpenConstrArgType b -let globwit_open_constr_gen b = OpenConstrArgType b +let globwit_open_constr_gen b = OpenConstrArgType b let wit_open_constr_gen b = OpenConstrArgType b let rawwit_open_constr = rawwit_open_constr_gen false diff --git a/interp/genarg.mli b/interp/genarg.mli index e6747db171..48e5b3c31b 100644 --- a/interp/genarg.mli +++ b/interp/genarg.mli @@ -75,7 +75,7 @@ val pr_or_and_intro_pattern : or_and_intro_pattern_expr -> Pp.std_ppcmds effective use \end{verbatim} -To distinguish between the uninterpreted (raw), globalized and +To distinguish between the uninterpreted (raw), globalized and interpreted worlds, we annotate the type [generic_argument] by a phantom argument which is either [constr_expr], [rawconstr] or [constr]. @@ -107,11 +107,11 @@ ExtraArgType of string '_a '_b \end{verbatim} *) -(* All of [rlevel], [glevel] and [tlevel] must be non convertible +(* All of [rlevel], [glevel] and [tlevel] must be non convertible to ensure the injectivity of the type inference from type ['co generic_argument] to [('a,'co) abstract_argument_type]; this guarantees that, for 'co fixed, the type of - out_gen is monomorphic over 'a, hence type-safe + out_gen is monomorphic over 'a, hence type-safe *) type rlevel = constr_expr @@ -222,29 +222,29 @@ val wit_pair : (* ['a generic_argument] = (Sigma t:type. t[[constr/'a]]) *) type 'a generic_argument -val fold_list0 : +val fold_list0 : ('a generic_argument -> 'c -> 'c) -> 'a generic_argument -> 'c -> 'c -val fold_list1 : +val fold_list1 : ('a generic_argument -> 'c -> 'c) -> 'a generic_argument -> 'c -> 'c val fold_opt : ('a generic_argument -> 'c) -> 'c -> 'a generic_argument -> 'c val fold_pair : - ('a generic_argument -> 'a generic_argument -> 'c) -> + ('a generic_argument -> 'a generic_argument -> 'c) -> 'a generic_argument -> 'c (* [app_list0] fails if applied to an argument not of tag [List0 t] for some [t]; it's the responsability of the caller to ensure it *) -val app_list0 : ('a generic_argument -> 'b generic_argument) -> +val app_list0 : ('a generic_argument -> 'b generic_argument) -> 'a generic_argument -> 'b generic_argument -val app_list1 : ('a generic_argument -> 'b generic_argument) -> +val app_list1 : ('a generic_argument -> 'b generic_argument) -> 'a generic_argument -> 'b generic_argument -val app_opt : ('a generic_argument -> 'b generic_argument) -> +val app_opt : ('a generic_argument -> 'b generic_argument) -> 'a generic_argument -> 'b generic_argument val app_pair : @@ -294,7 +294,7 @@ val unquote : ('a,'co) abstract_argument_type -> argument_type val in_gen : ('a,'co) abstract_argument_type -> 'a -> 'co generic_argument val out_gen : - ('a,'co) abstract_argument_type -> 'co generic_argument -> 'a + ('a,'co) abstract_argument_type -> 'co generic_argument -> 'a (* [in_generic] is used in combination with camlp4 [Gramext.action] magic @@ -308,5 +308,5 @@ val out_gen : *) type an_arg_of_this_type -val in_generic : +val in_generic : argument_type -> an_arg_of_this_type -> 'co generic_argument diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index a550111a30..7b1a1ff4cc 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -26,7 +26,7 @@ open Typeclasses_errors open Pp (*i*) -let ids_of_list l = +let ids_of_list l = List.fold_right Idset.add l Idset.empty let locate_reference qid = @@ -35,9 +35,9 @@ let locate_reference qid = | SynDef kn -> true let is_global id = - try + try locate_reference (qualid_of_ident id) - with Not_found -> + with Not_found -> false let is_freevar ids env x = @@ -48,13 +48,13 @@ let is_freevar ids env x = with _ -> not (is_global x) with _ -> true -(* Auxilliary functions for the inference of implicitly quantified variables. *) +(* Auxilliary functions for the inference of implicitly quantified variables. *) -let free_vars_of_constr_expr c ?(bound=Idset.empty) l = - let found id bdvars l = - if List.mem id l then l +let free_vars_of_constr_expr c ?(bound=Idset.empty) l = + let found id bdvars l = + if List.mem id l then l else if not (is_freevar bdvars (Global.env ()) id) - then l else id :: l + then l else id :: l in let rec aux bdvars l c = match c with | CRef (Ident (_,id)) -> found id bdvars l @@ -63,107 +63,107 @@ let free_vars_of_constr_expr c ?(bound=Idset.empty) l = | c -> fold_constr_expr_with_binders (fun a l -> Idset.add a l) aux bdvars l c in aux bound l c -let ids_of_names l = +let ids_of_names l = List.fold_left (fun acc x -> match snd x with Name na -> na :: acc | Anonymous -> acc) [] l -let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) = +let free_vars_of_binders ?(bound=Idset.empty) l (binders : local_binder list) = let rec aux bdvars l c = match c with ((LocalRawAssum (n, _, c)) :: tl) -> let bound = ids_of_names n in let l' = free_vars_of_constr_expr c ~bound:bdvars l in aux (Idset.union (ids_of_list bound) bdvars) l' tl - | ((LocalRawDef (n, c)) :: tl) -> + | ((LocalRawDef (n, c)) :: tl) -> let bound = match snd n with Anonymous -> [] | Name n -> [n] in let l' = free_vars_of_constr_expr c ~bound:bdvars l in aux (Idset.union (ids_of_list bound) bdvars) l' tl - + | [] -> bdvars, l in aux bound l binders -let add_name_to_ids set na = - match na with - | Anonymous -> set - | Name id -> Idset.add id set - +let add_name_to_ids set na = + match na with + | Anonymous -> set + | Name id -> Idset.add id set + let free_vars_of_rawconstr ?(bound=Idset.empty) = let rec vars bound vs = function - | RVar (loc,id) -> + | RVar (loc,id) -> if is_freevar bound (Global.env ()) id then - if List.mem_assoc id vs then vs + if List.mem_assoc id vs then vs else (id, loc) :: vs else vs | RApp (loc,f,args) -> List.fold_left (vars bound) vs (f::args) - | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) -> - let vs' = vars bound vs ty in - let bound' = add_name_to_ids bound na in + | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) -> + let vs' = vars bound vs ty in + let bound' = add_name_to_ids bound na in vars bound' vs' c | RCases (loc,sty,rtntypopt,tml,pl) -> - let vs1 = vars_option bound vs rtntypopt in - let vs2 = List.fold_left (fun vs (tm,_) -> vars bound vs tm) vs1 tml in + let vs1 = vars_option bound vs rtntypopt in + let vs2 = List.fold_left (fun vs (tm,_) -> vars bound vs tm) vs1 tml in List.fold_left (vars_pattern bound) vs2 pl | RLetTuple (loc,nal,rtntyp,b,c) -> - let vs1 = vars_return_type bound vs rtntyp in - let vs2 = vars bound vs1 b in + let vs1 = vars_return_type bound vs rtntyp in + let vs2 = vars bound vs1 b in let bound' = List.fold_left add_name_to_ids bound nal in vars bound' vs2 c - | RIf (loc,c,rtntyp,b1,b2) -> - let vs1 = vars_return_type bound vs rtntyp in - let vs2 = vars bound vs1 c in - let vs3 = vars bound vs2 b1 in + | RIf (loc,c,rtntyp,b1,b2) -> + let vs1 = vars_return_type bound vs rtntyp in + let vs2 = vars bound vs1 c in + let vs3 = vars bound vs2 b1 in vars bound vs3 b2 | RRec (loc,fk,idl,bl,tyl,bv) -> - let bound' = Array.fold_right Idset.add idl bound in - let vars_fix i vs fid = - let vs1,bound1 = - List.fold_left - (fun (vs,bound) (na,k,bbd,bty) -> - let vs' = vars_option bound vs bbd in + let bound' = Array.fold_right Idset.add idl bound in + let vars_fix i vs fid = + let vs1,bound1 = + List.fold_left + (fun (vs,bound) (na,k,bbd,bty) -> + let vs' = vars_option bound vs bbd in let vs'' = vars bound vs' bty in - let bound' = add_name_to_ids bound na in + let bound' = add_name_to_ids bound na in (vs'',bound') ) (vs,bound') bl.(i) in - let vs2 = vars bound1 vs1 tyl.(i) in + let vs2 = vars bound1 vs1 tyl.(i) in vars bound1 vs2 bv.(i) in array_fold_left_i vars_fix vs idl - | RCast (loc,c,k) -> let v = vars bound vs c in + | RCast (loc,c,k) -> let v = vars bound vs c in (match k with CastConv (_,t) -> vars bound v t | _ -> v) | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> vs - and vars_pattern bound vs (loc,idl,p,c) = - let bound' = List.fold_right Idset.add idl bound in + and vars_pattern bound vs (loc,idl,p,c) = + let bound' = List.fold_right Idset.add idl bound in vars bound' vs c and vars_option bound vs = function None -> vs | Some p -> vars bound vs p - and vars_return_type bound vs (na,tyopt) = - let bound' = add_name_to_ids bound na in + and vars_return_type bound vs (na,tyopt) = + let bound' = add_name_to_ids bound na in vars_option bound' vs tyopt - in + in fun rt -> List.rev (vars bound [] rt) - + let rec make_fresh ids env x = if is_freevar ids env x then x else make_fresh ids env (Nameops.lift_ident x) -let fre_ids env ids = +let fre_ids env ids = List.filter (is_freevar env (Global.env())) ids - + let next_ident_away_from id avoid = make_fresh avoid (Global.env ()) id -let next_name_away_from na avoid = +let next_name_away_from na avoid = match na with | Anonymous -> make_fresh avoid (Global.env ()) (id_of_string "anon") | Name id -> make_fresh avoid (Global.env ()) id let combine_params avoid fn applied needed = - let named, applied = - List.partition + let named, applied = + List.partition (function - (t, Some (loc, ExplByName id)) -> + (t, Some (loc, ExplByName id)) -> if not (List.exists (fun (_, (id', _, _)) -> Name id = id') needed) then user_err_loc (loc,"",str "Wrong argument name: " ++ Nameops.pr_id id); true @@ -179,43 +179,43 @@ let combine_params avoid fn applied needed = | app, (_, (Name id, _, _)) :: need when List.mem_assoc id named -> aux (List.assoc id named :: ids) avoid app need - + | (x, None) :: app, (None, (Name id, _, _)) :: need -> aux (x :: ids) avoid app need - - | _, (Some cl, (_, _, _) as d) :: need -> + + | _, (Some cl, (_, _, _) as d) :: need -> let t', avoid' = fn avoid d in aux (t' :: ids) avoid' app need | x :: app, (None, _) :: need -> aux (fst x :: ids) avoid app need - | [], (None, _ as decl) :: need -> + | [], (None, _ as decl) :: need -> let t', avoid' = fn avoid decl in aux (t' :: ids) avoid' app need - | (x,_) :: _, [] -> + | (x,_) :: _, [] -> user_err_loc (constr_loc x,"",str "Typeclass does not expect more arguments") in aux [] avoid applied needed let combine_params_freevar = - fun avoid (_, (na, _, _)) -> + fun avoid (_, (na, _, _)) -> let id' = next_name_away_from na avoid in (CRef (Ident (dummy_loc, id')), Idset.add id' avoid) - + let destClassApp cl = match cl with | CApp (loc, (None,CRef ref), l) -> loc, ref, List.map fst l | CAppExpl (loc, (None, ref), l) -> loc, ref, l | CRef ref -> loc_of_reference ref, ref, [] | _ -> raise Not_found - + let destClassAppExpl cl = match cl with | CApp (loc, (None,CRef ref), l) -> loc, ref, l | CRef ref -> loc_of_reference ref, ref, [] | _ -> raise Not_found -let implicit_application env ?(allow_partial=true) f ty = +let implicit_application env ?(allow_partial=true) f ty = let is_class = try let (loc, r, _ as clapp) = destClassAppExpl ty in @@ -223,30 +223,30 @@ let implicit_application env ?(allow_partial=true) f ty = let gr = Nametab.locate qid in if Typeclasses.is_class gr then Some (clapp, gr) else None with Not_found -> None - in + in match is_class with | None -> ty - | Some ((loc, id, par), gr) -> + | Some ((loc, id, par), gr) -> let avoid = Idset.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in let c, avoid = let c = class_info gr in let (ci, rd) = c.cl_context in if not allow_partial then - begin + begin let applen = List.fold_left (fun acc (x, y) -> if y = None then succ acc else acc) 0 par in let needlen = List.fold_left (fun acc x -> if x = None then succ acc else acc) 0 ci in - if needlen <> applen then + if needlen <> applen then Typeclasses_errors.mismatched_ctx_inst (Global.env ()) Parameters (List.map fst par) rd end; let pars = List.rev (List.combine ci rd) in let args, avoid = combine_params avoid f par pars in CAppExpl (loc, (None, id), args), avoid in c - -let implicits_of_rawterm l = - let rec aux i c = + +let implicits_of_rawterm l = + let rec aux i c = match c with - RProd (loc, na, bk, t, b) | RLambda (loc, na, bk, t, b) -> + RProd (loc, na, bk, t, b) | RLambda (loc, na, bk, t, b) -> let rest = aux (succ i) b in if bk = Implicit then let name = diff --git a/interp/interp.mllib b/interp/interp.mllib index 991cfac57b..3825f3d879 100644 --- a/interp/interp.mllib +++ b/interp/interp.mllib @@ -3,15 +3,15 @@ Topconstr Ppextend Notation Dumpglob -Genarg +Genarg Syntax_def Smartlocate Reserve -Impargs +Impargs Implicit_quantifiers Constrintern Modintern -Constrextern +Constrextern Coqlib Discharge Declare diff --git a/interp/modintern.ml b/interp/modintern.ml index 3482dd3a02..041e32bf6d 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -15,7 +15,7 @@ open Entries open Libnames open Topconstr open Constrintern - + let rec make_mp mp = function [] -> mp | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl @@ -25,7 +25,7 @@ let rec make_mp mp = function the module prefix *) exception BadRef -let lookup_qualid (modtype:bool) qid = +let lookup_qualid (modtype:bool) qid = let rec make_mp mp = function [] -> mp | h::tl -> make_mp (MPdot(mp, label_of_id h)) tl @@ -33,13 +33,13 @@ let lookup_qualid (modtype:bool) qid = let rec find_module_prefix dir n = if n<0 then raise Not_found; let dir',dir'' = list_chop n dir in - let id',dir''' = - match dir'' with - | hd::tl -> hd,tl + let id',dir''' = + match dir'' with + | hd::tl -> hd,tl | _ -> anomaly "This list should not be empty!" in let qid' = make_qualid dir' id' in - try + try match Nametab.locate qid' with | ModRef mp -> mp,dir''' | _ -> raise BadRef @@ -47,11 +47,11 @@ let lookup_qualid (modtype:bool) qid = Not_found -> find_module_prefix dir (pred n) in try Nametab.locate qid - with Not_found -> + with Not_found -> let (dir,id) = repr_qualid qid in let pref_mp,dir' = find_module_prefix dir (List.length dir - 1) in - let mp = - List.fold_left (fun mp id -> MPdot (mp, label_of_id id)) pref_mp dir' + let mp = + List.fold_left (fun mp id -> MPdot (mp, label_of_id id)) pref_mp dir' in if modtype then ModTypeRef (make_ln mp (label_of_id id)) @@ -61,7 +61,7 @@ let lookup_qualid (modtype:bool) qid = *) -(* Search for the head of [qid] in [binders]. +(* Search for the head of [qid] in [binders]. If found, returns the module_path/kernel_name created from the dirpath and the basename. Searches Nametab otherwise. *) @@ -71,22 +71,22 @@ let lookup_module (loc,qid) = Dumpglob.dump_modref loc mp "modtype"; mp with | Not_found -> Modops.error_not_a_module_loc loc (string_of_qualid qid) - + let lookup_modtype (loc,qid) = try let mp = Nametab.locate_modtype qid in Dumpglob.dump_modref loc mp "mod"; mp with - | Not_found -> + | Not_found -> Modops.error_not_a_modtype_loc loc (string_of_qualid qid) -let transl_with_decl env = function +let transl_with_decl env = function | CWith_Module ((_,fqid),qid) -> With_Module (fqid,lookup_module qid) | CWith_Definition ((_,fqid),c) -> With_Definition (fqid,interp_constr Evd.empty env c) -let rec interp_modexpr env = function +let rec interp_modexpr env = function | CMEident qid -> MSEident (lookup_module qid) | CMEapply (me1,me2) -> @@ -94,10 +94,10 @@ let rec interp_modexpr env = function let me2 = interp_modexpr env me2 in MSEapply(me1,me2) -let rec interp_modtype env = function +let rec interp_modtype env = function | CMTEident qid -> MSEident (lookup_modtype qid) - | CMTEapply (mty1,me) -> + | CMTEapply (mty1,me) -> let mty' = interp_modtype env mty1 in let me' = interp_modexpr env me in MSEapply(mty',me') diff --git a/interp/modintern.mli b/interp/modintern.mli index 1f27e3c189..f39205d8b5 100644 --- a/interp/modintern.mli +++ b/interp/modintern.mli @@ -18,7 +18,7 @@ open Names open Topconstr (*i*) -(* Module expressions and module types are interpreted relatively to +(* Module expressions and module types are interpreted relatively to eventual functor or funsig arguments. *) val interp_modtype : env -> module_type_ast -> module_struct_entry diff --git a/interp/notation.ml b/interp/notation.ml index 58c28149dd..8dec15b602 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -30,7 +30,7 @@ open Ppextend no interpretation for negative numbers in [nat]); interpreters both for terms and patterns can be set; these interpreters are in permanent table [numeral_interpreter_tab] - - a set of ML printers for expressions denoting numbers parsable in + - a set of ML printers for expressions denoting numbers parsable in this scope - a set of interpretations for infix (more generally distfix) notations - an optional pair of delimiters which, when occurring in a syntactic @@ -92,10 +92,10 @@ let scope_stack = ref [] let current_scopes () = !scope_stack -let scope_is_open_in_scopes sc l = +let scope_is_open_in_scopes sc l = List.mem (Scope sc) l -let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack) +let scope_is_open sc = scope_is_open_in_scopes sc (!scope_stack) (* TODO: push nat_scope, z_scope, ... in scopes summary *) @@ -118,7 +118,7 @@ let classify_scope (local,_,_ as o) = let export_scope (local,_,_ as x) = if local then None else Some x -let (inScope,outScope) = +let (inScope,outScope) = declare_object {(default_object "SCOPE") with cache_function = cache_scope; open_function = open_scope; @@ -149,7 +149,7 @@ let declare_delimiters scope key = let sc = find_scope scope in if sc.delimiters <> None && Flags.is_verbose () then begin let old = Option.get sc.delimiters in - Flags.if_verbose + Flags.if_verbose warning ("Overwritting previous delimiting key "^old^" in scope "^scope) end; let sc = { sc with delimiters = Some key } in @@ -160,10 +160,10 @@ let declare_delimiters scope key = end; delimiters_map := Gmap.add key scope !delimiters_map -let find_delimiters_scope loc key = +let find_delimiters_scope loc key = try Gmap.find key !delimiters_map - with Not_found -> - user_err_loc + with Not_found -> + user_err_loc (loc, "find_delimiters", str ("Unknown scope delimiting key "^key^".")) (* Uninterpretation tables *) @@ -201,7 +201,7 @@ let aconstr_key = function (* Rem: AApp(ARef ref,[]) stands for @ref *) (**********************************************************************) (* Interpreting numbers (not in summary because functional objects) *) -type required_module = full_path * string list +type required_module = full_path * string list type 'a prim_token_interpreter = loc -> 'a -> rawconstr @@ -218,7 +218,7 @@ let prim_token_interpreter_tab = (Hashtbl.create 7 : (scope_name, internal_prim_token_interpreter) Hashtbl.t) let add_prim_token_interpreter sc interp = - try + try let cont = Hashtbl.find prim_token_interpreter_tab sc in Hashtbl.replace prim_token_interpreter_tab sc (interp cont) with Not_found -> @@ -228,7 +228,7 @@ let add_prim_token_interpreter sc interp = let declare_prim_token_interpreter sc interp (patl,uninterp,b) = declare_scope sc; add_prim_token_interpreter sc interp; - List.iter (fun pat -> + List.iter (fun pat -> Hashtbl.add prim_token_key_table (rawconstr_key pat) (sc,uninterp,b)) patl @@ -265,7 +265,7 @@ let find_with_delimiters = function | None -> None let rec find_without_delimiters find (ntn_scope,ntn) = function - | Scope scope :: scopes -> + | Scope scope :: scopes -> (* Is the expected ntn/numpr attached to the most recently open scope? *) if Some scope = ntn_scope then Some (None,None) @@ -277,7 +277,7 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function else find_without_delimiters find (ntn_scope,ntn) scopes | SingleNotation ntn' :: scopes -> - if ntn_scope = None & ntn = Some ntn' then + if ntn_scope = None & ntn = Some ntn' then Some (None,None) else find_without_delimiters find (ntn_scope,ntn) scopes @@ -376,7 +376,7 @@ let availability_of_notation (ntn_scope,ntn) scopes = find_without_delimiters f (ntn_scope,Some ntn) (make_current_scopes scopes) let uninterp_prim_token c = - try + try let (sc,numpr,_) = Hashtbl.find prim_token_key_table (rawconstr_key c) in match numpr c with | None -> raise No_match @@ -384,7 +384,7 @@ let uninterp_prim_token c = with Not_found -> raise No_match let uninterp_prim_token_cases_pattern c = - try + try let k = cases_pattern_key c in let (sc,numpr,b) = Hashtbl.find prim_token_key_table k in if not b then raise No_match; @@ -480,7 +480,7 @@ let rebuild_arguments_scope (req,r,l) = let l1,_ = list_chop (List.length l' - List.length l) l' in (req,r,l1@l) -let (inArgumentsScope,outArgumentsScope) = +let (inArgumentsScope,outArgumentsScope) = declare_object {(default_object "ARGUMENTS-SCOPE") with cache_function = cache_arguments_scope; load_function = load_arguments_scope; @@ -517,7 +517,7 @@ type symbol = let rec string_of_symbol = function | NonTerminal _ -> ["_"] | Terminal s -> [s] - | SProdList (_,l) -> + | SProdList (_,l) -> let l = List.flatten (List.map string_of_symbol l) in "_"::l@".."::l@["_"] | Break _ -> [] @@ -530,14 +530,14 @@ let decompose_notation_key s = if n>=len then List.rev dirs else let pos = try - String.index_from s n ' ' + String.index_from s n ' ' with Not_found -> len in let tok = match String.sub s n (pos-n) with | "_" -> NonTerminal (id_of_string "_") | s -> Terminal (drop_simple_quotes s) in - decomp_ntn (tok::dirs) (pos+1) + decomp_ntn (tok::dirs) (pos+1) in decomp_ntn [] 0 @@ -554,12 +554,12 @@ let classes_of_scope sc = let pr_scope_classes sc = let l = classes_of_scope sc in if l = [] then mt() - else + else hov 0 (str ("Bound to class"^(if List.tl l=[] then "" else "es")) ++ spc() ++ prlist_with_sep spc pr_class l) ++ fnl() let pr_notation_info prraw ntn c = - str "\"" ++ str ntn ++ str "\" := " ++ + str "\"" ++ str ntn ++ str "\" := " ++ prraw (rawconstr_of_aconstr dummy_loc c) let pr_named_scope prraw scope sc = @@ -567,7 +567,7 @@ let pr_named_scope prraw scope sc = match Gmap.fold (fun _ _ x -> x+1) sc.notations 0 with | 0 -> str "No lonely notation" | n -> str "Lonely notation" ++ (if n=1 then mt() else str"s") - else + else str "Scope " ++ str scope ++ fnl () ++ pr_delimiters_info sc.delimiters) ++ fnl () ++ pr_scope_classes scope @@ -579,7 +579,7 @@ let pr_named_scope prraw scope sc = let pr_scope prraw scope = pr_named_scope prraw scope (find_scope scope) let pr_scopes prraw = - Gmap.fold + Gmap.fold (fun scope sc strm -> pr_named_scope prraw scope sc ++ fnl () ++ strm) !scope_map (mt ()) @@ -611,7 +611,7 @@ let browse_notation strict ntn map = let trms = List.filter (function Terminal _ -> true | _ -> false) toks in if strict then [Terminal ntn] = trms else List.mem (Terminal ntn) trms in let l = - Gmap.fold + Gmap.fold (fun scope_name sc -> Gmap.fold (fun ntn ((_,r),df) l -> if find ntn then (ntn,(scope_name,r,df))::l else l) sc.notations) @@ -621,7 +621,7 @@ let browse_notation strict ntn map = let global_reference_of_notation test (ntn,(sc,c,_)) = match c with | ARef ref when test ref -> Some (ntn,sc,ref) - | AApp (ARef ref, l) when List.for_all isAVar_or_AHole l & test ref -> + | AApp (ARef ref, l) when List.for_all isAVar_or_AHole l & test ref -> Some (ntn,sc,ref) | _ -> None @@ -643,7 +643,7 @@ let interp_notation_as_global_reference loc test ntn sc = match Option.List.flatten refs with | [_,_,ref] -> ref | [] -> error_notation_not_reference loc ntn - | refs -> + | refs -> let f (ntn,sc,ref) = find_default ntn !scope_stack = Some sc in match List.filter f refs with | [_,_,ref] -> ref @@ -657,14 +657,14 @@ let locate_notation prraw ntn scope = str "Unknown notation" else t (str "Notation " ++ - tab () ++ str "Scope " ++ tab () ++ fnl () ++ + tab () ++ str "Scope " ++ tab () ++ fnl () ++ prlist (fun (ntn,l) -> let scope = find_default ntn scopes in - prlist + prlist (fun (sc,r,(_,df)) -> hov 0 ( pr_notation_info prraw df r ++ tbrk (1,2) ++ - (if sc = default_scope then mt () else (str ": " ++ str sc)) ++ + (if sc = default_scope then mt () else (str ": " ++ str sc)) ++ tbrk (1,2) ++ (if Some sc = scope then str "(default interpretation)" else mt ()) ++ fnl ())) @@ -694,7 +694,7 @@ let collect_notations stack = let all' = match all with | (s,lonelyntn)::rest when s = default_scope -> (s,(df,r)::lonelyntn)::rest - | _ -> + | _ -> (default_scope,[df,r])::all in (all',ntn::knownntn)) ([],[]) stack) @@ -706,11 +706,11 @@ let pr_visible_in_scope prraw (scope,ntns) = ntns (mt ()) in (if scope = default_scope then str "Lonely notation" ++ (if List.length ntns <> 1 then str "s" else mt()) - else + else str "Visible in scope " ++ str scope) ++ fnl () ++ strm -let pr_scope_stack prraw stack = +let pr_scope_stack prraw stack = List.fold_left (fun strm scntns -> strm ++ pr_visible_in_scope prraw scntns ++ fnl ()) (mt ()) (collect_notations stack) @@ -725,7 +725,7 @@ let pr_visibility prraw = function type unparsing_rule = unparsing list * precedence (* Concrete syntax for symbolic-extension table *) -let printing_rules = +let printing_rules = ref (Gmap.empty : (string,unparsing_rule) Gmap.t) let declare_notation_printing_rule ntn unpl = @@ -765,7 +765,7 @@ let init () = printing_rules := Gmap.empty; class_scope_map := Gmap.add CL_SORT "type_scope" Gmap.empty -let _ = +let _ = declare_summary "symbols" { freeze_function = freeze; unfreeze_function = unfreeze; diff --git a/interp/notation.mli b/interp/notation.mli index 57e0deb10a..f3036f226f 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -46,7 +46,7 @@ val scope_is_open : scope_name -> bool (* Open scope *) -val open_close_scope : +val open_close_scope : (* locality *) bool * (* open *) bool * scope_name -> unit (* Extend a list of scopes *) @@ -66,7 +66,7 @@ val find_delimiters_scope : loc -> delimiters -> scope_name an appropriate error message *) type notation_location = dir_path * string -type required_module = full_path * string list +type required_module = full_path * string list type cases_pattern_status = bool (* true = use prim token in patterns *) type 'a prim_token_interpreter = @@ -86,18 +86,18 @@ val declare_string_interpreter : scope_name -> required_module -> val interp_prim_token : loc -> prim_token -> local_scopes -> rawconstr * (notation_location * scope_name option) -val interp_prim_token_cases_pattern : loc -> prim_token -> name -> +val interp_prim_token_cases_pattern : loc -> prim_token -> name -> local_scopes -> cases_pattern * (notation_location * scope_name option) (* Return the primitive token associated to a [term]/[cases_pattern]; raise [No_match] if no such token *) -val uninterp_prim_token : +val uninterp_prim_token : rawconstr -> scope_name * prim_token -val uninterp_prim_token_cases_pattern : +val uninterp_prim_token_cases_pattern : cases_pattern -> name * scope_name * prim_token -val availability_of_prim_token : +val availability_of_prim_token : scope_name -> local_scopes -> delimiters option option (*s Declare and interpret back and forth a notation *) @@ -125,7 +125,7 @@ val uninterp_cases_pattern_notations : cases_pattern -> (* Test if a notation is available in the scopes *) (* context [scopes]; if available, the result is not None; the first *) (* argument is itself not None if a delimiters is needed *) -val availability_of_notation : scope_name option * notation -> local_scopes -> +val availability_of_notation : scope_name option * notation -> local_scopes -> (scope_name option * delimiters option) option (*s Declare and test the level of a (possibly uninterpreted) notation *) @@ -135,7 +135,7 @@ val level_of_notation : notation -> level (* raise [Not_found] if no level *) (*s** Miscellaneous *) -val interp_notation_as_global_reference : loc -> (global_reference -> bool) -> +val interp_notation_as_global_reference : loc -> (global_reference -> bool) -> notation -> delimiters option -> global_reference (* Checks for already existing notations *) @@ -143,7 +143,7 @@ val exists_notation_in_scope : scope_name option -> notation -> interpretation -> bool (* Declares and looks for scopes associated to arguments of a global ref *) -val declare_arguments_scope : +val declare_arguments_scope : bool (* true=local *) -> global_reference -> scope_name option list -> unit val find_arguments_scope : global_reference -> scope_name option list @@ -167,7 +167,7 @@ val decompose_notation_key : notation -> symbol list (* Prints scopes (expect a pure aconstr printer *) val pr_scope : (rawconstr -> std_ppcmds) -> scope_name -> std_ppcmds val pr_scopes : (rawconstr -> std_ppcmds) -> std_ppcmds -val locate_notation : (rawconstr -> std_ppcmds) -> notation -> +val locate_notation : (rawconstr -> std_ppcmds) -> notation -> scope_name option -> std_ppcmds val pr_visibility: (rawconstr -> std_ppcmds) -> scope_name option -> std_ppcmds diff --git a/interp/ppextend.ml b/interp/ppextend.ml index baef2c628f..a4142d6949 100644 --- a/interp/ppextend.ml +++ b/interp/ppextend.ml @@ -50,7 +50,7 @@ let ppcmd_of_cut = function | PpBrk(n1,n2) -> brk(n1,n2) | PpTbrk(n1,n2) -> tbrk(n1,n2) -type unparsing = +type unparsing = | UnpMetaVar of int * parenRelation | UnpListMetaVar of int * parenRelation * unparsing list | UnpTerminal of string diff --git a/interp/ppextend.mli b/interp/ppextend.mli index bddd1eef2e..3d09587d05 100644 --- a/interp/ppextend.mli +++ b/interp/ppextend.mli @@ -40,7 +40,7 @@ val ppcmd_of_box : ppbox -> std_ppcmds -> std_ppcmds val ppcmd_of_cut : ppcut -> std_ppcmds -type unparsing = +type unparsing = | UnpMetaVar of int * parenRelation | UnpListMetaVar of int * parenRelation * unparsing list | UnpTerminal of string diff --git a/interp/reserve.ml b/interp/reserve.ml index 93fc60dfb2..9d8412825f 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -24,22 +24,22 @@ let cache_reserved_type (_,(id,t)) = reserve_table := Idmap.add id t !reserve_table let (in_reserved, _) = - declare_object {(default_object "RESERVED-TYPE") with + declare_object {(default_object "RESERVED-TYPE") with cache_function = cache_reserved_type } -let _ = +let _ = Summary.declare_summary "reserved-type" { Summary.freeze_function = (fun () -> !reserve_table); Summary.unfreeze_function = (fun r -> reserve_table := r); Summary.init_function = (fun () -> reserve_table := Idmap.empty) } -let declare_reserved_type (loc,id) t = +let declare_reserved_type (loc,id) t = if id <> root_of_id id then user_err_loc(loc,"declare_reserved_type", (pr_id id ++ str " is not reservable: it must have no trailing digits, quote, or _")); begin try - let _ = Idmap.find id !reserve_table in + let _ = Idmap.find id !reserve_table in user_err_loc(loc,"declare_reserved_type", (pr_id id++str" is already bound to a type")) with Not_found -> () end; @@ -66,7 +66,7 @@ let rec unloc = function RIf (dummy_loc,unloc c,(na,Option.map unloc po),unloc b1,unloc b2) | RRec (_,fk,idl,bl,tyl,bv) -> RRec (dummy_loc,fk,idl, - Array.map (List.map + Array.map (List.map (fun (na,k,obd,ty) -> (na,k,Option.map unloc obd, unloc ty))) bl, Array.map unloc tyl, @@ -82,7 +82,7 @@ let rec unloc = function let anonymize_if_reserved na t = match na with | Name id as na -> - (try + (try if not !Flags.raw_print & unloc t = find_reserved_type id then RHole (dummy_loc,Evd.BinderType na) else t diff --git a/interp/smartlocate.ml b/interp/smartlocate.ml index 07ae87fa08..f16f5363ce 100644 --- a/interp/smartlocate.ml +++ b/interp/smartlocate.ml @@ -24,7 +24,7 @@ open Topconstr let global_of_extended_global = function | TrueGlobal ref -> ref - | SynDef kn -> + | SynDef kn -> match search_syntactic_definition dummy_loc kn with | [],ARef ref -> ref | _ -> raise Not_found @@ -33,7 +33,7 @@ let locate_global_with_alias (loc,qid) = let ref = Nametab.locate_extended qid in try global_of_extended_global ref with Not_found -> - user_err_loc (loc,"",pr_qualid qid ++ + user_err_loc (loc,"",pr_qualid qid ++ str " is bound to a notation that does not denote a reference") let global_inductive_with_alias r = diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index 3ba78e91d9..747f7b9daa 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -21,7 +21,7 @@ open Libnames type syndef_interpretation = (identifier * subscopes) list * aconstr -val declare_syntactic_definition : bool -> identifier -> bool -> +val declare_syntactic_definition : bool -> identifier -> bool -> syndef_interpretation -> unit val search_syntactic_definition : loc -> kernel_name -> syndef_interpretation diff --git a/interp/topconstr.ml b/interp/topconstr.ml index eb46a5d6e7..bea0eae314 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -23,7 +23,7 @@ open Mod_subst (* This is the subtype of rawconstr allowed in syntactic extensions *) (* For AList: first constr is iterator, second is terminator; - first id is where each argument of the list has to be substituted + first id is where each argument of the list has to be substituted in iterator and snd id is alternative name just for printing; boolean is associativity *) @@ -43,7 +43,7 @@ type aconstr = | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr | AIf of aconstr * (name * aconstr option) * aconstr * aconstr | ARec of fix_kind * identifier array * - (name * aconstr option * aconstr) list array * aconstr array * + (name * aconstr option * aconstr) list array * aconstr array * aconstr array | ASort of rawsort | AHole of Evd.hole_kind @@ -55,7 +55,7 @@ type aconstr = let name_to_ident = function | Anonymous -> error "This expression should be a simple identifier." - | Name id -> id + | Name id -> id let to_id g e id = let e,na = g e (Name id) in e,name_to_ident na @@ -92,8 +92,8 @@ let rawconstr_of_aconstr_with_binders loc g f e = function let e',tml' = List.fold_right (fun (tm,(na,t)) (e',tml') -> let e',t' = match t with | None -> e',None - | Some (ind,npar,nal) -> - let e',nal' = List.fold_right (fun na (e',nal) -> + | Some (ind,npar,nal) -> + let e',nal' = List.fold_right (fun na (e',nal) -> let e',na' = g e' na in e',na'::nal) nal (e',[]) in e',Some (loc,ind,npar,nal') in let e',na' = g e' na in @@ -105,7 +105,7 @@ let rawconstr_of_aconstr_with_binders loc g f e = function (loc,idl,patl,f e rhs)) eqnl in RCases (loc,sty,Option.map (f e') rtntypopt,tml',eqnl') | ALetTuple (nal,(na,po),b,c) -> - let e,nal = list_fold_map g e nal in + let e,nal = list_fold_map g e nal in let e,na = g e na in RLetTuple (loc,nal,(na,Option.map (f e) po),f e b,f e c) | AIf (c,(na,po),b1,b2) -> @@ -117,8 +117,8 @@ let rawconstr_of_aconstr_with_binders loc g f e = function let e,na = g e na in (e,(na,Explicit,Option.map (f e) oc,f e b)))) e dll in RRec (loc,fk,idl,dll,Array.map (f e) tl,Array.map (f e) bl) - | ACast (c,k) -> RCast (loc,f e c, - match k with + | ACast (c,k) -> RCast (loc,f e c, + match k with | CastConv (k,t) -> CastConv (k,f e t) | CastCoerce -> CastCoerce) | ASort x -> RSort (loc,x) @@ -127,7 +127,7 @@ let rawconstr_of_aconstr_with_binders loc g f e = function | ARef x -> RRef (loc,x) let rec rawconstr_of_aconstr loc x = - let rec aux () x = + let rec aux () x = rawconstr_of_aconstr_with_binders loc (fun () id -> ((),id)) aux () x in aux () x @@ -167,7 +167,7 @@ let discriminate_patterns foundvars nl l1 l2 = let rec aux n c1 c2 = match c1,c2 with | RVar (_,v1), RVar (_,v2) when v1<>v2 -> if !diff = None then (diff := Some (v1,v2,(n>=nl)); true) - else + else !diff = Some (v1,v2,(n>=nl)) or !diff = Some (v2,v1,(n found := id::!found; AVar id - | RApp (_,f,args) when has_ldots args -> make_aconstr_list f args + | RApp (_,f,args) when has_ldots args -> make_aconstr_list f args | RApp (_,RVar (_,f),[RApp (_,t,[c]);d]) when f = ldots_var -> (* Special case for alternative (recursive) notation of application *) let x,y,lassoc = discriminate_patterns found 0 [c] [d] in @@ -216,13 +216,13 @@ let aconstr_and_vars_of_rawconstr a = AIf (aux c,(na,Option.map aux po),aux b1,aux b2) | RRec (_,fk,idl,dll,tl,bl) -> Array.iter (fun id -> found := id::!found) idl; - let dll = Array.map (List.map (fun (na,bk,oc,b) -> - if bk <> Explicit then + let dll = Array.map (List.map (fun (na,bk,oc,b) -> + if bk <> Explicit then error "Binders marked as implicit not allowed in notations."; add_name found na; (na,Option.map aux oc,aux b))) dll in ARec (fk,idl,dll,Array.map aux tl,Array.map aux bl) - | RCast (_,c,k) -> ACast (aux c, - match k with CastConv (k,t) -> CastConv (k,aux t) + | RCast (_,c,k) -> ACast (aux c, + match k with CastConv (k,t) -> CastConv (k,aux t) | CastCoerce -> CastCoerce) | RSort (_,s) -> ASort s | RHole (_,w) -> AHole w @@ -277,65 +277,65 @@ let aconstr_of_rawconstr vars a = let aconstr_of_constr avoiding t = aconstr_of_rawconstr [] (Detyping.detype false avoiding [] t) -let rec subst_pat subst pat = +let rec subst_pat subst pat = match pat with | PatVar _ -> pat - | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_kn subst kn + | PatCstr (loc,((kn,i),j),cpl,n) -> + let kn' = subst_kn subst kn and cpl' = list_smartmap (subst_pat subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) let rec subst_aconstr subst bound raw = match raw with - | ARef ref -> - let ref',t = subst_global subst ref in + | ARef ref -> + let ref',t = subst_global subst ref in if ref' == ref then raw else aconstr_of_constr bound t | AVar _ -> raw - | AApp (r,rl) -> - let r' = subst_aconstr subst bound r + | AApp (r,rl) -> + let r' = subst_aconstr subst bound r and rl' = list_smartmap (subst_aconstr subst bound) rl in if r' == r && rl' == rl then raw else AApp(r',rl') - | AList (id1,id2,r1,r2,b) -> + | AList (id1,id2,r1,r2,b) -> let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else AList (id1,id2,r1',r2',b) - | ALambda (n,r1,r2) -> + | ALambda (n,r1,r2) -> let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else ALambda (n,r1',r2') - | AProd (n,r1,r2) -> + | AProd (n,r1,r2) -> let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else AProd (n,r1',r2') - | ALetIn (n,r1,r2) -> - let r1' = subst_aconstr subst bound r1 + | ALetIn (n,r1,r2) -> + let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else ALetIn (n,r1',r2') - | ACases (sty,rtntypopt,rl,branches) -> + | ACases (sty,rtntypopt,rl,branches) -> let rtntypopt' = Option.smartmap (subst_aconstr subst bound) rtntypopt and rl' = list_smartmap - (fun (a,(n,signopt) as x) -> + (fun (a,(n,signopt) as x) -> let a' = subst_aconstr subst bound a in let signopt' = Option.map (fun ((indkn,i),n,nal as z) -> let indkn' = subst_kn subst indkn in if indkn == indkn' then z else ((indkn',i),n,nal)) signopt in if a' == a && signopt' == signopt then x else (a',(n,signopt'))) rl - and branches' = list_smartmap + and branches' = list_smartmap (fun (cpl,r as branch) -> let cpl' = list_smartmap (subst_pat subst) cpl and r' = subst_aconstr subst bound r in @@ -349,7 +349,7 @@ let rec subst_aconstr subst bound raw = | ALetTuple (nal,(na,po),b,c) -> let po' = Option.smartmap (subst_aconstr subst bound) po - and b' = subst_aconstr subst bound b + and b' = subst_aconstr subst bound b and c' = subst_aconstr subst bound c in if po' == po && b' == b && c' == c then raw else ALetTuple (nal,(na,po'),b',c') @@ -357,13 +357,13 @@ let rec subst_aconstr subst bound raw = | AIf (c,(na,po),b1,b2) -> let po' = Option.smartmap (subst_aconstr subst bound) po and b1' = subst_aconstr subst bound b1 - and b2' = subst_aconstr subst bound b2 + and b2' = subst_aconstr subst bound b2 and c' = subst_aconstr subst bound c in if po' == po && b1' == b1 && b2' == b2 && c' == c then raw else AIf (c',(na,po'),b1',b2') | ARec (fk,idl,dll,tl,bl) -> - let dll' = + let dll' = array_smartmap (list_smartmap (fun (na,oc,b as x) -> let oc' = Option.smartmap (subst_aconstr subst bound) oc in let b' = subst_aconstr subst bound b in @@ -376,17 +376,17 @@ let rec subst_aconstr subst bound raw = | APatVar _ | ASort _ -> raw | AHole (Evd.ImplicitArg (ref,i,b)) -> - let ref',t = subst_global subst ref in + let ref',t = subst_global subst ref in if ref' == ref then raw else AHole (Evd.InternalHole) - | AHole (Evd.BinderType _ | Evd.QuestionMark _ | Evd.CasesType + | AHole (Evd.BinderType _ | Evd.QuestionMark _ | Evd.CasesType | Evd.InternalHole | Evd.TomatchTypeParameter _ | Evd.GoalEvar | Evd.ImpossibleCase) -> raw - | ACast (r1,k) -> + | ACast (r1,k) -> match k with CastConv (k, r2) -> - let r1' = subst_aconstr subst bound r1 + let r1' = subst_aconstr subst bound r1 and r2' = subst_aconstr subst bound r2 in if r1' == r1 && r2' == r2 then raw else ACast (r1',CastConv (k,r2')) @@ -394,7 +394,7 @@ let rec subst_aconstr subst bound raw = let r1' = subst_aconstr subst bound r1 in if r1' == r1 then raw else ACast (r1',CastCoerce) - + let subst_interpretation subst (metas,pat) = let bound = List.map fst (fst metas @ snd metas) in (metas,subst_aconstr subst bound pat) @@ -449,7 +449,7 @@ let match_fix_kind fk1 fk2 = match (fk1,fk2) with | RCoFix n1, RCoFix n2 -> n1 = n2 | RFix (nl1,n1), RFix (nl2,n2) -> - n1 = n2 && + n1 = n2 && array_for_all2 (fun (n1,_) (n2,_) -> n2 = None || n1 = n2) nl1 nl2 | _ -> false @@ -496,7 +496,7 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with let l11,l12 = list_chop (n1-n2) l1 in RApp (loc,f1,l11),l12, f2,l2 else f1,l1, f2, l2 in List.fold_left2 (match_ alp metas) (match_ alp metas sigma f1 f2) l1 l2 - | RApp (loc,f1,l1), AList (x,_,(AApp (f2,l2) as iter),termin,lassoc) + | RApp (loc,f1,l1), AList (x,_,(AApp (f2,l2) as iter),termin,lassoc) when List.length l1 >= List.length l2 -> let f1,l1 = adjust_application_n (List.length l2) loc f1 l1 in match_alist alp metas sigma (f1::l1) (f2::l2) x iter termin lassoc @@ -506,20 +506,20 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2 | RLetIn (_,na1,t1,b1), ALetIn (na2,t2,b2) -> match_binders alp metas na1 na2 (match_ alp metas sigma t1 t2) b1 b2 - | RCases (_,sty1,rtno1,tml1,eqnl1), ACases (sty2,rtno2,tml2,eqnl2) + | RCases (_,sty1,rtno1,tml1,eqnl1), ACases (sty2,rtno2,tml2,eqnl2) when sty1 = sty2 & List.length tml1 = List.length tml2 & List.length eqnl1 = List.length eqnl2 -> let rtno1' = abstract_return_type_context_rawconstr tml1 rtno1 in let rtno2' = abstract_return_type_context_aconstr tml2 rtno2 in - let sigma = - try Option.fold_left2 (match_ alp metas) sigma rtno1' rtno2' - with Option.Heterogeneous -> raise No_match + let sigma = + try Option.fold_left2 (match_ alp metas) sigma rtno1' rtno2' + with Option.Heterogeneous -> raise No_match in - let sigma = List.fold_left2 + let sigma = List.fold_left2 (fun s (tm1,_) (tm2,_) -> match_ alp metas s tm1 tm2) sigma tml1 tml2 in List.fold_left2 (match_equations alp metas) sigma eqnl1 eqnl2 - | RLetTuple (_,nal1,(na1,to1),b1,c1), ALetTuple (nal2,(na2,to2),b2,c2) + | RLetTuple (_,nal1,(na1,to1),b1,c1), ALetTuple (nal2,(na2,to2),b2,c2) when List.length nal1 = List.length nal2 -> let sigma = match_opt (match_binders alp metas na1 na2) sigma to1 to2 in let sigma = match_ alp metas sigma b1 b2 in @@ -529,7 +529,7 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with | RIf (_,a1,(na1,to1),b1,c1), AIf (a2,(na2,to2),b2,c2) -> let sigma = match_opt (match_binders alp metas na1 na2) sigma to1 to2 in List.fold_left2 (match_ alp metas) sigma [a1;b1;c1] [a2;b2;c2] - | RRec (_,fk1,idl1,dll1,tl1,bl1), ARec (fk2,idl2,dll2,tl2,bl2) + | RRec (_,fk1,idl1,dll1,tl1,bl1), ARec (fk2,idl2,dll2,tl2,bl2) when match_fix_kind fk1 fk2 & Array.length idl1 = Array.length idl2 & array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) dll1 dll2 -> @@ -539,7 +539,7 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with match_ alp metas (match_opt (match_ alp metas) sigma oc1 oc2) b1 b2 in match_names metas (alp,sigma) na1 na2)) (alp,sigma) dll1 dll2 in let sigma = array_fold_left2 (match_ alp metas) sigma tl1 tl2 in - let alp,sigma = array_fold_right2 (fun id1 id2 alsig -> + let alp,sigma = array_fold_right2 (fun id1 id2 alsig -> match_names metas alsig (Name id1) (Name id2)) idl1 idl2 (alp,sigma) in array_fold_left2 (match_ alp metas) sigma bl1 bl2 | RCast(_,c1, CastConv(_,t1)), ACast(c2, CastConv (_,t2)) -> @@ -549,7 +549,7 @@ let rec match_ alp metas sigma a1 a2 = match (a1,a2) with | RSort (_,s1), ASort s2 when s1 = s2 -> sigma | RPatVar _, AHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match | a, AHole _ -> sigma - | (RDynamic _ | RRec _ | REvar _), _ + | (RDynamic _ | RRec _ | REvar _), _ | _,_ -> raise No_match and match_alist alp metas sigma l1 l2 x iter termin lassoc = @@ -563,7 +563,7 @@ and match_alist alp metas sigma l1 l2 x iter termin lassoc = let sigmavar = List.remove_assoc x (List.remove_assoc ldots_var sigmavar) in (* try to find the remaining elements or the terminator *) let rec match_alist_tail alp metas sigma acc rest = - try + try let sigmavar,sigmalist = match_ alp (ldots_var::metas) sigma rest iter in let rest = List.assoc ldots_var sigmavar in let t = List.assoc x sigmavar in @@ -582,7 +582,7 @@ and match_binders alp metas na1 na2 sigma b1 b2 = and match_equations alp metas sigma (_,_,patl1,rhs1) (patl2,rhs2) = (* patl1 and patl2 have the same length because they respectively correspond to some tml1 and tml2 that have the same length *) - let (alp,sigma) = + let (alp,sigma) = List.fold_left2 (match_cases_pattern metas) (alp,sigma) patl1 patl2 in match_ alp metas sigma rhs1 rhs2 @@ -645,7 +645,7 @@ type constr_expr = | CLambdaN of loc * (name located list * binder_kind * constr_expr) list * constr_expr | CLetIn of loc * name located * constr_expr * constr_expr | CAppExpl of loc * (proj_flag * reference) * constr_expr list - | CApp of loc * (proj_flag * constr_expr) * + | CApp of loc * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list | CRecord of loc * constr_expr option * (identifier located * constr_expr) list | CCases of loc * case_style * constr_expr option * @@ -672,7 +672,7 @@ and fixpoint_expr = and local_binder = | LocalRawDef of name located * constr_expr | LocalRawAssum of name located list * binder_kind * constr_expr - + and typeclass_constraint = name located * binding_kind * constr_expr and typeclass_context = typeclass_constraint list @@ -680,7 +680,7 @@ and typeclass_context = typeclass_constraint list and cofixpoint_expr = identifier located * local_binder list * constr_expr * constr_expr -and recursion_order_expr = +and recursion_order_expr = | CStructRec | CWfRec of constr_expr | CMeasureRec of constr_expr * constr_expr option (* measure, relation *) @@ -755,7 +755,7 @@ let ids_of_cases_indtype = let rec vars_of = function (* We deal only with the regular cases *) | CApp (_,_,l) -> List.fold_left add_var [] (List.map fst l) - | CNotation (_,_,(l,[])) + | CNotation (_,_,(l,[])) (* assume the ntn is applicative and does not instantiate the head !! *) | CAppExpl (_,_,l) -> List.fold_left add_var [] l | CDelimiters(_,_,c) -> vars_of c @@ -772,7 +772,7 @@ let ids_of_cases_tomatch tms = let is_constructor id = try ignore (Nametab.locate_extended (qualid_of_ident id)); true with Not_found -> true - + let rec cases_pattern_fold_names f a = function | CPatAlias (_,pat,id) -> f id a | CPatCstr (_,_,patl) | CPatOr (_,patl) -> @@ -785,7 +785,7 @@ let rec cases_pattern_fold_names f a = function let ids_of_pattern_list = List.fold_left - (located_fold_left + (located_fold_left (List.fold_left (cases_pattern_fold_names Idset.add))) Idset.empty @@ -837,12 +837,12 @@ let fold_constr_expr_with_binders g f n acc = function | CFix (loc,_,l) -> let n' = List.fold_right (fun ((_,id),_,_,_,_) -> g id) l n in List.fold_right (fun (_,(_,o),lb,t,c) acc -> - fold_local_binders g f n' + fold_local_binders g f n' (fold_local_binders g f n acc t lb) c lb) l acc - | CCoFix (loc,_,_) -> + | CCoFix (loc,_,_) -> Pp.warning "Capture check in multiple binders not done"; acc -let free_vars_of_constr_expr c = +let free_vars_of_constr_expr c = let rec aux bdvars l = function | CRef (Ident (_,id)) -> if List.mem id bdvars then l else Idset.add id l | c -> fold_constr_expr_with_binders (fun a l -> a::l) aux bdvars l c @@ -860,18 +860,18 @@ let mkProdC (idl,bk,a,b) = CProdN (dummy_loc,[idl,bk,a],b) let rec mkCProdN loc bll c = match bll with - | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> + | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> CProdN (loc,[idl,bk,t],mkCProdN (join_loc loc1 loc) bll c) - | LocalRawDef ((loc1,_) as id,b) :: bll -> + | LocalRawDef ((loc1,_) as id,b) :: bll -> CLetIn (loc,id,b,mkCProdN (join_loc loc1 loc) bll c) | [] -> c | LocalRawAssum ([],_,_) :: bll -> mkCProdN loc bll c let rec mkCLambdaN loc bll c = match bll with - | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> + | LocalRawAssum ((loc1,_)::_ as idl,bk,t) :: bll -> CLambdaN (loc,[idl,bk,t],mkCLambdaN (join_loc loc1 loc) bll c) - | LocalRawDef ((loc1,_) as id,b) :: bll -> + | LocalRawDef ((loc1,_) as id,b) :: bll -> CLetIn (loc,id,b,mkCLambdaN (join_loc loc1 loc) bll c) | [] -> c | LocalRawAssum ([],_,_) :: bll -> mkCLambdaN loc bll c @@ -882,7 +882,7 @@ let rec abstract_constr_expr c = function | LocalRawAssum (idl,bk,t)::bl -> List.fold_right (fun x b -> mkLambdaC([x],bk,t,b)) idl (abstract_constr_expr c bl) - + let rec prod_constr_expr c = function | [] -> c | LocalRawDef (x,b)::bl -> mkLetInC(x,b,prod_constr_expr c bl) @@ -932,8 +932,8 @@ let map_local_binders f g e bl = let map_constr_expr_with_binders g f e = function | CArrow (loc,a,b) -> CArrow (loc,f e a,f e b) - | CAppExpl (loc,r,l) -> CAppExpl (loc,r,List.map (f e) l) - | CApp (loc,(p,a),l) -> + | CAppExpl (loc,r,l) -> CAppExpl (loc,r,List.map (f e) l) + | CApp (loc,(p,a),l) -> CApp (loc,(p,f e a),List.map (fun (a,i) -> (f e a,i)) l) | CProdN (loc,bl,b) -> let (e,bl) = map_binders f g e bl in CProdN (loc,bl,f e b) @@ -946,7 +946,7 @@ let map_constr_expr_with_binders g f e = function CNotation (loc,n,(List.map (f e) l,List.map (List.map (f e)) ll)) | CGeneralization (loc,b,a,c) -> CGeneralization (loc,b,a,f e c) | CDelimiters (loc,s,a) -> CDelimiters (loc,s,f e a) - | CHole _ | CEvar _ | CPatVar _ | CSort _ + | CHole _ | CEvar _ | CPatVar _ | CSort _ | CPrim _ | CDynamic _ | CRef _ as x -> x | CRecord (loc,p,l) -> CRecord (loc,p,List.map (fun (id, c) -> (id, f e c)) l) | CCases (loc,sty,rtnpo,a,bl) -> @@ -963,7 +963,7 @@ let map_constr_expr_with_binders g f e = function let e' = Option.fold_right (name_fold g) ona e in CIf (loc,f e c,(ona,Option.map (f e') po),f e b1,f e b2) | CFix (loc,id,dl) -> - CFix (loc,id,List.map (fun (id,n,bl,t,d) -> + CFix (loc,id,List.map (fun (id,n,bl,t,d) -> let (e',bl') = map_local_binders f g e bl in let t' = f e' t in (* Note: fix names should be inserted before the arguments... *) @@ -982,22 +982,22 @@ let map_constr_expr_with_binders g f e = function let rec replace_vars_constr_expr l = function | CRef (Ident (loc,id)) as x -> (try CRef (Ident (loc,List.assoc id l)) with Not_found -> x) - | c -> map_constr_expr_with_binders List.remove_assoc + | c -> map_constr_expr_with_binders List.remove_assoc replace_vars_constr_expr l c (**********************************************************************) (* Concrete syntax for modules and modules types *) -type with_declaration_ast = +type with_declaration_ast = | CWith_Module of identifier list located * qualid located | CWith_Definition of identifier list located * constr_expr -type module_ast = +type module_ast = | CMEident of qualid located | CMEapply of module_ast * module_ast -type module_type_ast = +type module_type_ast = | CMTEident of qualid located | CMTEapply of module_type_ast * module_ast | CMTEwith of module_type_ast * with_declaration_ast diff --git a/interp/topconstr.mli b/interp/topconstr.mli index 0b6cf46c59..2c28b3bead 100644 --- a/interp/topconstr.mli +++ b/interp/topconstr.mli @@ -39,7 +39,7 @@ type aconstr = | ALetTuple of name list * (name * aconstr option) * aconstr * aconstr | AIf of aconstr * (name * aconstr option) * aconstr * aconstr | ARec of fix_kind * identifier array * - (name * aconstr option * aconstr) list array * aconstr array * + (name * aconstr option * aconstr) list array * aconstr array * aconstr array | ASort of rawsort | AHole of Evd.hole_kind @@ -48,7 +48,7 @@ type aconstr = (**********************************************************************) (* Translate a rawconstr into a notation given the list of variables *) -(* bound by the notation; also interpret recursive patterns *) +(* bound by the notation; also interpret recursive patterns *) val aconstr_of_rawconstr : identifier list -> rawconstr -> aconstr @@ -61,7 +61,7 @@ val eq_rawconstr : rawconstr -> rawconstr -> bool (**********************************************************************) (* Re-interpret a notation as a rawconstr, taking care of binders *) -val rawconstr_of_aconstr_with_binders : loc -> +val rawconstr_of_aconstr_with_binders : loc -> ('a -> name -> 'a * name) -> ('a -> aconstr -> rawconstr) -> 'a -> aconstr -> rawconstr @@ -97,9 +97,9 @@ val subst_interpretation : substitution -> interpretation -> interpretation type notation = string type explicitation = ExplByPos of int * identifier option | ExplByName of identifier - -type binder_kind = - | Default of binding_kind + +type binder_kind = + | Default of binding_kind | Generalized of binding_kind * binding_kind * bool (* Inner binding, outer bindings, typeclass-specific flag for implicit generalization of superclasses *) @@ -131,7 +131,7 @@ type constr_expr = | CLambdaN of loc * (name located list * binder_kind * constr_expr) list * constr_expr | CLetIn of loc * name located * constr_expr * constr_expr | CAppExpl of loc * (proj_flag * reference) * constr_expr list - | CApp of loc * (proj_flag * constr_expr) * + | CApp of loc * (proj_flag * constr_expr) * (constr_expr * explicitation located option) list | CRecord of loc * constr_expr option * (identifier located * constr_expr) list | CCases of loc * case_style * constr_expr option * @@ -158,7 +158,7 @@ and fixpoint_expr = and cofixpoint_expr = identifier located * local_binder list * constr_expr * constr_expr -and recursion_order_expr = +and recursion_order_expr = | CStructRec | CWfRec of constr_expr | CMeasureRec of constr_expr * constr_expr option (* measure, relation *) @@ -167,7 +167,7 @@ and recursion_order_expr = and local_binder = | LocalRawDef of name located * constr_expr | LocalRawAssum of name located list * binder_kind * constr_expr - + type typeclass_constraint = name located * binding_kind * constr_expr and typeclass_context = typeclass_constraint list @@ -240,16 +240,16 @@ val map_constr_expr_with_binders : (**********************************************************************) (* Concrete syntax for modules and module types *) -type with_declaration_ast = +type with_declaration_ast = | CWith_Module of identifier list located * qualid located | CWith_Definition of identifier list located * constr_expr -type module_ast = +type module_ast = | CMEident of qualid located | CMEapply of module_ast * module_ast -type module_type_ast = +type module_type_ast = | CMTEident of qualid located | CMTEapply of module_type_ast * module_ast | CMTEwith of module_type_ast * with_declaration_ast diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index ceba6e82a0..f4d0bb2b22 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -1,7 +1,7 @@ open Names open Term -type tag = int +type tag = int let id_tag = 0 let iddef_tag = 1 @@ -14,22 +14,22 @@ let cofix_evaluated_tag = 6 type structured_constant = | Const_sorts of sorts | Const_ind of inductive - | Const_b0 of tag + | Const_b0 of tag | Const_bn of tag * structured_constant array -type reloc_table = (tag * int) array +type reloc_table = (tag * int) array -type annot_switch = +type annot_switch = {ci : case_info; rtbl : reloc_table; tailcall : bool} - -module Label = + +module Label = struct type t = int let no = -1 let counter = ref no let create () = incr counter; !counter - let reset_label_counter () = counter := no + let reset_label_counter () = counter := no end @@ -49,24 +49,24 @@ type instruction = | Kgrab of int (* number of arguments *) | Kgrabrec of int (* rec arg *) | Kclosure of Label.t * int (* label, number of free variables *) - | Kclosurerec of int * int * Label.t array * Label.t array + | Kclosurerec of int * int * Label.t array * Label.t array (* nb fv, init, lbl types, lbl bodies *) - | Kclosurecofix of int * int * Label.t array * Label.t array + | Kclosurecofix of int * int * Label.t array * Label.t array (* nb fv, init, lbl types, lbl bodies *) | Kgetglobal of constant | Kconst of structured_constant | Kmakeblock of int * tag (* size, tag *) - | Kmakeprod + | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (* consts,blocks *) - | Kpushfields of int + | Kpushfields of int | Kfield of int | Ksetfield of int | Kstop | Ksequence of bytecodes * bytecodes (* spiwack: instructions concerning integers *) | Kbranch of Label.t (* jump to label *) - | Kaddint31 (* adds the int31 in the accu + | Kaddint31 (* adds the int31 in the accu and the one ontop of the stack *) | Kaddcint31 (* makes the sum and keeps the carry *) | Kaddcarrycint31 (* sum +1, keeps the carry *) @@ -77,10 +77,10 @@ type instruction = | Kmulcint31 (* multiplication, result in two int31, for exact computation *) | Kdiv21int31 (* divides a double size integer - (represented by an int31 in the - accumulator and one on the top of + (represented by an int31 in the + accumulator and one on the top of the stack) by an int31. The result - is a pair of the quotient and the + is a pair of the quotient and the rest. If the divisor is 0, it returns 0. *) @@ -90,11 +90,11 @@ type instruction = cycling. Takes 3 int31 i j and s, and returns x*2^s+y/(2^(31-s) *) | Kcompareint31 (* unsigned comparison of int31 - cf COMPAREINT31 in + cf COMPAREINT31 in kernel/byterun/coq_interp.c for more info *) | Khead0int31 (* Give the numbers of 0 in head of a in31*) - | Ktail0int31 (* Give the numbers of 0 in tail of a in31 + | Ktail0int31 (* Give the numbers of 0 in tail of a in31 ie low bits *) | Kisconst of Label.t (* conditional jump *) | Kareconst of int*Label.t (* conditional jump *) @@ -118,19 +118,19 @@ exception NotClosed type vm_env = { size : int; (* longueur de la liste [n] *) fv_rev : fv_elem list (* [fvn; ... ;fv1] *) - } - - -type comp_env = { + } + + +type comp_env = { nb_stack : int; (* nbre de variables sur la pile *) in_stack : int list; (* position dans la pile *) nb_rec : int; (* nbre de fonctions mutuellement *) (* recursives = nbr *) pos_rec : instruction list; (* instruction d'acces pour les variables *) (* de point fix ou de cofix *) - offset : int; - in_env : vm_env ref - } + offset : int; + in_env : vm_env ref + } @@ -176,7 +176,7 @@ let rec instruction ppf = function | Kmakeprod -> fprintf ppf "\tmakeprod" | Kmakeswitchblock(lblt,lbls,_,sz) -> fprintf ppf "\tmakeswitchblock %i, %i, %i" lblt lbls sz - | Kswitch(lblc,lblb) -> + | Kswitch(lblc,lblb) -> fprintf ppf "\tswitch"; Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblc; Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb; @@ -185,7 +185,7 @@ let rec instruction ppf = function | Kfield n -> fprintf ppf "\tgetfield %i" n | Kstop -> fprintf ppf "\tstop" | Ksequence (c1,c2) -> - fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 + fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 (* spiwack *) | Kbranch lbl -> fprintf ppf "\tbranch %i" lbl | Kaddint31 -> fprintf ppf "\taddint31" @@ -218,9 +218,9 @@ and instruction_list ppf = function fprintf ppf "%a@ %a" instruction instr instruction_list il -(*spiwack: moved this type in this file because I needed it for +(*spiwack: moved this type in this file because I needed it for retroknowledge which can't depend from cbytegen *) -type block = +type block = | Bconstr of constr | Bstrconst of structured_constant | Bmakeblock of int * block array @@ -228,10 +228,10 @@ type block = (* tag , nparams, arity *) | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array (* spiwack: compilation given by a function *) - (* compilation function (see get_vm_constant_dynamic_info in + (* compilation function (see get_vm_constant_dynamic_info in retroknowledge.mli for more info) , argument array *) - + let draw_instr c = fprintf std_formatter "@[%a@]" instruction_list c diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index c24b5a5301..f4dc0b14dd 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -1,7 +1,7 @@ open Names open Term -type tag = int +type tag = int val id_tag : tag val iddef_tag : tag @@ -14,21 +14,21 @@ val cofix_evaluated_tag : tag type structured_constant = | Const_sorts of sorts | Const_ind of inductive - | Const_b0 of tag + | Const_b0 of tag | Const_bn of tag * structured_constant array -type reloc_table = (tag * int) array +type reloc_table = (tag * int) array -type annot_switch = +type annot_switch = {ci : case_info; rtbl : reloc_table; tailcall : bool} -module Label : +module Label : sig type t = int val no : t val create : unit -> t val reset_label_counter : unit -> unit - end + end type instruction = | Klabel of Label.t @@ -46,24 +46,24 @@ type instruction = | Kgrab of int (* number of arguments *) | Kgrabrec of int (* rec arg *) | Kclosure of Label.t * int (* label, number of free variables *) - | Kclosurerec of int * int * Label.t array * Label.t array + | Kclosurerec of int * int * Label.t array * Label.t array (* nb fv, init, lbl types, lbl bodies *) - | Kclosurecofix of int * int * Label.t array * Label.t array + | Kclosurecofix of int * int * Label.t array * Label.t array (* nb fv, init, lbl types, lbl bodies *) | Kgetglobal of constant | Kconst of structured_constant | Kmakeblock of int * tag (* size, tag *) - | Kmakeprod + | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (* consts,blocks *) - | Kpushfields of int + | Kpushfields of int | Kfield of int | Ksetfield of int | Kstop | Ksequence of bytecodes * bytecodes (* spiwack: instructions concerning integers *) | Kbranch of Label.t (* jump to label, is it needed ? *) - | Kaddint31 (* adds the int31 in the accu + | Kaddint31 (* adds the int31 in the accu and the one ontop of the stack *) | Kaddcint31 (* makes the sum and keeps the carry *) | Kaddcarrycint31 (* sum +1, keeps the carry *) @@ -74,10 +74,10 @@ type instruction = | Kmulcint31 (* multiplication, result in two int31, for exact computation *) | Kdiv21int31 (* divides a double size integer - (represented by an int31 in the - accumulator and one on the top of + (represented by an int31 in the + accumulator and one on the top of the stack) by an int31. The result - is a pair of the quotient and the + is a pair of the quotient and the rest. If the divisor is 0, it returns 0. *) @@ -87,11 +87,11 @@ type instruction = cycling. Takes 3 int31 i j and s, and returns x*2^s+y/(2^(31-s) *) | Kcompareint31 (* unsigned comparison of int31 - cf COMPAREINT31 in + cf COMPAREINT31 in kernel/byterun/coq_interp.c for more info *) | Khead0int31 (* Give the numbers of 0 in head of a in31*) - | Ktail0int31 (* Give the numbers of 0 in tail of a in31 + | Ktail0int31 (* Give the numbers of 0 in tail of a in31 ie low bits *) | Kisconst of Label.t (* conditional jump *) | Kareconst of int*Label.t (* conditional jump *) @@ -116,31 +116,31 @@ exception NotClosed type vm_env = { size : int; (* longueur de la liste [n] *) fv_rev : fv_elem list (* [fvn; ... ;fv1] *) - } - - -type comp_env = { + } + + +type comp_env = { nb_stack : int; (* nbre de variables sur la pile *) in_stack : int list; (* position dans la pile *) nb_rec : int; (* nbre de fonctions mutuellement *) (* recursives = nbr *) pos_rec : instruction list; (* instruction d'acces pour les variables *) (* de point fix ou de cofix *) - offset : int; - in_env : vm_env ref - } + offset : int; + in_env : vm_env ref + } val draw_instr : bytecodes -> unit (*spiwack: moved this here because I needed it for retroknowledge *) -type block = +type block = | Bconstr of constr | Bstrconst of structured_constant | Bmakeblock of int * block array | Bconstruct_app of int * int * int * block array (* tag , nparams, arity *) | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array - (* compilation function (see get_vm_constant_dynamic_info in + (* compilation function (see get_vm_constant_dynamic_info in retroknowledge.mli for more info) , argument array *) diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 721134252b..a7e8b0b265 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -80,71 +80,71 @@ open Pre_env (* [a1] est mis a jour : *) (* a1 = [A_t | accumulate | [Cfxe_t | fcofix1 | [cons_t | 1 | a1]] ] *) (* Le cycle est cree ... *) - + (* On conserve la fct de cofix pour la conversion *) - - + + let empty_fv = { size= 0; fv_rev = [] } - + let fv r = !(r.in_env) - -let empty_comp_env ()= - { nb_stack = 0; + +let empty_comp_env ()= + { nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; - offset = 0; + offset = 0; in_env = ref empty_fv; - } + } (*i Creation functions for comp_env *) let rec add_param n sz l = - if n = 0 then l else add_param (n - 1) sz (n+sz::l) - -let comp_env_fun arity = - { nb_stack = arity; + if n = 0 then l else add_param (n - 1) sz (n+sz::l) + +let comp_env_fun arity = + { nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = 0; pos_rec = []; - offset = 1; - in_env = ref empty_fv - } - + offset = 1; + in_env = ref empty_fv + } -let comp_env_type rfv = - { nb_stack = 0; + +let comp_env_type rfv = + { nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; - offset = 1; - in_env = rfv + offset = 1; + in_env = rfv } - + let comp_env_fix ndef curr_pos arity rfv = let prec = ref [] in for i = ndef downto 1 do - prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec + prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec done; - { nb_stack = arity; + { nb_stack = arity; in_stack = add_param arity 0 []; - nb_rec = ndef; + nb_rec = ndef; pos_rec = !prec; offset = 2 * (ndef - curr_pos - 1)+1; - in_env = rfv - } + in_env = rfv + } let comp_env_cofix ndef arity rfv = let prec = ref [] in for i = 1 to ndef do prec := Kenvacc i :: !prec done; - { nb_stack = arity; + { nb_stack = arity; in_stack = add_param arity 0 []; - nb_rec = ndef; + nb_rec = ndef; pos_rec = !prec; offset = ndef+1; - in_env = rfv + in_env = rfv } (* [push_param ] ajoute les parametres de fonction dans la pile *) @@ -155,15 +155,15 @@ let push_param n sz r = (* [push_local e sz] ajoute une nouvelle variable dans la pile a la *) (* position [sz] *) -let push_local sz r = - { r with +let push_local sz r = + { r with nb_stack = r.nb_stack + 1; in_stack = (sz + 1) :: r.in_stack } (*i Compilation of variables *) -let find_at el l = +let find_at el l = let rec aux n = function | [] -> raise Not_found | hd :: tl -> if hd = el then n else aux (n+1) tl @@ -178,12 +178,12 @@ let pos_named id r = r.in_env := { size = pos+1; fv_rev = cid:: env.fv_rev}; Kenvacc (r.offset + pos) -let pos_rel i r sz = +let pos_rel i r sz = if i <= r.nb_stack then Kacc(sz - (List.nth r.in_stack (i-1))) else let i = i - r.nb_stack in - if i <= r.nb_rec then + if i <= r.nb_rec then try List.nth r.pos_rec (i-1) with _ -> assert false else @@ -223,7 +223,7 @@ let label_code = function when executed, branches to the continuation or performs what the continuation performs. We avoid generating branches to returns. *) (* spiwack: make_branch was only used once. Changed it back to the ZAM - one to match the appropriate semantics (old one avoided the + one to match the appropriate semantics (old one avoided the introduction of an unconditional branch operation, which seemed appropriate for the 31-bit integers' code). As a memory, I leave the former version in this comment. @@ -259,7 +259,7 @@ let rec is_tailcall = function | _ -> None (* Extention of the continuation *) - + (* Add a Kpop n instruction in front of a continuation *) let rec add_pop n = function | Kpop m :: cont -> add_pop (n+m) cont @@ -269,9 +269,9 @@ let rec add_pop n = function let add_grab arity lbl cont = if arity = 1 then Klabel lbl :: cont else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont - + let add_grabrec rec_arg arity lbl cont = - if arity = 1 then + if arity = 1 then Klabel lbl :: Kgrabrec 0 :: Krestart :: cont else Krestart :: Klabel lbl :: Kgrabrec rec_arg :: @@ -288,11 +288,11 @@ let cont_cofix arity = Kacc 2; Kfield 1; Kfield 0; - Kmakeblock(2, cofix_evaluated_tag); + Kmakeblock(2, cofix_evaluated_tag); Kpush; (* stk = [Cfxe_t|fcofix|res]::res::ai::args::ra::...*) Kacc 2; Ksetfield 1; (* ai = [At|accumulate|[Cfxe_t|fcofix|res]|args] *) - (* stk = res::ai::args::ra::... *) + (* stk = res::ai::args::ra::... *) Kacc 0; (* accu = res *) Kreturn (arity+2) ] @@ -315,24 +315,24 @@ let init_fun_code () = fun_code := [] let code_construct tag nparams arity cont = let f_cont = add_pop nparams - (if arity = 0 then + (if arity = 0 then [Kconst (Const_b0 tag); Kreturn 0] else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0]) - in + in let lbl = Label.create() in fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont let get_strcst = function | Bstrconst sc -> sc - | _ -> raise Not_found + | _ -> raise Not_found -let rec str_const c = +let rec str_const c = match kind_of_term c with | Sort s -> Bstrconst (Const_sorts s) - | Cast(c,_,_) -> str_const c - | App(f,args) -> + | Cast(c,_,_) -> str_const c + | App(f,args) -> begin match kind_of_term f with | Construct((kn,j),i) -> (* arnaud: Construct(((kn,j),i) as cstr) -> *) @@ -345,32 +345,32 @@ let rec str_const c = (* spiwack: *) (* 1/ tries to compile the constructor in an optimal way, it is supposed to work only if the arguments are - all fully constructed, fails with Cbytecodes.NotClosed. + all fully constructed, fails with Cbytecodes.NotClosed. it can also raise Not_found when there is no special - treatment for this constructor - for instance: tries to to compile an integer of the - form I31 D1 D2 ... D31 to [D1D2...D31] as + treatment for this constructor + for instance: tries to to compile an integer of the + form I31 D1 D2 ... D31 to [D1D2...D31] as a processor number (a caml number actually) *) - try + try try - Bstrconst (Retroknowledge.get_vm_constant_static_info + Bstrconst (Retroknowledge.get_vm_constant_static_info (!global_env).retroknowledge (kind_of_term f) args) with NotClosed -> - (* 2/ if the arguments are not all closed (this is - expectingly (and it is currently the case) the only - reason why this exception is raised) tries to + (* 2/ if the arguments are not all closed (this is + expectingly (and it is currently the case) the only + reason why this exception is raised) tries to give a clever, run-time behavior to the constructor. Raises Not_found if there is no special treatment for this integer. this is done in a lazy fashion, using the constructor Bspecial because it needs to know the continuation and such, which can't be done at this time. - for instance, for int31: if one of the digit is + for instance, for int31: if one of the digit is not closed, it's not impossible that the number gets fully instanciated at run-time, thus to ensure uniqueness of the representation in the vm - it is necessary to try and build a caml integer + it is necessary to try and build a caml integer during the execution *) let rargs = Array.sub args nparams arity in let b_args = Array.map str_const rargs in @@ -385,16 +385,16 @@ let rec str_const c = else let rargs = Array.sub args nparams arity in let b_args = Array.map str_const rargs in - try + try let sc_args = Array.map get_strcst b_args in Bstrconst(Const_bn(num, sc_args)) with Not_found -> Bmakeblock(num,b_args) - else + else let b_args = Array.map str_const args in (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) - try + try Bspecial ((Retroknowledge.get_vm_constant_dynamic_info (!global_env).retroknowledge (kind_of_term f)), @@ -407,7 +407,7 @@ let rec str_const c = | Ind ind -> Bstrconst (Const_ind ind) | Construct ((kn,j),i) -> (*arnaud: Construct ((kn,j),i as cstr) -> *) begin - (* spiwack: tries first to apply the run-time compilation + (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) try Bspecial ((Retroknowledge.get_vm_constant_dynamic_info @@ -415,7 +415,7 @@ let rec str_const c = (kind_of_term c)), [| |]) with Not_found -> - let oib = lookup_mind kn !global_env in + let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in let num,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in @@ -426,17 +426,17 @@ let rec str_const c = (* compilation des applications *) let comp_args comp_expr reloc args sz cont = - let nargs_m_1 = Array.length args - 1 in + let nargs_m_1 = Array.length args - 1 in let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in for i = 1 to nargs_m_1 do c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c) - done; + done; !c - + let comp_app comp_fun comp_arg reloc f args sz cont = let nargs = Array.length args in match is_tailcall cont with - | Some k -> + | Some k -> comp_args comp_arg reloc args sz (Kpush :: comp_fun reloc f (sz + nargs) @@ -445,14 +445,14 @@ let comp_app comp_fun comp_arg reloc f args sz cont = if nargs < 4 then comp_args comp_arg reloc args sz (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont))) - else + else let lbl,cont1 = label_code cont in Kpush_retaddr lbl :: (comp_args comp_arg reloc args (sz + 3) (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1)))) (* Compilation des variables libres *) - + let compile_fv_elem reloc fv sz cont = match fv with | FVrel i -> pos_rel i reloc sz :: cont @@ -463,7 +463,7 @@ let rec compile_fv reloc l sz cont = | [] -> cont | [fvn] -> compile_fv_elem reloc fvn sz cont | fvn :: tl -> - compile_fv_elem reloc fvn sz + compile_fv_elem reloc fvn sz (Kpush :: compile_fv reloc tl (sz + 1) cont) (* compilation des constantes *) @@ -474,14 +474,14 @@ let rec get_allias env kn = | BCallias kn' -> get_allias env kn' | _ -> kn - + (* compilation des expressions *) - + let rec compile_constr reloc c sz cont = match kind_of_term c with | Meta _ -> raise (Invalid_argument "Cbytegen.compile_constr : Meta") | Evar _ -> raise (Invalid_argument "Cbytegen.compile_constr : Evar") - + | Cast(c,_,_) -> compile_constr reloc c sz cont | Rel i -> pos_rel i reloc sz :: cont @@ -489,13 +489,13 @@ let rec compile_constr reloc c sz cont = | Const kn -> compile_const reloc kn [||] sz cont | Sort _ | Ind _ | Construct _ -> compile_str_cst reloc (str_const c) sz cont - + | LetIn(_,xb,_,body) -> - compile_constr reloc xb sz - (Kpush :: + compile_constr reloc xb sz + (Kpush :: (compile_constr (push_local sz reloc) body (sz+1) (add_pop 1 cont))) | Prod(id,dom,codom) -> - let cont1 = + let cont1 = Kpush :: compile_constr reloc dom (sz+1) (Kmakeprod :: cont) in compile_constr reloc (mkLambda(id,dom,codom)) sz cont1 | Lambda _ -> @@ -503,18 +503,18 @@ let rec compile_constr reloc c sz cont = let arity = List.length params in let r_fun = comp_env_fun arity in let lbl_fun = Label.create() in - let cont_fun = + let cont_fun = compile_constr r_fun body arity [Kreturn arity] in fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) - - | App(f,args) -> - begin + + | App(f,args) -> + begin match kind_of_term f with | Construct _ -> compile_str_cst reloc (str_const c) sz cont | Const kn -> compile_const reloc kn args sz cont - | _ -> comp_app compile_constr compile_constr reloc f args sz cont + | _ -> comp_app compile_constr compile_constr reloc f args sz cont end | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) -> let ndef = Array.length type_bodies in @@ -524,10 +524,10 @@ let rec compile_constr reloc c sz cont = (* Compilation des types *) let env_type = comp_env_type rfv in for i = 0 to ndef - 1 do - let lbl,fcode = - label_code - (compile_constr env_type type_bodies.(i) 0 [Kstop]) in - lbl_types.(i) <- lbl; + let lbl,fcode = + label_code + (compile_constr env_type type_bodies.(i) 0 [Kstop]) in + lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; (* Compilation des corps *) @@ -535,7 +535,7 @@ let rec compile_constr reloc c sz cont = let params,body = decompose_lam rec_bodies.(i) in let arity = List.length params in let env_body = comp_env_fix ndef i arity rfv in - let cont1 = + let cont1 = compile_constr env_body body arity [Kreturn arity] in let lbl = Label.create () in lbl_bodies.(i) <- lbl; @@ -543,9 +543,9 @@ let rec compile_constr reloc c sz cont = fun_code := [Ksequence(fcode,!fun_code)] done; let fv = !rfv in - compile_fv reloc fv.fv_rev sz + compile_fv reloc fv.fv_rev sz (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) - + | CoFix(init,(_,type_bodies,rec_bodies)) -> let ndef = Array.length type_bodies in let lbl_types = Array.create ndef Label.no in @@ -554,10 +554,10 @@ let rec compile_constr reloc c sz cont = let rfv = ref empty_fv in let env_type = comp_env_type rfv in for i = 0 to ndef - 1 do - let lbl,fcode = - label_code + let lbl,fcode = + label_code (compile_constr env_type type_bodies.(i) 0 [Kstop]) in - lbl_types.(i) <- lbl; + lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; (* Compilation des corps *) @@ -566,17 +566,17 @@ let rec compile_constr reloc c sz cont = let arity = List.length params in let env_body = comp_env_cofix ndef arity rfv in let lbl = Label.create () in - let cont1 = + let cont1 = compile_constr env_body body (arity+1) (cont_cofix arity) in - let cont2 = + let cont2 = add_grab (arity+1) lbl cont1 in lbl_bodies.(i) <- lbl; fun_code := [Ksequence(cont2,!fun_code)]; done; let fv = !rfv in - compile_fv reloc fv.fv_rev sz + compile_fv reloc fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) - + | Case(ci,t,a,branchs) -> let ind = ci.ci_ind in let mib = lookup_mind (fst ind) !global_env in @@ -586,20 +586,20 @@ let rec compile_constr reloc c sz cont = let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in let branch1,cont = make_branch cont in (* Compilation du type *) - let lbl_typ,fcode = + let lbl_typ,fcode = label_code (compile_constr reloc t sz [Kpop sz; Kstop]) in fun_code := [Ksequence(fcode,!fun_code)]; - (* Compilation des branches *) + (* Compilation des branches *) let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = - match branch1 with + match branch1 with | Kreturn k -> assert (k = sz); sz, branch1, true | _ -> sz+3, Kjump, false in let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in (* Compilation de la branche accumulate *) - let lbl_accu, code_accu = - label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) + let lbl_accu, code_accu = + label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) in lbl_blocks.(0) <- lbl_accu; let c = ref code_accu in @@ -607,14 +607,14 @@ let rec compile_constr reloc c sz cont = for i = 0 to Array.length tbl - 1 do let tag, arity = tbl.(i) in if arity = 0 then - let lbl_b,code_b = + let lbl_b,code_b = label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in - lbl_consts.(tag) <- lbl_b; + lbl_consts.(tag) <- lbl_b; c := code_b - else + else let args, body = decompose_lam branchs.(i) in let nargs = List.length args in - let lbl_b,code_b = + let lbl_b,code_b = label_code( if nargs = arity then Kpushfields arity :: @@ -622,7 +622,7 @@ let rec compile_constr reloc c sz cont = body (sz_b+arity) (add_pop arity (branch :: !c)) else let sz_appterm = if is_tailcall then sz_b + arity else arity in - Kpushfields arity :: + Kpushfields arity :: compile_constr reloc branchs.(i) (sz_b+arity) (Kappterm(arity,sz_appterm) :: !c)) in @@ -630,21 +630,21 @@ let rec compile_constr reloc c sz cont = c := code_b done; c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c; - let code_sw = - match branch1 with - (* spiwack : branch1 can't be a lbl anymore it's a Branch instead + let code_sw = + match branch1 with + (* spiwack : branch1 can't be a lbl anymore it's a Branch instead | Klabel lbl -> Kpush_retaddr lbl :: !c *) | Kbranch lbl -> Kpush_retaddr lbl :: !c - | _ -> !c + | _ -> !c in - compile_constr reloc a sz - (try + compile_constr reloc a sz + (try let entry = Term.Ind ind in Retroknowledge.get_vm_before_match_info (!global_env).retroknowledge entry code_sw with Not_found -> code_sw) - + and compile_str_cst reloc sc sz cont = match sc with | Bconstr c -> compile_constr reloc c sz cont @@ -655,25 +655,25 @@ and compile_str_cst reloc sc sz cont = | Bconstruct_app(tag,nparams,arity,args) -> if Array.length args = 0 then code_construct tag nparams arity cont else - comp_app - (fun _ _ _ cont -> code_construct tag nparams arity cont) + comp_app + (fun _ _ _ cont -> code_construct tag nparams arity cont) compile_str_cst reloc () args sz cont | Bspecial (comp_fx, args) -> comp_fx reloc args sz cont -(* spiwack : compilation of constants with their arguments. +(* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) and compile_const = -(*arnaud: let code_construct kn cont = - let f_cont = +(*arnaud: let code_construct kn cont = + let f_cont = let else_lbl = Label.create () in Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: Kaddint31:: Kreturn 0:: Klabel else_lbl:: (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*) Kgetglobal (get_allias !global_env kn):: Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) - in - let lbl = Label.create () in + in + let lbl = Label.create () in fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in *) @@ -685,14 +685,14 @@ and compile_const = try Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge (kind_of_term (mkConst kn)) reloc args sz cont - with Not_found -> + with Not_found -> if nargs = 0 then Kgetglobal (get_allias !global_env kn) :: cont else - comp_app (fun _ _ _ cont -> + comp_app (fun _ _ _ cont -> Kgetglobal (get_allias !global_env kn) :: cont) compile_constr reloc () args sz cont - + let compile env c = set_global_env env; init_fun_code (); @@ -724,7 +724,7 @@ let compile_constant_body env body opaque boxed = else match kind_of_term body with | Const kn' -> BCallias (get_allias env kn') - | _ -> + | _ -> let res = compile env body in let to_patch = to_memory res in BCdefined (false, to_patch) @@ -743,9 +743,9 @@ let make_areconst n else_lbl cont = (* try to compile int31 as a const_b0. Succeed if all the arguments are closed fails otherwise by raising NotClosed*) let compile_structured_int31 fc args = - if not fc then raise Not_found else + if not fc then raise Not_found else Const_b0 - (Array.fold_left + (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with | Construct (_,d) -> 2*temp_i+d-1 | _ -> raise NotClosed) @@ -753,7 +753,7 @@ let compile_structured_int31 fc args = ) (* this function is used for the compilation of the constructor of - the int31, it is used when it appears not fully applied, or + the int31, it is used when it appears not fully applied, or applied to at least one non-closed digit *) let dynamic_int31_compilation fc reloc args sz cont = if not fc then raise Not_found else @@ -761,32 +761,32 @@ let dynamic_int31_compilation fc reloc args sz cont = if nargs = 31 then let (escape,labeled_cont) = make_branch cont in let else_lbl = Label.create() in - comp_args compile_str_cst reloc args sz + comp_args compile_str_cst reloc args sz ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont) - else + else let code_construct cont = (* spiwack: variant of the global code_construct - which handles dynamic compilation of + which handles dynamic compilation of integers *) - let f_cont = + let f_cont = let else_lbl = Label.create () in [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl); Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0] - in + in let lbl = Label.create() in fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont - in + in if nargs = 0 then code_construct cont else comp_app (fun _ _ _ cont -> code_construct cont) compile_str_cst reloc () args sz cont - + (*(* template compilation for 2ary operation, it probably possible to make a generic such function with arity abstracted *) let op2_compilation op = let code_construct normal cont = (*kn cont =*) - let f_cont = + let f_cont = let else_lbl = Label.create () in Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: @@ -795,7 +795,7 @@ let op2_compilation op = normal:: Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) in - let lbl = Label.create () in + let lbl = Label.create () in fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in @@ -805,8 +805,8 @@ let op2_compilation op = if nargs=2 then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in - comp_args compile_constr reloc args sz - (Kisconst else_lbl::(make_areconst 1 else_lbl + comp_args compile_constr reloc args sz + (Kisconst else_lbl::(make_areconst 1 else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = 2 and non-tailcall cont*) @@ -820,14 +820,14 @@ let op2_compilation op = compile_constr reloc () args sz cont *) (*template for n-ary operation, invariant: n>=1, - the operations does the following : - 1/ checks if all the arguments are constants (i.e. non-block values) + the operations does the following : + 1/ checks if all the arguments are constants (i.e. non-block values) 2/ if they are, uses the "op" instruction to execute - 3/ if at least one is not, branches to the normal behavior: + 3/ if at least one is not, branches to the normal behavior: Kgetglobal (get_allias !global_env kn) *) let op_compilation n op = - let code_construct kn cont = - let f_cont = + let code_construct kn cont = + let f_cont = let else_lbl = Label.create () in Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: @@ -835,7 +835,7 @@ let op_compilation n op = Kgetglobal (get_allias !global_env kn):: Kappterm(n, n):: [] (* = discard_dead_code [Kreturn 0] *) in - let lbl = Label.create () in + let lbl = Label.create () in fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in @@ -845,8 +845,8 @@ let op_compilation n op = if nargs=n then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in - comp_args compile_constr reloc args sz - (Kisconst else_lbl::(make_areconst (n-1) else_lbl + comp_args compile_constr reloc args sz + (Kisconst else_lbl::(make_areconst (n-1) else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = n and non-tailcall cont*) diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index dfdcb07473..f33fd6cb0e 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -1,6 +1,6 @@ open Names open Cbytecodes -open Cemitcodes +open Cemitcodes open Term open Declarations open Pre_env @@ -9,7 +9,7 @@ open Pre_env val compile : env -> constr -> bytecodes * bytecodes * fv (* init, fun, fv *) -val compile_constant_body : +val compile_constant_body : env -> constr_substituted option -> bool -> bool -> body_code (* opaque *) (* boxed *) @@ -17,15 +17,15 @@ val compile_constant_body : (* spiwack: this function contains the information needed to perform the static compilation of int31 (trying and obtaining a 31-bit integer in processor representation at compile time) *) -val compile_structured_int31 : bool -> constr array -> +val compile_structured_int31 : bool -> constr array -> structured_constant (* this function contains the information needed to perform the dynamic compilation of int31 (trying and obtaining a 31-bit integer in processor representation at runtime when it failed at compile time *) -val dynamic_int31_compilation : bool -> comp_env -> - block array -> +val dynamic_int31_compilation : bool -> comp_env -> + block array -> int -> bytecodes -> bytecodes (*spiwack: template for the compilation n-ary operation, invariant: n>=1. @@ -35,6 +35,6 @@ val dynamic_int31_compilation : bool -> comp_env -> val op_compilation : int -> instruction -> constant -> bool -> comp_env -> constr array -> int -> bytecodes-> bytecodes -(*spiwack: compiling function to insert dynamic decompilation before +(*spiwack: compiling function to insert dynamic decompilation before matching integers (in case they are in processor representation) *) val int31_escape_before_match : bool -> bytecodes -> bytecodes diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 7617c454d9..89264e88b1 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -6,11 +6,11 @@ open Mod_subst (* Relocation information *) type reloc_info = - | Reloc_annot of annot_switch + | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of constant -type patch = reloc_info * int +type patch = reloc_info * int let patch_int buff pos n = String.unsafe_set buff pos (Char.unsafe_chr n); @@ -76,10 +76,10 @@ type label_definition = | Label_undefined of (int * int) list let label_table = ref ([| |] : label_definition array) -(* le ieme element de la table = Label_defined n signifie que l'on a +(* le ieme element de la table = Label_defined n signifie que l'on a deja rencontrer le label i et qu'il est a l'offset n. - = Label_undefined l signifie que l'on a - pas encore rencontrer ce label, le premier entier indique ou est l'entier + = Label_undefined l signifie que l'on a + pas encore rencontrer ce label, le premier entier indique ou est l'entier a patcher dans la string, le deuxieme son origine *) let extend_label_table needed = @@ -156,11 +156,11 @@ let emit_instr = function if ofs = -2 || ofs = 0 || ofs = 2 then out (opOFFSETCLOSURE0 + ofs / 2) else (out opOFFSETCLOSURE; out_int ofs) - | Kpush -> + | Kpush -> out opPUSH - | Kpop n -> + | Kpop n -> out opPOP; out_int n - | Kpush_retaddr lbl -> + | Kpush_retaddr lbl -> out opPUSH_RETADDR; out_label lbl | Kapply n -> if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n) @@ -173,11 +173,11 @@ let emit_instr = function out opRETURN; out_int 0 | Krestart -> out opRESTART - | Kgrab n -> + | Kgrab n -> out opGRAB; out_int n - | Kgrabrec(rec_arg) -> + | Kgrabrec(rec_arg) -> out opGRABREC; out_int rec_arg - | Kclosure(lbl, n) -> + | Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl | Kclosurerec(nfv,init,lbl_types,lbl_bodies) -> out opCLOSUREREC;out_int (Array.length lbl_bodies); @@ -193,12 +193,12 @@ let emit_instr = function Array.iter (out_label_with_orig org) lbl_types; let org = !out_position in Array.iter (out_label_with_orig org) lbl_bodies - | Kgetglobal q -> + | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q - | Kconst((Const_b0 i)) -> + | Kconst((Const_b0 i)) -> if i >= 0 && i <= 3 then out (opCONST0 + i) - else (out opCONSTINT; out_int i) + else (out opCONSTINT; out_int i) | Kconst c -> out opGETGLOBAL; slot_for_const c | Kmakeblock(n, t) -> @@ -223,7 +223,7 @@ let emit_instr = function if n <= 1 then out (opGETFIELD0+n) else (out opGETFIELD;out_int n) | Ksetfield n -> - if n <= 1 then out (opSETFIELD0+n) + if n <= 1 then out (opSETFIELD0+n) else (out opSETFIELD;out_int n) | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr") (* spiwack *) @@ -247,7 +247,7 @@ let emit_instr = function | Kcompint31 -> out opCOMPINT31 | Kdecompint31 -> out opDECOMPINT31 (*/spiwack *) - | Kstop -> + | Kstop -> out opSTOP (* Emission of a list of instructions. Include some peephole optimization. *) @@ -258,26 +258,26 @@ let rec emit = function | Kpush :: Kacc n :: c -> if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); emit c - | Kpush :: Kenvacc n :: c -> + | Kpush :: Kenvacc n :: c -> if n >= 1 && n <= 4 then out(opPUSHENVACC1 + n - 1) else (out opPUSHENVACC; out_int n); emit c - | Kpush :: Koffsetclosure ofs :: c -> + | Kpush :: Koffsetclosure ofs :: c -> if ofs = -2 || ofs = 0 || ofs = 2 then out(opPUSHOFFSETCLOSURE0 + ofs / 2) else (out opPUSHOFFSETCLOSURE; out_int ofs); emit c | Kpush :: Kgetglobal id :: c -> - out opPUSHGETGLOBAL; slot_for_getglobal id; emit c - | Kpush :: Kconst (Const_b0 i) :: c -> + out opPUSHGETGLOBAL; slot_for_getglobal id; emit c + | Kpush :: Kconst (Const_b0 i) :: c -> if i >= 0 && i <= 3 then out (opPUSHCONST0 + i) else (out opPUSHCONSTINT; out_int i); emit c | Kpush :: Kconst const :: c -> out opPUSHGETGLOBAL; slot_for_const const; - emit c + emit c | Kpop n :: Kjump :: c -> out opRETURN; out_int n; emit c | Ksequence(c1,c2)::c -> @@ -306,7 +306,7 @@ let rec subst_strcst s sc = | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_kn s kn, i)) -let subst_patch s (ri,pos) = +let subst_patch s (ri,pos) = match ri with | Reloc_annot a -> let (kn,i) = a.ci.ci_ind in @@ -315,7 +315,7 @@ let subst_patch s (ri,pos) = | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos) -let subst_to_patch s (code,pl,fv) = +let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv type body_code = @@ -334,7 +334,7 @@ let from_val = from_val let force = force subst_body_code -let subst_to_patch_subst = subst_substituted +let subst_to_patch_subst = subst_substituted let is_boxed tps = match force tps with @@ -348,10 +348,10 @@ let to_memory (init_code, fun_code, fv) = let code = String.create !out_position in String.unsafe_blit !out_buffer 0 code 0 !out_position; let reloc = List.rev !reloc_info in - Array.iter (fun lbl -> + Array.iter (fun lbl -> (match lbl with Label_defined _ -> assert true - | Label_undefined patchlist -> + | Label_undefined patchlist -> assert (patchlist = []))) !label_table; (code, reloc, fv) diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index ca6da65e1d..965228fa1e 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -2,17 +2,17 @@ open Names open Cbytecodes type reloc_info = - | Reloc_annot of annot_switch + | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of constant -type patch = reloc_info * int +type patch = reloc_info * int (* A virer *) val subst_patch : Mod_subst.substitution -> patch -> patch - -type emitcodes -val length : emitcodes -> int +type emitcodes + +val length : emitcodes -> int val patch_int : emitcodes -> (*pos*)int -> int -> unit @@ -26,9 +26,9 @@ type body_code = | BCconstant -type to_patch_substituted +type to_patch_substituted -val from_val : body_code -> to_patch_substituted +val from_val : body_code -> to_patch_substituted val force : to_patch_substituted -> body_code @@ -37,4 +37,4 @@ val is_boxed : to_patch_substituted -> bool val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted val to_memory : bytecodes * bytecodes * fv -> to_patch - (* init code, fun code, fv *) + (* init code, fun code, fv *) diff --git a/kernel/closure.ml b/kernel/closure.ml index c4759fa925..bce564397c 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -40,7 +40,7 @@ let incr_cnt red cnt = if red then begin if !stats then incr cnt; true - end else + end else false let with_stats c = @@ -126,13 +126,13 @@ module RedFlags = (struct { red with r_const = Idpred.remove id l1, l2 } let red_add_transparent red tr = - { red with r_const = tr } + { red with r_const = tr } let mkflags = List.fold_left red_add no_red let red_set red = function | BETA -> incr_cnt red.r_beta beta - | CONST kn -> + | CONST kn -> let (_,l) = red.r_const in let c = Cpred.mem kn l in incr_cnt c delta @@ -168,7 +168,7 @@ let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] (* Removing fZETA for finer behaviour would break many developments *) let unfold_side_flags = [fBETA;fIOTA;fZETA] let unfold_side_red = mkflags [fBETA;fIOTA;fZETA] -let unfold_red kn = +let unfold_red kn = let flag = match kn with | EvalVarRef id -> fVAR id | EvalConstRef kn -> fCONST kn in @@ -208,7 +208,7 @@ type 'a infos = { let info_flags info = info.i_flags let ref_value_cache info ref = - try + try Some (Hashtbl.find info.i_tab ref) with Not_found -> try @@ -232,7 +232,7 @@ let evar_value info ev = let defined_vars flags env = (* if red_local_const (snd flags) then*) - Sign.fold_named_context + Sign.fold_named_context (fun (id,b,_) e -> match b with | None -> e @@ -242,7 +242,7 @@ let defined_vars flags env = let defined_rels flags env = (* if red_local_const (snd flags) then*) - Sign.fold_rel_context + Sign.fold_rel_context (fun (id,b,t) (i,subs) -> match b with | None -> (i+1, subs) @@ -300,8 +300,8 @@ let neutr = function | (Whnf|Norm) -> Whnf | (Red|Cstr) -> Red -type fconstr = { - mutable norm: red_state; +type fconstr = { + mutable norm: red_state; mutable term: fterm } and fterm = @@ -339,7 +339,7 @@ let update v1 (no,t) = else {norm=no;term=t} (**********************************************************************) -(* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) +(* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) type stack_member = | Zapp of fconstr array @@ -387,7 +387,7 @@ let array_of_stack s = in Array.concat (stackrec s) let rec stack_assign s p c = match s with | Zapp args :: s -> - let q = Array.length args in + let q = Array.length args in if p >= q then Zapp args :: stack_assign s (p-q) c else @@ -395,7 +395,7 @@ let rec stack_assign s p c = match s with nargs.(p) <- c; Zapp nargs :: s) | _ -> s -let rec stack_tail p s = +let rec stack_tail p s = if p = 0 then s else match s with | Zapp args :: s -> @@ -659,7 +659,7 @@ let term_of_fconstr = (* fstrong applies unfreeze_fun recursively on the (freeze) term and * yields a term. Assumes that the unfreeze_fun never returns a - * FCLOS term. + * FCLOS term. let rec fstrong unfreeze_fun lfts v = to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v) *) @@ -852,7 +852,7 @@ let rec knr info m stk = | FLambda(n,tys,f,e) when red_set info.i_flags fBETA -> (match get_args n tys f e stk with Inl e', s -> knit info e' f s - | Inr lam, s -> (lam,s)) + | Inr lam, s -> (lam,s)) | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) -> (match ref_value_cache info (ConstKey kn) with Some v -> kni info v stk @@ -931,7 +931,7 @@ let rec kl info m = zip_term (kl info) (norm_head info nm) s (* no redex: go up for atoms and already normalized terms, go down - otherwise. *) + otherwise. *) and norm_head info m = if is_val m then (incr prune; term_of_fconstr m) else match m.term with diff --git a/kernel/closure.mli b/kernel/closure.mli index ede0d6379f..b6ff1fa15d 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -24,7 +24,7 @@ val with_stats: 'a Lazy.t -> 'a (*s Delta implies all consts (both global (= by [kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's. - Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of + Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) @@ -102,7 +102,7 @@ type fconstr type fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) - | FCast of fconstr * cast_kind * fconstr + | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive | FConstruct of constructor diff --git a/kernel/cooking.ml b/kernel/cooking.ml index edd3e498de..e42a732d38 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -29,7 +29,7 @@ let pop_kn kn = let (mp,dir,l) = Names.repr_kn kn in Names.make_kn mp (pop_dirpath dir) l -let pop_con con = +let pop_con con = let (mp,dir,l) = Names.repr_con con in Names.make_con mp (pop_dirpath dir) l @@ -47,9 +47,9 @@ let share r (cstl,knl) = with Not_found -> let f,l = match r with - | IndRef (kn,i) -> + | IndRef (kn,i) -> mkInd (pop_kn kn,i), KNmap.find kn knl - | ConstructRef ((kn,i),j) -> + | ConstructRef ((kn,i),j) -> mkConstruct ((pop_kn kn,i),j), KNmap.find kn knl | ConstRef cst -> mkConst (pop_con cst), Cmap.find cst cstl in @@ -60,7 +60,7 @@ let share r (cstl,knl) = let update_case_info ci modlist = try - let ind, n = + let ind, n = match kind_of_term (share (IndRef ci.ci_ind) modlist) with | App (f,l) -> (destInd f, Array.length l) | Ind ind -> ind, 0 @@ -80,19 +80,19 @@ let expmod_constr modlist c = | Ind ind -> (try share (IndRef ind) modlist - with + with | Not_found -> map_constr substrec c) - + | Construct cstr -> (try share (ConstructRef cstr) modlist - with + with | Not_found -> map_constr substrec c) - + | Const cst -> (try share (ConstRef cst) modlist - with + with | Not_found -> map_constr substrec c) | _ -> map_constr substrec c @@ -112,7 +112,7 @@ type recipe = { d_abstract : named_context; d_modlist : work_list } -let on_body f = +let on_body f = Option.map (fun c -> Declarations.from_val (f (Declarations.force c))) let cook_constant env r = @@ -120,7 +120,7 @@ let cook_constant env r = let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in let body = on_body (fun c -> - abstract_constant_body (expmod_constr r.d_modlist c) hyps) + abstract_constant_body (expmod_constr r.d_modlist c) hyps) cb.const_body in let typ = match cb.const_type with | NonPolymorphicType t -> diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 4afdaa55ed..23b1f25347 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -24,8 +24,8 @@ type recipe = { d_modlist : work_list } val cook_constant : - env -> recipe -> - constr_substituted option * constant_type * constraints * bool * bool + env -> recipe -> + constr_substituted option * constant_type * constraints * bool * bool * bool (*s Utility functions used in module [Discharge]. *) diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index 26b997f0f4..58a5bf3278 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -11,15 +11,15 @@ open Cbytegen external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code" external free_tcode : tcode -> unit = "coq_static_free" external eval_tcode : tcode -> values array -> values = "coq_eval_tcode" - + (*******************) (* Linkage du code *) (*******************) (* Table des globaux *) -(* [global_data] contient les valeurs des constantes globales - (axiomes,definitions), les annotations des switch et les structured +(* [global_data] contient les valeurs des constantes globales + (axiomes,definitions), les annotations des switch et les structured constant *) external global_data : unit -> values array = "get_coq_global_data" @@ -28,18 +28,18 @@ external realloc_global_data : int -> unit = "realloc_coq_global_data" let check_global_data n = if n >= Array.length (global_data()) then realloc_global_data n - + let num_global = ref 0 -let set_global v = +let set_global v = let n = !num_global in check_global_data n; (global_data()).(n) <- v; incr num_global; n -(* [global_transp],[global_boxed] contiennent les valeurs des - definitions gelees. Les deux versions sont maintenues en //. +(* [global_transp],[global_boxed] contiennent les valeurs des + definitions gelees. Les deux versions sont maintenues en //. [global_transp] contient la version transparente. [global_boxed] contient la version gelees. *) @@ -50,7 +50,7 @@ external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed" let check_global_boxed n = if n >= Array.length (global_boxed()) then realloc_global_boxed n - + let num_boxed = ref 0 let boxed_tbl = Hashtbl.create 53 @@ -59,7 +59,7 @@ let cst_opaque = ref Cpred.full let is_opaque kn = Cpred.mem kn !cst_opaque -let set_global_boxed kn v = +let set_global_boxed kn v = let n = !num_boxed in check_global_boxed n; (global_boxed()).(n) <- (is_opaque kn); @@ -91,17 +91,17 @@ let key rk = (* slot_for_*, calcul la valeur de l'objet, la place dans la table global, rend sa position dans la table *) - + let slot_for_str_cst key = - try Hashtbl.find str_cst_tbl key - with Not_found -> + try Hashtbl.find str_cst_tbl key + with Not_found -> let n = set_global (val_of_str_const key) in Hashtbl.add str_cst_tbl key n; n let slot_for_annot key = - try Hashtbl.find annot_tbl key - with Not_found -> + try Hashtbl.find annot_tbl key + with Not_found -> let n = set_global (Obj.magic key) in Hashtbl.add annot_tbl key n; n @@ -112,25 +112,25 @@ let rec slot_for_getglobal env kn = with NotEvaluated -> let pos = match Cemitcodes.force cb.const_body_code with - | BCdefined(boxed,(code,pl,fv)) -> + | BCdefined(boxed,(code,pl,fv)) -> let v = eval_to_patch env (code,pl,fv) in - if boxed then set_global_boxed kn v - else set_global v - | BCallias kn' -> slot_for_getglobal env kn' + if boxed then set_global_boxed kn v + else set_global v + | BCallias kn' -> slot_for_getglobal env kn' | BCconstant -> set_global (val_of_constant kn) in rk := Some pos; pos and slot_for_fv env fv = match fv with - | FVnamed id -> + | FVnamed id -> let nv = Pre_env.lookup_named_val id env in begin match !nv with | VKvalue (v,_) -> v - | VKnone -> + | VKnone -> let (_, b, _) = Sign.lookup_named id env.env_named_context in - let v,d = + let v,d = match b with | None -> (val_of_named id, Idset.empty) | Some c -> (val_of_constr env c, Environ.global_vars_set (Environ.env_of_pre_env env) c) @@ -142,43 +142,43 @@ and slot_for_fv env fv = begin match !rv with | VKvalue (v, _) -> v - | VKnone -> + | VKnone -> let (_, b, _) = lookup_rel i env.env_rel_context in let (v, d) = - match b with + match b with | None -> (val_of_rel i, Idset.empty) | Some c -> let renv = env_of_rel i env in (val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c) in rv := VKvalue (v,d); v end - -and eval_to_patch env (buff,pl,fv) = + +and eval_to_patch env (buff,pl,fv) = let patch = function | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a) | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc) - | Reloc_getglobal kn, pos -> + | Reloc_getglobal kn, pos -> patch_int buff pos (slot_for_getglobal env kn) - in + in List.iter patch pl; - let vm_env = Array.map (slot_for_fv env) fv in + let vm_env = Array.map (slot_for_fv env) fv in let tc = tcode_of_code buff (length buff) in eval_tcode tc vm_env -and val_of_constr env c = - let (_,fun_code,_ as ccfv) = - try compile env c +and val_of_constr env c = + let (_,fun_code,_ as ccfv) = + try compile env c with e -> print_string "can not compile \n";Format.print_flush();raise e in eval_to_patch env (to_memory ccfv) - + let set_transparent_const kn = cst_opaque := Cpred.remove kn !cst_opaque; - List.iter (fun n -> (global_boxed()).(n) <- false) + List.iter (fun n -> (global_boxed()).(n) <- false) (Hashtbl.find_all boxed_tbl kn) let set_opaque_const kn = cst_opaque := Cpred.add kn !cst_opaque; - List.iter (fun n -> (global_boxed()).(n) <- true) + List.iter (fun n -> (global_boxed()).(n) <- true) (Hashtbl.find_all boxed_tbl kn) diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli index 2640a4df13..894a33ef5b 100644 --- a/kernel/csymtable.mli +++ b/kernel/csymtable.mli @@ -2,7 +2,7 @@ open Names open Term open Pre_env -val val_of_constr : env -> constr -> values +val val_of_constr : env -> constr -> values val set_opaque_const : constant -> unit val set_transparent_const : constant -> unit diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 8b2402bb54..c48c01d786 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -38,7 +38,7 @@ type constr_substituted = constr substituted let from_val = from_val -let force = force subst_mps +let force = force subst_mps let subst_constr_subst = subst_substituted @@ -49,7 +49,7 @@ type constant_body = { const_body_code : Cemitcodes.to_patch_substituted; (* const_type_code : Cemitcodes.to_patch; *) const_constraints : constraints; - const_opaque : bool; + const_opaque : bool; const_inline : bool} (*s Inductive types (internal representation with redundant @@ -62,9 +62,9 @@ let subst_rel_declaration sub (id,copt,t as x) = let subst_rel_context sub = list_smartmap (subst_rel_declaration sub) -type recarg = - | Norec - | Mrec of int +type recarg = + | Norec + | Mrec of int | Imbr of inductive let subst_recarg sub r = match r with @@ -86,7 +86,7 @@ let dest_subterms p = let (_,cstrs) = Rtree.dest_node p in Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs -let recarg_length p j = +let recarg_length p j = let (_,cstrs) = Rtree.dest_node p in Array.length (snd (Rtree.dest_node cstrs.(j-1))) @@ -105,7 +105,7 @@ type monomorphic_inductive_arity = { mind_sort : sorts; } -type inductive_arity = +type inductive_arity = | Monomorphic of monomorphic_inductive_arity | Polymorphic of polymorphic_arity @@ -158,7 +158,7 @@ type one_inductive_body = { (* number of no constant constructor *) mind_nb_args : int; - mind_reloc_tbl : Cbytecodes.reloc_table; + mind_reloc_tbl : Cbytecodes.reloc_table; } type mutual_inductive_body = { @@ -207,7 +207,7 @@ let subst_const_body sub cb = { (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*) const_constraints = cb.const_constraints; const_opaque = cb.const_opaque; - const_inline = cb.const_inline} + const_inline = cb.const_inline} let subst_arity sub = function | Monomorphic s -> @@ -217,7 +217,7 @@ let subst_arity sub = function } | Polymorphic s as x -> x -let subst_mind_packet sub mbp = +let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_consnrealdecls = mbp.mind_consnrealdecls; mind_typename = mbp.mind_typename; @@ -228,20 +228,20 @@ let subst_mind_packet sub mbp = mind_nrealargs = mbp.mind_nrealargs; mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt; mind_kelim = mbp.mind_kelim; - mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); mind_nb_constant = mbp.mind_nb_constant; mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } -let subst_mind sub mib = - { mind_record = mib.mind_record ; +let subst_mind sub mib = + { mind_record = mib.mind_record ; mind_finite = mib.mind_finite ; mind_ntypes = mib.mind_ntypes ; mind_hyps = (assert (mib.mind_hyps=[]); []) ; mind_nparams = mib.mind_nparams; mind_nparams_rec = mib.mind_nparams_rec; - mind_params_ctxt = + mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt; mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; mind_constraints = mib.mind_constraints ; @@ -251,11 +251,11 @@ let subst_mind sub mib = (*s Modules: signature component specifications, module types, and module declarations *) -type structure_field_body = +type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * struct_expr_body option + | SFBalias of module_path * struct_expr_body option * constraints option | SFBmodtype of module_type_body @@ -263,25 +263,25 @@ and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path - | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body + | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body | SEBstruct of mod_self_id * structure_body | SEBapply of struct_expr_body * struct_expr_body * constraints | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path + With_module_body of identifier list * module_path * struct_expr_body option * constraints | With_definition_body of identifier list * constant_body - -and module_body = + +and module_body = { mod_expr : struct_expr_body option; mod_type : struct_expr_body option; mod_constraints : constraints; mod_alias : substitution; mod_retroknowledge : Retroknowledge.action list} -and module_type_body = +and module_type_body = { typ_expr : struct_expr_body; typ_strength : module_path option; typ_alias : substitution} diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 454debd736..c7e27db6be 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -55,9 +55,9 @@ val subst_const_body : substitution -> constant_body -> constant_body (**********************************************************************) (*s Representation of mutual inductive types in the kernel *) -type recarg = - | Norec - | Mrec of int +type recarg = + | Norec + | Mrec of int | Imbr of inductive val subst_recarg : substitution -> recarg -> recarg @@ -85,7 +85,7 @@ type monomorphic_inductive_arity = { mind_sort : sorts; } -type inductive_arity = +type inductive_arity = | Monomorphic of monomorphic_inductive_arity | Polymorphic of polymorphic_arity @@ -139,7 +139,7 @@ type one_inductive_body = { (* number of no constant constructor *) mind_nb_args : int; - mind_reloc_tbl : Cbytecodes.reloc_table; + mind_reloc_tbl : Cbytecodes.reloc_table; } type mutual_inductive_body = { @@ -181,11 +181,11 @@ val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body (*s Modules: signature component specifications, module types, and module declarations *) -type structure_field_body = +type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * struct_expr_body option + | SFBalias of module_path * struct_expr_body option * constraints option | SFBmodtype of module_type_body @@ -193,25 +193,25 @@ and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path - | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body + | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body | SEBstruct of mod_self_id * structure_body | SEBapply of struct_expr_body * struct_expr_body * constraints | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path + With_module_body of identifier list * module_path * struct_expr_body option * constraints | With_definition_body of identifier list * constant_body - -and module_body = + +and module_body = { mod_expr : struct_expr_body option; mod_type : struct_expr_body option; mod_constraints : constraints; mod_alias : substitution; mod_retroknowledge : Retroknowledge.action list} -and module_type_body = +and module_type_body = { typ_expr : struct_expr_body; typ_strength : module_path option; typ_alias : substitution} diff --git a/kernel/entries.ml b/kernel/entries.ml index e30fe7737e..26e9a62503 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -64,23 +64,23 @@ type definition_entry = { type parameter_entry = types*bool -type constant_entry = +type constant_entry = | DefinitionEntry of definition_entry | ParameterEntry of parameter_entry (*s Modules *) -type module_struct_entry = +type module_struct_entry = MSEident of module_path | MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry | MSEwith of module_struct_entry * with_declaration | MSEapply of module_struct_entry * module_struct_entry -and with_declaration = +and with_declaration = With_Module of identifier list * module_path | With_Definition of identifier list * constr -and module_entry = +and module_entry = { mod_entry_type : module_struct_entry option; mod_entry_expr : module_struct_entry option} diff --git a/kernel/entries.mli b/kernel/entries.mli index dc1522dbfb..291ff0d458 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -63,7 +63,7 @@ type definition_entry = { type parameter_entry = types*bool (*inline flag*) -type constant_entry = +type constant_entry = | DefinitionEntry of definition_entry | ParameterEntry of parameter_entry @@ -75,11 +75,11 @@ type module_struct_entry = | MSEwith of module_struct_entry * with_declaration | MSEapply of module_struct_entry * module_struct_entry -and with_declaration = +and with_declaration = With_Module of identifier list * module_path | With_Definition of identifier list * constr -and module_entry = +and module_entry = { mod_entry_type : module_struct_entry option; mod_entry_expr : module_struct_entry option} diff --git a/kernel/environ.ml b/kernel/environ.ml index de833c540e..fb51660b3e 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -35,8 +35,8 @@ let named_context env = env.env_named_context let named_context_val env = env.env_named_context,env.env_named_vals let rel_context env = env.env_rel_context -let empty_context env = - env.env_rel_context = empty_rel_context +let empty_context env = + env.env_rel_context = empty_rel_context && env.env_named_context = empty_named_context (* Rel context *) @@ -53,7 +53,7 @@ let nb_rel env = env.env_nb_rel let push_rel = push_rel let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x - + let push_rec_types (lna,typarray,_) env = let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt @@ -63,12 +63,12 @@ let fold_rel_context f env ~init = match env.env_rel_context with | [] -> init | rd::rc -> - let env = + let env = { env with env_rel_context = rc; env_rel_val = List.tl env.env_rel_val; env_nb_rel = env.env_nb_rel - 1 } in - f env rd (fold_right env) + f env rd (fold_right env) in fold_right env (* Named context *) @@ -78,13 +78,13 @@ let named_vals_of_val = snd (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. - *** /!\ *** [f t] should be convertible with t *) -let map_named_val f (ctxt,ctxtv) = + *** /!\ *** [f t] should be convertible with t *) +let map_named_val f (ctxt,ctxtv) = let ctxt = List.map (fun (id,body,typ) -> (id, Option.map f body, f typ)) ctxt in (ctxt,ctxtv) -let empty_named_context = empty_named_context +let empty_named_context = empty_named_context let push_named = push_named let push_named_context_val = push_named_context_val @@ -111,7 +111,7 @@ let evaluable_named id env = match named_body id env with | Some _ -> true | _ -> false - + let reset_with_named_context (ctxt,ctxtv) env = { env with env_named_context = ctxt; @@ -121,36 +121,36 @@ let reset_with_named_context (ctxt,ctxtv) env = env_nb_rel = 0 } let reset_context = reset_with_named_context empty_named_context_val - + let fold_named_context f env ~init = let rec fold_right env = match env.env_named_context with | [] -> init | d::ctxt -> - let env = + let env = reset_with_named_context (ctxt,List.tl env.env_named_vals) env in - f env d (fold_right env) + f env d (fold_right env) in fold_right env let fold_named_context_reverse f ~init env = Sign.fold_named_context_reverse f ~init:init (named_context env) - + (* Global constants *) let lookup_constant = lookup_constant let add_constant kn cs env = - let new_constants = + let new_constants = Cmap.add kn (cs,ref None) env.env_globals.env_constants in - let new_globals = - { env.env_globals with - env_constants = new_constants } in + let new_globals = + { env.env_globals with + env_constants = new_constants } in { env with env_globals = new_globals } (* constant_type gives the type of a constant *) let constant_type env kn = let cb = lookup_constant kn env in - cb.const_type + cb.const_type type const_evaluation_result = NoBody | Opaque @@ -179,8 +179,8 @@ let scrape_mind = scrape_mind let add_mind kn mib env = let new_inds = KNmap.add kn mib env.env_globals.env_inductives in - let new_globals = - { env.env_globals with + let new_globals = + { env.env_globals with env_inductives = new_inds } in { env with env_globals = new_globals } @@ -188,15 +188,15 @@ let add_mind kn mib env = let set_universes g env = if env.env_stratification.env_universes == g then env else - { env with env_stratification = + { env with env_stratification = { env.env_stratification with env_universes = g } } let add_constraints c env = - if c == Constraint.empty then - env + if c == Constraint.empty then + env else let s = env.env_stratification in - { env with env_stratification = + { env with env_stratification = { s with env_universes = merge_constraints c s.env_universes } } let set_engagement c env = (* Unsafe *) @@ -225,17 +225,17 @@ let vars_of_global env constr = | Construct cstr -> lookup_constructor_variables cstr env | _ -> [] -let global_vars_set env constr = +let global_vars_set env constr = let rec filtrec acc c = let vl = vars_of_global env c in let acc = List.fold_right Idset.add vl acc in fold_constr filtrec acc c - in + in filtrec Idset.empty constr -(* [keep_hyps env ids] keeps the part of the section context of [env] which - contains the variables of the set [ids], and recursively the variables +(* [keep_hyps env ids] keeps the part of the section context of [env] which + contains the variables of the set [ids], and recursively the variables contained in the types of the needed variables. *) let keep_hyps env needed = @@ -243,12 +243,12 @@ let keep_hyps env needed = Sign.fold_named_context_reverse (fun need (id,copt,t) -> if Idset.mem id need then - let globc = + let globc = match copt with | None -> Idset.empty | Some c -> global_vars_set env c in Idset.union - (global_vars_set env t) + (global_vars_set env t) (Idset.union globc need) else need) ~init:needed @@ -262,39 +262,39 @@ let keep_hyps env needed = (* Modules *) -let add_modtype ln mtb env = +let add_modtype ln mtb env = let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in - let new_globals = - { env.env_globals with + let new_globals = + { env.env_globals with env_modtypes = new_modtypes } in { env with env_globals = new_globals } -let shallow_add_module mp mb env = +let shallow_add_module mp mb env = let new_mods = MPmap.add mp mb env.env_globals.env_modules in - let new_globals = - { env.env_globals with + let new_globals = + { env.env_globals with env_modules = new_mods } in { env with env_globals = new_globals } -let rec scrape_alias mp env = +let rec scrape_alias mp env = try let mp1 = MPmap.find mp env.env_globals.env_alias in scrape_alias mp1 env with Not_found -> mp -let lookup_module mp env = +let lookup_module mp env = let mp = scrape_alias mp env in MPmap.find mp env.env_globals.env_modules -let lookup_modtype ln env = +let lookup_modtype ln env = let mp = scrape_alias ln env in MPmap.find mp env.env_globals.env_modtypes let register_alias mp1 mp2 env = let new_alias = MPmap.add mp1 mp2 env.env_globals.env_alias in - let new_globals = - { env.env_globals with + let new_globals = + { env.env_globals with env_alias = new_alias } in { env with env_globals = new_globals } @@ -302,8 +302,8 @@ let lookup_alias mp env = MPmap.find mp env.env_globals.env_alias (*s Judgments. *) - -type unsafe_judgment = { + +type unsafe_judgment = { uj_val : constr; uj_type : types } @@ -314,13 +314,13 @@ let make_judge v tj = let j_val j = j.uj_val let j_type j = j.uj_type -type unsafe_type_judgment = { +type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } (*s Compilation of global declaration *) -let compile_constant_body = Cbytegen.compile_constant_body +let compile_constant_body = Cbytegen.compile_constant_body exception Hyp_not_found @@ -330,7 +330,7 @@ let rec apply_to_hyp (ctxt,vals) id f = | (idc,c,ct as d)::ctxt, v::vals -> if idc = id then (f ctxt d rtail)::ctxt, v::vals - else + else let ctxt',vals' = aux (d::rtail) ctxt vals in d::ctxt', v::vals' | [],[] -> raise Hyp_not_found @@ -343,8 +343,8 @@ let rec apply_to_hyp_and_dependent_on (ctxt,vals) id f g = | (idc,c,ct as d)::ctxt, v::vals -> if idc = id then let sign = ctxt,vals in - push_named_context_val (f d sign) sign - else + push_named_context_val (f d sign) sign + else let (ctxt,vals as sign) = aux ctxt vals in push_named_context_val (g d sign) sign | [],[] -> raise Hyp_not_found @@ -356,9 +356,9 @@ let insert_after_hyp (ctxt,vals) id d check = match ctxt, vals with | (idc,c,ct)::ctxt', v::vals' -> if idc = id then begin - check ctxt; - push_named_context_val d (ctxt,vals) - end else + check ctxt; + push_named_context_val d (ctxt,vals) + end else let ctxt,vals = aux ctxt vals in d::ctxt, v::vals | [],[] -> raise Hyp_not_found @@ -369,9 +369,9 @@ let insert_after_hyp (ctxt,vals) id d check = (* To be used in Logic.clear_hyps *) let remove_hyps ids check_context check_value (ctxt, vals) = List.fold_right2 (fun (id,_,_ as d) (id',v) (ctxt,vals) -> - if List.mem id ids then + if List.mem id ids then (ctxt,vals) - else + else let nd = check_context d in let nv = check_value v in (nd::ctxt,(id',nv)::vals)) @@ -402,25 +402,25 @@ let registered env field = unregister function *) let unregister env field = match field with - | KInt31 (_,Int31Type) -> + | KInt31 (_,Int31Type) -> (*there is only one matching kind due to the fact that Environ.env is abstract, and that the only function which add elements to the retroknowledge is Environ.register which enforces this shape *) - (match retroknowledge find env field with + (match retroknowledge find env field with | Ind i31t -> let i31c = Construct (i31t, 1) in - {env with retroknowledge = + {env with retroknowledge = remove (retroknowledge clear_info env i31c) field} | _ -> assert false) |_ -> {env with retroknowledge = - try - remove (retroknowledge clear_info env + try + remove (retroknowledge clear_info env (retroknowledge find env field)) field with Not_found -> retroknowledge remove env field} -(* the Environ.register function syncrhonizes the proactive and reactive +(* the Environ.register function syncrhonizes the proactive and reactive retroknowledge. *) let register = @@ -428,7 +428,7 @@ let register = see pretyping/vnorm.ml for more information) *) let constr_of_int31 = let nth_digit_plus_one i n = (* calculates the nth (starting with 0) - digit of i and adds 1 to it + digit of i and adds 1 to it (nth_digit_plus_one 1 3 = 2) *) if (land) i ((lsl) 1 n) = 0 then 1 @@ -445,8 +445,8 @@ let register = (* subfunction which adds the information bound to the constructor of the int31 type to the reactive retroknowledge *) - let add_int31c retroknowledge c = - let rk = add_vm_constant_static_info retroknowledge c + let add_int31c retroknowledge c = + let rk = add_vm_constant_static_info retroknowledge c Cbytegen.compile_structured_int31 in add_vm_constant_dynamic_info rk c Cbytegen.dynamic_int31_compilation @@ -464,7 +464,7 @@ fun env field value -> operators to the reactive retroknowledge. *) let add_int31_binop_from_const op = match value with - | Const kn -> retroknowledge add_int31_op env value 2 + | Const kn -> retroknowledge add_int31_op env value 2 op kn | _ -> anomaly "Environ.register: should be a constant" in @@ -476,66 +476,66 @@ fun env field value -> in (* subfunction which completes the function constr_of_int31 above by performing the actual retroknowledge operations *) - let add_int31_decompilation_from_type rk = - (* invariant : the type of bits is registered, otherwise the function + let add_int31_decompilation_from_type rk = + (* invariant : the type of bits is registered, otherwise the function would raise Not_found. The invariant is enforced in safe_typing.ml *) match field with - | KInt31 (grp, Int31Type) -> + | KInt31 (grp, Int31Type) -> (match Retroknowledge.find rk (KInt31 (grp,Int31Bits)) with - | Ind i31bit_type -> - (match value with - | Ind i31t -> + | Ind i31bit_type -> + (match value with + | Ind i31t -> Retroknowledge.add_vm_decompile_constant_info rk value (constr_of_int31 i31t i31bit_type) | _ -> anomaly "Environ.register: should be an inductive type") | _ -> anomaly "Environ.register: Int31Bits should be an inductive type") | _ -> anomaly "Environ.register: add_int31_decompilation_from_type called with an abnormal field" in - {env with retroknowledge = - let retroknowledge_with_reactive_info = + {env with retroknowledge = + let retroknowledge_with_reactive_info = match field with - | KInt31 (_, Int31Type) -> + | KInt31 (_, Int31Type) -> let i31c = match value with | Ind i31t -> (Construct (i31t, 1)) | _ -> anomaly "Environ.register: should be an inductive type" in - add_int31_decompilation_from_type - (add_vm_before_match_info - (retroknowledge add_int31c env i31c) + add_int31_decompilation_from_type + (add_vm_before_match_info + (retroknowledge add_int31c env i31c) value Cbytegen.int31_escape_before_match) | KInt31 (_, Int31Plus) -> add_int31_binop_from_const Cbytecodes.Kaddint31 | KInt31 (_, Int31PlusC) -> add_int31_binop_from_const Cbytecodes.Kaddcint31 | KInt31 (_, Int31PlusCarryC) -> add_int31_binop_from_const Cbytecodes.Kaddcarrycint31 | KInt31 (_, Int31Minus) -> add_int31_binop_from_const Cbytecodes.Ksubint31 | KInt31 (_, Int31MinusC) -> add_int31_binop_from_const Cbytecodes.Ksubcint31 - | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const + | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const Cbytecodes.Ksubcarrycint31 | KInt31 (_, Int31Times) -> add_int31_binop_from_const Cbytecodes.Kmulint31 | KInt31 (_, Int31TimesC) -> add_int31_binop_from_const Cbytecodes.Kmulcint31 | KInt31 (_, Int31Div21) -> (* this is a ternary operation *) (match value with | Const kn -> - retroknowledge add_int31_op env value 3 + retroknowledge add_int31_op env value 3 Cbytecodes.Kdiv21int31 kn | _ -> anomaly "Environ.register: should be a constant") | KInt31 (_, Int31Div) -> add_int31_binop_from_const Cbytecodes.Kdivint31 | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *) (match value with | Const kn -> - retroknowledge add_int31_op env value 3 + retroknowledge add_int31_op env value 3 Cbytecodes.Kaddmuldivint31 kn | _ -> anomaly "Environ.register: should be a constant") | KInt31 (_, Int31Compare) -> add_int31_binop_from_const Cbytecodes.Kcompareint31 | KInt31 (_, Int31Head0) -> add_int31_unop_from_const Cbytecodes.Khead0int31 - | KInt31 (_, Int31Tail0) -> add_int31_unop_from_const Cbytecodes.Ktail0int31 - | _ -> env.retroknowledge + | KInt31 (_, Int31Tail0) -> add_int31_unop_from_const Cbytecodes.Ktail0int31 + | _ -> env.retroknowledge in Retroknowledge.add_field retroknowledge_with_reactive_info field value } (**************************************************************) -(* spiwack: the following definitions are used by the function +(* spiwack: the following definitions are used by the function [assumptions] which gives as an output the set of all axioms and sections variables on which a given term depends in a context (expectingly the Global context) *) @@ -546,10 +546,10 @@ type context_object = | Opaque of constant (* An opaque constant. *) (* Defines a set of [assumption] *) -module OrderedContextObject = -struct +module OrderedContextObject = +struct type t = context_object - let compare x y = + let compare x y = match x , y with | Variable i1 , Variable i2 -> id_ord i1 i2 | Axiom k1 , Axiom k2 -> Pervasives.compare k1 k2 @@ -572,8 +572,8 @@ let assumptions ?(add_opaque=false) st (* t env *) = on a and a ContextObjectSet, ContextObjectMap. *) let ( ** ) f1 f2 s m = let (s',m') = f1 s m in f2 s' m' in (* This function eases memoization, by checking if an object is already - stored before trying and applying a function. - If the object is there, the function is not fired (we are in a + stored before trying and applying a function. + If the object is there, the function is not fired (we are in a particular case where memoized object don't need a treatment at all). If the object isn't there, it is stored and the function is fired*) let try_and_go o f s m = @@ -585,7 +585,7 @@ let assumptions ?(add_opaque=false) st (* t env *) = let identity2 s m = (s,m) in (* Goes recursively into the term to see if it depends on assumptions the 3 important cases are : - Const _ where we need to first unfold - the constant and return the needed assumptions of its body in the + the constant and return the needed assumptions of its body in the environment, - Rel _ which means the term is a variable which has been bound earlier by a Lambda or a Prod (returns [] ), @@ -601,30 +601,30 @@ let assumptions ?(add_opaque=false) st (* t env *) = let rec aux t env s acc = match kind_of_term t with | Var id -> aux_memoize_id id env s acc - | Meta _ | Evar _ -> + | Meta _ | Evar _ -> Util.anomaly "Environ.assumption: does not expect a meta or an evar" - | Cast (e1,_,e2) | Prod (_,e1,e2) | Lambda (_,e1,e2) -> + | Cast (e1,_,e2) | Prod (_,e1,e2) | Lambda (_,e1,e2) -> ((aux e1 env)**(aux e2 env)) s acc | LetIn (_,e1,e2,e3) -> ((aux e1 env)** (aux e2 env)** (aux e3 env)) - s acc + s acc | App (e1, e_array) -> ((aux e1 env)** - (Array.fold_right + (Array.fold_right (fun e f -> (aux e env)**f) e_array identity2)) s acc | Case (_,e1,e2,e_array) -> ((aux e1 env)** (aux e2 env)** - (Array.fold_right + (Array.fold_right (fun e f -> (aux e env)**f) e_array identity2)) s acc | Fix (_,(_, e1_array, e2_array)) | CoFix (_,(_,e1_array, e2_array)) -> - ((Array.fold_right + ((Array.fold_right (fun e f -> (aux e env)**f) e1_array identity2) ** - (Array.fold_right + (Array.fold_right (fun e f -> (aux e env)**f) e2_array identity2)) s acc @@ -654,7 +654,7 @@ let assumptions ?(add_opaque=false) st (* t env *) = let (s,acc) = if cb.Declarations.const_body <> None && (cb.Declarations.const_opaque || not (Cpred.mem kn knst)) - && add_opaque + && add_opaque then do_type (Opaque kn) else (s,acc) @@ -662,13 +662,13 @@ let assumptions ?(add_opaque=false) st (* t env *) = match cb.Declarations.const_body with | None -> do_type (Axiom kn) | Some body -> aux (Declarations.force body) env s acc - + and aux_memoize_kn kn env = try_and_go (Axiom kn) (add_kn kn env) in fun t env -> snd (aux t env (ContextObjectSet.empty) (ContextObjectMap.empty)) - + (* /spiwack *) diff --git a/kernel/environ.mli b/kernel/environ.mli index 9e1afdf19b..0ae2855286 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -15,7 +15,7 @@ open Declarations open Sign (*i*) -(*s Unsafe environments. We define here a datatype for environments. +(*s Unsafe environments. We define here a datatype for environments. Since typing is not yet defined, it is not possible to check the informations added in environments, and that is why we speak here of ``unsafe'' environments. *) @@ -24,7 +24,7 @@ open Sign - a context for de Bruijn variables - a context for de Bruijn variables vm values - a context for section variables and goal assumptions - - a context for section variables and goal assumptions vm values + - a context for section variables and goal assumptions vm values - a context for global constants and axioms - a context for inductive definitions - a set of universe constraints @@ -55,7 +55,7 @@ val empty_context : env -> bool (************************************************************************) (*s Context of de Bruijn variables ([rel_context]) *) -val nb_rel : env -> int +val nb_rel : env -> int val push_rel : rel_declaration -> env -> env val push_rel_context : rel_context -> env -> env val push_rec_types : rec_declaration -> env -> env @@ -80,12 +80,12 @@ val empty_named_context_val : named_context_val (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. - *** /!\ *** [f t] should be convertible with t *) -val map_named_val : + *** /!\ *** [f t] should be convertible with t *) +val map_named_val : (constr -> constr) -> named_context_val -> named_context_val val push_named : named_declaration -> env -> env -val push_named_context_val : +val push_named_context_val : named_declaration -> named_context_val -> named_context_val @@ -98,7 +98,7 @@ val lookup_named_val : variable -> named_context_val -> named_declaration val evaluable_named : variable -> env -> bool val named_type : variable -> env -> types val named_body : variable -> env -> constr option - + (*s Recurrence on [named_context]: older declarations processed first *) val fold_named_context : @@ -181,7 +181,7 @@ val keep_hyps : env -> Idset.t -> section_context actually only a datatype to store a term with its type and the type of its type. *) -type unsafe_judgment = { +type unsafe_judgment = { uj_val : constr; uj_type : types } @@ -189,14 +189,14 @@ val make_judge : constr -> types -> unsafe_judgment val j_val : unsafe_judgment -> constr val j_type : unsafe_judgment -> types -type unsafe_type_judgment = { +type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } (*s Compilation of global declaration *) -val compile_constant_body : +val compile_constant_body : env -> constr_substituted option -> bool -> bool -> Cemitcodes.body_code (* opaque *) (* boxed *) @@ -206,7 +206,7 @@ exception Hyp_not_found return [tail::(f head (id,_,_) (rev tail))::head]. the value associated to id should not change *) -val apply_to_hyp : named_context_val -> variable -> +val apply_to_hyp : named_context_val -> variable -> (named_context -> named_declaration -> named_context -> named_declaration) -> named_context_val @@ -219,7 +219,7 @@ val apply_to_hyp_and_dependent_on : named_context_val -> variable -> named_context_val val insert_after_hyp : named_context_val -> variable -> - named_declaration -> + named_declaration -> (named_context -> unit) -> named_context_val val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val @@ -250,7 +250,7 @@ type context_object = module OrderedContextObject : Set.OrderedType with type t = context_object module ContextObjectMap : Map.S with type key = context_object -(* collects all the assumptions (optionally including opaque definitions) +(* collects all the assumptions (optionally including opaque definitions) on which a term relies (together with their type) *) val assumptions : ?add_opaque:bool -> transparent_state -> constr -> env -> Term.types ContextObjectMap.t diff --git a/kernel/esubst.ml b/kernel/esubst.ml index dc29e4e985..c8b5fb269e 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -110,7 +110,7 @@ let rec is_subs_id = function * the result is (Inr (k+lams,p)) when the variable is just relocated * where p is None if the variable points inside subs and Some(k) if the * variable points k bindings beyond subs. - *) + *) let rec exp_rel lams k subs = match subs with | CONS (def,_) when k <= Array.length def diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 75d460ce63..bf1d232413 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -35,7 +35,7 @@ val subs_shift_cons: int * 'a subs * 'a array -> 'a subs * shifted by lams), or (Inr (k',p)) when the variable k is just relocated * as k'; p is None if the variable points inside subs and Some(k) if the * variable points k bindings beyond subs (cf argument of ESID). - *) + *) val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union (* Tests whether a substitution behaves like the identity *) diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index ccf9b3f6c5..c202d627df 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -58,8 +58,8 @@ exception InductiveError of inductive_error let check_constructors_names = let rec check idset = function | [] -> idset - | c::cl -> - if Idset.mem c idset then + | c::cl -> + if Idset.mem c idset then raise (InductiveError (SameNamesConstructors c)) else check (Idset.add c idset) cl @@ -73,7 +73,7 @@ let check_constructors_names = let mind_check_names mie = let rec check indset cstset = function | [] -> () - | ind::inds -> + | ind::inds -> let id = ind.mind_entry_typename in let cl = ind.mind_entry_consnames in if Idset.mem id indset then @@ -89,7 +89,7 @@ let mind_check_names mie = let mind_check_arities env mie = let check_arity id c = - if not (is_arity env c) then + if not (is_arity env c) then raise (InductiveError (NotAnArity id)) in List.iter @@ -110,12 +110,12 @@ let is_small infos = List.for_all (fun (logic,small) -> small) infos let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos (* An inductive definition is a "unit" if it has only one constructor - and that all arguments expected by this constructor are - logical, this is the case for equality, conjunction of logical properties + and that all arguments expected by this constructor are + logical, this is the case for equality, conjunction of logical properties *) let is_unit constrsinfos = match constrsinfos with (* One info = One constructor *) - | [constrinfos] -> is_logic_constr constrinfos + | [constrinfos] -> is_logic_constr constrinfos | [] -> (* type without constructors *) true | _ -> false @@ -132,7 +132,7 @@ let rec infos_and_sort env t = | _ -> (* don't fail if not positive, it is tested later *) [] let small_unit constrsinfos = - let issmall = List.for_all is_small constrsinfos + let issmall = List.for_all is_small constrsinfos and isunit = is_unit constrsinfos in issmall, isunit @@ -154,7 +154,7 @@ let small_unit constrsinfos = w1,w2,w3 <= u1 w1,w2 <= u2 w1,w2,w3 <= u3 -*) +*) let extract_level (_,_,_,lc,lev) = (* Enforce that the level is not in Prop if more than two constructors *) @@ -245,11 +245,11 @@ let typecheck_inductive env mie = let inds = Array.of_list inds in let arities = Array.of_list arity_list in let param_ccls = List.fold_left (fun l (_,b,p) -> - if b = None then + if b = None then let _,c = dest_prod_assum env p in let u = match kind_of_term c with Sort (Type u) -> Some u | _ -> None in u::l - else + else l) [] params in (* Compute/check the sorts of the inductive types *) @@ -258,7 +258,7 @@ let typecheck_inductive env mie = array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst -> let sign, s = dest_arity env full_arity in let status,cst = match s with - | Type u when ar_level <> None (* Explicitly polymorphic *) + | Type u when ar_level <> None (* Explicitly polymorphic *) && no_upper_constraints u cst -> (* The polymorphic level is a function of the level of the *) (* conclusions of the parameters *) @@ -297,20 +297,20 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum -let explain_ind_err id ntyp env0 nbpar c nargs err = +let explain_ind_err id ntyp env0 nbpar c nargs err = let (lpar,c') = mind_extract_params nbpar c in let env = push_rel_context lpar env0 in match err with - | LocalNonPos kt -> + | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar)))) - | LocalNotEnoughArgs kt -> - raise (InductiveError + | LocalNotEnoughArgs kt -> + raise (InductiveError (NotEnoughArgs (env,c',mkRel (kt+nbpar)))) | LocalNotConstructor -> - raise (InductiveError + raise (InductiveError (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nbpar,nargs))) | LocalNonPar (n,l) -> - raise (InductiveError + raise (InductiveError (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar)))) let failwith_non_pos n ntypes c = @@ -330,7 +330,7 @@ let failwith_non_pos_list n ntypes l = let check_correct_par (env,n,ntypes,_) hyps l largs = let nparams = rel_context_nhyps hyps in let largs = Array.of_list largs in - if Array.length largs < nparams then + if Array.length largs < nparams then raise (IllFormedInd (LocalNotEnoughArgs l)); let (lpar,largs') = array_chop nparams largs in let nhyps = List.length hyps in @@ -342,20 +342,20 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = | Rel w when w = index -> check (k-1) (index+1) hyps | _ -> raise (IllFormedInd (LocalNonPar (k+1,l))) in check (nparams-1) (n-nhyps) hyps; - if not (array_for_all (noccur_between n ntypes) largs') then + if not (array_for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' -(* Computes the maximum number of recursive parameters : - the first parameters which are constant in recursive arguments - n is the current depth, nmr is the maximum number of possible +(* Computes the maximum number of recursive parameters : + the first parameters which are constant in recursive arguments + n is the current depth, nmr is the maximum number of possible recursive parameters *) -let compute_rec_par (env,n,_,_) hyps nmr largs = +let compute_rec_par (env,n,_,_) hyps nmr largs = if nmr = 0 then 0 else (* start from 0, hyps will be in reverse order *) let (lpar,_) = list_chop nmr largs in - let rec find k index = - function + let rec find k index = + function ([],_) -> nmr | (_,[]) -> assert false (* |hyps|>=nmr *) | (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps) @@ -367,14 +367,14 @@ if nmr = 0 then 0 else (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) -let abstract_mind_lc env ntyps npars lc = - if npars = 0 then +let abstract_mind_lc env ntyps npars lc = + if npars = 0 then lc - else - let make_abs = + else + let make_abs = list_tabulate - (function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps - in + (function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps + in Array.map (substl make_abs) lc (* [env] is the typing environment @@ -382,7 +382,7 @@ let abstract_mind_lc env ntyps npars lc = [ntypes] is the number of inductive types in the definition (i.e. range of inductives is [n; n+ntypes-1]) [lra] is the list of recursive tree of each variable - *) + *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) @@ -392,7 +392,7 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = let env' = push_rel (Anonymous,None, hnf_prod_applist env (type_of_inductive env specif) lpar) env in - let ra_env' = + let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in (* New index of the inductive types *) @@ -408,7 +408,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = let lparams = rel_context_length hyps in let nmr = rel_context_nhyps hyps in (* Checking the (strict) positivity of a constructor argument type [c] *) - let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = + let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = let x,largs = decompose_app (whd_betadeltaiota env c) in match kind_of_term x with | Prod (na,b,d) -> @@ -418,12 +418,12 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = | Some b -> check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d) | Rel k -> - (try let (ra,rarg) = List.nth ra_env (k-1) in + (try let (ra,rarg) = List.nth ra_env (k-1) in let nmr1 = (match ra with Mrec _ -> compute_rec_par ienv hyps nmr largs | _ -> nmr) - in + in if not (List.for_all (noccur_between n ntypes) largs) then failwith_non_pos_list n ntypes largs else (nmr1,rarg) @@ -433,9 +433,9 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = parameter, then we have a nested indtype *) if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) else check_positive_nested ienv nmr (ind_kn, largs) - | err -> + | err -> if noccur_between n ntypes x && - List.for_all (noccur_between n ntypes) largs + List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) else failwith_non_pos_list n ntypes (x::largs) @@ -444,14 +444,14 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = let (mib,mip) = lookup_mind_specif env mi in let auxnpar = mib.mind_nparams_rec in let (lpar,auxlargs) = - try list_chop auxnpar largs - with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in + try list_chop auxnpar largs + with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in (* If the inductive appears in the args (non params) then the definition is not positive. *) if not (List.for_all (noccur_between n ntypes) auxlargs) then raise (IllFormedInd (LocalNonPos n)); (* We do not deal with imbricated mutual inductive types *) - let auxntyp = mib.mind_ntypes in + let auxntyp = mib.mind_ntypes in if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n)); (* The nested inductive type with parameters removed *) let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in @@ -460,35 +460,35 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in - let irecargs_nmr = + let irecargs_nmr = (* fails if the inductive type occurs non positively *) - (* when substituted *) - Array.map - (function c -> - let c' = hnf_prod_applist env' c lpar' in - check_constructors ienv' false nmr c') + (* when substituted *) + Array.map + (function c -> + let c' = hnf_prod_applist env' c lpar' in + check_constructors ienv' false nmr c') auxlcvect in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr - in + in (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)) - + (* check the inductive types occur positively in the products of C, if check_head=true, also check the head corresponds to a constructor of - the ith type *) - - and check_constructors ienv check_head nmr c = - let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = + the ith type *) + + and check_constructors ienv check_head nmr c = + let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = let x,largs = decompose_app (whd_betadeltaiota env c) in match kind_of_term x with - | Prod (na,b,d) -> + | Prod (na,b,d) -> assert (largs = []); - let nmr',recarg = check_pos ienv nmr b in + let nmr',recarg = check_pos ienv nmr b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' nmr' (recarg::lrec) d - + | hd -> if check_head then if hd = Rel (n+ntypes-i-1) then @@ -507,7 +507,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = let _,rawc = mind_extract_params lparams c in try check_constructors ienv true nmr rawc - with IllFormedInd err -> + with IllFormedInd err -> explain_ind_err id (ntypes-i) env lparams c nargs err) (Array.of_list lcnames) indlc in @@ -526,9 +526,9 @@ let check_positivity env_ar params inds = list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in let ienv = (env_ar, 1+lparams, ntypes, ra_env) in let nargs = rel_context_nhyps sign - nmr in - check_positivity_one ienv params i nargs lcnames lc + check_positivity_one ienv params i nargs lcnames lc in - let irecargs_nmr = Array.mapi check_one inds in + let irecargs_nmr = Array.mapi check_one inds in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr',Rtree.mk_rec irecargs) @@ -537,14 +537,14 @@ let check_positivity env_ar params inds = (************************************************************************) (************************************************************************) (* Build the inductive packet *) - + (* Elimination sorts *) let is_recursive = Rtree.is_infinite -(* let rec one_is_rec rvec = - List.exists (function Mrec(i) -> List.mem i listind +(* let rec one_is_rec rvec = + List.exists (function Mrec(i) -> List.mem i listind | Imbr(_,lvec) -> array_exists one_is_rec lvec | Norec -> false) rvec - in + in array_exists one_is_rec *) @@ -603,27 +603,27 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = | Inr (param_levels,lev) -> Polymorphic { poly_param_levels = param_levels; - poly_level = lev; + poly_level = lev; }, all_sorts | Inl ((issmall,isunit),ar,s) -> let kelim = allowed_sorts issmall isunit s in Monomorphic { mind_user_arity = ar; - mind_sort = s; + mind_sort = s; }, kelim in (* Assigning VM tags to constructors *) - let nconst, nblock = ref 0, ref 0 in + let nconst, nblock = ref 0, ref 0 in let transf num = let arity = List.length (dest_subterms recarg).(num) in - if arity = 0 then + if arity = 0 then let p = (!nconst, 0) in incr nconst; p - else + else let p = (!nblock + 1, arity) in incr nblock; p (* les tag des constructeur constant commence a 0, les tag des constructeur non constant a 1 (0 => accumulator) *) - in + in let rtbl = Array.init (List.length cnames) transf in (* Build the inductive packet *) { mind_typename = id; @@ -648,7 +648,7 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = mind_finite = isfinite; mind_hyps = hyps; mind_nparams = nparamargs; - mind_nparams_rec = nmr; + mind_nparams_rec = nmr; mind_params_ctxt = params; mind_packets = packets; mind_constraints = cst; diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 6da102a940..19e4130ffd 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -55,7 +55,7 @@ let inductive_params (mib,_) = mib.mind_nparams (* inductives *) let ind_subst mind mib = let ntypes = mib.mind_ntypes in - let make_Ik k = mkInd (mind,ntypes-k-1) in + let make_Ik k = mkInd (mind,ntypes-k-1) in list_tabulate make_Ik ntypes (* Instantiate inductives in constructor type *) @@ -64,7 +64,7 @@ let constructor_instantiate mind mib c = substl s c let instantiate_params full t args sign = - let fail () = + let fail () = anomaly "instantiate_params: type, ctxt and args mismatch" in let (rem_args, subs, ty) = Sign.fold_rel_context @@ -75,7 +75,7 @@ let instantiate_params full t args sign = | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) sign - ~init:(args,[],t) + ~init:(args,[],t) in if rem_args <> [] then fail(); substl subs ty @@ -101,11 +101,11 @@ let full_constructor_instantiate ((mind,_),(mib,_),params) = let number_of_inductives mib = Array.length mib.mind_packets let number_of_constructors mip = Array.length mip.mind_consnames -(* +(* Computing the actual sort of an applied or partially applied inductive type: I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a) -uniformargs : utyps +uniformargs : utyps otherargs : otyps I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj s'_k = max(..s_kj..) @@ -221,11 +221,11 @@ let type_of_constructor cstr (mib,mip) = if i > nconstr then error "Not enough constructors in the type."; constructor_instantiate (fst ind) mib specif.(i-1) -let arities_of_specif kn (mib,mip) = +let arities_of_specif kn (mib,mip) = let specif = mip.mind_nf_lc in Array.map (constructor_instantiate kn mib) specif -let arities_of_constructors ind specif = +let arities_of_constructors ind specif = arities_of_specif (fst ind) specif let type_of_constructors ind (mib,mip) = @@ -250,7 +250,7 @@ let local_rels ctxt = None -> (mkRel n :: rels, n+1) | Some _ -> (rels, n+1)) ~init:([],1) - ctxt + ctxt in rels @@ -258,7 +258,7 @@ let local_rels ctxt = let inductive_sort_family mip = match mip.mind_arity with - | Monomorphic s -> family_of_sort s.mind_sort + | Monomorphic s -> family_of_sort s.mind_sort | Polymorphic _ -> InType let mind_arity mip = @@ -275,25 +275,25 @@ let extended_rel_list n hyps = | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps | (_,Some _,_) :: hyps -> reln l (p+1) hyps | [] -> l - in + in reln [] 1 hyps let build_dependent_inductive ind (_,mip) params = let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in - applist + applist (mkInd ind, - List.map (lift mip.mind_nrealargs_ctxt) params + List.map (lift mip.mind_nrealargs_ctxt) params @ extended_rel_list 0 realargs) (* This exception is local *) exception LocalArity of (sorts_family * sorts_family * arity_error) option let check_allowed_sort ksort specif = - if not (List.exists ((=) ksort) (elim_sorts specif)) then + if not (List.exists ((=) ksort) (elim_sorts specif)) then let s = inductive_sort_family (snd specif) in raise (LocalArity (Some(ksort,s,error_elim_expln ksort s))) -let is_correct_arity env c pj ind specif params = +let is_correct_arity env c pj ind specif params = let arsign,_ = get_instantiated_arity specif params in let rec srec env pt ar u = let pt' = whd_betadeltaiota env pt in @@ -305,9 +305,9 @@ let is_correct_arity env c pj ind specif params = srec (push_rel (na1,None,a1) env) t ar' (Constraint.union u univ) | Prod (_,a1,a2), [] -> (* whnf of t was not needed here! *) let ksort = match kind_of_term (whd_betadeltaiota env a2) with - | Sort s -> family_of_sort s + | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in - let dep_ind = build_dependent_inductive ind specif params in + let dep_ind = build_dependent_inductive ind specif params in let univ = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in @@ -317,7 +317,7 @@ let is_correct_arity env c pj ind specif params = srec (push_rel d env) (lift 1 pt') ar' u | _ -> raise (LocalArity None) - in + in try srec env pj.uj_type (List.rev arsign) Constraint.empty with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c pj kinds @@ -335,7 +335,7 @@ let build_branches_type ind (_,mip as specif) params p = let nargs = rel_context_length args in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = list_chop (inductive_params specif) allargs in - let cargs = + let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in vargs @ [dep_cstr] in @@ -349,7 +349,7 @@ let build_case_type n p c realargs = betazeta_appvect (n+1) p (Array.of_list (realargs@[c])) let type_case_branches env (ind,largs) pj c = - let specif = lookup_mind_specif env ind in + let specif = lookup_mind_specif env ind in let nparams = inductive_params specif in let (params,realargs) = list_chop nparams largs in let p = pj.uj_val in @@ -385,7 +385,7 @@ let check_case_info env indsp ci = (* Guard conditions for fix and cofix-points *) -(* Check if t is a subterm of Rel n, and gives its specification, +(* Check if t is a subterm of Rel n, and gives its specification, assuming lst already gives index of subterms with corresponding specifications of recursive arguments *) @@ -430,7 +430,7 @@ type subterm_spec = let spec_of_tree t = if Rtree.eq_rtree (=) t mk_norec then Not_subterm else Subterm(Strict,t) - + let subterm_spec_glb = let glb2 s1 s2 = match s1,s2 with @@ -443,7 +443,7 @@ let subterm_spec_glb = (* branches do not return objects with same spec *) else Not_subterm in Array.fold_left glb2 Dead_code - + type guard_env = { env : env; (* dB of last fixpoint *) @@ -467,7 +467,7 @@ let make_renv env minds recarg (kn,tyi) = genv = [Subterm(Large,mind_recvec.(tyi))] } let push_var renv (x,ty,spec) = - { renv with + { renv with env = push_rel (x,None,ty) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } @@ -479,7 +479,7 @@ let push_var_renv renv (x,ty) = push_var renv (x,ty,Not_subterm) (* Fetch recursive information about a variable p *) -let subterm_var p renv = +let subterm_var p renv = try List.nth renv.genv (p-1) with Failure _ | Invalid_argument _ -> Not_subterm @@ -489,7 +489,7 @@ let add_subterm renv (x,a,spec) = let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in - { renv with + { renv with env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> Not_subterm::ge) n renv.genv } @@ -528,8 +528,8 @@ let lookup_subterms env ind = associated to its own subterms. Rq: if branch is not eta-long, then the recursive information is not propagated to the missing abstractions *) -let case_branches_specif renv c_spec ind lbr = - let rec push_branch_args renv lrec c = +let case_branches_specif renv c_spec ind lbr = + let rec push_branch_args renv lrec c = match lrec with ra::lr -> let c' = whd_betadeltaiota renv.env c in @@ -545,7 +545,7 @@ let case_branches_specif renv c_spec ind lbr = let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in assert (Array.length sub_spec = Array.length lbr); array_map2 (push_branch_args renv) sub_spec lbr - | Dead_code -> + | Dead_code -> let t = dest_subterms (lookup_subterms renv.env ind) in let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in assert (Array.length sub_spec = Array.length lbr); @@ -558,10 +558,10 @@ let case_branches_specif renv c_spec ind lbr = about variables. *) -let rec subterm_specif renv t = +let rec subterm_specif renv t = (* maybe reduction is not always necessary! *) let f,l = decompose_app (whd_betadeltaiota renv.env t) in - match kind_of_term f with + match kind_of_term f with | Rel k -> subterm_var k renv | Case (ci,_,c,lbr) -> @@ -573,7 +573,7 @@ let rec subterm_specif renv t = Array.map (fun (renv',br') -> subterm_specif renv' br') lbr_spec in subterm_spec_glb stl - + | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> (* when proving that the fixpoint f(x)=e is less than n, it is enough to prove that e is less than n assuming f is less than n @@ -596,7 +596,7 @@ let rec subterm_specif renv t = (* Why Strict here ? To be general, it could also be Large... *) assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in - let decrArg = recindxs.(i) in + let decrArg = recindxs.(i) in let theBody = bodies.(i) in let nbOfAbst = decrArg+1 in let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in @@ -610,7 +610,7 @@ let rec subterm_specif renv t = assign_var_spec renv'' (1, arg_spec) in subterm_specif renv'' strippedBody) - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> assert (l=[]); subterm_specif (push_var_renv renv (x,a)) b @@ -622,7 +622,7 @@ let rec subterm_specif renv t = (* Check term c can be applied to one of the mutual fixpoints. *) -let check_is_subterm renv c = +let check_is_subterm renv c = match subterm_specif renv c with Subterm (Strict,_) | Dead_code -> true | _ -> false @@ -650,21 +650,21 @@ let error_partial_apply renv fx = given [recpos], the decreasing arguments of each mutually defined fixpoint. *) let check_one_fix renv recpos def = - let nfi = Array.length recpos in + let nfi = Array.length recpos in (* Checks if [t] only make valid recursive calls *) - let rec check_rec_call renv t = + let rec check_rec_call renv t = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else let (f,l) = decompose_app (whd_betaiotazeta t) in match kind_of_term f with - | Rel p -> - (* Test if [p] is a fixpoint (recursive call) *) + | Rel p -> + (* Test if [p] is a fixpoint (recursive call) *) if renv.rel_min <= p & p < renv.rel_min+nfi then begin List.iter (check_rec_call renv) l; - (* the position of the invoked fixpoint: *) + (* the position of the invoked fixpoint: *) let glob = renv.rel_min+nfi-1-p in (* the decreasing arg of the rec call: *) let np = recpos.(glob) in @@ -697,9 +697,9 @@ let check_one_fix renv recpos def = (* Enables to traverse Fixpoint definitions in a more intelligent way, ie, the rule : if - g = Fix g/p := [y1:T1]...[yp:Tp]e & - - f is guarded with respect to the set of pattern variables S + - f is guarded with respect to the set of pattern variables S in a1 ... am & - - f is guarded with respect to the set of pattern variables S + - f is guarded with respect to the set of pattern variables S in T1 ... Tp & - ap is a sub-term of the formal argument of f & - f is guarded with respect to the set of pattern variables @@ -711,10 +711,10 @@ let check_one_fix renv recpos def = List.iter (check_rec_call renv) l; Array.iter (check_rec_call renv) typarray; let decrArg = recindxs.(i) in - let renv' = push_fix_renv renv recdef in + let renv' = push_fix_renv renv recdef in if (List.length l < (decrArg+1)) then Array.iter (check_rec_call renv') bodies - else + else Array.iteri (fun j body -> if i=j then @@ -724,8 +724,8 @@ let check_one_fix renv recpos def = else check_rec_call renv' body) bodies - | Const kn -> - if evaluable_constant kn renv.env then + | Const kn -> + if evaluable_constant kn renv.env then try List.iter (check_rec_call renv) l with (FixGuardError _ ) -> check_rec_call renv(applist(constant_value renv.env kn, l)) @@ -733,14 +733,14 @@ let check_one_fix renv recpos def = (* The cases below simply check recursively the condition on the subterms *) - | Cast (a,_, b) -> + | Cast (a,_, b) -> List.iter (check_rec_call renv) (a::b::l) | Lambda (x,a,b) -> List.iter (check_rec_call renv) (a::l); check_rec_call (push_var_renv renv (x,a)) b - | Prod (x,a,b) -> + | Prod (x,a,b) -> List.iter (check_rec_call renv) (a::l); check_rec_call (push_var_renv renv (x,a)) b @@ -786,9 +786,9 @@ let judgment_of_fixpoint (_, types, bodies) = array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = - let nbfix = Array.length bodies in + let nbfix = Array.length bodies in if nbfix = 0 - or Array.length nvect <> nbfix + or Array.length nvect <> nbfix or Array.length types <> nbfix or Array.length names <> nbfix or bodynum < 0 @@ -799,18 +799,18 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = let raise_err env i err = error_ill_formed_rec_body env err names i fixenv vdefj in (* Check the i-th definition with recarg k *) - let find_ind i k def = - (* check fi does not appear in the k+1 first abstractions, + let find_ind i k def = + (* check fi does not appear in the k+1 first abstractions, gives the type of the k+1-eme abstraction (must be an inductive) *) - let rec check_occur env n def = + let rec check_occur env n def = match kind_of_term (whd_betadeltaiota env def) with - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in if n = k+1 then (* get the inductive type of the fixpoint *) - let (mind, _) = - try find_inductive env a + let (mind, _) = + try find_inductive env a with Not_found -> raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) @@ -830,7 +830,7 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = let renv = make_renv fenv minds nvect.(i) minds.(i) in try check_one_fix renv nvect body with FixGuardError (fixenv,err) -> - error_ill_formed_rec_body fixenv err names i + error_ill_formed_rec_body fixenv err names i (push_rec_types recdef env) (judgment_of_fixpoint recdef) done @@ -851,17 +851,17 @@ let rec codomain_is_coind env c = let b = whd_betadeltaiota env c in match kind_of_term b with | Prod (x,a,b) -> - codomain_is_coind (push_rel (x, None, a) env) b - | _ -> + codomain_is_coind (push_rel (x, None, a) env) b + | _ -> (try find_coinductive env b with Not_found -> raise (CoFixGuardError (env, CodomainNotInductiveType b))) -let check_one_cofix env nbfix def deftype = +let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n vlra t = if not (noccur_with_meta n nbfix t) then let c,args = decompose_app (whd_betadeltaiota env t) in - match kind_of_term c with + match kind_of_term c with | Rel p when n <= p && p < n+nbfix -> (* recursive call: must be guarded and no nested recursive call allowed *) @@ -869,14 +869,14 @@ let check_one_cofix env nbfix def deftype = raise (CoFixGuardError (env,UnguardedRecursiveCall t)) else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) - + | Construct (_,i as cstr_kn) -> - let lra = vlra.(i-1) in + let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in let realargs = list_skipn mib.mind_nparams args in let rec process_args_of_constr = function - | (t::lr), (rar::lrar) -> + | (t::lr), (rar::lrar) -> if rar = mk_norec then if noccur_with_meta n nbfix t then process_args_of_constr (lr, lrar) @@ -887,26 +887,26 @@ let check_one_cofix env nbfix def deftype = check_rec_call env true n spec t; process_args_of_constr (lr, lrar) | [],_ -> () - | _ -> anomaly_ill_typed () + | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) - + | Lambda (x,a,b) -> assert (args = []); if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in check_rec_call env' alreadygrd (n+1) vlra b - else + else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) - + | CoFix (j,(_,varit,vdefs as recdef)) -> if (List.for_all (noccur_with_meta n nbfix) args) - then + then let nbfix = Array.length vdefs in if (array_for_all (noccur_with_meta n nbfix) varit) then let env' = push_rec_types recdef env in (Array.iter (check_rec_call env' alreadygrd (n+1) vlra) vdefs; List.iter (check_rec_call env alreadygrd n vlra) args) - else + else raise (CoFixGuardError (env,RecCallInTypeOfDef c)) else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) @@ -916,32 +916,32 @@ let check_one_cofix env nbfix def deftype = if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then Array.iter (check_rec_call env alreadygrd n vlra) vrest - else + else raise (CoFixGuardError (env,RecCallInCaseFun c)) - else + else raise (CoFixGuardError (env,RecCallInCaseArg c)) - else + else raise (CoFixGuardError (env,RecCallInCasePred c)) - + | Meta _ -> () | Evar _ -> List.iter (check_rec_call env alreadygrd n vlra) args - - | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in + + | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let (mind, _) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in check_rec_call env false 1 (dest_subterms vlra) def -(* The function which checks that the whole block of definitions +(* The function which checks that the whole block of definitions satisfies the guarded condition *) -let check_cofix env (bodynum,(names,types,bodies as recdef)) = - let nbfix = Array.length bodies in +let check_cofix env (bodynum,(names,types,bodies as recdef)) = + let nbfix = Array.length bodies in for i = 0 to nbfix-1 do let fixenv = push_rec_types recdef env in try check_one_cofix fixenv nbfix bodies.(i) types.(i) - with CoFixGuardError (errenv,err) -> - error_ill_formed_rec_body errenv err names i + with CoFixGuardError (errenv,err) -> + error_ill_formed_rec_body errenv err names i fixenv (judgment_of_fixpoint recdef) done diff --git a/kernel/inductive.mli b/kernel/inductive.mli index f877b5391f..9f8d109006 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -51,7 +51,7 @@ val arities_of_constructors : inductive -> mind_specif -> types array val type_of_constructors : inductive -> mind_specif -> types array (* Transforms inductive specification into types (in nf) *) -val arities_of_specif : mutual_inductive -> mind_specif -> types array +val arities_of_specif : mutual_inductive -> mind_specif -> types array (* [type_case_branches env (I,args) (p:A) c] computes useful types diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 2ac7b623b4..238aa3544a 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -27,8 +27,8 @@ let apply_opt_resolver resolve kn = | Some resolve -> try List.assoc kn resolve with Not_found -> None -type substitution_domain = - MSI of mod_self_id +type substitution_domain = + MSI of mod_self_id | MBI of mod_bound_id | MPI of module_path @@ -37,7 +37,7 @@ let string_of_subst_domain = function | MBI mbid -> debug_string_of_mbid mbid | MPI mp -> string_of_mp mp -module Umap = Map.Make(struct +module Umap = Map.Make(struct type t = substitution_domain let compare = Pervasives.compare end) @@ -58,27 +58,27 @@ let map_msid msid mp = add_msid msid mp empty_subst let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst let map_mp mp1 mp2 = add_mp mp1 mp2 empty_subst -let list_contents sub = +let list_contents sub = let one_pair uid (mp,_) l = (string_of_subst_domain uid, string_of_mp mp)::l in Umap.fold one_pair sub [] -let debug_string_of_subst sub = +let debug_string_of_subst sub = let l = List.map (fun (s1,s2) -> s1^"|->"^s2) (list_contents sub) in "{" ^ String.concat "; " l ^ "}" -let debug_pr_subst sub = +let debug_pr_subst sub = let l = list_contents sub in - let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) + let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) in - str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" + str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" let subst_mp0 sub mp = (* 's like subst *) let rec aux mp = match mp with - | MPself sid -> + | MPself sid -> let mp',resolve = Umap.find (MSI sid) sub in mp',resolve | MPbound bid -> @@ -86,17 +86,17 @@ let subst_mp0 sub mp = (* 's like subst *) mp',resolve | MPdot (mp1,l) as mp2 -> begin - try + try let mp',resolve = Umap.find (MPI mp2) sub in mp',resolve - with Not_found -> + with Not_found -> let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve end | _ -> raise Not_found in try - Some (aux mp) + Some (aux mp) with Not_found -> None let subst_mp sub mp = @@ -148,84 +148,84 @@ let subst_evaluable_reference subst = function -let rec map_kn f f' c = +let rec map_kn f f' c = let func = map_kn f f' in match kind_of_term c with - | Const kn -> + | Const kn -> (match f' kn with None -> c | Some const ->const) - | Ind (kn,i) -> + | Ind (kn,i) -> (match f kn with None -> c | Some kn' -> mkInd (kn',i)) - | Construct ((kn,i),j) -> + | Construct ((kn,i),j) -> (match f kn with None -> c | Some kn' -> mkConstruct ((kn',i),j)) - | Case (ci,p,ct,l) -> + | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in let p' = func p in let ct' = func ct in let l' = array_smartmap func l in - if (ci.ci_ind==ci_ind && p'==p + if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c - else + else mkCase ({ci with ci_ind = ci_ind}, - p',ct', l') - | Cast (ct,k,t) -> + p',ct', l') + | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in - if (t'==t && ct'==ct) then c + if (t'==t && ct'==ct) then c else mkCast (ct', k, t') - | Prod (na,t,ct) -> + | Prod (na,t,ct) -> let ct' = func ct in let t'= func t in - if (t'==t && ct'==ct) then c + if (t'==t && ct'==ct) then c else mkProd (na, t', ct') - | Lambda (na,t,ct) -> + | Lambda (na,t,ct) -> let ct' = func ct in let t'= func t in - if (t'==t && ct'==ct) then c + if (t'==t && ct'==ct) then c else mkLambda (na, t', ct') - | LetIn (na,b,t,ct) -> + | LetIn (na,b,t,ct) -> let ct' = func ct in let t'= func t in let b'= func b in - if (t'==t && ct'==ct && b==b') then c + if (t'==t && ct'==ct && b==b') then c else mkLetIn (na, b', t', ct') - | App (ct,l) -> + | App (ct,l) -> let ct' = func ct in let l' = array_smartmap func l in if (ct'== ct && l'==l) then c else mkApp (ct',l') - | Evar (e,l) -> + | Evar (e,l) -> let l' = array_smartmap func l in if (l'==l) then c else mkEvar (e,l') | Fix (ln,(lna,tl,bl)) -> let tl' = array_smartmap func tl in let bl' = array_smartmap func bl in - if (bl == bl'&& tl == tl') then c + if (bl == bl'&& tl == tl') then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = array_smartmap func tl in let bl' = array_smartmap func bl in - if (bl == bl'&& tl == tl') then c + if (bl == bl'&& tl == tl') then c else mkCoFix (ln,(lna,tl',bl')) | _ -> c -let subst_mps sub = +let subst_mps sub = map_kn (subst_kn0 sub) (subst_con0 sub) let rec replace_mp_in_mp mpfrom mpto mp = match mp with | _ when mp = mpfrom -> mpto - | MPdot (mp1,l) -> + | MPdot (mp1,l) -> let mp1' = replace_mp_in_mp mpfrom mpto mp1 in if mp1==mp1' then mp else MPdot (mp1',l) @@ -282,7 +282,7 @@ let join (subst1 : substitution) (subst2 : substitution) = let key' = match key with MSI msid -> MPself msid - | MBI mbid -> MPbound mbid + | MBI mbid -> MPbound mbid | MPI mp1 -> mp1 in let kn' = replace_mp_in_con mp key' kn in if kn==kn' then @@ -297,12 +297,12 @@ let join (subst1 : substitution) (subst2 : substitution) = mp',resolve'' in let subst = Umap.mapi (apply_subst subst2) subst1 in (Umap.fold Umap.add subst2 subst) - + let subst_key subst1 subst2 = let replace_in_key key (mp,resolve) sub= - let newkey = + let newkey = match key with - | MPI mp1 -> + | MPI mp1 -> begin match subst_mp0 subst1 mp1 with | None -> None @@ -318,22 +318,22 @@ let subst_key subst1 subst2 = let update_subst_alias subst1 subst2 = let subst_inv key (mp,resolve) sub = - let newmp = - match key with + let newmp = + match key with | MBI msid -> MPbound msid | MSI msid -> MPself msid | MPI mp -> mp in - match mp with + match mp with | MPbound mbid -> Umap.add (MBI mbid) (newmp,None) sub | MPself msid -> Umap.add (MSI msid) (newmp,None) sub | _ -> Umap.add (MPI mp) (newmp,None) sub - in + in let subst_mbi = Umap.fold subst_inv subst2 empty_subst in let alias_subst key (mp,resolve) sub= - let newkey = + let newkey = match key with - | MPI mp1 -> + | MPI mp1 -> begin match subst_mp0 subst_mbi mp1 with | None -> None @@ -349,23 +349,23 @@ let update_subst_alias subst1 subst2 = let update_subst subst1 subst2 = let subst_inv key (mp,resolve) l = - let newmp = - match key with + let newmp = + match key with | MBI msid -> MPbound msid | MSI msid -> MPself msid | MPI mp -> mp in - match mp with + match mp with | MPbound mbid -> ((MBI mbid),newmp,resolve)::l | MPself msid -> ((MSI msid),newmp,resolve)::l | _ -> ((MPI mp),newmp,resolve)::l - in + in let subst_mbi = Umap.fold subst_inv subst2 [] in let alias_subst key (mp,resolve) sub= - let newsetkey = + let newsetkey = match key with - | MPI mp1 -> - let compute_set_newkey l (k,mp',resolve) = + | MPI mp1 -> + let compute_set_newkey l (k,mp',resolve) = let mp_from_key = match k with | MBI msid -> MPbound msid | MSI msid -> MPself msid @@ -383,7 +383,7 @@ let update_subst subst1 subst2 = in match newsetkey with | None -> sub - | Some l -> + | Some l -> List.fold_left (fun s (k,r) -> Umap.add k (mp,r) s) sub l in @@ -431,7 +431,7 @@ let join_alias (subst1 : substitution) (subst2 : substitution) = let key' = match key with MSI msid -> MPself msid - | MBI mbid -> MPbound mbid + | MBI mbid -> MPbound mbid | MPI mp1 -> mp1 in let kn' = replace_mp_in_con mp key' kn in if kn==kn' then @@ -444,7 +444,7 @@ let join_alias (subst1 : substitution) (subst2 : substitution) = Some (changeDom res) in mp',resolve'' in - Umap.mapi (apply_subst subst2) subst1 + Umap.mapi (apply_subst subst2) subst1 let remove_alias subst = let rec remove key (mp,resolve) sub = @@ -453,7 +453,7 @@ let remove_alias subst = | _ -> Umap.add key (mp,resolve) sub in Umap.fold remove subst empty_subst - + let rec occur_in_path uid path = match uid,path with @@ -461,34 +461,34 @@ let rec occur_in_path uid path = | MBI bid,MPbound bid' -> bid = bid' | _,MPdot (mp1,_) -> occur_in_path uid mp1 | _ -> false - -let occur_uid uid sub = + +let occur_uid uid sub = let check_one uid' (mp,_) = if uid = uid' || occur_in_path uid mp then raise Exit in - try + try Umap.iter check_one sub; false with Exit -> true let occur_msid uid = occur_uid (MSI uid) let occur_mbid uid = occur_uid (MBI uid) - + type 'a lazy_subst = | LSval of 'a | LSlazy of substitution * 'a - + type 'a substituted = 'a lazy_subst ref - + let from_val a = ref (LSval a) - -let force fsubst r = + +let force fsubst r = match !r with | LSval a -> a - | LSlazy(s,a) -> + | LSlazy(s,a) -> let a' = fsubst s a in r := LSval a'; - a' + a' let subst_substituted s r = match !r with @@ -496,4 +496,4 @@ let subst_substituted s r = | LSlazy(s',a) -> let s'' = join s' s in ref (LSlazy(s'',a)) - + diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 6ae9649d6b..d30168a1bf 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -20,9 +20,9 @@ val make_resolver : (constant * constr option) list -> resolver val empty_subst : substitution -val add_msid : +val add_msid : mod_self_id -> module_path -> substitution -> substitution -val add_mbid : +val add_mbid : mod_bound_id -> module_path -> resolver option -> substitution -> substitution val add_mp : module_path -> module_path -> substitution -> substitution @@ -34,7 +34,7 @@ val map_mbid : val map_mp : module_path -> module_path -> substitution -(* sequential composition: +(* sequential composition: [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)] *) val join : substitution -> substitution -> substitution @@ -50,10 +50,10 @@ val debug_pr_subst : substitution -> Pp.std_ppcmds (*i*) (* [subst_mp sub mp] guarantees that whenever the result of the - substitution is structutally equal [mp], it is equal by pointers - as well [==] *) + substitution is structutally equal [mp], it is equal by pointers + as well [==] *) -val subst_mp : +val subst_mp : substitution -> module_path -> module_path val subst_kn : @@ -77,7 +77,7 @@ val replace_mp_in_con : module_path -> module_path -> constant -> constant names appearing in [c] *) val subst_mps : substitution -> constr -> constr -(* [occur_*id id sub] returns true iff [id] occurs in [sub] +(* [occur_*id id sub] returns true iff [id] occurs in [sub] on either side *) val occur_msid : mod_self_id -> substitution -> bool diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index f4f52d83dd..3d55fb69a2 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -30,9 +30,9 @@ let rec list_split_assoc k rev_before = function | (k',b)::after when k=k' -> rev_before,b,after | h::tail -> list_split_assoc k (h::rev_before) tail -let rec list_fold_map2 f e = function +let rec list_fold_map2 f e = function | [] -> (e,[],[]) - | h::t -> + | h::t -> let e',h1',h2' = f e h in let e'',t1',t2' = list_fold_map2 f e' t in e'',h1'::t1',h2'::t2' @@ -40,14 +40,14 @@ let rec list_fold_map2 f e = function let rec rebuild_mp mp l = match l with []-> mp - | i::r -> rebuild_mp (MPdot(mp,i)) r - -let type_of_struct env b meb = - let rec aux env = function + | i::r -> rebuild_mp (MPdot(mp,i)) r + +let type_of_struct env b meb = + let rec aux env = function | SEBfunctor (mp,mtb,body) -> let env = add_module (MPbound mp) (module_body_of_type mtb) env in SEBfunctor(mp,mtb, aux env body) - | SEBident mp -> + | SEBident mp -> strengthen env (lookup_modtype mp env).typ_expr mp | SEBapply _ as mtb -> eval_struct env mtb | str -> str @@ -63,28 +63,28 @@ let rec bounded_str_expr = function | SEBapply (f,a,_)->(bounded_str_expr f) | _ -> false -let return_opt_type mp env mtb = +let return_opt_type mp env mtb = if (check_bound_mp mp) then Some (strengthen env mtb.typ_expr mp) else None -let rec check_with env mtb with_decl = +let rec check_with env mtb with_decl = match with_decl with - | With_Definition (id,_) -> + | With_Definition (id,_) -> let cb = check_with_aux_def env mtb with_decl in SEBwith(mtb,With_definition_body(id,cb)),empty_subst - | With_Module (id,mp) -> + | With_Module (id,mp) -> let cst,sub,typ_opt = check_with_aux_mod env mtb with_decl true in SEBwith(mtb,With_module_body(id,mp,typ_opt,cst)),sub -and check_with_aux_def env mtb with_decl = - let msid,sig_b = match (eval_struct env mtb) with +and check_with_aux_def env mtb with_decl = + let msid,sig_b = match (eval_struct env mtb) with | SEBstruct(msid,sig_b) -> msid,sig_b | _ -> error_signature_expected mtb in - let id,idl = match with_decl with + let id,idl = match with_decl with | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl | With_Definition ([],_) | With_Module ([],_) -> assert false in @@ -95,33 +95,33 @@ and check_with_aux_def env mtb with_decl = let env' = Modops.add_signature (MPself msid) before env in match with_decl with | With_Definition ([],_) -> assert false - | With_Definition ([id],c) -> + | With_Definition ([id],c) -> let cb = match spec with SFBconst cb -> cb | _ -> error_not_a_constant l - in + in begin match cb.const_body with - | None -> + | None -> let (j,cst1) = Typeops.infer env' c in let typ = Typeops.type_of_constant_type env' cb.const_type in let cst2 = Reduction.conv_leq env' j.uj_type typ in - let cst = - Constraint.union + let cst = + Constraint.union (Constraint.union cb.const_constraints cst1) cst2 in let body = Some (Declarations.from_val j.uj_val) in - let cb' = {cb with + let cb' = {cb with const_body = body; const_body_code = Cemitcodes.from_val (compile_constant_body env' body false false); const_constraints = cst} in cb' - | Some b -> + | Some b -> let cst1 = Reduction.conv env' c (Declarations.force b) in let cst = Constraint.union cb.const_constraints cst1 in let body = Some (Declarations.from_val c) in - let cb' = {cb with + let cb' = {cb with const_body = body; const_body_code = Cemitcodes.from_val (compile_constant_body env' body false false); @@ -138,7 +138,7 @@ and check_with_aux_def env mtb with_decl = | None -> let new_with_decl = match with_decl with With_Definition (_,c) -> With_Definition (idl,c) - | With_Module (_,c) -> With_Module (idl,c) in + | With_Module (_,c) -> With_Module (idl,c) in check_with_aux_def env' (type_of_mb env old) new_with_decl | Some msb -> error_a_generative_module_expected l @@ -148,13 +148,13 @@ and check_with_aux_def env mtb with_decl = Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l -and check_with_aux_mod env mtb with_decl now = - let initmsid,msid,sig_b = match (eval_struct env mtb) with +and check_with_aux_mod env mtb with_decl now = + let initmsid,msid,sig_b = match (eval_struct env mtb) with | SEBstruct(msid,sig_b) ->let msid'=(refresh_msid msid) in msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b) | _ -> error_signature_expected mtb in - let id,idl = match with_decl with + let id,idl = match with_decl with | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl | With_Definition ([],_) | With_Module ([],_) -> assert false in @@ -165,7 +165,7 @@ and check_with_aux_mod env mtb with_decl now = let rec mp_rec = function | [] -> MPself initmsid | i::r -> MPdot(mp_rec r,label_of_id i) - in + in let env' = Modops.add_signature (MPself msid) before env in match with_decl with | With_Module ([],_) -> assert false @@ -180,7 +180,7 @@ and check_with_aux_mod env mtb with_decl now = match old,alias with Some msb,None -> begin - try Constraint.union + try Constraint.union (check_subtypes env' mtb' (module_type_of_module None msb)) msb.mod_constraints with Failure _ -> error_with_incorrect (label_of_id id) @@ -194,14 +194,14 @@ and check_with_aux_mod env mtb with_decl now = | _,_ -> anomaly "Mod_typing:no implementation and no alias" in - if now then + if now then let mp' = scrape_alias mp env' in let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in let up_subst = update_subst sub (map_mp (mp_rec [id]) mp') in cst, (join (map_mp (mp_rec [id]) mp') up_subst),(return_opt_type mp env' mtb') else cst,empty_subst,(return_opt_type mp env' mtb') - | With_Module (_::_,mp) -> + | With_Module (_::_,mp) -> let old,alias = match spec with SFBmodule msb -> Some msb, None | SFBalias (mpold,typ_opt,cst)->None, Some mpold @@ -213,19 +213,19 @@ and check_with_aux_mod env mtb with_decl now = match old.mod_expr with None -> let new_with_decl = match with_decl with - With_Definition (_,c) -> + With_Definition (_,c) -> With_Definition (idl,c) | With_Module (_,c) -> With_Module (idl,c) in let cst,_,typ_opt = - check_with_aux_mod env' + check_with_aux_mod env' (type_of_mb env' old) new_with_decl false in - if now then + if now then let mtb' = lookup_modtype mp env' in let mp' = scrape_alias mp env' in let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in - let up_subst = update_subst + let up_subst = update_subst sub (map_mp (mp_rec (List.rev (id::idl))) mp') in - cst, + cst, (join (map_mp (mp_rec (List.rev (id::idl))) mp') up_subst), typ_opt else @@ -233,7 +233,7 @@ and check_with_aux_mod env mtb with_decl now = | Some msb -> error_a_generative_module_expected l else - let mpold = Option.get alias in + let mpold = Option.get alias in let mpnew = rebuild_mp mpold (List.map label_of_id idl) in check_modpath_equiv env' mpnew mp; let mtb' = lookup_modtype mp env' in @@ -243,26 +243,26 @@ and check_with_aux_mod env mtb with_decl now = with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l - + and translate_module env me = match me.mod_entry_expr, me.mod_entry_type with - | None, None -> + | None, None -> anomaly "Mod_typing.translate_module: empty type and expr in module entry" - | None, Some mte -> + | None, Some mte -> let mtb,sub = translate_struct_entry env mte in { mod_expr = None; mod_type = Some mtb; mod_alias = sub; - mod_constraints = Constraint.empty; + mod_constraints = Constraint.empty; mod_retroknowledge = []} - | Some mexpr, _ -> + | Some mexpr, _ -> let meb,sub1 = translate_struct_entry env mexpr in let mod_typ,sub,cst = match me.mod_entry_type with - | None -> + | None -> (type_of_struct env (bounded_str_expr meb) meb) ,sub1,Constraint.empty - | Some mte -> + | Some mte -> let mtb2,sub2 = translate_struct_entry env mte in let cst = check_subtypes env {typ_expr = meb; @@ -286,7 +286,7 @@ and translate_module env me = and translate_struct_entry env mse = match mse with | MSEident mp -> - let mtb = lookup_modtype mp env in + let mtb = lookup_modtype mp env in SEBident mp,mtb.typ_alias | MSEfunctor (arg_id, arg_e, body_expr) -> let arg_b,sub = translate_struct_entry env arg_e in @@ -302,7 +302,7 @@ and translate_struct_entry env mse = match mse with let feb'= eval_struct env feb in let farg_id, farg_b, fbody_b = destr_functor env feb' in - let mtb,mp = + let mtb,mp = try let mp = scrape_alias (path_of_mexpr mexpr) env in lookup_modtype mp env,mp @@ -310,13 +310,13 @@ and translate_struct_entry env mse = match mse with | Not_path -> error_application_to_not_path mexpr (* place for nondep_supertype *) in let meb,sub2= translate_struct_entry env (MSEident mp) in - if sub1 = empty_subst then + if sub1 = empty_subst then let cst = check_subtypes env mtb farg_b in SEBapply(feb,meb,cst),sub1 else let sub2 = match eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> - join_alias + | SEBstruct (msid,sign) -> + join_alias (subst_key (map_msid msid mp) sub2) (map_msid msid mp) | _ -> sub2 in @@ -328,34 +328,34 @@ and translate_struct_entry env mse = match mse with let mtb,sub1 = translate_struct_entry env mte in let mtb',sub2 = check_with env mtb with_decl in mtb',join sub1 sub2 - + let rec add_struct_expr_constraints env = function | SEBident _ -> env - | SEBfunctor (_,mtb,meb) -> - add_struct_expr_constraints + | SEBfunctor (_,mtb,meb) -> + add_struct_expr_constraints (add_modtype_constraints env mtb) meb | SEBstruct (_,structure_body) -> - List.fold_left + List.fold_left (fun env (l,item) -> add_struct_elem_constraints env item) env structure_body | SEBapply (meb1,meb2,cst) -> - Environ.add_constraints cst - (add_struct_expr_constraints - (add_struct_expr_constraints env meb1) + Environ.add_constraints cst + (add_struct_expr_constraints + (add_struct_expr_constraints env meb1) meb2) | SEBwith(meb,With_definition_body(_,cb))-> Environ.add_constraints cb.const_constraints (add_struct_expr_constraints env meb) | SEBwith(meb,With_module_body(_,_,_,cst))-> Environ.add_constraints cst - (add_struct_expr_constraints env meb) - -and add_struct_elem_constraints env = function + (add_struct_expr_constraints env meb) + +and add_struct_elem_constraints env = function | SFBconst cb -> Environ.add_constraints cb.const_constraints env | SFBmind mib -> Environ.add_constraints mib.mind_constraints env | SFBmodule mb -> add_module_constraints env mb @@ -363,46 +363,46 @@ and add_struct_elem_constraints env = function | SFBalias (mp,_,None) -> env | SFBmodtype mtb -> add_modtype_constraints env mtb -and add_module_constraints env mb = +and add_module_constraints env mb = let env = match mb.mod_expr with | None -> env | Some meb -> add_struct_expr_constraints env meb in let env = match mb.mod_type with | None -> env - | Some mtb -> + | Some mtb -> add_struct_expr_constraints env mtb in Environ.add_constraints mb.mod_constraints env -and add_modtype_constraints env mtb = +and add_modtype_constraints env mtb = add_struct_expr_constraints env mtb.typ_expr - + let rec struct_expr_constraints cst = function | SEBident _ -> cst - | SEBfunctor (_,mtb,meb) -> - struct_expr_constraints + | SEBfunctor (_,mtb,meb) -> + struct_expr_constraints (modtype_constraints cst mtb) meb | SEBstruct (_,structure_body) -> - List.fold_left + List.fold_left (fun cst (l,item) -> struct_elem_constraints cst item) cst structure_body | SEBapply (meb1,meb2,cst1) -> - struct_expr_constraints + struct_expr_constraints (struct_expr_constraints (Univ.Constraint.union cst1 cst) meb1) meb2 | SEBwith(meb,With_definition_body(_,cb))-> struct_expr_constraints (Univ.Constraint.union cb.const_constraints cst) meb | SEBwith(meb,With_module_body(_,_,_,cst1))-> - struct_expr_constraints (Univ.Constraint.union cst1 cst) meb - -and struct_elem_constraints cst = function + struct_expr_constraints (Univ.Constraint.union cst1 cst) meb + +and struct_elem_constraints cst = function | SFBconst cb -> cst | SFBmind mib -> cst | SFBmodule mb -> module_constraints cst mb @@ -410,7 +410,7 @@ and struct_elem_constraints cst = function | SFBalias (mp,_,None) -> cst | SFBmodtype mtb -> modtype_constraints cst mtb -and module_constraints cst mb = +and module_constraints cst mb = let cst = match mb.mod_expr with | None -> cst | Some meb -> struct_expr_constraints cst meb in @@ -419,9 +419,9 @@ and module_constraints cst mb = | Some mtb -> struct_expr_constraints cst mtb in Univ.Constraint.union mb.mod_constraints cst -and modtype_constraints cst mtb = +and modtype_constraints cst mtb = struct_expr_constraints cst mtb.typ_expr - + let struct_expr_constraints = struct_expr_constraints Univ.Constraint.empty let module_constraints = module_constraints Univ.Constraint.empty diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index eef16dd8f7..1fadec2ad9 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -18,7 +18,7 @@ open Mod_subst val translate_module : env -> module_entry -> module_body -val translate_struct_entry : env -> module_struct_entry -> +val translate_struct_entry : env -> module_struct_entry -> struct_expr_body * substitution val add_modtype_constraints : env -> module_type_body -> env diff --git a/kernel/modops.ml b/kernel/modops.ml index 97697f5de6..3f38cc2f7c 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -22,7 +22,7 @@ open Mod_subst -let error_existing_label l = +let error_existing_label l = error ("The label "^string_of_label l^" is already declared.") let error_declaration_not_path _ = error "Declaration is not a path." @@ -39,31 +39,31 @@ let error_not_match l _ = error ("Signature components for label "^string_of_lab let error_no_such_label l = error ("No such label "^string_of_label l^".") -let error_incompatible_labels l l' = +let error_incompatible_labels l l' = error ("Opening and closing labels are not the same: " ^string_of_label l^" <> "^string_of_label l'^" !") -let error_result_must_be_signature () = +let error_result_must_be_signature () = error "The result module type must be a signature." let error_signature_expected mtb = error "Signature expected." -let error_no_module_to_end _ = +let error_no_module_to_end _ = error "No open module to end." let error_no_modtype_to_end _ = error "No open module type to end." -let error_not_a_modtype_loc loc s = +let error_not_a_modtype_loc loc s = user_err_loc (loc,"",str ("\""^s^"\" is not a module type.")) -let error_not_a_module_loc loc s = +let error_not_a_module_loc loc s = user_err_loc (loc,"",str ("\""^s^"\" is not a module.")) let error_not_a_module s = error_not_a_module_loc dummy_loc s -let error_not_a_constant l = +let error_not_a_constant l = error ("\""^(string_of_label l)^"\" is not a constant.") let error_with_incorrect l = @@ -74,9 +74,9 @@ let error_a_generative_module_expected l = "component of generative modules can be changed using the \"with\" " ^ "construct.") -let error_local_context lo = +let error_local_context lo = match lo with - None -> + None -> error ("The local context is not empty.") | (Some l) -> error ("The local context of the component "^ @@ -106,7 +106,7 @@ let destr_functor env mtb = (* the constraints are not important here *) -let module_body_of_type mtb = +let module_body_of_type mtb = { mod_type = Some mtb.typ_expr; mod_expr = None; mod_constraints = Constraint.empty; @@ -114,30 +114,30 @@ let module_body_of_type mtb = mod_retroknowledge = []} let module_type_of_module mp mb = - let mp1,expr = + let mp1,expr = (match mb.mod_type with | Some expr -> mp,expr | None -> (match mb.mod_expr with | Some (SEBident mp') ->(Some mp'),(SEBident mp') | Some expr -> mp,expr - | None -> + | None -> anomaly "Modops: empty expr and type")) in {typ_expr = expr; typ_alias = mb.mod_alias; typ_strength = mp1 } -let rec check_modpath_equiv env mp1 mp2 = +let rec check_modpath_equiv env mp1 mp2 = if mp1=mp2 then () else let mp1 = scrape_alias mp1 env in let mp2 = scrape_alias mp2 env in if mp1=mp2 then () - else + else error_not_equal mp1 mp2 - + let rec subst_with_body sub = function | With_module_body(id,mp,typ_opt,cst) -> - With_module_body(id,subst_mp sub mp,Option.smartmap + With_module_body(id,subst_mp sub mp,Option.smartmap (subst_struct_expr sub) typ_opt,cst) | With_definition_body(id,cb) -> With_definition_body( id,subst_const_body sub cb) @@ -148,22 +148,22 @@ and subst_modtype sub mtb = if typ_expr'==mtb.typ_expr && sub_mtb==mtb.typ_alias then mtb else - { mtb with + { mtb with typ_expr = typ_expr'; typ_alias = sub_mtb} - -and subst_structure sub sign = + +and subst_structure sub sign = let subst_body = function - SFBconst cb -> + SFBconst cb -> SFBconst (subst_const_body sub cb) - | SFBmind mib -> + | SFBmind mib -> SFBmind (subst_mind sub mib) - | SFBmodule mb -> + | SFBmodule mb -> SFBmodule (subst_module sub mb) - | SFBmodtype mtb -> + | SFBmodtype mtb -> SFBmodtype (subst_modtype sub mtb) | SFBalias (mp,typ_opt,cst) -> - SFBalias (subst_mp sub mp,Option.smartmap + SFBalias (subst_mp sub mp,Option.smartmap (subst_struct_expr sub) typ_opt,cst) in List.map (fun (l,b) -> (l,subst_body b)) sign @@ -177,15 +177,15 @@ and subst_module sub mb = let me' = Option.smartmap (subst_struct_expr sub) mb.mod_expr in let mb_alias = update_subst sub mb.mod_alias in let mb_alias = if mb_alias = empty_subst then - join_alias mb.mod_alias sub - else + join_alias mb.mod_alias sub + else join mb_alias (join_alias mb.mod_alias sub) in - if mtb'==mb.mod_type && mb.mod_expr == me' + if mtb'==mb.mod_type && mb.mod_expr == me' && mb_alias == mb.mod_alias then mb else { mod_expr = me'; - mod_type=mtb'; + mod_type=mtb'; mod_constraints=mb.mod_constraints; mod_alias = mb_alias; mod_retroknowledge=mb.mod_retroknowledge} @@ -193,7 +193,7 @@ and subst_module sub mb = and subst_struct_expr sub = function | SEBident mp -> SEBident (subst_mp sub mp) - | SEBfunctor (msid, mtb, meb') -> + | SEBfunctor (msid, mtb, meb') -> SEBfunctor(msid,subst_modtype sub mtb,subst_struct_expr sub meb') | SEBstruct (msid,str)-> SEBstruct(msid, subst_structure sub str) @@ -201,15 +201,15 @@ and subst_struct_expr sub = function SEBapply(subst_struct_expr sub meb1, subst_struct_expr sub meb2, cst) - | SEBwith (meb,wdb)-> + | SEBwith (meb,wdb)-> SEBwith(subst_struct_expr sub meb, subst_with_body sub wdb) - -let subst_signature_msid msid mp = + +let subst_signature_msid msid mp = subst_structure (map_msid msid mp) -(* spiwack: here comes the function which takes care of importing +(* spiwack: here comes the function which takes care of importing the retroknowledge declared in the library *) (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) let add_retroknowledge msid mp = @@ -217,8 +217,8 @@ let add_retroknowledge msid mp = let subst_and_perform rkaction env = match rkaction with | Retroknowledge.RKRegister (f, e) -> - Environ.register env f - (match e with + Environ.register env f + (match e with | Const kn -> kind_of_term (subst_mps subst (mkConst kn)) | Ind ind -> kind_of_term (subst_mps subst (mkInd ind)) | _ -> anomaly "Modops.add_retroknowledge: had to import an unsupported kind of term") @@ -229,41 +229,41 @@ let add_retroknowledge msid mp = int31 type registration absolutely needs int31 bits to be registered. Since the local_retroknowledge is stored in reverse order (each new registration is added at the top of the list) we need a fold_right - for things to go right (the pun is not intented). So we lose + for things to go right (the pun is not intented). So we lose tail recursivity, but the world will have exploded before any module imports 10 000 retroknowledge registration.*) List.fold_right subst_and_perform lclrk env -let strengthen_const env mp l cb = +let strengthen_const env mp l cb = match cb.const_opaque, cb.const_body with | false, Some _ -> cb - | true, Some _ + | true, Some _ | _, None -> - let const = mkConst (make_con mp empty_dirpath l) in + let const = mkConst (make_con mp empty_dirpath l) in let const_subs = Some (Declarations.from_val const) in - {cb with + {cb with const_body = const_subs; const_opaque = false; const_body_code = Cemitcodes.from_val (compile_constant_body env const_subs false false) } - + let strengthen_mind env mp l mib = match mib.mind_equiv with | Some _ -> mib | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)} -let rec eval_struct env = function - | SEBident mp -> +let rec eval_struct env = function + | SEBident mp -> begin let mtb =lookup_modtype mp env in match mtb.typ_expr,mtb.typ_strength with mtb,None -> eval_struct env mtb | mtb,Some mp -> strengthen_mtb env mp (eval_struct env mtb) end - | SEBapply (seb1,seb2,_) -> + | SEBapply (seb1,seb2,_) -> let svb1 = eval_struct env seb1 in let farg_id, farg_b, fbody_b = destr_functor env svb1 in let mp = path_of_seb seb2 in @@ -271,15 +271,15 @@ let rec eval_struct env = function let sub_alias = (lookup_modtype mp env).typ_alias in let sub_alias = match eval_struct env (SEBident mp) with | SEBstruct (msid,sign) -> - join_alias + join_alias (subst_key (map_msid msid mp) sub_alias) (map_msid msid mp) | _ -> sub_alias in let resolve = resolver_of_environment farg_id farg_b mp sub_alias env in - let sub_alias1 = update_subst sub_alias + let sub_alias1 = update_subst sub_alias (map_mbid farg_id mp (Some resolve)) in - eval_struct env (subst_struct_expr - (join sub_alias1 + eval_struct env (subst_struct_expr + (join sub_alias1 (map_mbid farg_id mp (Some resolve))) fbody_b) | SEBwith (mtb,(With_definition_body _ as wdb)) -> let mtb',_ = merge_with env mtb wdb empty_subst in @@ -292,24 +292,24 @@ let rec eval_struct env = function | _ -> alias_in_mp in let mtb',_ = merge_with env mtb wdb alias_in_mp in mtb' -(* | SEBfunctor(mbid,mtb,body) -> +(* | SEBfunctor(mbid,mtb,body) -> let env = add_module (MPbound mbid) (module_body_of_type mtb) env in SEBfunctor(mbid,mtb,eval_struct env body) *) | mtb -> mtb - + and type_of_mb env mb = match mb.mod_type,mb.mod_expr with None,Some b -> eval_struct env b | Some t, _ -> eval_struct env t - | _,_ -> anomaly - "Modops: empty type and empty expr" - -and merge_with env mtb with_decl alias= - let msid,sig_b = match (eval_struct env mtb) with + | _,_ -> anomaly + "Modops: empty type and empty expr" + +and merge_with env mtb with_decl alias= + let msid,sig_b = match (eval_struct env mtb) with | SEBstruct(msid,sig_b) -> msid,sig_b | _ -> error_signature_expected mtb in - let id,idl = match with_decl with + let id,idl = match with_decl with | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false in @@ -320,20 +320,20 @@ and merge_with env mtb with_decl alias= let rec mp_rec = function | [] -> MPself msid | i::r -> MPdot(mp_rec r,label_of_id i) - in + in let env' = add_signature (MPself msid) before env in let new_spec,subst = match with_decl with | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false - | With_definition_body ([id],c) -> + | With_definition_body ([id],c) -> SFBconst c,None | With_module_body ([id], mp,typ_opt,cst) -> let mp' = scrape_alias mp env' in let new_alias = update_subst alias (map_mp (mp_rec [id]) mp') in SFBalias (mp,typ_opt,Some cst), Some(join (map_mp (mp_rec [id]) mp') new_alias) - | With_definition_body (_::_,_) - | With_module_body (_::_,_,_,_) -> + | With_definition_body (_::_,_) + | With_module_body (_::_,_,_,_) -> let old,aliasold = match spec with SFBmodule msb -> Some msb, None | SFBalias (mpold,typ_opt,cst) ->None, Some (mpold,typ_opt,cst) @@ -341,24 +341,24 @@ and merge_with env mtb with_decl alias= in if aliasold = None then let old = Option.get old in - let new_with_decl,subst1 = + let new_with_decl,subst1 = match with_decl with With_definition_body (_,c) -> With_definition_body (idl,c),None - | With_module_body (idc,mp,typ_opt,cst) -> + | With_module_body (idc,mp,typ_opt,cst) -> let mp' = scrape_alias mp env' in With_module_body (idl,mp,typ_opt,cst), - Some(map_mp (mp_rec (List.rev idc)) mp') + Some(map_mp (mp_rec (List.rev idc)) mp') in let subst = match subst1 with | None -> None | Some s -> Some (join s (update_subst alias s)) in - let modtype,subst_msb = + let modtype,subst_msb = merge_with env' (type_of_mb env' old) new_with_decl alias in let msb = { mod_expr = None; - mod_type = Some modtype; + mod_type = Some modtype; mod_constraints = old.mod_constraints; - mod_alias = begin + mod_alias = begin match subst_msb with |None -> empty_subst |Some s -> s @@ -366,8 +366,8 @@ and merge_with env mtb with_decl alias= mod_retroknowledge = old.mod_retroknowledge} in (SFBmodule msb),subst - else - let mpold,typ_opt,cst = Option.get aliasold in + else + let mpold,typ_opt,cst = Option.get aliasold in SFBalias (mpold,typ_opt,cst),None in SEBstruct(msid, before@(l,new_spec):: @@ -375,36 +375,36 @@ and merge_with env mtb with_decl alias= with Not_found -> error_no_such_label l -and add_signature mp sign env = +and add_signature mp sign env = let add_one env (l,elem) = let kn = make_kn mp empty_dirpath l in let con = make_con mp empty_dirpath l in match elem with | SFBconst cb -> Environ.add_constant con cb env | SFBmind mib -> Environ.add_mind kn mib env - | SFBmodule mb -> - add_module (MPdot (mp,l)) mb env + | SFBmodule mb -> + add_module (MPdot (mp,l)) mb env (* adds components as well *) - | SFBalias (mp1,_,cst) -> + | SFBalias (mp1,_,cst) -> Environ.register_alias (MPdot(mp,l)) mp1 env - | SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) + | SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) mtb env in List.fold_left add_one env sign -and add_module mp mb env = +and add_module mp mb env = let env = Environ.shallow_add_module mp mb env in let env = Environ.add_modtype mp (module_type_of_module (Some mp) mb) env in let mod_typ = type_of_mb env mb in match mod_typ with - | SEBstruct (msid,sign) -> + | SEBstruct (msid,sign) -> add_retroknowledge msid mp (mb.mod_retroknowledge) (add_signature mp (subst_signature_msid msid mp sign) env) | SEBfunctor _ -> env | _ -> anomaly "Modops:the evaluation of the structure failed " - + and constants_of_specification env mp sign = @@ -413,30 +413,30 @@ and constants_of_specification env mp sign = | SFBconst cb -> env,((make_con mp empty_dirpath l),cb)::res | SFBmind _ -> env,res | SFBmodule mb -> - let new_env = add_module (MPdot (mp,l)) mb env in + let new_env = add_module (MPdot (mp,l)) mb env in new_env,(constants_of_modtype env (MPdot (mp,l)) (type_of_mb env mb)) @ res | SFBalias (mp1,typ_opt,cst) -> - let new_env = register_alias (MPdot (mp,l)) mp1 env in + let new_env = register_alias (MPdot (mp,l)) mp1 env in new_env,(constants_of_modtype env (MPdot (mp,l)) (eval_struct env (SEBident mp1))) @ res - | SFBmodtype mtb -> - (* module type dans un module type. - Il faut au moins mettre mtb dans l'environnement (avec le bon - kn pour pouvoir continuer aller deplier les modules utilisant ce + | SFBmodtype mtb -> + (* module type dans un module type. + Il faut au moins mettre mtb dans l'environnement (avec le bon + kn pour pouvoir continuer aller deplier les modules utilisant ce mtb - ex: - Module Type T1. + ex: + Module Type T1. Module Type T2. .... End T2. ..... Declare Module M : T2. - End T2 - si on ne rajoute pas T2 dans l'environement de typage + End T2 + si on ne rajoute pas T2 dans l'environement de typage on va exploser au moment du Declare Module *) - let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in + let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in new_env, (constants_of_modtype env (MPdot(mp,l)) mtb.typ_expr) @ res in snd (List.fold_left aux (env,[]) sign) @@ -474,23 +474,23 @@ and resolver_of_environment mbid modtype mp alias env = let resolve = make_resolve constants in Mod_subst.make_resolver resolve - + and strengthen_mtb env mp mtb = - let mtb1 = eval_struct env mtb in + let mtb1 = eval_struct env mtb in match mtb1 with | SEBfunctor _ -> mtb1 - | SEBstruct (msid,sign) -> + | SEBstruct (msid,sign) -> SEBstruct (msid,strengthen_sig env msid sign mp) | _ -> anomaly "Modops:the evaluation of the structure failed " -and strengthen_mod env mp mb = +and strengthen_mod env mp mb = let mod_typ = type_of_mb env mb in { mod_expr = mb.mod_expr; mod_type = Some (strengthen_mtb env mp mod_typ); mod_constraints = mb.mod_constraints; mod_alias = mb.mod_alias; mod_retroknowledge = mb.mod_retroknowledge} - + and strengthen_sig env msid sign mp = match sign with | [] -> [] | (l,SFBconst cb) :: rest -> @@ -504,7 +504,7 @@ and strengthen_sig env msid sign mp = match sign with | (l,SFBmodule mb) :: rest -> let mp' = MPdot (mp,l) in let item' = l,SFBmodule (strengthen_mod env mp' mb) in - let env' = add_module + let env' = add_module (MPdot (MPself msid,l)) mb env in let rest' = strengthen_sig env' msid rest mp in item':: rest' @@ -512,22 +512,22 @@ and strengthen_sig env msid sign mp = match sign with let env' = register_alias (MPdot(MPself msid,l)) mp1 env in let rest' = strengthen_sig env' msid rest mp in item::rest' - | (l,SFBmodtype mty as item) :: rest -> - let env' = add_modtype - (MPdot((MPself msid),l)) + | (l,SFBmodtype mty as item) :: rest -> + let env' = add_modtype + (MPdot((MPself msid),l)) mty env in let rest' = strengthen_sig env' msid rest mp in item::rest' - + let strengthen env mtb mp = strengthen_mtb env mp mtb let update_subst env mb mp = match type_of_mb env mb with - | SEBstruct(msid,str) -> false, join_alias + | SEBstruct(msid,str) -> false, join_alias (subst_key (map_msid msid mp) mb.mod_alias) (map_msid msid mp) | _ -> true, mb.mod_alias diff --git a/kernel/modops.mli b/kernel/modops.mli index 11f0ddd171..4cd72a2ef5 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -23,10 +23,10 @@ open Mod_subst (* make the environment entry out of type *) val module_body_of_type : module_type_body -> module_body -val module_type_of_module : module_path option -> module_body -> - module_type_body +val module_type_of_module : module_path option -> module_body -> + module_type_body -val destr_functor : +val destr_functor : env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body val subst_modtype : substitution -> module_type_body -> module_type_body @@ -35,7 +35,7 @@ val subst_structure : substitution -> structure_body -> structure_body val subst_struct_expr : substitution -> struct_expr_body -> struct_expr_body val subst_signature_msid : - mod_self_id -> module_path -> + mod_self_id -> module_path -> structure_body -> structure_body val subst_structure : substitution -> structure_body -> structure_body @@ -48,7 +48,7 @@ val type_of_mb : env -> module_body -> struct_expr_body (* [add_signature mp sign env] assumes that the substitution [msid] $\mapsto$ [mp] has already been performed (or is not necessary, like when [mp = MPself msid]) *) -val add_signature : +val add_signature : module_path -> structure_body -> env -> env (* adds a module and its components, but not the constraints *) @@ -69,13 +69,13 @@ val error_application_to_not_path : module_struct_entry -> 'a val error_not_a_functor : module_struct_entry -> 'a -val error_incompatible_modtypes : +val error_incompatible_modtypes : module_type_body -> module_type_body -> 'a val error_not_equal : module_path -> module_path -> 'a val error_not_match : label -> structure_field_body -> 'a - + val error_incompatible_labels : label -> label -> 'a val error_no_such_label : label -> 'a @@ -84,15 +84,15 @@ val error_result_must_be_signature : unit -> 'a val error_signature_expected : struct_expr_body -> 'a -val error_no_module_to_end : unit -> 'a +val error_no_module_to_end : unit -> 'a val error_no_modtype_to_end : unit -> 'a -val error_not_a_modtype_loc : loc -> string -> 'a +val error_not_a_modtype_loc : loc -> string -> 'a -val error_not_a_module_loc : loc -> string -> 'a +val error_not_a_module_loc : loc -> string -> 'a -val error_not_a_module : string -> 'a +val error_not_a_module : string -> 'a val error_not_a_constant : label -> 'a @@ -105,6 +105,6 @@ val error_local_context : label option -> 'a val error_no_such_label_sub : label->string->string->'a val resolver_of_environment : - mod_bound_id -> module_type_body -> module_path -> substitution + mod_bound_id -> module_type_body -> module_path -> substitution -> env -> resolver diff --git a/kernel/names.ml b/kernel/names.ml index 953c13aa95..0d61a29aa5 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -23,7 +23,7 @@ let string_of_id id = String.copy id (* Hash-consing of identifier *) module Hident = Hashcons.Make( - struct + struct type t = string type u = string -> string let hash_sub hstr id = hstr id @@ -31,7 +31,7 @@ module Hident = Hashcons.Make( let hash = Hashtbl.hash end) -module IdOrdered = +module IdOrdered = struct type t = identifier let compare = id_ord @@ -47,7 +47,7 @@ type name = Name of identifier | Anonymous (* Dirpaths are lists of module identifiers. The actual representation is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *) - + type module_ident = identifier type dir_path = module_ident list @@ -63,16 +63,16 @@ let string_of_dirpath = function | sl -> String.concat "." (List.map string_of_id (List.rev sl)) -let u_number = ref 0 +let u_number = ref 0 type uniq_ident = int * string * dir_path let make_uid dir s = incr u_number;(!u_number,String.copy s,dir) let debug_string_of_uid (i,s,p) = "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">" -let string_of_uid (i,s,p) = +let string_of_uid (i,s,p) = string_of_dirpath p ^"."^s -module Umap = Map.Make(struct - type t = uniq_ident +module Umap = Map.Make(struct + type t = uniq_ident let compare = Pervasives.compare end) @@ -108,7 +108,7 @@ module Labmap = Idmap type module_path = | MPfile of dir_path | MPbound of mod_bound_id - | MPself of mod_self_id + | MPself of mod_self_id | MPdot of module_path * label let rec check_bound_mp = function @@ -124,7 +124,7 @@ let rec string_of_mp = function (* we compare labels first if both are MPdots *) let rec mp_ord mp1 mp2 = match (mp1,mp2) with - MPdot(mp1,l1), MPdot(mp2,l2) -> + MPdot(mp1,l1), MPdot(mp2,l2) -> let c = Pervasives.compare l1 l2 in if c<>0 then c @@ -147,28 +147,28 @@ type kernel_name = module_path * dir_path * label let make_kn mp dir l = (mp,dir,l) let repr_kn kn = kn -let modpath kn = +let modpath kn = let mp,_,_ = repr_kn kn in mp -let label kn = +let label kn = let _,_,l = repr_kn kn in l -let string_of_kn (mp,dir,l) = +let string_of_kn (mp,dir,l) = string_of_mp mp ^ "#" ^ string_of_dirpath dir ^ "#" ^ string_of_label l let pr_kn kn = str (string_of_kn kn) -let kn_ord kn1 kn2 = +let kn_ord kn1 kn2 = let mp1,dir1,l1 = kn1 in let mp2,dir2,l2 = kn2 in let c = Pervasives.compare l1 l2 in if c <> 0 then c - else + else let c = Pervasives.compare dir1 dir2 in if c<>0 then - c + c else MPord.compare mp1 mp2 @@ -217,7 +217,7 @@ let index_of_constructor (ind,i) = i module InductiveOrdered = struct type t = inductive - let compare (spx,ix) (spy,iy) = + let compare (spx,ix) (spy,iy) = let c = ix - iy in if c = 0 then KNord.compare spx spy else c end @@ -225,7 +225,7 @@ module Indmap = Map.Make(InductiveOrdered) module ConstructorOrdered = struct type t = constructor - let compare (indx,ix) (indy,iy) = + let compare (indx,ix) (indy,iy) = let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c end @@ -238,7 +238,7 @@ type evaluable_global_reference = (* Hash-consing of name objects *) module Hname = Hashcons.Make( - struct + struct type t = name type u = identifier -> identifier let hash_sub hident = function @@ -253,7 +253,7 @@ module Hname = Hashcons.Make( end) module Hdir = Hashcons.Make( - struct + struct type t = dir_path type u = identifier -> identifier let hash_sub hident d = List.map hident d @@ -265,7 +265,7 @@ module Hdir = Hashcons.Make( end) module Huniqid = Hashcons.Make( - struct + struct type t = uniq_ident type u = (string -> string) * (dir_path -> dir_path) let hash_sub (hstr,hdir) (n,s,dir) = (n,hstr s,hdir dir) @@ -274,7 +274,7 @@ module Huniqid = Hashcons.Make( end) module Hmod = Hashcons.Make( - struct + struct type t = module_path type u = (dir_path -> dir_path) * (uniq_ident -> uniq_ident) * (string -> string) @@ -293,7 +293,7 @@ module Hmod = Hashcons.Make( end) module Hkn = Hashcons.Make( - struct + struct type t = kernel_name type u = (module_path -> module_path) * (dir_path -> dir_path) * (string -> string) @@ -326,11 +326,11 @@ let cst_full_transparent_state = (Idpred.empty, Cpred.full) type 'a tableKey = | ConstKey of constant | VarKey of identifier - | RelKey of 'a + | RelKey of 'a type inv_rel_key = int (* index in the [rel_context] part of environment - starting by the end, {\em inverse} + starting by the end, {\em inverse} of de Bruijn indice *) type id_key = inv_rel_key tableKey diff --git a/kernel/names.mli b/kernel/names.mli index d0efe2380e..fb3b5c81b5 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -40,12 +40,12 @@ val empty_dirpath : dir_path val string_of_dirpath : dir_path -> string -(*s Unique identifier to be used as "self" in structures and +(*s Unique identifier to be used as "self" in structures and signatures - invisible for users *) -type label +type label type mod_self_id -(* The first argument is a file name - to prevent conflict between +(* The first argument is a file name - to prevent conflict between different files *) val make_msid : dir_path -> string -> mod_self_id val repr_msid : mod_self_id -> int * string * dir_path @@ -80,7 +80,7 @@ module Labmap : Map.S with type key = label type module_path = | MPfile of dir_path | MPbound of mod_bound_id - | MPself of mod_self_id + | MPself of mod_self_id | MPdot of module_path * label (*i | MPapply of module_path * module_path in the future (maybe) i*) @@ -168,7 +168,7 @@ val hcons_names : unit -> type 'a tableKey = | ConstKey of constant | VarKey of identifier - | RelKey of 'a + | RelKey of 'a type transparent_state = Idpred.t * Cpred.t @@ -178,7 +178,7 @@ val var_full_transparent_state : transparent_state val cst_full_transparent_state : transparent_state type inv_rel_key = int (* index in the [rel_context] part of environment - starting by the end, {\em inverse} + starting by the end, {\em inverse} of de Bruijn indice *) type id_key = inv_rel_key tableKey diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 0c01267623..4216722015 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -18,10 +18,10 @@ open Declarations (* The type of environments. *) -type key = int option ref +type key = int option ref type constant_key = constant_body * key - + type globals = { env_constants : constant_key Cmap.t; env_inductives : mutual_inductive_body KNmap.t; @@ -34,7 +34,7 @@ type stratification = { env_engagement : engagement option } -type val_kind = +type val_kind = | VKvalue of values * Idset.t | VKnone @@ -56,7 +56,7 @@ type named_context_val = named_context * named_vals let empty_named_context_val = [],[] -let empty_env = { +let empty_env = { env_globals = { env_constants = Cmap.empty; env_inductives = KNmap.empty; @@ -77,25 +77,25 @@ let empty_env = { (* Rel context *) let nb_rel env = env.env_nb_rel - + let push_rel d env = let rval = ref VKnone in { env with env_rel_context = add_rel_decl d env.env_rel_context; env_rel_val = rval :: env.env_rel_val; env_nb_rel = env.env_nb_rel + 1 } - + let lookup_rel_val n env = try List.nth env.env_rel_val (n - 1) with _ -> raise Not_found - + let env_of_rel n env = { env with env_rel_context = Util.list_skipn n env.env_rel_context; env_rel_val = Util.list_skipn n env.env_rel_val; env_nb_rel = env.env_nb_rel - n } - + (* Named context *) let push_named_context_val d (ctxt,vals) = @@ -105,21 +105,21 @@ let push_named_context_val d (ctxt,vals) = exception ASSERT of rel_context -let push_named d env = +let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) let id,body,_ = d in let rval = ref VKnone in - { env with + { env with env_named_context = Sign.add_named_decl d env.env_named_context; env_named_vals = (id,rval):: env.env_named_vals } let lookup_named_val id env = snd(List.find (fun (id',_) -> id = id') env.env_named_vals) - + (* Warning all the names should be different *) let env_of_named id env = env - + (* Global constants *) let lookup_constant_key kn env = @@ -132,7 +132,7 @@ let lookup_constant kn env = let lookup_mind kn env = KNmap.find kn env.env_globals.env_inductives -let rec scrape_mind env kn = +let rec scrape_mind env kn = match (lookup_mind kn env).mind_equiv with | None -> kn | Some kn' -> scrape_mind env kn' diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 518c6330d8..abbf9b1b53 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -18,10 +18,10 @@ open Declarations (* The type of environments. *) -type key = int option ref +type key = int option ref type constant_key = constant_body * key - + type globals = { env_constants : constant_key Cmap.t; env_inductives : mutual_inductive_body KNmap.t; @@ -34,7 +34,7 @@ type stratification = { env_engagement : engagement option } -type val_kind = +type val_kind = | VKvalue of values * Idset.t | VKnone @@ -49,7 +49,7 @@ type env = { env_rel_context : rel_context; env_rel_val : lazy_val list; env_nb_rel : int; - env_stratification : stratification; + env_stratification : stratification; retroknowledge : Retroknowledge.retroknowledge } type named_context_val = named_context * named_vals @@ -63,14 +63,14 @@ val empty_env : env val nb_rel : env -> int val push_rel : rel_declaration -> env -> env val lookup_rel_val : int -> env -> lazy_val -val env_of_rel : int -> env -> env +val env_of_rel : int -> env -> env (* Named context *) -val push_named_context_val : +val push_named_context_val : named_declaration -> named_context_val -> named_context_val val push_named : named_declaration -> env -> env val lookup_named_val : identifier -> env -> lazy_val -val env_of_named : identifier -> env -> env +val env_of_named : identifier -> env -> env (* Global constants *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 89f1b443b9..0a404fff31 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -22,7 +22,7 @@ let unfold_reference ((ids, csts), infos) k = | VarKey id when not (Idpred.mem id ids) -> None | ConstKey cst when not (Cpred.mem cst csts) -> None | _ -> unfold_reference infos k - + let rec is_empty_stack = function [] -> true | Zupdate _::s -> is_empty_stack s @@ -96,13 +96,13 @@ let whd_betaiotazeta x = Prod _|Lambda _|Fix _|CoFix _) -> x | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x) -let whd_betadeltaiota env t = +let whd_betadeltaiota env t = match kind_of_term t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> t | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t) -let whd_betadeltaiota_nolet env t = +let whd_betadeltaiota_nolet env t = match kind_of_term t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t @@ -167,8 +167,8 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = and this holds whatever Set is predicative or impredicative *) -type conv_pb = - | CONV +type conv_pb = + | CONV | CUMUL let sort_cmp pb s0 s1 cuniv = @@ -227,7 +227,7 @@ let in_whnf (t,stk) = | FLOCKED -> assert false (* Conversion between [lft1]term1 and [lft2]term2 *) -let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = +let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = eqappr cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) @@ -249,7 +249,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* case of leaves *) | (FAtom a1, FAtom a2) -> (match kind_of_term a1, kind_of_term a2 with - | (Sort s1, Sort s2) -> + | (Sort s1, Sort s2) -> assert (is_empty_stack v1 && is_empty_stack v2); sort_cmp cv_pb s1 s2 cuniv | (Meta n, Meta m) -> @@ -299,7 +299,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* only one constant, defined var or defined rel *) | (FFlex fl1, _) -> (match unfold_reference infos fl1 with - | Some def1 -> + | Some def1 -> eqappr cv_pb infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv | None -> raise NotConvertible) | (_, FFlex fl2) -> @@ -307,7 +307,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = | Some def2 -> eqappr cv_pb infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv | None -> raise NotConvertible) - + (* other constructors *) | (FLambda _, FLambda _) -> assert (is_empty_stack v1 && is_empty_stack v2); @@ -346,7 +346,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in let u2 = - convert_vect infos + convert_vect infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in convert_stacks infos lft1 lft2 v1 v2 u2 else raise NotConvertible @@ -370,7 +370,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false - + (* In all other cases, terms are not convertible *) | _ -> raise NotConvertible @@ -384,8 +384,8 @@ and convert_vect infos lft1 lft2 v1 v2 cuniv = let lv1 = Array.length v1 in let lv2 = Array.length v2 in if lv1 = lv2 - then - let rec fold n univ = + then + let rec fold n univ = if n >= lv1 then univ else let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in @@ -412,10 +412,10 @@ let conv ?(evars=fun _->None) = fconv CONV evars let conv_leq ?(evars=fun _->None) = fconv CUMUL evars let conv_leq_vecti ?(evars=fun _->None) env v1 v2 = - array_fold_left2_i + array_fold_left2_i (fun i c t1 t2 -> let c' = - try conv_leq ~evars env t1 t2 + try conv_leq ~evars env t1 t2 with NotConvertible -> raise (NotConvertibleVect i) in Constraint.union c c') Constraint.empty @@ -426,25 +426,25 @@ let conv_leq_vecti ?(evars=fun _->None) env v1 v2 = let vm_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None)) let set_vm_conv f = vm_conv := f -let vm_conv cv_pb env t1 t2 = - try +let vm_conv cv_pb env t1 t2 = + try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> (* If compilation fails, fall-back to closure conversion *) fconv cv_pb (fun _->None) env t1 t2 - + let default_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None)) let set_default_conv f = default_conv := f -let default_conv cv_pb env t1 t2 = - try +let default_conv cv_pb env t1 t2 = + try !default_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> (* If compilation fails, fall-back to closure conversion *) fconv cv_pb (fun _->None) env t1 t2 - + let default_conv_leq = default_conv CUMUL (* let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";; @@ -471,12 +471,12 @@ let hnf_prod_app env t n = | Prod (_,_,b) -> subst1 n b | _ -> anomaly "hnf_prod_app: Need a product" -let hnf_prod_applist env t nl = +let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl (* Dealing with arities *) -let dest_prod env = +let dest_prod env = let rec decrec env m c = let t = whd_betadeltaiota env c in match kind_of_term t with @@ -484,11 +484,11 @@ let dest_prod env = let d = (n,None,a) in decrec (push_rel d env) (add_rel_decl d m) c0 | _ -> m,t - in + in decrec env empty_rel_context (* The same but preserving lets *) -let dest_prod_assum env = +let dest_prod_assum env = let rec prodec_rec env l ty = let rty = whd_betadeltaiota_nolet env ty in match kind_of_term rty with diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 9960513294..f2c9df1568 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -33,7 +33,7 @@ type 'a trans_conversion_function = Names.transparent_state -> env -> 'a -> 'a - type conv_pb = CONV | CUMUL -val sort_cmp : +val sort_cmp : conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints val conv_sort : sorts conversion_function @@ -63,10 +63,10 @@ val default_conv_leq : types conversion_function (************************************************************************) -(* Builds an application node, reducing beta redexes it may produce. *) +(* Builds an application node, reducing beta redexes it may produce. *) val beta_appvect : constr -> constr array -> constr -(* Builds an application node, reducing the [n] first beta-zeta redexes. *) +(* Builds an application node, reducing the [n] first beta-zeta redexes. *) val betazeta_appvect : int -> constr -> constr array -> constr (* Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 44d13a0cb9..a3e493db9f 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -28,8 +28,8 @@ type nat_field = | NatType | NatPlus | NatTimes - -type n_field = + +type n_field = | NPositive | NType | NTwice @@ -39,7 +39,7 @@ type n_field = | NPlus | NTimes -type int31_field = +type int31_field = | Int31Bits | Int31Type | Int31Twice @@ -83,9 +83,9 @@ module Proactive = type proactive = entry Proactive.t -(* the reactive knowledge is represented as a functionaly map +(* the reactive knowledge is represented as a functionaly map from the type of terms (actually it is the terms whose outermost - layer is unfolded (typically by Term.kind_of_term)) to the + layer is unfolded (typically by Term.kind_of_term)) to the type reactive_end which is a record containing all the kind of reactive information needed *) (* todo: because of the bug with output state, reactive_end should eventually @@ -131,18 +131,18 @@ type action = (*initialisation*) -let initial_flags = +let initial_flags = {fastcomputation = true;} -let initial_proactive = +let initial_proactive = (Proactive.empty:proactive) -let initial_reactive = +let initial_reactive = (Reactive.empty:reactive) let initial_retroknowledge = - {flags = initial_flags; - proactive = initial_proactive; + {flags = initial_flags; + proactive = initial_proactive; reactive = initial_reactive } let empty_reactive_end = @@ -175,7 +175,7 @@ let find knowledge field = (*access functions for reactive retroknowledge*) (* used for compiling of functions (add, mult, etc..) *) -let get_vm_compiling_info knowledge key = +let get_vm_compiling_info knowledge key = match (Reactive.find key knowledge.reactive).vm_compiling with | None -> raise Not_found @@ -195,18 +195,18 @@ let get_vm_constant_dynamic_info knowledge key = | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation -let get_vm_before_match_info knowledge key = +let get_vm_before_match_info knowledge key = match (Reactive.find key knowledge.reactive).vm_before_match with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation -let get_vm_decompile_constant_info knowledge key = +let get_vm_decompile_constant_info knowledge key = match (Reactive.find key knowledge.reactive).vm_decompile_const with | None -> raise Not_found | Some f -> f - + (* functions manipulating reactive knowledge *) diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 2baf382854..0f1cdc8e22 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -24,8 +24,8 @@ type nat_field = | NatType | NatPlus | NatTimes - -type n_field = + +type n_field = | NPositive | NType | NTwice @@ -35,7 +35,7 @@ type n_field = | NPlus | NTimes -type int31_field = +type int31_field = | Int31Bits | Int31Type | Int31Twice @@ -81,14 +81,14 @@ val initial_retroknowledge : retroknowledge returns the compilation of id in cont if it has a specific treatment or raises Not_found if id should be compiled as usual *) val get_vm_compiling_info : retroknowledge -> entry -> Cbytecodes.comp_env -> - constr array -> + constr array -> int -> Cbytecodes.bytecodes-> Cbytecodes.bytecodes (*Given an identifier id (usually Construct _) and its argument array, returns a function that tries an ad-hoc optimisated compilation (in the case of the 31-bit integers it means compiling them directly into an integer) raises Not_found if id should be compiled as usual, and expectingly - CBytecodes.NotClosed if the term is not a closed constructor pattern + CBytecodes.NotClosed if the term is not a closed constructor pattern (a constant for the compiler) *) val get_vm_constant_static_info : retroknowledge -> entry -> constr array -> @@ -99,19 +99,19 @@ val get_vm_constant_static_info : retroknowledge -> entry -> of id+args+cont when id has a specific treatment (in the case of 31-bit integers, that would be the dynamic compilation into integers) or raises Not_found if id should be compiled as usual *) -val get_vm_constant_dynamic_info : retroknowledge -> entry -> - Cbytecodes.comp_env -> - Cbytecodes.block array -> +val get_vm_constant_dynamic_info : retroknowledge -> entry -> + Cbytecodes.comp_env -> + Cbytecodes.block array -> int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes -(* Given a type identifier, this function is used before compiling a match - over this type. In the case of 31-bit integers for instance, it is used +(* Given a type identifier, this function is used before compiling a match + over this type. In the case of 31-bit integers for instance, it is used to add the instruction sequence which would perform a dynamic decompilation in case the argument of the match is not in coq representation *) val get_vm_before_match_info : retroknowledge -> entry -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes -(* Given a type identifier, this function is used by pretyping/vnorm.ml to - recover the elements of that type from their compiled form if it's non +(* Given a type identifier, this function is used by pretyping/vnorm.ml to + recover the elements of that type from their compiled form if it's non standard (it is used (and can be used) only when the compiled form is not a block *) val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> Term.constr @@ -127,26 +127,26 @@ val find : retroknowledge -> field -> entry (* the following function manipulate the reactive information of values they are only used by the functions of Pre_env, and Environ to implement the functions register and unregister of Environ *) -val add_vm_compiling_info : retroknowledge-> entry -> +val add_vm_compiling_info : retroknowledge-> entry -> (bool -> Cbytecodes.comp_env -> constr array -> int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) -> retroknowledge -val add_vm_constant_static_info : retroknowledge-> entry -> +val add_vm_constant_static_info : retroknowledge-> entry -> (bool->constr array-> Cbytecodes.structured_constant) -> retroknowledge -val add_vm_constant_dynamic_info : retroknowledge-> entry -> - (bool -> Cbytecodes.comp_env -> - Cbytecodes.block array -> int -> +val add_vm_constant_dynamic_info : retroknowledge-> entry -> + (bool -> Cbytecodes.comp_env -> + Cbytecodes.block array -> int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) -> retroknowledge val add_vm_before_match_info : retroknowledge -> entry -> (bool->Cbytecodes.bytecodes->Cbytecodes.bytecodes) -> retroknowledge -val add_vm_decompile_constant_info : retroknowledge -> entry -> +val add_vm_decompile_constant_info : retroknowledge -> entry -> (int -> constr) -> retroknowledge - + val clear_info : retroknowledge-> entry -> retroknowledge diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 7469e12181..e73689bc8c 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -28,13 +28,13 @@ open Mod_typing open Mod_subst -type modvariant = - | NONE - | SIG of (* funsig params *) (mod_bound_id * module_type_body) list +type modvariant = + | NONE + | SIG of (* funsig params *) (mod_bound_id * module_type_body) list | STRUCT of (* functor params *) (mod_bound_id * module_type_body) list | LIBRARY of dir_path -type module_info = +type module_info = { msid : mod_self_id; modpath : module_path; seed : dir_path; (* the "seed" of unique identifier generator *) @@ -42,7 +42,7 @@ type module_info = variant : modvariant; alias_subst : substitution} -let check_label l labset = +let check_label l labset = if Labset.mem l labset then error_existing_label l let set_engagement_opt oeng env = @@ -52,7 +52,7 @@ let set_engagement_opt oeng env = type library_info = dir_path * Digest.t -type safe_environment = +type safe_environment = { old : safe_environment; env : env; modinfo : module_info; @@ -76,8 +76,8 @@ type safe_environment = (* a small hack to avoid variants and an unused case in all functions *) -let rec empty_environment = - { old = empty_environment; +let rec empty_environment = + { old = empty_environment; env = empty_env; modinfo = { msid = initial_msid; @@ -103,7 +103,7 @@ let env_of_senv = env_of_safe_env -let add_constraints cst senv = +let add_constraints cst senv = {senv with env = Environ.add_constraints cst senv.env; univ = Univ.Constraint.union cst senv.univ } @@ -113,7 +113,7 @@ let add_constraints cst senv = (* terms which are closed under the environnement env, i.e terms which only depends on constant who are themselves closed *) -let closed env term = +let closed env term = ContextObjectMap.is_empty (assumptions full_transparent_state env term) (* the set of safe terms in an environement any recursive set of @@ -126,15 +126,15 @@ let safe = (* universal lifting, used for the "get" operations mostly *) -let retroknowledge f senv = +let retroknowledge f senv = Environ.retroknowledge f (env_of_senv senv) -let register senv field value by_clause = +let register senv field value by_clause = (* todo : value closed, by_clause safe, by_clause of the proper type*) (* spiwack : updates the safe_env with the information that the register action has to be performed (again) when the environement is imported *) {senv with env = Environ.register senv.env field value; - local_retroknowledge = + local_retroknowledge = Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge } @@ -163,7 +163,7 @@ let unregister senv field = let safe_push_named (id,_,_ as d) env = let _ = try - let _ = lookup_named id env in + let _ = lookup_named id env in error ("Identifier "^string_of_id id^" already defined.") with Not_found -> () in Environ.push_named d env @@ -183,7 +183,7 @@ let push_named_assum (id,t) senv = (* Insertion of constants and parameters in environment. *) -type global_declaration = +type global_declaration = | ConstantEntry of constant_entry | GlobalRecipe of Cooking.recipe @@ -206,8 +206,8 @@ let hcons_constant_body cb = let add_constant dir l decl senv = check_label l senv.labset; let kn = make_con senv.modinfo.modpath dir l in - let cb = - match decl with + let cb = + match decl with | ConstantEntry ce -> translate_constant senv.env kn ce | GlobalRecipe r -> let cb = translate_recipe senv.env kn r in @@ -225,20 +225,20 @@ let add_constant dir l decl senv = imports = senv'.imports; loads = senv'.loads ; local_retroknowledge = senv'.local_retroknowledge } - + (* Insertion of inductive types. *) let add_mind dir l mie senv = - if mie.mind_entry_inds = [] then - anomaly "empty inductive types declaration"; + if mie.mind_entry_inds = [] then + anomaly "empty inductive types declaration"; (* this test is repeated by translate_mind *) let id = (List.nth mie.mind_entry_inds 0).mind_entry_typename in if l <> label_of_id id then anomaly ("the label of inductive packet and its first inductive"^ " type do not match"); - check_label l senv.labset; - (* TODO: when we will allow reorderings we will have to verify + check_label l senv.labset; + (* TODO: when we will allow reorderings we will have to verify all labels *) let mib = translate_mind senv.env mie in let senv' = add_constraints mib.mind_constraints senv in @@ -257,13 +257,13 @@ let add_mind dir l mie senv = (* Insertion of module types *) -let add_modtype l mte senv = - check_label l senv.labset; +let add_modtype l mte senv = + check_label l senv.labset; let mtb_expr,sub = translate_struct_entry senv.env mte in let mtb = { typ_expr = mtb_expr; typ_strength = None; typ_alias = sub} in - let senv' = add_constraints + let senv' = add_constraints (struct_expr_constraints mtb_expr) senv in let mp = MPdot(senv.modinfo.modpath, l) in let env'' = Environ.add_modtype mp mtb senv'.env in @@ -284,22 +284,22 @@ let full_add_module mp mb senv = let senv = add_constraints (module_constraints mb) senv in let env = Modops.add_module mp mb senv.env in {senv with env = env} - + (* Insertion of modules *) - -let add_module l me senv = - check_label l senv.labset; + +let add_module l me senv = + check_label l senv.labset; let mb = translate_module senv.env me in let mp = MPdot(senv.modinfo.modpath, l) in let senv' = full_add_module mp mb senv in let is_functor,sub = Modops.update_subst senv'.env mb mp in mp, { old = senv'.old; env = senv'.env; - modinfo = + modinfo = if is_functor then senv'.modinfo else - {senv'.modinfo with + {senv'.modinfo with alias_subst = join senv'.modinfo.alias_subst sub}; labset = Labset.add l senv'.labset; revstruct = (l,SFBmodule mb)::senv'.revstruct; @@ -308,17 +308,17 @@ let add_module l me senv = imports = senv'.imports; loads = senv'.loads; local_retroknowledge = senv'.local_retroknowledge } - + let add_alias l mp senv = - check_label l senv.labset; + check_label l senv.labset; let mp' = MPdot(senv.modinfo.modpath, l) in let mp1 = scrape_alias mp senv.env in - let typ_opt = + let typ_opt = if check_bound_mp mp then Some (strengthen senv.env (lookup_modtype mp senv.env).typ_expr mp) else - None + None in (* we get all updated alias substitution {mp1.K\M} that comes from mp1 *) let _,sub = Modops.update_subst senv.env (lookup_module mp1 senv.env) mp1 in @@ -331,8 +331,8 @@ let add_alias l mp senv = let env' = register_alias mp' mp senv.env in mp', { old = senv.old; env = env'; - modinfo = { senv.modinfo with - alias_subst = join + modinfo = { senv.modinfo with + alias_subst = join senv.modinfo.alias_subst sub}; labset = Labset.add l senv.labset; revstruct = (l,SFBalias (mp,typ_opt,None))::senv.revstruct; @@ -344,8 +344,8 @@ let add_alias l mp senv = (* Interactive modules *) -let start_module l senv = - check_label l senv.labset; +let start_module l senv = + check_label l senv.labset; let msid = make_msid senv.modinfo.seed (string_of_label l) in let mp = MPself msid in let modinfo = { msid = msid; @@ -367,31 +367,31 @@ let start_module l senv = (* spiwack : not sure, but I hope it's correct *) local_retroknowledge = [] } -let end_module l restype senv = +let end_module l restype senv = let oldsenv = senv.old in let modinfo = senv.modinfo in let restype = Option.map (translate_struct_entry senv.env) restype in - let params,is_functor = + let params,is_functor = match modinfo.variant with | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end () | STRUCT params -> params, (List.length params > 0) in if l <> modinfo.label then error_incompatible_labels l modinfo.label; if not (empty_context senv.env) then error_local_context None; - let functorize_struct tb = + let functorize_struct tb = List.fold_left - (fun mtb (arg_id,arg_b) -> + (fun mtb (arg_id,arg_b) -> SEBfunctor(arg_id,arg_b,mtb)) tb params in - let auto_tb = + let auto_tb = SEBstruct (modinfo.msid, List.rev senv.revstruct) in - let mod_typ,subst,cst = + let mod_typ,subst,cst = match restype with | None -> None,modinfo.alias_subst,Constraint.empty - | Some (res_tb,subst) -> + | Some (res_tb,subst) -> let cst = check_subtypes senv.env {typ_expr = auto_tb; typ_strength = None; @@ -404,7 +404,7 @@ let end_module l restype senv = in let mexpr = functorize_struct auto_tb in let cst = Constraint.union cst senv.univ in - let mb = + let mb = { mod_expr = Some mexpr; mod_type = mod_typ; mod_constraints = cst; @@ -415,24 +415,24 @@ let end_module l restype senv = let newenv = oldsenv.env in let newenv = set_engagement_opt senv.engagement newenv in let senv'= {senv with env=newenv} in - let senv' = + let senv' = List.fold_left - (fun env (mp,mb) -> full_add_module mp mb env) + (fun env (mp,mb) -> full_add_module mp mb env) senv' (List.rev senv'.loads) in let newenv = Environ.add_constraints cst senv'.env in - let newenv = + let newenv = Modops.add_module mp mb newenv - in + in let is_functor,subst = Modops.update_subst newenv mb mp in - let newmodinfo = + let newmodinfo = if is_functor then oldsenv.modinfo else - { oldsenv.modinfo with - alias_subst = join - oldsenv.modinfo.alias_subst + { oldsenv.modinfo with + alias_subst = join + oldsenv.modinfo.alias_subst subst }; in mp, { old = oldsenv.old; @@ -458,7 +458,7 @@ let end_module l restype senv = in let mp_sup = senv.modinfo.modpath in let str1 = subst_signature_msid msid mp_sup str in - let add senv (l,elem) = + let add senv (l,elem) = check_label l senv.labset; match elem with | SFBconst cb -> @@ -475,7 +475,7 @@ let end_module l restype senv = imports = senv'.imports; loads = senv'.loads ; local_retroknowledge = senv'.local_retroknowledge } - + | SFBmind mib -> let kn = make_kn mp_sup empty_dirpath l in let senv' = add_constraints mib.mind_constraints senv in @@ -483,25 +483,25 @@ let end_module l restype senv = { old = senv'.old; env = env''; modinfo = senv'.modinfo; - labset = Labset.add l senv'.labset; + labset = Labset.add l senv'.labset; revstruct = (l,SFBmind mib)::senv'.revstruct; univ = senv'.univ; engagement = senv'.engagement; imports = senv'.imports; loads = senv'.loads; local_retroknowledge = senv'.local_retroknowledge } - + | SFBmodule mb -> let mp = MPdot(senv.modinfo.modpath, l) in let is_functor,sub = Modops.update_subst senv.env mb mp in let senv' = full_add_module mp mb senv in { old = senv'.old; env = senv'.env; - modinfo = + modinfo = if is_functor then senv'.modinfo else - {senv'.modinfo with + {senv'.modinfo with alias_subst = join senv'.modinfo.alias_subst sub}; labset = Labset.add l senv'.labset; revstruct = (l,SFBmodule mb)::senv'.revstruct; @@ -511,7 +511,7 @@ let end_module l restype senv = loads = senv'.loads; local_retroknowledge = senv'.local_retroknowledge } | SFBalias (mp',typ_opt,cst) -> - let env' = Option.fold_right + let env' = Option.fold_right Environ.add_constraints cst senv.env in let mp = MPdot(senv.modinfo.modpath, l) in let mp1 = scrape_alias mp' senv.env in @@ -522,8 +522,8 @@ let end_module l restype senv = let env' = register_alias mp mp' env' in { old = senv.old; env = env'; - modinfo = { senv.modinfo with - alias_subst = join + modinfo = { senv.modinfo with + alias_subst = join senv.modinfo.alias_subst sub}; labset = Labset.add l senv.labset; revstruct = (l,SFBalias (mp',typ_opt,cst))::senv.revstruct; @@ -548,7 +548,7 @@ let end_module l restype senv = local_retroknowledge = senv.local_retroknowledge } in List.fold_left add senv str1 - + (* Adding parameters to modules or module types *) let add_module_parameter mbid mte senv = @@ -558,12 +558,12 @@ let add_module_parameter mbid mte senv = let mtb = {typ_expr = mtb_expr; typ_strength = None; typ_alias = sub} in - let senv = full_add_module (MPbound mbid) (module_body_of_type mtb) senv + let senv = full_add_module (MPbound mbid) (module_body_of_type mtb) senv in let new_variant = match senv.modinfo.variant with | STRUCT params -> STRUCT ((mbid,mtb) :: params) | SIG params -> SIG ((mbid,mtb) :: params) - | _ -> + | _ -> anomaly "Module parameters can only be added to modules or signatures" in { old = senv.old; @@ -580,8 +580,8 @@ let add_module_parameter mbid mte senv = (* Interactive module types *) -let start_modtype l senv = - check_label l senv.labset; +let start_modtype l senv = + check_label l senv.labset; let msid = make_msid senv.modinfo.seed (string_of_label l) in let mp = MPself msid in let modinfo = { msid = msid; @@ -603,22 +603,22 @@ let start_modtype l senv = (* spiwack: not 100% sure, but I think it should be like that *) local_retroknowledge = []} -let end_modtype l senv = +let end_modtype l senv = let oldsenv = senv.old in let modinfo = senv.modinfo in - let params = + let params = match modinfo.variant with | LIBRARY _ | NONE | STRUCT _ -> error_no_modtype_to_end () | SIG params -> params in if l <> modinfo.label then error_incompatible_labels l modinfo.label; if not (empty_context senv.env) then error_local_context None; - let auto_tb = + let auto_tb = SEBstruct (modinfo.msid, List.rev senv.revstruct) in - let mtb_expr = + let mtb_expr = List.fold_left - (fun mtb (arg_id,arg_b) -> + (fun mtb (arg_id,arg_b) -> SEBfunctor(arg_id,arg_b,mtb)) auto_tb params @@ -630,9 +630,9 @@ let end_modtype l senv = let newenv = Environ.add_constraints senv.univ newenv in let newenv = set_engagement_opt senv.engagement newenv in let senv = {senv with env=newenv} in - let senv = + let senv = List.fold_left - (fun env (mp,mb) -> full_add_module mp mb env) + (fun env (mp,mb) -> full_add_module mp mb env) senv (List.rev senv.loads) in @@ -640,9 +640,9 @@ let end_modtype l senv = let mtb = {typ_expr = mtb_expr; typ_strength = None; typ_alias = subst} in - let newenv = + let newenv = Environ.add_modtype mp mtb senv.env - in + in mp, { old = oldsenv.old; env = newenv; modinfo = oldsenv.modinfo; @@ -654,9 +654,9 @@ let end_modtype l senv = loads = senv.loads@oldsenv.loads; (* spiwack : if there is a bug with retroknowledge in nested modules it's likely to come from here *) - local_retroknowledge = + local_retroknowledge = senv.local_retroknowledge@oldsenv.local_retroknowledge} - + let current_modpath senv = senv.modinfo.modpath let current_msid senv = senv.modinfo.msid @@ -677,10 +677,10 @@ let set_engagement c senv = (* Libraries = Compiled modules *) -type compiled_library = +type compiled_library = dir_path * module_body * library_info list * engagement option -(* We check that only initial state Require's were performed before +(* We check that only initial state Require's were performed before [start_library] was called *) let is_empty senv = @@ -691,7 +691,7 @@ let is_empty senv = let start_library dir senv = if not (is_empty senv) then anomaly "Safe_typing.start_library: environment should be empty"; - let dir_path,l = + let dir_path,l = match (repr_dirpath dir) with [] -> anomaly "Empty dirpath in Safe_typing.start_library" | hd::tl -> @@ -719,11 +719,11 @@ let start_library dir senv = -let export senv dir = +let export senv dir = let modinfo = senv.modinfo in begin match modinfo.variant with - | LIBRARY dp -> + | LIBRARY dp -> if dir <> dp then anomaly "We are not exporting the right library!" | _ -> @@ -731,7 +731,7 @@ let export senv dir = end; (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then (* error_export_simple *) (); *) - let mb = + let mb = { mod_expr = Some (SEBstruct (modinfo.msid, List.rev senv.revstruct)); mod_type = None; mod_constraints = senv.univ; @@ -749,7 +749,7 @@ let check_imports senv needed = if stamp <> actual_stamp then error ("Inconsistent assumptions over module "^(string_of_dirpath id)^".") - with Not_found -> + with Not_found -> error ("Reference to unknown module "^(string_of_dirpath id)^".") in List.iter check needed @@ -768,16 +768,16 @@ environment, and store for the future (instead of just its type) loaded by side-effect once and for all (like it is done in OCaml). Would this be correct with respect to undo's and stuff ? *) - -let import (dp,mb,depends,engmt) digest senv = + +let import (dp,mb,depends,engmt) digest senv = check_imports senv depends; check_engagement senv.env engmt; let mp = MPfile dp in let env = senv.env in let env = Environ.add_constraints mb.mod_constraints env in let env = Modops.add_module mp mb env in - mp, { senv with - env = env; + mp, { senv with + env = env; imports = (dp,digest)::senv.imports; loads = (mp,mb)::senv.loads } @@ -788,22 +788,22 @@ let import (dp,mb,depends,engmt) digest senv = mod_expr = Option.map lighten_modexpr mb.mod_expr; mod_type = Option.map lighten_modexpr mb.mod_type; } - -and lighten_struct struc = + +and lighten_struct struc = let lighten_body (l,body) = (l,match body with | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None} | (SFBconst _ | SFBmind _ | SFBalias _) as x -> x | SFBmodule m -> SFBmodule (lighten_module m) - | SFBmodtype m -> SFBmodtype - ({m with + | SFBmodtype m -> SFBmodtype + ({m with typ_expr = lighten_modexpr m.typ_expr})) in List.map lighten_body struc and lighten_modexpr = function | SEBfunctor (mbid,mty,mexpr) -> - SEBfunctor (mbid, - ({mty with + SEBfunctor (mbid, + ({mty with typ_expr = lighten_modexpr mty.typ_expr}), lighten_modexpr mexpr) | SEBident mp as x -> x @@ -812,8 +812,8 @@ and lighten_modexpr = function | SEBapply (mexpr,marg,u) -> SEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u) | SEBwith (seb,wdcl) -> - SEBwith (lighten_modexpr seb,wdcl) - + SEBwith (lighten_modexpr seb,wdcl) + let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s) @@ -823,5 +823,5 @@ let j_val j = j.uj_val let j_type j = j.uj_type let safe_infer senv = infer (env_of_senv senv) - + let typing senv = Typeops.typing (env_of_senv senv) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 07f82876f6..ac1e3863ad 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -20,7 +20,7 @@ open Entries typed before being added. We also add [open_structure] and [close_section], [close_module] to - provide functionnality for sections and interactive modules + provide functionnality for sections and interactive modules *) type safe_environment @@ -39,35 +39,35 @@ val push_named_def : Univ.constraints * safe_environment (* Adding global axioms or definitions *) -type global_declaration = +type global_declaration = | ConstantEntry of constant_entry | GlobalRecipe of Cooking.recipe -val add_constant : - dir_path -> label -> global_declaration -> safe_environment -> +val add_constant : + dir_path -> label -> global_declaration -> safe_environment -> constant * safe_environment (* Adding an inductive type *) -val add_mind : +val add_mind : dir_path -> label -> mutual_inductive_entry -> safe_environment -> mutual_inductive * safe_environment (* Adding a module *) val add_module : - label -> module_entry -> safe_environment + label -> module_entry -> safe_environment -> module_path * safe_environment (* Adding a module alias*) val add_alias : - label -> module_path -> safe_environment + label -> module_path -> safe_environment -> module_path * safe_environment (* Adding a module type *) val add_modtype : - label -> module_struct_entry -> safe_environment + label -> module_struct_entry -> safe_environment -> module_path * safe_environment (* Adding universe constraints *) -val add_constraints : +val add_constraints : Univ.constraints -> safe_environment -> safe_environment (* Settin the strongly constructive or classical logical engagement *) @@ -75,11 +75,11 @@ val set_engagement : engagement -> safe_environment -> safe_environment (*s Interactive module functions *) -val start_module : +val start_module : label -> safe_environment -> module_path * safe_environment val end_module : - label -> module_struct_entry option - -> safe_environment -> module_path * safe_environment + label -> module_struct_entry option + -> safe_environment -> module_path * safe_environment val add_module_parameter : mod_bound_id -> module_struct_entry -> safe_environment -> safe_environment @@ -102,13 +102,13 @@ val current_msid : safe_environment -> mod_self_id (* exporting and importing modules *) type compiled_library -val start_library : dir_path -> safe_environment +val start_library : dir_path -> safe_environment -> module_path * safe_environment -val export : safe_environment -> dir_path +val export : safe_environment -> dir_path -> mod_self_id * compiled_library -val import : compiled_library -> Digest.t -> safe_environment +val import : compiled_library -> Digest.t -> safe_environment -> module_path * safe_environment (* Remove the body of opaque constants *) diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 1f77c3e43c..861dc9a3fd 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -27,7 +27,7 @@ open Entries (* This local type is used to subtype a constant with a constructor or an inductive type. It can also be useful to allow reorderings in inductive types *) -type namedobject = +type namedobject = | Constant of constant_body | IndType of inductive * mutual_inductive_body | IndConstr of constructor * mutual_inductive_body @@ -38,11 +38,11 @@ type namedobject = (* adds above information about one mutual inductive: all types and constructors *) -let add_nameobjects_of_mib ln mib map = +let add_nameobjects_of_mib ln mib map = let add_nameobjects_of_one j oib map = let ip = (ln,j) in - let map = - array_fold_right_i + let map = + array_fold_right_i (fun i id map -> Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map) oib.mind_consnames @@ -55,8 +55,8 @@ let add_nameobjects_of_mib ln mib map = (* creates namedobject map for the whole signature *) -let make_label_map mp list = - let add_one (l,e) map = +let make_label_map mp list = + let add_one (l,e) map = let add_map obj = Labmap.add l obj map in match e with | SFBconst cb -> add_map (Constant cb) @@ -75,11 +75,11 @@ let check_conv_error error cst f env a1 a2 = NotConvertible -> error () (* for now we do not allow reorderings *) -let check_inductive cst env msid1 l info1 mib2 spec2 = +let check_inductive cst env msid1 l info1 mib2 spec2 = let kn = make_kn (MPself msid1) empty_dirpath l in let error () = error_not_match l spec2 in let check_conv cst f = check_conv_error error cst f in - let mib1 = + let mib1 = match info1 with | IndType ((_,0), mib) -> mib | _ -> error () @@ -88,7 +88,7 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = (* Due to sort-polymorphism in inductive types, the conclusions of t1 and t2, if in Type, are generated as the least upper bounds - of the types of the constructors. + of the types of the constructors. By monotonicity of the infered l.u.b. wrt subtyping (i.e. if X:U |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each @@ -138,7 +138,7 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = cst in let check_cons_types i cst p1 p2 = - array_fold_left2 + array_fold_left2 (fun cst t1 t2 -> check_conv cst conv env t1 t2) cst (arities_of_specif kn (mib1,p1)) @@ -148,7 +148,7 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = check (fun mib -> mib.mind_finite); check (fun mib -> mib.mind_ntypes); assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]); - assert (Array.length mib1.mind_packets >= 1 + assert (Array.length mib1.mind_packets >= 1 && Array.length mib2.mind_packets >= 1); (* Check that the expected numbers of uniform parameters are the same *) @@ -158,10 +158,10 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = (* the inductive types and constructors types have to be convertible *) check (fun mib -> mib.mind_nparams); - begin + begin match mib2.mind_equiv with | None -> () - | Some kn2' -> + | Some kn2' -> let kn2 = scrape_mind env kn2' in let kn1 = match mib1.mind_equiv with None -> kn @@ -171,33 +171,33 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = end; (* we check that records and their field names are preserved. *) check (fun mib -> mib.mind_record); - if mib1.mind_record then begin - let rec names_prod_letin t = match kind_of_term t with + if mib1.mind_record then begin + let rec names_prod_letin t = match kind_of_term t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t | _ -> [] - in + in assert (Array.length mib1.mind_packets = 1); assert (Array.length mib2.mind_packets = 1); - assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); - assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); + assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); + assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0)); end; (* we first check simple things *) - let cst = + let cst = array_fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets in (* and constructor types in the end *) - let cst = + let cst = array_fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets in cst - -let check_constant cst env msid1 l info1 cb2 spec2 = + +let check_constant cst env msid1 l info1 cb2 spec2 = let error () = error_not_match l spec2 in let check_conv cst f = check_conv_error error cst f in - let check_type cst env t1 t2 = + let check_type cst env t1 t2 = (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion @@ -208,7 +208,7 @@ let check_constant cst env msid1 l info1 cb2 spec2 = Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). Hence they don't have to be checked again *) - let t1,t2 = + let t1,t2 = if isArity t2 then let (ctx2,s2) = destArity t2 in match s2 with @@ -259,15 +259,15 @@ let check_constant cst env msid1 l info1 cb2 spec2 = | Some lc2 -> let c2 = Declarations.force lc2 in let c1 = match cb1.const_body with - | Some lc1 -> + | Some lc1 -> let c = Declarations.force lc1 in begin match (kind_of_term c) with - Const n -> + Const n -> let cb = lookup_constant n env in (match cb.const_opaque, cb.const_body with - | true, Some lc1 -> + | true, Some lc1 -> Declarations.force lc1 | _,_ -> c) | _ -> c @@ -310,7 +310,7 @@ let check_constant cst env msid1 l info1 cb2 spec2 = let ty2 = Typeops.type_of_constant_type env cb2.const_type in check_conv cst conv env ty1 ty2 | _ -> error () - + let rec check_modules cst env msid1 l msb1 msb2 alias = let mp = (MPdot(MPself msid1,l)) in let mty1 = module_type_of_module (Some mp) msb1 in @@ -318,40 +318,40 @@ let rec check_modules cst env msid1 l msb1 msb2 alias = | SEBstruct (msid,sign) as str -> update_subst alias (map_msid msid mp),str | _ as str -> empty_subst,str in - let mty1 = {mty1 with + let mty1 = {mty1 with typ_expr = struct_expr; typ_alias = join alias1 mty1.typ_alias } in let mty2 = module_type_of_module None msb2 in let cst = check_modtypes cst env mty1 mty2 false in cst - -and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = + +and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = let mp1 = MPself msid1 in - let env = add_signature mp1 sig1 env in + let env = add_signature mp1 sig1 env in let sig1 = subst_structure alias sig1 in let alias1 = update_subst alias (map_msid msid2 mp1) in let sig2 = subst_structure alias1 sig2' in let sig2 = subst_signature_msid msid2 mp1 sig2 in let map1 = make_label_map mp1 sig1 in - let check_one_body cst (l,spec2) = - let info1 = - try - Labmap.find l map1 - with - Not_found -> error_no_such_label_sub l + let check_one_body cst (l,spec2) = + let info1 = + try + Labmap.find l map1 + with + Not_found -> error_no_such_label_sub l (string_of_msid msid1) (string_of_msid msid2) in match spec2 with | SFBconst cb2 -> check_constant cst env msid1 l info1 cb2 spec2 - | SFBmind mib2 -> + | SFBmind mib2 -> check_inductive cst env msid1 l info1 mib2 spec2 - | SFBmodule msb2 -> + | SFBmodule msb2 -> begin match info1 with | Module msb -> check_modules cst env msid1 l msb msb2 alias - | Alias (mp,typ_opt) ->let msb = + | Alias (mp,typ_opt) ->let msb = {mod_expr = Some (SEBident mp); mod_type = typ_opt; mod_constraints = Constraint.empty; @@ -361,11 +361,11 @@ and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = | _ -> error_not_match l spec2 end | SFBalias (mp,typ_opt,_) -> - begin + begin match info1 with | Alias (mp1,_) -> check_modpath_equiv env mp mp1; cst - | Module msb -> - let msb1 = + | Module msb -> + let msb1 = {mod_expr = Some (SEBident mp); mod_type = typ_opt; mod_constraints = Constraint.empty; @@ -375,7 +375,7 @@ and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = | _ -> error_not_match l spec2 end | SFBmodtype mtb2 -> - let mtb1 = + let mtb1 = match info1 with | Modtype mtb -> mtb | _ -> error_not_match l spec2 @@ -383,9 +383,9 @@ and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = check_modtypes cst env mtb1 mtb2 true in List.fold_left check_one_body cst sig2 - -and check_modtypes cst env mtb1 mtb2 equiv = + +and check_modtypes cst env mtb1 mtb2 equiv = if mtb1==mtb2 then cst else (* just in case :) *) let mtb1',mtb2'= (match mtb1.typ_strength with @@ -393,25 +393,25 @@ and check_modtypes cst env mtb1 mtb2 equiv = eval_struct env mtb2.typ_expr | Some mp -> strengthen env mtb1.typ_expr mp, eval_struct env mtb2.typ_expr) in - let rec check_structure cst env str1 str2 equiv = + let rec check_structure cst env str1 str2 equiv = match str1, str2 with - | SEBstruct (msid1,list1), - SEBstruct (msid2,list2) -> + | SEBstruct (msid1,list1), + SEBstruct (msid2,list2) -> let cst = check_signatures cst env (msid1,list1) mtb1.typ_alias (msid2,list2) in if equiv then - check_signatures cst env - (msid2,list2) mtb2.typ_alias (msid1,list1) + check_signatures cst env + (msid2,list2) mtb2.typ_alias (msid1,list1) else cst - | SEBfunctor (arg_id1,arg_t1,body_t1), + | SEBfunctor (arg_id1,arg_t1,body_t1), SEBfunctor (arg_id2,arg_t2,body_t2) -> - let cst = check_modtypes cst env arg_t2 arg_t1 equiv in + let cst = check_modtypes cst env arg_t2 arg_t1 equiv in (* contravariant *) - let env = - add_module (MPbound arg_id2) (module_body_of_type arg_t2) env + let env = + add_module (MPbound arg_id2) (module_body_of_type arg_t2) env in - let body_t1' = + let body_t1' = (* since we are just checking well-typedness we do not need to expand any constant. Hence the identity resolver. *) subst_struct_expr @@ -421,9 +421,9 @@ and check_modtypes cst env mtb1 mtb2 equiv = check_structure cst env (eval_struct env body_t1') (eval_struct env body_t2) equiv | _ , _ -> error_incompatible_modtypes mtb1 mtb2 - in - if mtb1'== mtb2' then cst + in + if mtb1'== mtb2' then cst else check_structure cst env mtb1' mtb2' equiv - -let check_subtypes env sup super = + +let check_subtypes env sup super = check_modtypes Constraint.empty env sup super false diff --git a/kernel/term.ml b/kernel/term.ml index 8a2c3278cb..68ea2ed3fe 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -42,7 +42,7 @@ type contents = Pos | Null type sorts = | Prop of contents (* proposition types *) | Type of universe - + let prop_sort = Prop Null let set_sort = Prop Pos let type1_sort = Type type1_univ @@ -58,7 +58,7 @@ let family_of_sort = function (* Constructions as implemented *) (********************************************************************) -type cast_kind = VMcast | DEFAULTcast +type cast_kind = VMcast | DEFAULTcast (* [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) @@ -93,7 +93,7 @@ type ('constr, 'types) kind_of_term = (* Experimental *) type ('constr, 'types) kind_of_type = | SortType of sorts - | CastType of 'types * 'types + | CastType of 'types * 'types | ProdType of name * 'types * 'types | LetInType of name * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array @@ -118,7 +118,7 @@ type fixpoint = (int array * int) * rec_declaration type cofixpoint = int * rec_declaration (***************************) -(* hash-consing functions *) +(* hash-consing functions *) (***************************) let comp_term t1 t2 = @@ -211,7 +211,7 @@ let mkVar id = Var id let mkSort s = Sort s (* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) -(* (that means t2 is declared as the type of t1) +(* (that means t2 is declared as the type of t1) [s] is the strategy to use when *) let mkCast (t1,k2,t2) = match t1 with @@ -230,14 +230,14 @@ let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2) (* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *) (* We ensure applicative terms have at least one argument and the function is not itself an applicative term *) -let mkApp (f, a) = +let mkApp (f, a) = if Array.length a = 0 then f else match f with | App (g, cl) -> App (g, Array.append cl a) | _ -> App (f, a) -(* Constructs a constant *) +(* Constructs a constant *) (* The array of terms correspond to the variables introduced in the section *) let mkConst c = Const c @@ -248,7 +248,7 @@ let mkEvar e = Evar e (* The array of terms correspond to the variables introduced in the section *) let mkInd m = Ind m -(* Constructs the jth constructor of the ith (co)inductive type of the +(* Constructs the jth constructor of the ith (co)inductive type of the block named kn. The array of terms correspond to the variables introduced in the section *) let mkConstruct c = Construct c @@ -285,7 +285,7 @@ type hnftype = (* Non primitive term destructors *) (**********************************************************************) -(* Destructor operations : partial functions +(* Destructor operations : partial functions Raise invalid_arg "dest*" if the const has not the expected form *) (* Destructs a DeBrujin index *) @@ -349,12 +349,12 @@ let same_kind c1 c2 = (isprop c1 & isprop c2) or (is_Type c1 & is_Type c2) (* Tests if an evar *) let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false -let isEvar_or_Meta c = match kind_of_term c with +let isEvar_or_Meta c = match kind_of_term c with | Evar _ | Meta _ -> true | _ -> false (* Destructs a casted term *) -let destCast c = match kind_of_term c with +let destCast c = match kind_of_term c with | Cast (t1,k,t2) -> (t1,k,t2) | _ -> invalid_arg "destCast" @@ -371,22 +371,22 @@ let isVar c = match kind_of_term c with Var _ -> true | _ -> false let isInd c = match kind_of_term c with Ind _ -> true | _ -> false (* Destructs the product (x:t1)t2 *) -let destProd c = match kind_of_term c with - | Prod (x,t1,t2) -> (x,t1,t2) +let destProd c = match kind_of_term c with + | Prod (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destProd" let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false (* Destructs the abstraction [x:t1]t2 *) -let destLambda c = match kind_of_term c with - | Lambda (x,t1,t2) -> (x,t1,t2) +let destLambda c = match kind_of_term c with + | Lambda (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destLambda" let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false (* Destructs the let [x:=b:t1]t2 *) -let destLetIn c = match kind_of_term c with - | LetIn (x,b,t1,t2) -> (x,b,t1,t2) +let destLetIn c = match kind_of_term c with + | LetIn (x,b,t1,t2) -> (x,b,t1,t2) | _ -> invalid_arg "destProd" let isLetIn c = match kind_of_term c with LetIn _ -> true | _ -> false @@ -435,13 +435,13 @@ let destCase c = match kind_of_term c with let isCase c = match kind_of_term c with Case _ -> true | _ -> false -let destFix c = match kind_of_term c with +let destFix c = match kind_of_term c with | Fix fix -> fix | _ -> invalid_arg "destFix" let isFix c = match kind_of_term c with Fix _ -> true | _ -> false -let destCoFix c = match kind_of_term c with +let destCoFix c = match kind_of_term c with | CoFix cofix -> cofix | _ -> invalid_arg "destCoFix" @@ -471,7 +471,7 @@ let rec under_casts f c = match kind_of_term c with (* flattens application lists throwing casts in-between *) let rec collapse_appl c = match kind_of_term c with - | App (f,cl) -> + | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term (strip_outer_cast f) with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) @@ -487,12 +487,12 @@ let decompose_app c = (* strips head casts and flattens head applications *) let rec strip_head_cast c = match kind_of_term c with - | App (f,cl) -> + | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term f with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) | Cast (c,_,_) -> collapse_rec c cl2 | _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2) - in + in collapse_rec f cl | Cast (c,_,_) -> strip_head_cast c | _ -> c @@ -555,7 +555,7 @@ let iter_constr_with_binders g f n c = match kind_of_term c with | App (c,l) -> f n c; Array.iter (f n) l | Evar (_,l) -> Array.iter (f n) l | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl - | Fix (_,(_,tl,bl)) -> + | Fix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl | CoFix (_,(_,tl,bl)) -> @@ -624,7 +624,7 @@ let compare_constr f t1 t2 = if Array.length l1 = Array.length l2 then f c1 c2 & array_for_all2 f l1 l2 else - let (h1,l1) = decompose_app t1 in + let (h1,l1) = decompose_app t1 in let (h2,l2) = decompose_app t2 in if List.length l1 = List.length l2 then f h1 h2 & List.for_all2 f l1 l2 @@ -647,7 +647,7 @@ let compare_constr f t1 t2 = type types = constr -type strategy = types option +type strategy = types option type named_declaration = identifier * constr option * types type rel_declaration = name * constr option * types @@ -699,11 +699,11 @@ exception LocalOccur (* (closedn n M) raises FreeVar if a variable of height greater than n occurs in M, returns () otherwise *) -let closedn n c = +let closedn n c = let rec closed_rec n c = match kind_of_term c with | Rel m -> if m>n then raise LocalOccur | _ -> iter_constr_with_binders succ closed_rec n c - in + in try closed_rec n c; true with LocalOccur -> false (* [closed0 M] is true iff [M] is a (deBruijn) closed term *) @@ -712,21 +712,21 @@ let closed0 = closedn 0 (* (noccurn n M) returns true iff (Rel n) does NOT occur in term M *) -let noccurn n term = +let noccurn n term = let rec occur_rec n c = match kind_of_term c with | Rel m -> if m = n then raise LocalOccur | _ -> iter_constr_with_binders succ occur_rec n c - in + in try occur_rec n term; true with LocalOccur -> false -(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M +(* (noccur_between n m M) returns true iff (Rel p) does NOT occur in term M for n <= p < n+m *) -let noccur_between n m term = +let noccur_between n m term = let rec occur_rec n c = match kind_of_term c with | Rel(p) -> if n<=p && p iter_constr_with_binders succ occur_rec n c - in + in try occur_rec n term; true with LocalOccur -> false (* Checking function for terms containing existential variables. @@ -736,7 +736,7 @@ let noccur_between n m term = which may contain the CoFix variables. These occurrences of CoFix variables are not considered *) -let noccur_with_meta n m term = +let noccur_with_meta n m term = let rec occur_rec n c = match kind_of_term c with | Rel p -> if n<=p & p @@ -761,18 +761,18 @@ let rec exliftn el c = match kind_of_term c with (* Lifting the binding depth across k bindings *) -let liftn k n = +let liftn k n = match el_liftn (pred n) (el_shft k ELID) with | ELID -> (fun c -> c) | el -> exliftn el - + let lift k = liftn k 1 (*********************) (* Substituting *) (*********************) -(* (subst1 M c) substitutes M for Rel(1) in c +(* (subst1 M c) substitutes M for Rel(1) in c we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel M1,...,Mn for respectively Rel(1),...,Rel(n) in c *) @@ -792,15 +792,15 @@ let rec lift_substituend depth s = let make_substituend c = { sinfo=Unknown; sit=c } let substn_many lamv n c = - let lv = Array.length lamv in + let lv = Array.length lamv in if lv = 0 then c - else + else let rec substrec depth c = match kind_of_term c with | Rel k -> if k<=depth then c else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1) else mkRel (k-lv) - | _ -> map_constr_with_binders succ substrec depth c in + | _ -> map_constr_with_binders succ substrec depth c in substrec n c (* @@ -824,21 +824,21 @@ let substl_named_decl = substl_decl let rec thin_val = function | [] -> [] - | (((id,{ sit = v }) as s)::tl) when isVar v -> + | (((id,{ sit = v }) as s)::tl) when isVar v -> if id = destVar v then thin_val tl else s::(thin_val tl) | h::tl -> h::(thin_val tl) (* (replace_vars sigma M) applies substitution sigma to term M *) -let replace_vars var_alist = +let replace_vars var_alist = let var_alist = List.map (fun (str,c) -> (str,make_substituend c)) var_alist in - let var_alist = thin_val var_alist in + let var_alist = thin_val var_alist in let rec substrec n c = match kind_of_term c with | Var x -> (try lift_substituend n (List.assoc x var_alist) with Not_found -> c) | _ -> map_constr_with_binders succ substrec n c - in + in if var_alist = [] then (function x -> x) else substrec 0 (* @@ -943,7 +943,7 @@ let mkAppA v = if l=0 then anomaly "mkAppA received an empty array" else mkApp (v.(0), Array.sub v 1 (Array.length v -1)) -(* Constructs a constant *) +(* Constructs a constant *) (* The array of terms correspond to the variables introduced in the section *) let mkConst = mkConst @@ -954,7 +954,7 @@ let mkEvar = mkEvar (* The array of terms correspond to the variables introduced in the section *) let mkInd = mkInd -(* Constructs the jth constructor of the ith (co)inductive type of the +(* Constructs the jth constructor of the ith (co)inductive type of the block named kn. The array of terms correspond to the variables introduced in the section *) let mkConstruct = mkConstruct @@ -963,15 +963,15 @@ let mkConstruct = mkConstruct let mkCase = mkCase let mkCaseL (ci, p, c, ac) = mkCase (ci, p, c, Array.of_list ac) -(* If recindxs = [|i1,...in|] +(* If recindxs = [|i1,...in|] funnames = [|f1,...fn|] typarray = [|t1,...tn|] bodies = [|b1,...bn|] - then + then mkFix ((recindxs,i),(funnames,typarray,bodies)) - - constructs the ith function of the block + + constructs the ith function of the block Fixpoint f1 [ctx1] : t1 := b1 with f2 [ctx2] : t2 := b2 @@ -986,12 +986,12 @@ let mkFix = mkFix (* If funnames = [|f1,...fn|] typarray = [|t1,...tn|] bodies = [|b1,...bn|] - then + then mkCoFix (i,(funnames,typsarray,bodies)) - constructs the ith function of the block - + constructs the ith function of the block + CoFixpoint f1 : t1 := b1 with f2 : t2 := b2 ... @@ -1017,7 +1017,7 @@ let prodn n env b = | (0, env, b) -> b | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) | _ -> assert false - in + in prodrec (n,env,b) (* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) @@ -1029,7 +1029,7 @@ let lamn n env b = | (0, env, b) -> b | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) | _ -> assert false - in + in lamrec (n,env,b) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) @@ -1040,29 +1040,29 @@ let applist (f,l) = mkApp (f, Array.of_list l) let applistc f l = mkApp (f, Array.of_list l) let appvect = mkApp - + let appvectc f l = mkApp (f,l) - + (* to_lambda n (x1:T1)...(xn:Tn)T = * [x1:T1]...[xn:Tn]T *) let rec to_lambda n prod = - if n = 0 then - prod - else - match kind_of_term prod with + if n = 0 then + prod + else + match kind_of_term prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) | Cast (c,_,_) -> to_lambda n c - | _ -> errorlabstrm "to_lambda" (mt ()) + | _ -> errorlabstrm "to_lambda" (mt ()) let rec to_prod n lam = - if n=0 then + if n=0 then lam - else - match kind_of_term lam with + else + match kind_of_term lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) | Cast (c,_,_) -> to_prod n c - | _ -> errorlabstrm "to_prod" (mt ()) - + | _ -> errorlabstrm "to_prod" (mt ()) + (* pseudo-reduction rule: * [prod_app s (Prod(_,B)) N --> B[N] * with an strip_outer_cast on the first argument to produce a product *) @@ -1090,123 +1090,123 @@ let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) -let decompose_prod = +let decompose_prod = let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c - in + in prodec_rec [] (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) -let decompose_lam = +let decompose_lam = let rec lamdec_rec l c = match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c - in + in lamdec_rec [] -(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T +(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_prod_n n = if n < 0 then error "decompose_prod_n: integer parameter must be positive"; - let rec prodec_rec l n c = - if n=0 then l,c - else match kind_of_term c with + let rec prodec_rec l n c = + if n=0 then l,c + else match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | _ -> error "decompose_prod_n: not enough products" - in - prodec_rec [] n + in + prodec_rec [] n -(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T +(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_lam_n n = if n < 0 then error "decompose_lam_n: integer parameter must be positive"; - let rec lamdec_rec l n c = - if n=0 then l,c - else match kind_of_term c with + let rec lamdec_rec l n c = + if n=0 then l,c + else match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c | _ -> error "decompose_lam_n: not enough abstractions" - in - lamdec_rec [] n + in + lamdec_rec [] n (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) -let decompose_prod_assum = +let decompose_prod_assum = let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) c | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c - in + in prodec_rec empty_rel_context (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) -let decompose_lam_assum = +let decompose_lam_assum = let rec lamdec_rec l c = match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) c | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c - in + in lamdec_rec empty_rel_context -(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T +(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_prod_n_assum n = if n < 0 then error "decompose_prod_n_assum: integer parameter must be positive"; - let rec prodec_rec l n c = + let rec prodec_rec l n c = if n=0 then l,c - else match kind_of_term c with + else match kind_of_term c with | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | c -> error "decompose_prod_n_assum: not enough assumptions" - in + in prodec_rec empty_rel_context n -(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T +(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T) Lets in between are not expanded but turn into local definitions, but n is the actual number of destructurated lambdas. *) let decompose_lam_n_assum n = if n < 0 then error "decompose_lam_n_assum: integer parameter must be positive"; - let rec lamdec_rec l n c = - if n=0 then l,c - else match kind_of_term c with + let rec lamdec_rec l n c = + if n=0 then l,c + else match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) n c | Cast (c,_,_) -> lamdec_rec l n c | c -> error "decompose_lam_n_assum: not enough abstractions" - in - lamdec_rec empty_rel_context n + in + lamdec_rec empty_rel_context n (* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction * gives n (casts are ignored) *) -let nb_lam = +let nb_lam = let rec nbrec n c = match kind_of_term c with | Lambda (_,_,c) -> nbrec (n+1) c | Cast (c,_,_) -> nbrec n c | _ -> n - in + in nbrec 0 - + (* similar to nb_lam, but gives the number of products instead *) -let nb_prod = +let nb_prod = let rec nbrec n c = match kind_of_term c with | Prod (_,_,c) -> nbrec (n+1) c | Cast (c,_,_) -> nbrec n c | _ -> n - in + in nbrec 0 let prod_assum t = fst (decompose_prod_assum t) @@ -1230,7 +1230,7 @@ let strip_lam_n n t = snd (decompose_lam_n n t) type arity = rel_context * sorts -let destArity = +let destArity = let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c @@ -1238,7 +1238,7 @@ let destArity = | Cast (c,_,_) -> prodec_rec l c | Sort s -> l,s | _ -> anomaly "destArity: not an arity" - in + in prodec_rec [] let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign @@ -1252,19 +1252,19 @@ let rec isArity c = | _ -> false (*******************************) -(* alpha conversion functions *) +(* alpha conversion functions *) (*******************************) (* alpha conversion : ignore print names and casts *) -let rec eq_constr m n = +let rec eq_constr m n = (m==n) or compare_constr eq_constr m n let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) (*******************) -(* hash-consing *) +(* hash-consing *) (*******************) module Htype = diff --git a/kernel/term.mli b/kernel/term.mli index bc1cac44ae..5929250db4 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -63,13 +63,13 @@ val eq_constr : constr -> constr -> bool (* [types] is the same as [constr] but is intended to be used for documentation to indicate that such or such function specifically works - with {\em types} (i.e. terms of type a sort). + with {\em types} (i.e. terms of type a sort). (Rem:plurial form since [type] is a reserved ML keyword) *) type types = constr (*s Functions for dealing with constr terms. - The following functions are intended to simplify and to uniform the + The following functions are intended to simplify and to uniform the manipulation of terms. Some of these functions may be overlapped with previous ones. *) @@ -96,9 +96,9 @@ val mkType : Univ.universe -> types (* This defines the strategy to use for verifiying a Cast *) -type cast_kind = VMcast | DEFAULTcast +type cast_kind = VMcast | DEFAULTcast -(* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the +(* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the type $t_2$ (that means t2 is declared as the type of t1). *) val mkCast : constr * cast_kind * constr -> constr @@ -122,7 +122,7 @@ val mkNamedLetIn : identifier -> constr -> types -> constr -> constr $(f~t_1~\dots~t_n)$. *) val mkApp : constr * constr array -> constr -(* Constructs a constant *) +(* Constructs a constant *) (* The array of terms correspond to the variables introduced in the section *) val mkConst : constant -> constr @@ -132,7 +132,7 @@ val mkConst : constant -> constr (* The array of terms correspond to the variables introduced in the section *) val mkInd : inductive -> constr -(* Constructs the jth constructor of the ith (co)inductive type of the +(* Constructs the jth constructor of the ith (co)inductive type of the block named kn. The array of terms correspond to the variables introduced in the section *) val mkConstruct : constructor -> constr @@ -162,8 +162,8 @@ val mkFix : fixpoint -> constr [typarray = [|t1,...tn|]] [bodies = [b1,.....bn]] \par\noindent then [mkCoFix (i, (typsarray, funnames, bodies))] - constructs the ith function of the block - + constructs the ith function of the block + [CoFixpoint f1 = b1 with f2 = b2 ... @@ -213,7 +213,7 @@ val kind_of_term2 : constr -> ((constr,types) kind_of_term,constr) kind_of_term (* Experimental *) type ('constr, 'types) kind_of_type = | SortType of sorts - | CastType of 'types * 'types + | CastType of 'types * 'types | ProdType of name * 'types * 'types | LetInType of name * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array @@ -247,7 +247,7 @@ val is_Type : constr -> bool val iskind : constr -> bool val is_small : sorts -> bool -(*s Term destructors. +(*s Term destructors. Destructor operations are partial functions and raise [invalid_arg "dest*"] if the term has not the expected form. *) @@ -260,7 +260,7 @@ val destMeta : constr -> metavariable (* Destructs a variable *) val destVar : constr -> identifier -(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether +(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether [isprop] recognizes both \textsf{Prop} and \textsf{Set}. *) val destSort : constr -> sorts @@ -300,7 +300,7 @@ val destConstruct : constr -> constructor (* Destructs a term

Case c of lc1 | lc2 .. | lcn end *) val destCase : constr -> case_info * constr * constr * constr array -(* Destructs the $i$th function of the block +(* Destructs the $i$th function of the block $\mathit{Fixpoint} ~ f_1 ~ [ctx_1] = b_1 \mathit{with} ~ f_2 ~ [ctx_2] = b_2 \dots @@ -366,7 +366,7 @@ val applistc : constr -> constr list -> constr val appvect : constr * constr array -> constr val appvectc : constr -> constr array -> constr -(* [prodn n l b] = $(x_1:T_1)..(x_n:T_n)b$ +(* [prodn n l b] = $(x_1:T_1)..(x_n:T_n)b$ where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *) val prodn : int -> (name * constr) list -> constr -> constr @@ -384,12 +384,12 @@ val lamn : int -> (name * constr) list -> constr -> constr Inverse of [it_destLam] *) val compose_lam : (name * constr) list -> constr -> constr -(* [to_lambda n l] +(* [to_lambda n l] = $[x_1:T_1]...[x_n:T_n]T$ where $l = (x_1:T_1)...(x_n:T_n)T$ *) val to_lambda : int -> constr -> constr -(* [to_prod n l] +(* [to_prod n l] = $(x_1:T_1)...(x_n:T_n)T$ where $l = [x_1:T_1]...[x_n:T_n]T$ *) val to_prod : int -> constr -> constr @@ -414,16 +414,16 @@ val decompose_prod : constr -> (name*constr) list * constr $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a lambda. *) val decompose_lam : constr -> (name*constr) list * constr -(* Given a positive integer n, transforms a product term +(* Given a positive integer n, transforms a product term $(x_1:T_1)..(x_n:T_n)T$ into the pair $([(xn,Tn);...;(x1,T1)],T)$. *) val decompose_prod_n : int -> constr -> (name * constr) list * constr -(* Given a positive integer $n$, transforms a lambda term +(* Given a positive integer $n$, transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *) val decompose_lam_n : int -> constr -> (name * constr) list * constr -(* Extract the premisses and the conclusion of a term of the form +(* Extract the premisses and the conclusion of a term of the form "(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *) val decompose_prod_assum : types -> rel_context * types @@ -599,7 +599,7 @@ val hcons_constr: (dir_path -> dir_path) * (name -> name) * (identifier -> identifier) * - (string -> string) + (string -> string) -> (constr -> constr) * (types -> types) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index ccc62b756d..c465adfac2 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -25,7 +25,7 @@ open Typeops let constrain_type env j cst1 = function | None -> make_polymorphic_if_constant_for_ind env j, cst1 - | Some t -> + | Some t -> let (tj,cst2) = infer_type env t in let (_,cst3) = judge_of_cast env j DEFAULTcast tj in assert (t = tj.utj_val); @@ -34,7 +34,7 @@ let constrain_type env j cst1 = function let local_constrain_type env j cst1 = function | None -> j.uj_type, cst1 - | Some t -> + | Some t -> let (tj,cst2) = infer_type env t in let (_,cst3) = judge_of_cast env j DEFAULTcast tj in assert (t = tj.utj_val); @@ -59,7 +59,7 @@ let translate_local_assum env t = let safe_push_named (id,_,_ as d) env = let _ = try - let _ = lookup_named id env in + let _ = lookup_named id env in error ("Identifier "^string_of_id id^" already defined.") with Not_found -> () in push_named d env @@ -99,18 +99,18 @@ let infer_declaration env dcl = let global_vars_set_constant_type env = function | NonPolymorphicType t -> global_vars_set env t | PolymorphicArity (ctx,_) -> - Sign.fold_rel_context + Sign.fold_rel_context (fold_rel_declaration (fun t c -> Idset.union (global_vars_set env t) c)) ctx ~init:Idset.empty let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) = let ids = - match body with + match body with | None -> global_vars_set_constant_type env typ | Some b -> - Idset.union - (global_vars_set env (Declarations.force b)) + Idset.union + (global_vars_set env (Declarations.force b)) (global_vars_set_constant_type env typ) in let tps = Cemitcodes.from_val (compile_constant_body env body op boxed) in @@ -121,7 +121,7 @@ let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) = const_body_code = tps; (* const_type_code = to_patch env typ;*) const_constraints = cst; - const_opaque = op; + const_opaque = op; const_inline = inline} (*s Global and local constant declaration. *) @@ -129,9 +129,9 @@ let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) = let translate_constant env kn ce = build_constant_declaration env kn (infer_declaration env ce) -let translate_recipe env kn r = +let translate_recipe env kn r = build_constant_declaration env kn (Cooking.cook_constant env r) (* Insertion of inductive types. *) -let translate_mind env mie = check_inductive env mie +let translate_mind env mie = check_inductive env mie diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index abff3e8b74..69b13e3b8c 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -19,13 +19,13 @@ open Entries open Typeops (*i*) -val translate_local_def : env -> constr * types option -> +val translate_local_def : env -> constr * types option -> constr * types * Univ.constraints val translate_local_assum : env -> types -> types * Univ.constraints -val infer_declaration : env -> constant_entry -> +val infer_declaration : env -> constant_entry -> constr_substituted option * constant_type * constraints * bool * bool * bool val build_constant_declaration : env -> 'a -> @@ -34,8 +34,8 @@ val build_constant_declaration : env -> 'a -> val translate_constant : env -> constant -> constant_entry -> constant_body -val translate_mind : +val translate_mind : env -> mutual_inductive_entry -> mutual_inductive_body -val translate_recipe : +val translate_recipe : env -> constant -> Cooking.recipe -> constant_body diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 116a749476..2d26d27e1b 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -80,10 +80,10 @@ let error_assumption env j = let error_reference_variables env id = raise (TypeError (env, ReferenceVariables id)) -let error_elim_arity env ind aritylst c pj okinds = +let error_elim_arity env ind aritylst c pj okinds = raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds))) -let error_case_not_inductive env j = +let error_case_not_inductive env j = raise (TypeError (env, CaseNotInductive j)) let error_number_branches env cj expn = diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 38bd0d394b..9c7b6561c1 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -71,11 +71,11 @@ val error_unbound_var : env -> variable -> 'a val error_not_type : env -> unsafe_judgment -> 'a val error_assumption : env -> unsafe_judgment -> 'a - + val error_reference_variables : env -> constr -> 'a -val error_elim_arity : - env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> +val error_elim_arity : + env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a @@ -88,11 +88,11 @@ val error_generalization : env -> name * types -> unsafe_judgment -> 'a val error_actual_type : env -> unsafe_judgment -> types -> 'a -val error_cant_apply_not_functional : +val error_cant_apply_not_functional : env -> unsafe_judgment -> unsafe_judgment array -> 'a -val error_cant_apply_bad_type : - env -> int * constr * constr -> +val error_cant_apply_bad_type : + env -> int * constr * constr -> unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 53f230baae..27db208c65 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -19,15 +19,15 @@ open Entries open Reduction open Inductive open Type_errors - + let conv = default_conv CONV let conv_leq = default_conv CUMUL let conv_leq_vecti env v1 v2 = - array_fold_left2_i + array_fold_left2_i (fun i c t1 t2 -> let c' = - try default_conv CUMUL env t1 t2 + try default_conv CUMUL env t1 t2 with NotConvertible -> raise (NotConvertibleVect i) in Constraint.union c c') Constraint.empty @@ -77,13 +77,13 @@ let judge_of_type u = uj_type = mkType uu } (*s Type of a de Bruijn index. *) - -let judge_of_relative env n = + +let judge_of_relative env n = try let (_,_,typ) = lookup_rel n env in { uj_val = mkRel n; uj_type = lift n typ } - with Not_found -> + with Not_found -> error_unbound_rel env n (* Type of variables *) @@ -91,7 +91,7 @@ let judge_of_variable env id = try let ty = named_type id env in make_judge (mkVar id) ty - with Not_found -> + with Not_found -> error_unbound_var env id (* Management of context of variables. *) @@ -164,7 +164,7 @@ let type_of_constant env cst = let judge_of_constant_knowing_parameters env cst jl = let c = mkConst cst in let cb = lookup_constant cst env in - let _ = check_args env c cb.const_hyps in + let _ = check_args env c cb.const_hyps in let paramstyp = Array.map (fun j -> j.uj_type) jl in let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in make_judge c t @@ -198,25 +198,25 @@ let judge_of_letin env name defj typj j = let judge_of_apply env funj argjv = let rec apply_rec n typ cst = function - | [] -> + | [] -> { uj_val = mkApp (j_val funj, Array.map j_val argjv); uj_type = typ }, cst | hj::restjl -> (match kind_of_term (whd_betadeltaiota env typ) with | Prod (_,c1,c2) -> - (try + (try let c = conv_leq env hj.uj_type c1 in let cst' = Constraint.union cst c in apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl - with NotConvertible -> + with NotConvertible -> error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv) | _ -> error_cant_apply_not_functional env funj argjv) - in + in apply_rec 1 funj.uj_type Constraint.empty @@ -226,7 +226,7 @@ let judge_of_apply env funj argjv = let sort_of_product env domsort rangsort = match (domsort, rangsort) with - (* Product rule (s,Prop,Prop) *) + (* Product rule (s,Prop,Prop) *) | (_, Prop Null) -> rangsort (* Product rule (Prop/Set,Set,Set) *) | (Prop _, Prop Pos) -> rangsort @@ -242,7 +242,7 @@ let sort_of_product env domsort rangsort = | (Prop Pos, Type u2) -> Type (sup type0_univ u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort - (* Product rule (Type_i,Type_i,Type_i) *) + (* Product rule (Type_i,Type_i,Type_i) *) | (Type u1, Type u2) -> Type (sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule @@ -269,8 +269,8 @@ let judge_of_product env name t1 t2 = let judge_of_cast env cj k tj = let expected_type = tj.utj_val in - try - let cst = + try + let cst = match k with | VMcast -> vm_conv CUMUL env cj.uj_type expected_type | DEFAULTcast -> conv_leq env cj.uj_type expected_type in @@ -312,13 +312,13 @@ let judge_of_constructor env c = let _ = let ((kn,_),_) = c in let mib = lookup_mind kn env in - check_args env constr mib.mind_hyps in + check_args env constr mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in make_judge constr (type_of_constructor c specif) (* Case. *) -let check_branch_types env cj (lfj,explft) = +let check_branch_types env cj (lfj,explft) = try conv_leq_vecti env (Array.map j_type lfj) explft with NotConvertibleVect i -> @@ -368,16 +368,16 @@ let univ_combinator (cst,univ) (j,c') = let rec execute env cstr cu = match kind_of_term cstr with (* Atomic terms *) - | Sort (Prop c) -> + | Sort (Prop c) -> (judge_of_prop_contents c, cu) | Sort (Type u) -> (judge_of_type u, cu) - | Rel n -> + | Rel n -> (judge_of_relative env n, cu) - | Var id -> + | Var id -> (judge_of_variable env id, cu) | Const c -> @@ -391,21 +391,21 @@ let rec execute env cstr cu = | Ind ind -> (* Sort-polymorphism of inductive types *) judge_of_inductive_knowing_parameters env ind jl, cu1 - | Const cst -> + | Const cst -> (* Sort-polymorphism of constant *) judge_of_constant_knowing_parameters env cst jl, cu1 - | _ -> + | _ -> (* No sort-polymorphism *) execute env f cu1 in univ_combinator cu2 (judge_of_apply env j jl) - - | Lambda (name,c1,c2) -> + + | Lambda (name,c1,c2) -> let (varj,cu1) = execute_type env c1 cu in let env1 = push_rel (name,None,varj.utj_val) env in - let (j',cu2) = execute env1 c2 cu1 in + let (j',cu2) = execute env1 c2 cu1 in (judge_of_abstraction env name varj j', cu2) - + | Prod (name,c1,c2) -> let (varj,cu1) = execute_type env c1 cu in let env1 = push_rel (name,None,varj.utj_val) env in @@ -415,12 +415,12 @@ let rec execute env cstr cu = | LetIn (name,c1,c2,c3) -> let (j1,cu1) = execute env c1 cu in let (j2,cu2) = execute_type env c2 cu1 in - let (_,cu3) = + let (_,cu3) = univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in let (j',cu4) = execute env1 c3 cu3 in (judge_of_letin env name j1 j2 j', cu4) - + | Cast (c,k, t) -> let (cj,cu1) = execute env c cu in let (tj,cu2) = execute_type env t cu1 in @@ -431,7 +431,7 @@ let rec execute env cstr cu = | Ind ind -> (judge_of_inductive env ind, cu) - | Construct c -> + | Construct c -> (judge_of_constructor env c, cu) | Case (ci,p,c,lf) -> @@ -440,13 +440,13 @@ let rec execute env cstr cu = let (lfj,cu3) = execute_array env lf cu2 in univ_combinator cu3 (judge_of_case env ci pj cj lfj) - + | Fix ((vn,i as vni),recdef) -> let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in let fix = (vni,recdef') in check_fix env fix; (make_judge (mkFix fix) fix_ty, cu1) - + | CoFix (i,recdef) -> let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in let cofix = (i,recdef') in @@ -460,10 +460,10 @@ let rec execute env cstr cu = | Evar _ -> anomaly "the kernel does not support existential variables" -and execute_type env constr cu = +and execute_type env constr cu = let (j,cu1) = execute env constr cu in (type_judgment env j, cu1) - + and execute_recdef env (names,lar,vdef) i cu = let (larj,cu1) = execute_array env lar cu in let lara = Array.map (assumption_of_judgment env) larj in @@ -476,7 +476,7 @@ and execute_recdef env (names,lar,vdef) i cu = and execute_array env = array_fold_map' (execute env) -and execute_list env = list_fold_map' (execute env) +and execute_list env = list_fold_map' (execute env) (* Derived functions *) let infer env constr = @@ -494,11 +494,11 @@ let infer_v env cv = let (jv,(cst,_)) = execute_array env cv (Constraint.empty, universes env) in (jv, cst) - + (* Typing of several terms. *) let infer_local_decl env id = function - | LocalDef c -> + | LocalDef c -> let (j,cst) = infer env c in (Name id, Some j.uj_val, j.uj_type), cst | LocalAssum c -> @@ -507,7 +507,7 @@ let infer_local_decl env id = function let infer_local_decls env decls = let rec inferec env = function - | (id, d) :: l -> + | (id, d) :: l -> let env, l, cst1 = inferec env l in let d, cst2 = infer_local_decl env id d in push_rel d env, add_rel_decl d l, Constraint.union cst1 cst2 @@ -516,7 +516,7 @@ let infer_local_decls env decls = (* Exported typing functions *) -let typing env c = +let typing env c = let (j,cst) = infer env c in let _ = add_constraints cst env in j diff --git a/kernel/typeops.mli b/kernel/typeops.mli index 23c7556904..b0f15e75dc 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -52,23 +52,23 @@ val judge_of_constant_knowing_parameters : env -> constant -> unsafe_judgment array -> unsafe_judgment (*s Type of application. *) -val judge_of_apply : +val judge_of_apply : env -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment * constraints (*s Type of an abstraction. *) -val judge_of_abstraction : - env -> name -> unsafe_type_judgment -> unsafe_judgment +val judge_of_abstraction : + env -> name -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment (*s Type of a product. *) val judge_of_product : - env -> name -> unsafe_type_judgment -> unsafe_type_judgment + env -> name -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment (* s Type of a let in. *) val judge_of_letin : - env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment + env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment (*s Type of a cast. *) @@ -80,7 +80,7 @@ val judge_of_cast : val judge_of_inductive : env -> inductive -> unsafe_judgment -val judge_of_inductive_knowing_parameters : +val judge_of_inductive_knowing_parameters : env -> inductive -> unsafe_judgment array -> unsafe_judgment val judge_of_constructor : env -> constructor -> unsafe_judgment @@ -91,7 +91,7 @@ val judge_of_case : env -> case_info -> unsafe_judgment * constraints (* Typecheck general fixpoint (not checking guard conditions) *) -val type_fixpoint : env -> name array -> types array +val type_fixpoint : env -> name array -> types array -> unsafe_judgment array -> constraints (* Kernel safe typing but applicable to partial proofs *) @@ -101,7 +101,7 @@ val type_of_constant : env -> constant -> types val type_of_constant_type : env -> constant_type -> types -val type_of_constant_knowing_parameters : +val type_of_constant_knowing_parameters : env -> constant_type -> constr array -> types (* Make a type polymorphic if an arity *) diff --git a/kernel/univ.ml b/kernel/univ.ml index 24af5da050..ef2024c7a3 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -71,7 +71,7 @@ let make_univ (m,n) = Atom (Level (m,n)) let pr_uni_level u = str (string_of_univ_level u) let pr_uni = function - | Atom u -> + | Atom u -> pr_uni_level u | Max ([],[u]) -> str "(" ++ pr_uni_level u ++ str ")+1" @@ -86,7 +86,7 @@ let pr_uni = function (* Returns the formal universe that lies juste above the universe variable u. Used to type the sort u. *) let super = function - | Atom u -> + | Atom u -> Max ([],[u]) | Max _ -> anomaly ("Cannot take the successor of a non variable universe:\n"^ @@ -165,14 +165,14 @@ let initial_universes = UniverseLMap.empty (* repr : universes -> universe_level -> canonical_arc *) (* canonical representative : we follow the Equiv links *) -let repr g u = +let repr g u = let rec repr_rec u = let a = try UniverseLMap.find u g with Not_found -> anomalylabstrm "Univ.repr" - (str"Universe " ++ pr_uni_level u ++ str" undefined") + (str"Universe " ++ pr_uni_level u ++ str" undefined") in - match a with + match a with | Equiv(_,v) -> repr_rec v | Canonical arc -> arc in @@ -189,16 +189,16 @@ let collect g arcu = let rec coll_rec lt le = function | [],[] -> (lt, list_subtractq le lt) | arcv::lt', le' -> - if List.memq arcv lt then + if List.memq arcv lt then coll_rec lt le (lt',le') else coll_rec (arcv::lt) le ((can g (arcv.lt@arcv.le))@lt',le') - | [], arcw::le' -> - if (List.memq arcw lt) or (List.memq arcw le) then + | [], arcw::le' -> + if (List.memq arcw lt) or (List.memq arcw le) then coll_rec lt le ([],le') else coll_rec lt (arcw::le) (can g arcw.lt, (can g arcw.le)@le') - in + in coll_rec [] [] ([],[arcu]) (* reprleq : canonical_arc -> canonical_arc list *) @@ -208,19 +208,19 @@ let reprleq g arcu = | [] -> w | v :: vl -> let arcv = repr g v in - if List.memq arcv w || arcu==arcv then + if List.memq arcv w || arcu==arcv then searchrec w vl - else + else searchrec (arcv :: w) vl - in + in searchrec [] arcu.le (* between : universe_level -> canonical_arc -> canonical_arc list *) -(* between u v = {w|u<=w<=v, w canonical} *) +(* between u v = {w|u<=w<=v, w canonical} *) (* between is the most costly operation *) -let between g u arcv = +let between g u arcv = (* good are all w | u <= w <= v *) (* bad are all w | u <= w ~<= v *) (* find good and bad nodes in {w | u <= w} *) @@ -230,50 +230,50 @@ let between g u arcv = (good, bad, true) (* b or true *) else if List.memq arcu bad then input (* (good, bad, b or false) *) - else - let leq = reprleq g arcu in + else + let leq = reprleq g arcu in (* is some universe >= u good ? *) - let good, bad, b_leq = + let good, bad, b_leq = List.fold_left explore (good, bad, false) leq in if b_leq then arcu::good, bad, true (* b or true *) - else + else good, arcu::bad, b (* b or false *) in let good,_,_ = explore ([arcv],[],false) (repr g u) in good - + (* We assume compare(u,v) = LE with v canonical (see compare below). In this case List.hd(between g u v) = repr u - Otherwise, between g u v = [] + Otherwise, between g u v = [] *) type order = EQ | LT | LE | NLE (* compare : universe_level -> universe_level -> order *) -let compare g u v = - let arcu = repr g u +let compare g u v = + let arcu = repr g u and arcv = repr g v in - if arcu==arcv then + if arcu==arcv then EQ - else + else let (lt,leq) = collect g arcu in - if List.memq arcv lt then + if List.memq arcv lt then LT - else if List.memq arcv leq then + else if List.memq arcv leq then LE - else + else NLE (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ compare(u,v) = LT or LE => compare(v,u) = NLE compare(u,v) = NLE => compare(v,u) = NLE or LE or LT - Adding u>=v is consistent iff compare(v,u) # LT + Adding u>=v is consistent iff compare(v,u) # LT and then it is redundant iff compare(u,v) # NLE - Adding u>v is consistent iff compare(v,u) = NLE + Adding u>v is consistent iff compare(v,u) = NLE and then it is redundant iff compare(u,v) = LT *) let compare_eq g u v = @@ -285,7 +285,7 @@ let compare_eq g u v = type check_function = universes -> universe -> universe -> bool let incl_list cmp l1 l2 = - List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 + List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 let compare_list cmp l1 l2 = incl_list cmp l1 l2 && incl_list cmp l2 l1 @@ -358,7 +358,7 @@ let merge g u v = (* redirected to it *) let redirect (g,w,w') arcv = let g' = enter_equiv_arc arcv.univ arcu.univ g in - (g',list_unionq arcv.lt w,arcv.le@w') + (g',list_unionq arcv.lt w,arcv.le@w') in let (g',w,w') = List.fold_left redirect (g,[],[]) v in let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' w in @@ -392,7 +392,7 @@ let enforce_univ_leq u v g = let g = declare_univ u g in let g = declare_univ v g in match compare g u v with - | NLE -> + | NLE -> (match compare g v u with | LT -> error_inconsistency Le u v | LE -> merge g v u @@ -409,7 +409,7 @@ let enforce_univ_eq u v g = | EQ -> g | LT -> error_inconsistency Eq u v | LE -> merge g u v - | NLE -> + | NLE -> (match compare g v u with | LT -> error_inconsistency Eq u v | LE -> merge g v u @@ -424,13 +424,13 @@ let enforce_univ_lt u v g = | LT -> g | LE -> setlt g u v | EQ -> error_inconsistency Lt u v - | NLE -> + | NLE -> (match compare g v u with | NLE -> setlt g u v | _ -> error_inconsistency Lt u v) (* -let enforce_univ_relation g = function +let enforce_univ_relation g = function | Equiv (u,v) -> enforce_univ_eq u v g | Canonical {univ=u; lt=lt; le=le} -> let g' = List.fold_right (enforce_univ_lt u) lt g in @@ -458,14 +458,14 @@ let enforce_constraint cst g = module Constraint = Set.Make( - struct - type t = univ_constraint - let compare = Pervasives.compare + struct + type t = univ_constraint + let compare = Pervasives.compare end) - + type constraints = Constraint.t -type constraint_function = +type constraint_function = universe -> universe -> constraints -> constraints let constraint_add_leq v u c = @@ -512,17 +512,17 @@ let is_direct_constraint u = function | Atom u' -> u = u' | Max (le,lt) -> List.mem u le -(* +(* Solve a system of universe constraint of the form u_s11, ..., u_s1p1, w1 <= u1 ... u_sn1, ..., u_snpn, wn <= un -where +where - the ui (1 <= i <= n) are universe variables, - - the sjk select subsets of the ui for each equations, + - the sjk select subsets of the ui for each equations, - the wi are arbitrary complex universes that do not mention the ui. *) @@ -531,7 +531,7 @@ let is_direct_sort_constraint s v = match s with | None -> false let solve_constraints_system levels level_bounds = - let levels = + let levels = Array.map (Option.map (function Atom u -> u | _ -> anomaly "expects Atom")) levels in let v = Array.copy level_bounds in @@ -550,7 +550,7 @@ let solve_constraints_system levels level_bounds = v let subst_large_constraint u u' v = - match u with + match u with | Atom u -> if is_direct_constraint u v then sup u' (remove_large_constraint u v) else v @@ -576,8 +576,8 @@ let num_edges g = | Canonical {lt=lt;le=le} -> List.length lt + List.length le in UniverseLMap.fold (fun _ a n -> n + (reln_len a)) g 0 - -let pr_arc = function + +let pr_arc = function | Canonical {univ=u; lt=[]; le=[]} -> mt () | Canonical {univ=u; lt=lt; le=le} -> @@ -587,43 +587,43 @@ let pr_arc = function (if lt <> [] & le <> [] then spc () else mt()) ++ prlist_with_sep pr_spc (fun v -> str "<= " ++ pr_uni_level v) le) ++ fnl () - | Equiv (u,v) -> + | Equiv (u,v) -> pr_uni_level u ++ str " = " ++ pr_uni_level v ++ fnl () let pr_universes g = let graph = UniverseLMap.fold (fun k a l -> (k,a)::l) g [] in prlist (function (_,a) -> pr_arc a) graph - + let pr_constraints c = - Constraint.fold (fun (u1,op,u2) pp_std -> - let op_str = match op with + Constraint.fold (fun (u1,op,u2) pp_std -> + let op_str = match op with | Lt -> " < " | Leq -> " <= " | Eq -> " = " in pp_std ++ pr_uni_level u1 ++ str op_str ++ pr_uni_level u2 ++ fnl () ) c (str "") - + (* Dumping constrains to a file *) -let dump_universes output g = +let dump_universes output g = let dump_arc _ = function - | Canonical {univ=u; lt=lt; le=le} -> + | Canonical {univ=u; lt=lt; le=le} -> let u_str = string_of_univ_level u in - List.iter - (fun v -> + List.iter + (fun v -> Printf.fprintf output "%s < %s ;\n" u_str - (string_of_univ_level v)) + (string_of_univ_level v)) lt; - List.iter - (fun v -> + List.iter + (fun v -> Printf.fprintf output "%s <= %s ;\n" u_str - (string_of_univ_level v)) + (string_of_univ_level v)) le | Equiv (u,v) -> Printf.fprintf output "%s = %s ;\n" (string_of_univ_level u) (string_of_univ_level v) in - UniverseLMap.iter dump_arc g + UniverseLMap.iter dump_arc g (* Hash-consing *) diff --git a/kernel/univ.mli b/kernel/univ.mli index 225dce9a6c..2bfcc2aa86 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -53,7 +53,7 @@ type constraint_function = universe -> universe -> constraints -> constraints val enforce_geq : constraint_function val enforce_eq : constraint_function -(*s Merge of constraints in a universes graph. +(*s Merge of constraints in a universes graph. The function [merge_constraints] merges a set of constraints in a given universes graph. It raises the exception [UniverseInconsistency] if the constraints are not satisfiable. *) @@ -68,12 +68,12 @@ val merge_constraints : constraints -> universes -> universes val fresh_local_univ : unit -> universe -val solve_constraints_system : universe option array -> universe array -> +val solve_constraints_system : universe option array -> universe array -> universe array val subst_large_constraint : universe -> universe -> universe -> universe -val subst_large_constraints : +val subst_large_constraints : (universe * universe) list -> universe -> universe val no_upper_constraints : universe -> constraints -> bool diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 7c515735df..0dd119f7bb 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -3,10 +3,10 @@ open Declarations open Term open Environ open Conv_oracle -open Reduction +open Reduction open Closure open Vm -open Csymtable +open Csymtable open Univ let val_of_constr env c = @@ -27,7 +27,7 @@ let rec compare_stack stk1 stk2 = | z1::stk1, z2::stk2 -> if compare_zipper z1 z2 then compare_stack stk1 stk2 else false - | _, _ -> false + | _, _ -> false (* Conversion *) let conv_vect fconv vect1 vect2 cu = @@ -42,13 +42,13 @@ let conv_vect fconv vect1 vect2 cu = let infos = ref (create_clos_infos betaiotazeta Environ.empty_env) -let rec conv_val pb k v1 v2 cu = - if v1 == v2 then cu +let rec conv_val pb k v1 v2 cu = + if v1 == v2 then cu else conv_whd pb k (whd_val v1) (whd_val v2) cu - -and conv_whd pb k whd1 whd2 cu = + +and conv_whd pb k whd1 whd2 cu = match whd1, whd2 with - | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu + | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu | Vprod p1, Vprod p2 -> let cu = conv_val CONV k (dom p1) (dom p2) cu in conv_fun pb k (codom p1) (codom p2) cu @@ -58,11 +58,11 @@ and conv_whd pb k whd1 whd2 cu = if nargs args1 <> nargs args2 then raise NotConvertible else conv_arguments k args1 args2 (conv_fix k f1 f2 cu) | Vcofix (cf1,_,None), Vcofix (cf2,_,None) -> conv_cofix k cf1 cf2 cu - | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) -> + | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) -> if nargs args1 <> nargs args2 then raise NotConvertible else conv_arguments k args1 args2 (conv_cofix k cf1 cf2 cu) - | Vconstr_const i1, Vconstr_const i2 -> - if i1 = i2 then cu else raise NotConvertible + | Vconstr_const i1, Vconstr_const i2 -> + if i1 = i2 then cu else raise NotConvertible | Vconstr_block b1, Vconstr_block b2 -> let sz = bsize b1 in if btag b1 = btag b2 && sz = bsize b2 then @@ -72,11 +72,11 @@ and conv_whd pb k whd1 whd2 cu = done; !rcu else raise NotConvertible - | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> + | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom pb k a1 stk1 a2 stk2 cu - | _, Vatom_stk(Aiddef(_,v),stk) -> + | _, Vatom_stk(Aiddef(_,v),stk) -> conv_whd pb k whd1 (force_whd v stk) cu - | Vatom_stk(Aiddef(_,v),stk), _ -> + | Vatom_stk(Aiddef(_,v),stk), _ -> conv_whd pb k (force_whd v stk) whd2 cu | _, _ -> raise NotConvertible @@ -87,18 +87,18 @@ and conv_atom pb k a1 stk1 a2 stk2 cu = then conv_stack k stk1 stk2 cu else raise NotConvertible - | Aid ik1, Aid ik2 -> - if ik1 = ik2 && compare_stack stk1 stk2 then - conv_stack k stk1 stk2 cu + | Aid ik1, Aid ik2 -> + if ik1 = ik2 && compare_stack stk1 stk2 then + conv_stack k stk1 stk2 cu else raise NotConvertible | Aiddef(ik1,v1), Aiddef(ik2,v2) -> begin try if ik1 = ik2 && compare_stack stk1 stk2 then - conv_stack k stk1 stk2 cu + conv_stack k stk1 stk2 cu else raise NotConvertible with NotConvertible -> - if oracle_order ik1 ik2 then + if oracle_order ik1 ik2 then conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu end @@ -106,15 +106,15 @@ and conv_atom pb k a1 stk1 a2 stk2 cu = conv_whd pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu | _, Aiddef(ik2,v2) -> conv_whd pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu - | _, _ -> raise NotConvertible - + | _, _ -> raise NotConvertible + and conv_stack k stk1 stk2 cu = match stk1, stk2 with | [], [] -> cu | Zapp args1 :: stk1, Zapp args2 :: stk2 -> - conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu) + conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu) | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 -> - conv_stack k stk1 stk2 + conv_stack k stk1 stk2 (conv_arguments k args1 args2 (conv_fix k f1 f2 cu)) | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 -> if check_switch sw1 sw2 then @@ -122,7 +122,7 @@ and conv_stack k stk1 stk2 cu = let rcu = ref (conv_val CONV k vt1 vt2 cu) in let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in for i = 0 to Array.length b1 - 1 do - rcu := + rcu := conv_val CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu done; conv_stack k stk1 stk2 !rcu @@ -136,7 +136,7 @@ and conv_fun pb k f1 f2 cu = conv_val pb (k+arity) b1 b2 cu and conv_fix k f1 f2 cu = - if f1 == f2 then cu + if f1 == f2 then cu else if check_fix f1 f2 then let bf1, tf1 = reduce_fix k f1 in @@ -168,33 +168,33 @@ and conv_arguments k args1 args2 cu = else raise NotConvertible let rec conv_eq pb t1 t2 cu = - if t1 == t2 then cu + if t1 == t2 then cu else match kind_of_term t1, kind_of_term t2 with - | Rel n1, Rel n2 -> + | Rel n1, Rel n2 -> if n1 = n2 then cu else raise NotConvertible | Meta m1, Meta m2 -> if m1 = m2 then cu else raise NotConvertible - | Var id1, Var id2 -> + | Var id1, Var id2 -> if id1 = id2 then cu else raise NotConvertible | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu - | Prod (_,t1,c1), Prod (_,t2,c2) -> + | Prod (_,t1,c1), Prod (_,t2,c2) -> conv_eq pb c1 c2 (conv_eq CONV t1 t2 cu) | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq CONV c1 c2 cu - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> conv_eq pb c1 c2 (conv_eq CONV b1 b2 cu) | App (c1,l1), App (c2,l2) -> conv_eq_vect l1 l2 (conv_eq CONV c1 c2 cu) | Evar (e1,l1), Evar (e2,l2) -> if e1 = e2 then conv_eq_vect l1 l2 cu else raise NotConvertible - | Const c1, Const c2 -> + | Const c1, Const c2 -> if c1 = c2 then cu else raise NotConvertible - | Ind c1, Ind c2 -> + | Ind c1, Ind c2 -> if c1 = c2 then cu else raise NotConvertible - | Construct c1, Construct c2 -> + | Construct c1, Construct c2 -> if c1 = c2 then cu else raise NotConvertible | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> let pcu = conv_eq CONV p1 p2 cu in @@ -203,7 +203,7 @@ let rec conv_eq pb t1 t2 cu = | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu) else raise NotConvertible - | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu) else raise NotConvertible | _ -> raise NotConvertible @@ -216,7 +216,7 @@ and conv_eq_vect vt1 vt2 cu = rcu := conv_eq CONV vt1.(i) vt2.(i) !rcu done; !rcu else raise NotConvertible - + let vconv pb env t1 t2 = let cu = try conv_eq pb t1 t2 Constraint.empty @@ -227,7 +227,7 @@ let vconv pb env t1 t2 = let cu = conv_val pb (nb_rel env) v1 v2 Constraint.empty in cu in cu - + let _ = Reduction.set_vm_conv vconv let use_vm = ref false @@ -236,7 +236,7 @@ let set_use_vm b = use_vm := b; if b then Reduction.set_default_conv vconv else Reduction.set_default_conv Reduction.conv_cmp - + let use_vm _ = !use_vm diff --git a/kernel/vm.ml b/kernel/vm.ml index 665e00a305..576c209970 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -39,11 +39,11 @@ external set_transp_values : bool -> unit = "coq_set_transp_value" (* Le code machine ************************) (*******************************************) -type tcode +type tcode let tcode_of_obj v = ((Obj.obj v):tcode) -let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) +let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) + - external mkAccuCode : int -> tcode = "coq_makeaccu" external mkPopStopCode : int -> tcode = "coq_pushpop" @@ -57,21 +57,21 @@ let accumulate = accumulate () external is_accumulate : tcode -> bool = "coq_is_accumulate_code" -let popstop_tbl = ref (Array.init 30 mkPopStopCode) +let popstop_tbl = ref (Array.init 30 mkPopStopCode) let popstop_code i = let len = Array.length !popstop_tbl in - if i < len then !popstop_tbl.(i) + if i < len then !popstop_tbl.(i) else begin popstop_tbl := Array.init (i+10) (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j); - !popstop_tbl.(i) + !popstop_tbl.(i) end let stop = popstop_code 0 - + (******************************************************) (* Types de donnees abstraites et fonctions associees *) (******************************************************) @@ -81,23 +81,23 @@ let val_of_obj v = ((Obj.obj v):values) let crasy_val = (val_of_obj (Obj.repr 0)) (* Abstract data *) -type vprod +type vprod type vfun type vfix type vcofix type vblock type arguments -type vm_env +type vm_env type vstack = values array type vswitch = { - sw_type_code : tcode; - sw_code : tcode; + sw_type_code : tcode; + sw_code : tcode; sw_annot : annot_switch; sw_stk : vstack; sw_env : vm_env - } + } (* Representation des types abstraits: *) (* + Les produits : *) @@ -105,10 +105,10 @@ type vswitch = { (* dom : values, codom : vfun *) (* *) (* + Les fonctions ont deux representations possibles : *) -(* - fonction non applique : vf = Ct_[ C | fv1 | ... | fvn] *) +(* - fonction non applique : vf = Ct_[ C | fv1 | ... | fvn] *) (* C:tcode, fvi : values *) (* Remarque : il n'y a pas de difference entre la fct et son *) -(* environnement. *) +(* environnement. *) (* - Application partielle : Ct_[Restart:C| vf | arg1 | ... argn] *) (* *) (* + Les points fixes : *) @@ -138,7 +138,7 @@ type vswitch = { (* -- 4_[accu|vswitch] : un case bloque par un accu *) (* -- 5_[fcofix] : une fonction de cofix *) (* -- 6_[fcofix|val] : une fonction de cofix, val represente *) -(* la valeur de la reduction de la fct applique a arg1 ... argn *) +(* la valeur de la reduction de la fct applique a arg1 ... argn *) (* Le type [arguments] est utiliser de maniere abstraite comme un *) (* tableau, il represente la structure de donnee suivante : *) (* tag[ _ | _ |v1|... | vn] *) @@ -146,7 +146,7 @@ type vswitch = { (* Ne pas changer ce type sans modifier le code C, *) (* en particulier le fichier "coq_values.h" *) -type atom = +type atom = | Aid of id_key | Aiddef of id_key * values | Aind of inductive @@ -164,7 +164,7 @@ type to_up = values type whd = | Vsort of sorts - | Vprod of vprod + | Vprod of vprod | Vfun of vfun | Vfix of vfix * arguments option | Vcofix of vcofix * to_up * arguments option @@ -177,16 +177,16 @@ type whd = (*************************************************) let rec whd_accu a stk = - let stk = + let stk = if Obj.size a = 2 then stk else Zapp (Obj.obj a) :: stk in let at = Obj.field a 1 in match Obj.tag at with - | i when i <= 2 -> + | i when i <= 2 -> Vatom_stk(Obj.magic at, stk) | 3 (* fix_app tag *) -> let fa = Obj.field at 1 in - let zfix = + let zfix = Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in whd_accu (Obj.field at 0) (zfix :: stk) | 4 (* switch tag *) -> @@ -194,7 +194,7 @@ let rec whd_accu a stk = whd_accu (Obj.field at 0) (zswitch :: stk) | 5 (* cofix_tag *) -> begin match stk with - | [] -> + | [] -> let vcfx = Obj.obj (Obj.field at 0) in let to_up = Obj.obj a in Vcofix(vcfx, to_up, None) @@ -210,7 +210,7 @@ let rec whd_accu a stk = let vcofix = Obj.obj (Obj.field at 0) in let res = Obj.obj a in Vcofix(vcofix, res, None) - | [Zapp args] -> + | [Zapp args] -> let vcofix = Obj.obj (Obj.field at 0) in let res = Obj.obj a in Vcofix(vcofix, res, Some args) @@ -221,18 +221,18 @@ let rec whd_accu a stk = external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" let whd_val : values -> whd = - fun v -> - let o = Obj.repr v in + fun v -> + let o = Obj.repr v in if Obj.is_int o then Vconstr_const (Obj.obj o) - else + else let tag = Obj.tag o in if tag = accu_tag then ( if Obj.size o = 1 then Obj.obj o (* sort *) - else + else if is_accumulate (fun_code o) then whd_accu o [] else (Vprod(Obj.obj o))) - else + else if tag = Obj.closure_tag || tag = Obj.infix_tag then ( match kind_of_closure o with | 0 -> Vfun(Obj.obj o) @@ -241,7 +241,7 @@ let whd_val : values -> whd = | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) | _ -> Util.anomaly "Vm.whd : kind_of_closure does not work") else Vconstr_block(Obj.obj o) - + (************************************************) @@ -263,16 +263,16 @@ external interprete : tcode -> values -> vm_env -> int -> values = (* Functions over arguments *) let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 -let arg args i = - if 0 <= i && i < (nargs args) then +let arg args i = + if 0 <= i && i < (nargs args) then val_of_obj (Obj.field (Obj.repr args) (i+2)) - else raise (Invalid_argument + else raise (Invalid_argument ("Vm.arg size = "^(string_of_int (nargs args))^ " acces "^(string_of_int i))) let apply_arguments vf vargs = let n = nargs vargs in - if n = 0 then vf + if n = 0 then vf else begin push_ra stop; @@ -283,7 +283,7 @@ let apply_arguments vf vargs = let apply_vstack vf vstk = let n = Array.length vstk in if n = 0 then vf - else + else begin push_ra stop; push_vstack vstk; @@ -295,23 +295,23 @@ let apply_vstack vf vstk = (**********************************************) let obj_of_atom : atom -> Obj.t = - fun a -> + fun a -> let res = Obj.new_block accu_tag 2 in Obj.set_field res 0 (Obj.repr accumulate); Obj.set_field res 1 (Obj.repr a); - res + res (* obj_of_str_const : structured_constant -> Obj.t *) let rec obj_of_str_const str = - match str with + match str with | Const_sorts s -> Obj.repr (Vsort s) | Const_ind ind -> obj_of_atom (Aind ind) | Const_b0 tag -> Obj.repr tag | Const_bn(tag, args) -> let len = Array.length args in let res = Obj.new_block tag len in - for i = 0 to len - 1 do - Obj.set_field res i (obj_of_str_const args.(i)) + for i = 0 to len - 1 do + Obj.set_field res i (obj_of_str_const args.(i)) done; res @@ -324,8 +324,8 @@ let val_of_atom a = val_of_obj (obj_of_atom a) let idkey_tbl = Hashtbl.create 31 let val_of_idkey key = - try Hashtbl.find idkey_tbl key - with Not_found -> + try Hashtbl.find idkey_tbl key + with Not_found -> let v = val_of_atom (Aid key) in Hashtbl.add idkey_tbl key v; v @@ -335,9 +335,9 @@ let val_of_rel_def k v = val_of_atom(Aiddef(RelKey k, v)) let val_of_named id = val_of_idkey (VarKey id) let val_of_named_def id v = val_of_atom(Aiddef(VarKey id, v)) - + let val_of_constant c = val_of_idkey (ConstKey c) -let val_of_constant_def n c v = +let val_of_constant_def n c v = let res = Obj.new_block accu_tag 2 in Obj.set_field res 0 (Obj.repr (mkAccuCond n)); Obj.set_field res 1 (Obj.repr (Aiddef(ConstKey c, v))); @@ -354,7 +354,7 @@ let mkrel_vstack k arity = (* Functions over products *) -let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) +let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) let codom : vprod -> vfun = fun p -> (Obj.obj (Obj.field (Obj.repr p) 1)) (* Functions over vfun *) @@ -383,7 +383,7 @@ let current_fix vf = - (offset (Obj.repr vf) / 2) let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i)) let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 - + let rec_args vf = let fb = first (Obj.repr vf) in let size = Obj.size (last fb) in @@ -391,7 +391,7 @@ let rec_args vf = exception FALSE -let check_fix f1 f2 = +let check_fix f1 f2 = let i1, i2 = current_fix f1, current_fix f2 in (* Verification du point de depart *) if i1 = i2 then @@ -407,22 +407,22 @@ let check_fix f1 f2 = done; true with FALSE -> false - else false + else false else false (* Functions over vfix *) external atom_rel : unit -> atom array = "get_coq_atom_tbl" external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl" -let relaccu_tbl = +let relaccu_tbl = let atom_rel = atom_rel() in let len = Array.length atom_rel in for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done; - ref (Array.init len mkAccuCode) + ref (Array.init len mkAccuCode) let relaccu_code i = let len = Array.length !relaccu_tbl in - if i < len then !relaccu_tbl.(i) + if i < len then !relaccu_tbl.(i) else begin realloc_atom_rel i; @@ -432,7 +432,7 @@ let relaccu_code i = relaccu_tbl := Array.init nl (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j); - !relaccu_tbl.(i) + !relaccu_tbl.(i) end let reduce_fix k vf = @@ -441,8 +441,8 @@ let reduce_fix k vf = let fc_typ = ((Obj.obj (last fb)) : tcode array) in let ndef = Array.length fc_typ in let et = offset_closure fb (2*(ndef - 1)) in - let ftyp = - Array.map + let ftyp = + Array.map (fun c -> interprete c crasy_val (Obj.magic et) 0) fc_typ in (* Construction de l' environnement des corps des points fixes *) let e = Obj.dup fb in @@ -455,12 +455,12 @@ let reduce_fix k vf = let res = Obj.new_block Obj.closure_tag 2 in Obj.set_field res 0 (Obj.repr c); Obj.set_field res 1 (offset_closure e (2*i)); - ((Obj.obj res) : vfun) in + ((Obj.obj res) : vfun) in (Array.init ndef fix_body, ftyp) - + (* Functions over vcofix *) -let get_fcofix vcf i = +let get_fcofix vcf i = match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with | Vcofix(vcfi, _, _) -> vcfi | _ -> assert false @@ -482,29 +482,29 @@ let check_cofix vcf1 vcf2 = let reduce_cofix k vcf = let fc_typ = ((Obj.obj (last (Obj.repr vcf))) : tcode array) in let ndef = Array.length fc_typ in - let ftyp = + let ftyp = Array.map (fun c -> interprete c crasy_val (Obj.magic vcf) 0) fc_typ in (* Construction de l'environnement des corps des cofix *) - let e = Obj.dup (Obj.repr vcf) in + let e = Obj.dup (Obj.repr vcf) in for i = 0 to ndef - 1 do - Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) + Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) done; - + let cofix_body i = let vcfi = get_fcofix vcf i in let c = Obj.field (Obj.repr vcfi) 0 in - Obj.set_field e 0 c; + Obj.set_field e 0 c; let atom = Obj.new_block cofix_tag 1 in let self = Obj.new_block accu_tag 2 in Obj.set_field self 0 (Obj.repr accumulate); Obj.set_field self 1 (Obj.repr atom); - apply_vstack (Obj.obj e) [|Obj.obj self|] in + apply_vstack (Obj.obj e) [|Obj.obj self|] in (Array.init ndef cofix_body, ftyp) (* Functions over vblock *) - + let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b) let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b) let bfield b i = @@ -514,15 +514,15 @@ let bfield b i = (* Functions over vswitch *) -let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl - +let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl + let case_info sw = sw.sw_annot.ci - -let type_of_switch sw = + +let type_of_switch sw = push_vstack sw.sw_stk; - interprete sw.sw_type_code crasy_val sw.sw_env 0 - -let branch_arg k (tag,arity) = + interprete sw.sw_type_code crasy_val sw.sw_env 0 + +let branch_arg k (tag,arity) = if arity = 0 then ((Obj.magic tag):values) else let b = Obj.new_block tag arity in @@ -533,38 +533,38 @@ let branch_arg k (tag,arity) = let apply_switch sw arg = let tc = sw.sw_annot.tailcall in - if tc then + if tc then (push_ra stop;push_vstack sw.sw_stk) - else + else (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk))); interprete sw.sw_code arg sw.sw_env 0 - + let branch_of_switch k sw = let eval_branch (_,arity as ta) = let arg = branch_arg k ta in let v = apply_switch sw arg in (arity, v) - in + in Array.map eval_branch sw.sw_annot.rtbl - + (* Evaluation *) -let is_accu v = +let is_accu v = let o = Obj.repr v in - Obj.is_block o && Obj.tag o = accu_tag && - fun_code v == accumulate && Obj.tag (Obj.field o 1) < cofix_tag + Obj.is_block o && Obj.tag o = accu_tag && + fun_code v == accumulate && Obj.tag (Obj.field o 1) < cofix_tag -let rec whd_stack v stk = +let rec whd_stack v stk = match stk with | [] -> whd_val v | Zapp args :: stkt -> whd_stack (apply_arguments v args) stkt - | Zfix (f,args) :: stkt -> + | Zfix (f,args) :: stkt -> let o = Obj.repr v in if Obj.is_block o && Obj.tag o = accu_tag then whd_accu (Obj.repr v) stk - else + else let v', stkt = match stkt with | Zapp args' :: stkt -> @@ -573,30 +573,30 @@ let rec whd_stack v stk = push_val v; push_arguments args; let v' = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) + interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args+ nargs args') in v', stkt - | _ -> + | _ -> push_ra stop; push_val v; push_arguments args; let v' = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) + interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) in v', stkt in whd_stack v' stkt - | Zswitch sw :: stkt -> + | Zswitch sw :: stkt -> let o = Obj.repr v in if Obj.is_block o && Obj.tag o = accu_tag then if Obj.tag (Obj.field o 1) < cofix_tag then whd_accu (Obj.repr v) stk else - let to_up = + let to_up = match whd_accu (Obj.repr v) [] with | Vcofix (_, to_up, _) -> to_up | _ -> assert false in whd_stack (apply_switch sw to_up) stkt - else whd_stack (apply_switch sw v) stkt + else whd_stack (apply_switch sw v) stkt let rec force_whd v stk = match whd_stack v stk with diff --git a/kernel/vm.mli b/kernel/vm.mli index 279ac93709..84de8f270f 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -9,11 +9,11 @@ val set_drawinstr : unit -> unit val transp_values : unit -> bool val set_transp_values : bool -> unit (* le code machine *) -type tcode +type tcode (* Les valeurs ***********) -type vprod +type vprod type vfun type vfix type vcofix @@ -21,7 +21,7 @@ type vblock type vswitch type arguments -type atom = +type atom = | Aid of id_key | Aiddef of id_key * values | Aind of inductive @@ -39,30 +39,30 @@ type to_up type whd = | Vsort of sorts - | Vprod of vprod + | Vprod of vprod | Vfun of vfun | Vfix of vfix * arguments option | Vcofix of vcofix * to_up * arguments option | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack - + (** Constructors *) val val_of_str_const : structured_constant -> values -val val_of_rel : int -> values -val val_of_rel_def : int -> values -> values +val val_of_rel : int -> values +val val_of_rel_def : int -> values -> values val val_of_named : identifier -> values val val_of_named_def : identifier -> values -> values -val val_of_constant : constant -> values +val val_of_constant : constant -> values val val_of_constant_def : int -> constant -> values -> values (** Destructors *) val whd_val : values -> whd -(* Arguments *) +(* Arguments *) val nargs : arguments -> int val arg : arguments -> int -> values @@ -71,18 +71,18 @@ val dom : vprod -> values val codom : vprod -> vfun (* Function *) -val body_of_vfun : int -> vfun -> values +val body_of_vfun : int -> vfun -> values val decompose_vfun2 : int -> vfun -> vfun -> int * values * values (* Fix *) val current_fix : vfix -> int val check_fix : vfix -> vfix -> bool -val rec_args : vfix -> int array +val rec_args : vfix -> int array val reduce_fix : int -> vfix -> vfun array * values array (* bodies , types *) (* CoFix *) -val current_cofix : vcofix -> int +val current_cofix : vcofix -> int val check_cofix : vcofix -> vcofix -> bool val reduce_cofix : int -> vcofix -> values array * values array (* bodies , types *) diff --git a/lib/bigint.ml b/lib/bigint.ml index 3b974652b9..f505bbe14e 100644 --- a/lib/bigint.ml +++ b/lib/bigint.ml @@ -19,8 +19,8 @@ open Pp (* An integer is canonically represented as an array of k-digits blocs. 0 is represented by the empty array and -1 by the singleton [|-1|]. - The first bloc is in the range ]0;10^k[ for positive numbers. - The first bloc is in the range ]-10^k;-1[ for negative ones. + The first bloc is in the range ]0;10^k[ for positive numbers. + The first bloc is in the range ]-10^k;-1[ for negative ones. All other blocs are numbers in the range [0;10^k[. Negative numbers are represented using 2's complementation. For instance, @@ -78,7 +78,7 @@ let normalize_neg n = if Array.length n' = 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n') let rec normalize n = - if Array.length n = 0 then n else + if Array.length n = 0 then n else if n.(0) = -1 then normalize_neg n else normalize_pos n let neg m = @@ -192,7 +192,7 @@ let euclid m d = if is_strictly_neg m then (-1),neg m else 1,Array.copy m in let isnegd, d = if is_strictly_neg d then (-1),neg d else 1,d in if d = zero then raise Division_by_zero; - let q,r = + let q,r = if less_than m d then (zero,m) else let ql = Array.length m - Array.length d in let q = Array.create (ql+1) 0 in @@ -200,7 +200,7 @@ let euclid m d = while not (less_than_shift_pos !i m d) do if m.(!i)=0 then incr i else if can_divide !i m d 0 then begin - let v = + let v = if Array.length d > 1 && d.(0) <> m.(!i) then (m.(!i) * base + m.(!i+1)) / (d.(0) * base + d.(1) + 1) else @@ -232,11 +232,11 @@ let of_string s = let r = (String.length s - !d) mod size in let h = String.sub s (!d) r in if !d = String.length s - 1 && isneg && h="1" then neg_one else - let e = if h<>"" then 1 else 0 in + let e = if h<>"" then 1 else 0 in let l = (String.length s - !d) / size in let a = Array.create (l + e + n) 0 in if isneg then begin - a.(0) <- (-1); + a.(0) <- (-1); let carry = ref 0 in for i=l downto 1 do let v = int_of_string (String.sub s ((i-1)*size + !d +r) size)+ !carry in @@ -296,7 +296,7 @@ let app_pair f (m, n) = (f m, f n) let add m n = - if Obj.is_int m & Obj.is_int n + if Obj.is_int m & Obj.is_int n then big_of_int (coerce_to_int m + coerce_to_int n) else big_of_ints (add (ints_of_z m) (ints_of_z n)) @@ -311,8 +311,8 @@ let mult m n = else big_of_ints (mult (ints_of_z m) (ints_of_z n)) let euclid m n = - if Obj.is_int m & Obj.is_int n - then app_pair big_of_int + if Obj.is_int m & Obj.is_int n + then app_pair big_of_int (coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n) else app_pair big_of_ints (euclid (ints_of_z m) (ints_of_z n)) @@ -360,12 +360,12 @@ let pow = let (quo,rem) = div2_with_rest m in pow_aux ((* [if m mod 2 = 1]*) - if rem then + if rem then mult n odd_rest else odd_rest ) (* quo = [m/2] *) - (mult n n) quo + (mult n n) quo in pow_aux one @@ -393,7 +393,7 @@ let check () = let s = Printf.sprintf "%30s" (to_string n) in let s' = Printf.sprintf "% 30.0f" (round n') in if s <> s' then Printf.printf "%s: %s <> %s\n" op s s' in -List.iter (fun a -> List.iter (fun b -> +List.iter (fun a -> List.iter (fun b -> let n = of_string a and m = of_string b in let n' = float_of_string a and m' = float_of_string b in let a = add n m and a' = n' +. m' in diff --git a/lib/bstack.ml b/lib/bstack.ml index b4232ebcf0..4191ccdb15 100644 --- a/lib/bstack.ml +++ b/lib/bstack.ml @@ -47,10 +47,10 @@ let push bs e = incr_size bs; bs.depth <- bs.depth + 1; bs.stack.(bs.pos) <- e - + let pop bs = if bs.size > 1 then begin - bs.size <- bs.size - 1; + bs.size <- bs.size - 1; bs.depth <- bs.depth - 1; let oldpos = bs.pos in decr_pos bs; @@ -61,7 +61,7 @@ let pop bs = let top bs = if bs.size >= 1 then bs.stack.(bs.pos) else error "Nothing on the stack" - + let app_push bs f = if bs.size = 0 then error "Nothing on the stack" else push bs (f (bs.stack.(bs.pos))) diff --git a/lib/compat.ml4 b/lib/compat.ml4 index 481b9f8d46..7566624b80 100644 --- a/lib/compat.ml4 +++ b/lib/compat.ml4 @@ -12,8 +12,8 @@ IFDEF OCAML309 THEN DEFINE OCAML308 END -IFDEF CAMLP5 THEN -module M = struct +IFDEF CAMLP5 THEN +module M = struct type loc = Stdpp.location let dummy_loc = Stdpp.dummy_loc let make_loc = Stdpp.make_loc @@ -39,11 +39,11 @@ let unloc (b,e) = loc let join_loc loc1 loc2 = if loc1 = dummy_loc or loc2 = dummy_loc then dummy_loc - else (fst loc1, snd loc2) + else (fst loc1, snd loc2) type token = Token.t type lexer = Token.lexer end -ELSE +ELSE module M = struct type loc = int * int let dummy_loc = (0,0) diff --git a/lib/dnet.ml b/lib/dnet.ml index b5a7bb7283..0236cdab3a 100644 --- a/lib/dnet.ml +++ b/lib/dnet.ml @@ -10,8 +10,8 @@ (* Generic dnet implementation over non-recursive types *) -module type Datatype = -sig +module type Datatype = +sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t @@ -44,11 +44,11 @@ sig val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t end -module Make = - functor (T:Datatype) -> - functor (Ident:Set.OrderedType) -> +module Make = + functor (T:Datatype) -> + functor (Ident:Set.OrderedType) -> functor (Meta:Set.OrderedType) -> -struct +struct type ident = Ident.t type meta = Meta.t @@ -58,7 +58,7 @@ struct | Meta of meta type 'a structure = 'a T.t - + module Idset = Set.Make(Ident) module Mmap = Map.Make(Meta) module Tmap = Map.Make(struct type t = unit structure @@ -70,7 +70,7 @@ struct (* we store identifiers at the leaf of the dnet *) - type node = + type node = | Node of t structure | Terminal of t structure * idset @@ -85,7 +85,7 @@ struct (* given a node of the net and a word, returns the subnet with the same head as the word (with the rest of the nodes) *) - let split l (w:'a structure) : node * node Tmap.t = + let split l (w:'a structure) : node * node Tmap.t = let elt : node = Tmap.find (head w) l in (elt, Tmap.remove (head w) l) @@ -101,24 +101,24 @@ struct Nodes ((Tmap.add (head w) new_node tl), m) with Not_found -> let new_content = T.map (fun p -> add empty p id) w in - let new_node = + let new_node = if T.terminal w then Terminal (new_content, Idset.singleton id) else Node new_content in Nodes ((Tmap.add (head w) new_node t), m) ) - | Meta i -> - let m = + | Meta i -> + let m = try Mmap.add i (Idset.add id (Mmap.find i m)) m with Not_found -> Mmap.add i (Idset.singleton id) m in Nodes (t, m) let add t w id = add t w id - + let rec find_all (Nodes (t,m)) : idset = Idset.union (Mmap.fold (fun _ -> Idset.union) m Idset.empty) (Tmap.fold - ( fun _ n acc -> + ( fun _ n acc -> let s2 = match n with | Terminal (_,is) -> is | Node e -> T.choose find_all e in @@ -137,44 +137,44 @@ struct | (Some s, _ | _, Some s) -> s | _ -> raise Not_found - let fold_pattern ?(complete=true) f acc pat dn = + let fold_pattern ?(complete=true) f acc pat dn = let deferred = ref [] in let leafs,metas = ref None, ref None in - let leaf s = leafs := match !leafs with + let leaf s = leafs := match !leafs with | None -> Some s | Some s' -> Some (fast_inter s s') in let meta s = metas := match !metas with | None -> Some s | Some s' -> Some (Idset.union s s') in let defer c = deferred := c::!deferred in - let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = + let rec fp_rec (p:term_pattern) (Nodes(t,m) as dn:t) = Mmap.iter (fun _ -> meta) m; (* TODO: gérer patterns nonlin ici *) match p with | Meta m -> defer (m,dn) - | Term w -> + | Term w -> try match select t w with | Terminal (_,is) -> leaf is - | Node e -> + | Node e -> if complete then T.fold2 (fun _ -> fp_rec) () w e else - if T.fold2 + if T.fold2 (fun b p dn -> match p with | Term _ -> fp_rec p dn; false | Meta _ -> b ) true w e then T.choose (T.choose fp_rec w) e - with Not_found -> + with Not_found -> if Mmap.is_empty m then raise Not_found else () in try fp_rec pat dn; - (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), + (try Some (option_any2 Idset.union !leafs !metas) with Not_found -> None), List.fold_left (fun acc (m,dn) -> f m dn acc) acc !deferred with Not_found | Empty -> None,acc (* intersection of two dnets. keep only the common pairs *) let rec inter (t1:t) (t2:t) : t = let inter_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = - Nodes - (Tmap.fold + Nodes + (Tmap.fold ( fun k e acc -> try Tmap.add k (f e (Tmap.find k t2)) acc with Not_found -> acc @@ -193,8 +193,8 @@ struct ) t1 t2 let rec union (t1:t) (t2:t) : t = - let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = - Nodes + let union_map f (Nodes (t1,m1):t) (Nodes (t2,m2):t) : t = + Nodes (Tmap.fold ( fun k e acc -> try Tmap.add k (f e (Tmap.find k acc)) acc @@ -211,12 +211,12 @@ struct | Terminal (e1,s1), Terminal (_,s2) -> Terminal (e1,Idset.union s1 s2) | Node e1, Node e2 -> Node (T.map2 union e1 e2) | _ -> assert false - ) t1 t2 - + ) t1 t2 + let find_match (p:term_pattern) (t:t) : idset = let metas = ref Mmap.empty in let (mset,lset) = fold_pattern ~complete:false - (fun m t acc -> + (fun m t acc -> (* Printf.printf "eval pat %d\n" (Obj.magic m:int);*) Some (option_any2 fast_inter acc (Some(let t = try inter t (Mmap.find m !metas) with Not_found -> t in diff --git a/lib/dnet.mli b/lib/dnet.mli index a01bbb0e2e..b2f2714720 100644 --- a/lib/dnet.mli +++ b/lib/dnet.mli @@ -33,7 +33,7 @@ symmetric, see term_dnet.ml). The complexity of the search is (almost) the depth of the term. - + To use it, you have to provide a module (Datatype) with the datatype parametrized on the recursive argument. example: @@ -70,13 +70,13 @@ end module type S = sig type t - + (* provided identifier type *) type ident (* provided metavariable type *) type meta - + (* provided parametrized datastructure *) type 'a structure @@ -92,13 +92,13 @@ sig type term_pattern = 'a structure pattern as 'a val empty : t - + (* [add t w i] adds a new association (w,i) in t. *) val add : t -> term_pattern -> ident -> t - + (* [find_all t] returns all identifiers contained in t. *) val find_all : t -> Idset.t - + (* [fold_pattern f acc p dn] folds f on each meta of p, passing the meta and the sub-dnet under it. The result includes: - Some set if identifiers were gathered on the leafs of the term @@ -118,10 +118,10 @@ sig (* apply a function on each identifier and node of terms in a dnet *) val map : (ident -> ident) -> (unit structure -> unit structure) -> t -> t end - + module Make : - functor (T:Datatype) -> - functor (Ident:Set.OrderedType) -> + functor (T:Datatype) -> + functor (Ident:Set.OrderedType) -> functor (Meta:Set.OrderedType) -> S with type ident = Ident.t and type meta = Meta.t diff --git a/lib/dyn.ml b/lib/dyn.ml index 1e3aa294d7..d2bd458a7d 100644 --- a/lib/dyn.ml +++ b/lib/dyn.ml @@ -17,7 +17,7 @@ type t = string * Obj.t let dyntab = ref ([] : string list) let create s = - if List.mem s !dyntab then + if List.mem s !dyntab then anomaly ("Dyn.create: already declared dynamic " ^ s); dyntab := s :: !dyntab; ((fun v -> (s,Obj.repr v)), diff --git a/lib/edit.ml b/lib/edit.ml index e6f2907ecc..fd870a21ba 100644 --- a/lib/edit.ml +++ b/lib/edit.ml @@ -16,7 +16,7 @@ type ('a,'b,'c) t = { mutable last_focused_stk : 'a list; buf : ('a, 'b Bstack.t * 'c) Hashtbl.t } -let empty () = { +let empty () = { focus = None; last_focused_stk = []; buf = Hashtbl.create 17 } @@ -38,7 +38,7 @@ let unfocus e = e.last_focused_stk <- foc::(list_except foc e.last_focused_stk); e.focus <- None end - + let last_focused e = match e.last_focused_stk with | [] -> None @@ -48,7 +48,7 @@ let restore_last_focus e = match e.last_focused_stk with | [] -> () | f::_ -> focus e f - + let focusedp e = match e.focus with | None -> false @@ -96,8 +96,8 @@ let depth e = (* Undo focused proof of [e] to reach depth [n] *) let undo_todepth e n = match e.focus with - | None -> - if n <> 0 + | None -> + if n <> 0 then errorlabstrm "Edit.undo_todepth" (str"No proof in progress") else () (* if there is no proof in progress, then n must be zero *) | Some d -> @@ -109,7 +109,7 @@ let undo_todepth e n = let create e (d,b,c,usize) = if Hashtbl.mem e.buf d then - errorlabstrm "Edit.create" + errorlabstrm "Edit.create" (str"Already editing something of that name"); let bs = Bstack.create usize b in Hashtbl.add e.buf d (bs,c) @@ -123,11 +123,11 @@ let delete e d = | Some d' -> if d = d' then (e.focus <- None ; (restore_last_focus e)) | None -> () -let dom e = +let dom e = let l = ref [] in Hashtbl.iter (fun x _ -> l := x :: !l) e.buf; !l - + let clear e = e.focus <- None; e.last_focused_stk <- []; diff --git a/lib/envars.ml b/lib/envars.ml index d700ffe160..2e680ad057 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -9,77 +9,77 @@ (* This file gathers environment variables needed by Coq to run (such as coqlib) *) -let coqbin () = +let coqbin () = if !Flags.boot || Coq_config.local then Filename.concat Coq_config.coqsrc "bin" else System.canonical_path_name (Filename.dirname Sys.executable_name) -let guess_coqlib () = +let guess_coqlib () = let file = "states/initial.coq" in - if Sys.file_exists (Filename.concat Coq_config.coqlib file) + if Sys.file_exists (Filename.concat Coq_config.coqlib file) then Coq_config.coqlib - else + else let coqbin = System.canonical_path_name (Filename.dirname Sys.executable_name) in let prefix = Filename.dirname coqbin in - let rpath = if Coq_config.local then [] else + let rpath = if Coq_config.local then [] else (if Coq_config.arch = "win32" then ["lib"] else ["lib";"coq"]) in let coqlib = List.fold_left Filename.concat prefix rpath in if Sys.file_exists (Filename.concat coqlib file) then coqlib else Util.error "cannot guess a path for Coq libraries; please use -coqlib option" - -let coqlib () = + +let coqlib () = if !Flags.coqlib_spec then !Flags.coqlib else (if !Flags.boot then Coq_config.coqsrc else guess_coqlib ()) let path_to_list p = let sep = if Sys.os_type = "Win32" then ';' else ':' in - Util.split_string_at sep p + Util.split_string_at sep p let rec which l f = match l with | [] -> raise Not_found - | p :: tl -> - if Sys.file_exists (Filename.concat p f) - then p + | p :: tl -> + if Sys.file_exists (Filename.concat p f) + then p else which tl f - -let guess_camlbin () = - let path = try Sys.getenv "PATH" with _ -> raise Not_found in + +let guess_camlbin () = + let path = try Sys.getenv "PATH" with _ -> raise Not_found in let lpath = path_to_list path in which lpath "ocamlc" -let guess_camlp4bin () = - let path = try Sys.getenv "PATH" with _ -> raise Not_found in +let guess_camlp4bin () = + let path = try Sys.getenv "PATH" with _ -> raise Not_found in let lpath = path_to_list path in which lpath Coq_config.camlp4 -let camlbin () = +let camlbin () = if !Flags.camlbin_spec then !Flags.camlbin else if !Flags.boot then Coq_config.camlbin else try guess_camlbin () with _ -> Coq_config.camlbin -let camllib () = +let camllib () = if !Flags.boot then Coq_config.camllib - else - let camlbin = camlbin () in + else + let camlbin = camlbin () in let com = (Filename.concat camlbin "ocamlc") ^ " -where" in let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in Util.strip res (* TODO : essayer aussi camlbin *) -let camlp4bin () = +let camlp4bin () = if !Flags.camlp4bin_spec then !Flags.camlp4bin else if !Flags.boot then Coq_config.camlp4bin else try guess_camlp4bin () with _ -> Coq_config.camlp4bin -let camlp4lib () = +let camlp4lib () = if !Flags.boot then Coq_config.camlp4lib - else - let camlp4bin = camlp4bin () in + else + let camlp4bin = camlp4bin () in let com = (Filename.concat camlp4bin Coq_config.camlp4) ^ " -where" in let _,res = System.run_command (fun x -> x) (fun _ -> ()) com in Util.strip res - + diff --git a/lib/explore.ml b/lib/explore.ml index 51ff79e32b..7604950998 100644 --- a/lib/explore.ml +++ b/lib/explore.ml @@ -23,7 +23,7 @@ module Make = functor(S : SearchProblem) -> struct type position = int list - let pp_position p = + let pp_position p = let rec pp_rec = function | [] -> () | [i] -> printf "%d" i @@ -33,21 +33,21 @@ module Make = functor(S : SearchProblem) -> struct (*s Depth first search. *) - let rec depth_first s = + let rec depth_first s = if S.success s then s else depth_first_many (S.branching s) and depth_first_many = function | [] -> raise Not_found | [s] -> depth_first s | s :: l -> try depth_first s with Not_found -> depth_first_many l - let debug_depth_first s = + let debug_depth_first s = let rec explore p s = pp_position p; S.pp s; if S.success s then s else explore_many 1 p (S.branching s) and explore_many i p = function | [] -> raise Not_found | [s] -> explore (i::p) s - | s :: l -> + | s :: l -> try explore (i::p) s with Not_found -> explore_many (succ i) p l in explore [1] s @@ -66,7 +66,7 @@ module Make = functor(S : SearchProblem) -> struct | h, x::t -> x, (h,t) | h, [] -> match List.rev h with x::t -> x, ([],t) | [] -> raise Empty - let breadth_first s = + let breadth_first s = let rec explore q = let (s, q') = try pop q with Empty -> raise Not_found in enqueue q' (S.branching s) @@ -76,15 +76,15 @@ module Make = functor(S : SearchProblem) -> struct in enqueue empty [s] - let debug_breadth_first s = + let debug_breadth_first s = let rec explore q = - let ((p,s), q') = try pop q with Empty -> raise Not_found in + let ((p,s), q') = try pop q with Empty -> raise Not_found in enqueue 1 p q' (S.branching s) and enqueue i p q = function - | [] -> + | [] -> explore q | s :: l -> - let ps = i::p in + let ps = i::p in pp_position ps; S.pp s; if S.success s then s else enqueue (succ i) p (push (ps,s) q) l in diff --git a/lib/explore.mli b/lib/explore.mli index 907e2f2569..e29f27955a 100644 --- a/lib/explore.mli +++ b/lib/explore.mli @@ -12,12 +12,12 @@ (*s A search problem implements the following signature [SearchProblem]. [state] is the type of states of the search tree. - [branching] is the branching function; if [branching s] returns an + [branching] is the branching function; if [branching s] returns an empty list, then search from [s] is aborted; successors of [s] are recursively searched in the order they appear in the list. - [success] determines whether a given state is a success. + [success] determines whether a given state is a success. - [pp] is a pretty-printer for states used in debugging versions of the + [pp] is a pretty-printer for states used in debugging versions of the search functions. *) module type SearchProblem = sig @@ -33,7 +33,7 @@ module type SearchProblem = sig end (*s Functor [Make] returns some search functions given a search problem. - Search functions raise [Not_found] if no success is found. + Search functions raise [Not_found] if no success is found. States are always visited in the order they appear in the output of [branching] (whatever the search method is). Debugging versions of the search functions print the position of the diff --git a/lib/flags.ml b/lib/flags.ml index dac88a4733..1bf393fd08 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -80,8 +80,8 @@ let is_unsafe s = Stringset.mem s !unsafe_set let boxed_definitions = ref true let set_boxed_definitions b = boxed_definitions := b -let boxed_definitions _ = !boxed_definitions - +let boxed_definitions _ = !boxed_definitions + (* Flags for external tools *) let subst_command_placeholder s t = diff --git a/lib/gmapl.ml b/lib/gmapl.ml index 8fc2daf96a..cec10d6444 100644 --- a/lib/gmapl.ml +++ b/lib/gmapl.ml @@ -32,4 +32,4 @@ let remove x y m = let l = Gmap.find x m in Gmap.add x (if List.mem y l then list_subtract l [y] else l) m - + diff --git a/lib/hashcons.ml b/lib/hashcons.ml index c7cd145424..921a4ed563 100644 --- a/lib/hashcons.ml +++ b/lib/hashcons.ml @@ -19,7 +19,7 @@ * the hash-consing functions u provides. * [equal] is a comparison function. It is allowed to use physical equality * on the sub-terms hash-consed by the hash_sub function. - * [hash] is the hash function given to the Hashtbl.Make function + * [hash] is the hash function given to the Hashtbl.Make function * * Note that this module type coerces to the argument of Hashtbl.Make. *) @@ -106,7 +106,7 @@ let recursive_loop_hcons h u = let rec hrec visited x = if List.memq x visited then x else hc (hrec (x::visited),u) x - in + in hrec [] (* For 2 mutually recursive types *) @@ -164,7 +164,7 @@ let comp_obj o1 o2 = else false else o1=o2 -let hash_obj hrec o = +let hash_obj hrec o = begin if tuple_p o then let n = Obj.size o in diff --git a/lib/heap.ml b/lib/heap.ml index 47718bf3e7..7ddb4a7205 100644 --- a/lib/heap.ml +++ b/lib/heap.ml @@ -16,35 +16,35 @@ module type Ordered = sig end module type S =sig - + (* Type of functional heaps *) type t (* Type of elements *) type elt - + (* The empty heap *) val empty : t - + (* [add x h] returns a new heap containing the elements of [h], plus [x]; complexity $O(log(n))$ *) val add : elt -> t -> t - + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] when [h] is empty; complexity $O(1)$ *) val maximum : t -> elt - + (* [remove h] returns a new heap containing the elements of [h], except - the maximum of [h]; raises [EmptyHeap] when [h] is empty; - complexity $O(log(n))$ *) + the maximum of [h]; raises [EmptyHeap] when [h] is empty; + complexity $O(log(n))$ *) val remove : t -> t - + (* usual iterators and combinators; elements are presented in arbitrary order *) val iter : (elt -> unit) -> t -> unit - + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - + end exception EmptyHeap @@ -54,9 +54,9 @@ exception EmptyHeap module Functional(X : Ordered) = struct (* Heaps are encoded as complete binary trees, i.e., binary trees - which are full expect, may be, on the bottom level where it is filled - from the left. - These trees also enjoy the heap property, namely the value of any node + which are full expect, may be, on the bottom level where it is filled + from the left. + These trees also enjoy the heap property, namely the value of any node is greater or equal than those of its left and right subtrees. There are 4 kinds of complete binary trees, denoted by 4 constructors: @@ -68,7 +68,7 @@ module Functional(X : Ordered) = struct and [PFP] for a partial tree with a full left subtree and a partial right subtree. *) - type t = + type t = | Empty | FFF of t * X.t * t (* full (full, full) *) | PPF of t * X.t * t (* partial (partial, full) *) @@ -78,7 +78,7 @@ module Functional(X : Ordered) = struct type elt = X.t let empty = Empty - + (* smart constructors for insertion *) let p_f l x r = match l with | Empty | FFF _ -> PFF (l, x, r) @@ -89,7 +89,7 @@ module Functional(X : Ordered) = struct | r -> PFP (l, x, r) let rec add x = function - | Empty -> + | Empty -> FFF (Empty, x, Empty) (* insertion to the left *) | FFF (l, y, r) | PPF (l, y, r) -> @@ -113,9 +113,9 @@ module Functional(X : Ordered) = struct | r -> PFP (l, x, r) let rec remove = function - | Empty -> + | Empty -> raise EmptyHeap - | FFF (Empty, _, Empty) -> + | FFF (Empty, _, Empty) -> Empty | PFF (l, _, Empty) -> l @@ -124,30 +124,30 @@ module Functional(X : Ordered) = struct let xl = maximum l in let xr = maximum r in let l' = remove l in - if X.compare xl xr >= 0 then - p_f l' xl r - else + if X.compare xl xr >= 0 then + p_f l' xl r + else p_f l' xr (add xl (remove r)) (* remove on the right *) | FFF (l, x, r) | PFP (l, x, r) -> let xl = maximum l in let xr = maximum r in let r' = remove r in - if X.compare xl xr > 0 then + if X.compare xl xr > 0 then pf_ (add xr (remove l)) xl r' - else + else pf_ l xr r' let rec iter f = function - | Empty -> + | Empty -> () - | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> + | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> iter f l; f x; iter f r let rec fold f h x0 = match h with - | Empty -> + | Empty -> x0 - | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> + | FFF (l, x, r) | PPF (l, x, r) | PFF (l, x, r) | PFP (l, x, r) -> fold f l (fold f r (f x x0)) end diff --git a/lib/heap.mli b/lib/heap.mli index 0bef2edb22..777e356de7 100644 --- a/lib/heap.mli +++ b/lib/heap.mli @@ -16,35 +16,35 @@ module type Ordered = sig end module type S =sig - + (* Type of functional heaps *) type t (* Type of elements *) type elt - + (* The empty heap *) val empty : t - + (* [add x h] returns a new heap containing the elements of [h], plus [x]; complexity $O(log(n))$ *) val add : elt -> t -> t - + (* [maximum h] returns the maximum element of [h]; raises [EmptyHeap] when [h] is empty; complexity $O(1)$ *) val maximum : t -> elt - + (* [remove h] returns a new heap containing the elements of [h], except - the maximum of [h]; raises [EmptyHeap] when [h] is empty; - complexity $O(log(n))$ *) + the maximum of [h]; raises [EmptyHeap] when [h] is empty; + complexity $O(log(n))$ *) val remove : t -> t - + (* usual iterators and combinators; elements are presented in arbitrary order *) val iter : (elt -> unit) -> t -> unit - + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a - + end exception EmptyHeap diff --git a/lib/lib.mllib b/lib/lib.mllib index 1f203ec8d9..2321abd1b0 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -4,17 +4,17 @@ Compat Flags Util Bigint -Hashcons +Hashcons Dyn System -Envars -Bstack +Envars +Bstack Edit -Gset +Gset Gmap -Tlm +Tlm Gmapl -Profile +Profile Explore Predicate Rtree diff --git a/lib/option.ml b/lib/option.ml index 3d98034256..2a530b89bd 100644 --- a/lib/option.ml +++ b/lib/option.ml @@ -20,7 +20,7 @@ let has_some = function | None -> false | _ -> true - + exception IsNone (** [get x] returns [y] where [x] is [Some y]. It raises IsNone @@ -34,11 +34,11 @@ let make x = Some x (** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *) let init b x = - if b then + if b then Some x else None - + (** [flatten x] is [Some y] if [x] is [Some (Some y)] and [None] otherwise. *) let flatten = function @@ -48,7 +48,7 @@ let flatten = function (** {6 "Iterators"} ***) -(** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing +(** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing otherwise. *) let iter f = function | Some y -> f y @@ -60,7 +60,7 @@ exception Heterogeneous (** [iter2 f x y] executes [f z w] if [x] equals [Some z] and [y] equals [Some w]. It does nothing if both [x] and [y] are [None]. And raises [Heterogeneous] otherwise. *) -let iter2 f x y = +let iter2 f x y = match x,y with | Some z, Some w -> f z w | None,None -> () @@ -92,7 +92,7 @@ let fold_left2 f a x y = | _ -> raise Heterogeneous (** [fold_right f x a] is [f y a] if [x] is [Some y], and [a] otherwise. *) -let fold_right f x a = +let fold_right f x a = match x with | Some y -> f y a | _ -> a @@ -112,20 +112,20 @@ let default a = function (** [lift f x] is the same as [map f x]. *) let lift = map -(** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and +(** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and [None] otherwise. *) let lift_right f a = function | Some y -> Some (f a y) | _ -> None -(** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and +(** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and [None] otherwise. *) let lift_left f x a = match x with | Some y -> Some (f y a) | _ -> None -(** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals +(** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals [Some w]. It is [None] otherwise. *) let lift2 f x y = match x,y with @@ -137,18 +137,18 @@ let lift2 f x y = (** {6 Operations with Lists} *) module List = - struct + struct (** [List.cons x l] equals [y::l] if [x] is [Some y] and [l] otherwise. *) let cons x l = match x with | Some y -> y::l | _ -> l - + (** [List.flatten l] is the list of all the [y]s such that [l] contains [Some y] (in the same order). *) let rec flatten = function | x::l -> cons x (flatten l) - | [] -> [] + | [] -> [] end @@ -157,8 +157,8 @@ end module Misc = struct - (** [Misc.compare f x y] lifts the equality predicate [f] to - option types. That is, if both [x] and [y] are [None] then + (** [Misc.compare f x y] lifts the equality predicate [f] to + option types. That is, if both [x] and [y] are [None] then it returns [true], if they are bothe [Some _] then [f] is called. Otherwise it returns [false]. *) let compare f x y = diff --git a/lib/option.mli b/lib/option.mli index 04f3ca37d0..8002a7ea29 100644 --- a/lib/option.mli +++ b/lib/option.mli @@ -18,7 +18,7 @@ (** [has_some x] is [true] if [x] is of the form [Some y] and [false] otherwise. *) val has_some : 'a option -> bool - + exception IsNone (** [get x] returns [y] where [x] is [Some y]. It raises IsNone @@ -37,7 +37,7 @@ val flatten : 'a option option -> 'a option (** {6 "Iterators"} ***) -(** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing +(** [iter f x] executes [f y] if [x] equals [Some y]. It does nothing otherwise. *) val iter : ('a -> unit) -> 'a option -> unit @@ -77,15 +77,15 @@ val default : 'a -> 'a option -> 'a (** [lift] is the same as {!map}. *) val lift : ('a -> 'b) -> 'a option -> 'b option -(** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and +(** [lift_right f a x] is [Some (f a y)] if [x] is [Some y], and [None] otherwise. *) val lift_right : ('a -> 'b -> 'c) -> 'a -> 'b option -> 'c option -(** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and +(** [lift_left f x a] is [Some (f y a)] if [x] is [Some y], and [None] otherwise. *) val lift_left : ('a -> 'b -> 'c) -> 'a option -> 'b -> 'c option -(** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals +(** [lift2 f x y] is [Some (f z w)] if [x] equals [Some z] and [y] equals [Some w]. It is [None] otherwise. *) val lift2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option @@ -105,8 +105,8 @@ end (** {6 Miscelaneous Primitives} *) module Misc : sig - (** [Misc.compare f x y] lifts the equality predicate [f] to - option types. That is, if both [x] and [y] are [None] then + (** [Misc.compare f x y] lifts the equality predicate [f] to + option types. That is, if both [x] and [y] are [None] then it returns [true], if they are bothe [Some _] then [f] is called. Otherwise it returns [false]. *) val compare : ('a -> 'a -> bool) -> 'a option -> 'a option -> bool diff --git a/lib/pp.ml4 b/lib/pp.ml4 index 20a97810e7..b0948b0f40 100644 --- a/lib/pp.ml4 +++ b/lib/pp.ml4 @@ -19,7 +19,7 @@ let print_emacs = ref false let make_pp_emacs() = print_emacs:=true let make_pp_nonemacs() = print_emacs:=false -(* The different kinds of blocks are: +(* The different kinds of blocks are: \begin{description} \item[hbox:] Horizontal block no line breaking; \item[vbox:] Vertical block each break leads to a new line; @@ -31,9 +31,9 @@ let make_pp_nonemacs() = print_emacs:=false (except if no mark yet on the reste of the line) \end{description} *) - + let comments = ref [] - + let rec split_com comacc acc pos = function [] -> comments := List.rev acc; comacc | ((b,e),c as com)::coms -> @@ -132,7 +132,7 @@ let real r = str (string_of_float r) let bool b = str (string_of_bool b) let strbrk s = let rec aux p n = - if n < String.length s then + if n < String.length s then if s.[n] = ' ' then if p=n then [< spc (); aux (n+1) (n+1) >] else [< str (String.sub s p (n-p)); spc (); aux (n+1) (n+1) >] @@ -224,13 +224,13 @@ let rec pr_com ft s = | None -> () (* pretty printing functions *) -let pp_dirs ft = +let pp_dirs ft = let pp_open_box = function | Pp_hbox n -> Format.pp_open_hbox ft () | Pp_vbox n -> Format.pp_open_vbox ft n | Pp_hvbox n -> Format.pp_open_hvbox ft n | Pp_hovbox n -> Format.pp_open_hovbox ft n - | Pp_tbox -> Format.pp_open_tbox ft () + | Pp_tbox -> Format.pp_open_tbox ft () in let rec pp_cmd = function | Ppcmd_print(n,s) -> @@ -264,12 +264,12 @@ let pp_dirs ft = | Ppdir_ppcmds cmdstream -> Stream.iter pp_cmd cmdstream | Ppdir_print_newline -> com_brk ft; Format.pp_print_newline ft () - | Ppdir_print_flush -> Format.pp_print_flush ft () + | Ppdir_print_flush -> Format.pp_print_flush ft () in fun dirstream -> - try + try Stream.iter pp_dir dirstream; com_brk ft - with + with | e -> Format.pp_print_flush ft () ; raise e @@ -284,10 +284,10 @@ let ppcmds x = Ppdir_ppcmds x let emacs_warning_start_string = String.make 1 (Char.chr 254) let emacs_warning_end_string = String.make 1 (Char.chr 255) -let warnstart() = +let warnstart() = if not !print_emacs then mt() else str emacs_warning_start_string -let warnend() = +let warnend() = if not !print_emacs then mt() else str emacs_warning_end_string let warnbody strm = diff --git a/lib/pp.mli b/lib/pp.mli index ab2804a53f..66d9bfa674 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -85,7 +85,7 @@ val warning_with : Format.formatter -> string -> unit val warn_with : Format.formatter -> std_ppcmds -> unit val pp_flush_with : Format.formatter -> unit -> unit -val set_warning_function : (Format.formatter -> std_ppcmds -> unit) -> unit +val set_warning_function : (Format.formatter -> std_ppcmds -> unit) -> unit (*s Pretty-printing functions \emph{with flush}. *) diff --git a/lib/pp_control.ml b/lib/pp_control.ml index 7617d5ca42..ecc546491d 100644 --- a/lib/pp_control.ml +++ b/lib/pp_control.ml @@ -18,7 +18,7 @@ type pp_global_params = { (* Default parameters of pretty-printing *) -let dflt_gp = { +let dflt_gp = { margin = 78; max_indent = 50; max_depth = 50; @@ -26,7 +26,7 @@ let dflt_gp = { (* A deeper pretty-printer to print proof scripts *) -let deep_gp = { +let deep_gp = { margin = 78; max_indent = 50; max_depth = 10000; @@ -35,13 +35,13 @@ let deep_gp = { (* set_gp : Format.formatter -> pp_global_params -> unit * set the parameters of a formatter *) -let set_gp ft gp = +let set_gp ft gp = Format.pp_set_margin ft gp.margin ; Format.pp_set_max_indent ft gp.max_indent ; Format.pp_set_max_boxes ft gp.max_depth ; Format.pp_set_ellipsis_text ft gp.ellipsis -let set_dflt_gp ft = set_gp ft dflt_gp +let set_dflt_gp ft = set_gp ft dflt_gp let get_gp ft = { margin = Format.pp_get_margin ft (); @@ -56,7 +56,7 @@ type 'a pp_formatter_params = { fp_output : out_channel ; fp_output_function : string -> int -> int -> unit ; fp_flush_function : unit -> unit } - + (* Output functions for stdout and stderr *) let std_fp = { @@ -69,7 +69,7 @@ let err_fp = { fp_output_function = output stderr; fp_flush_function = (fun () -> flush stderr) } -(* with_fp : 'a pp_formatter_params -> Format.formatter +(* with_fp : 'a pp_formatter_params -> Format.formatter * returns of formatter for given formatter functions *) let with_fp fp = @@ -83,7 +83,7 @@ let with_output_to ch = let ft = with_fp { fp_output = ch ; fp_output_function = (output ch) ; fp_flush_function = (fun () -> flush ch) } in - set_gp ft deep_gp; + set_gp ft deep_gp; ft let std_ft = ref Format.std_formatter diff --git a/lib/pp_control.mli b/lib/pp_control.mli index b43584f344..5c481b89af 100644 --- a/lib/pp_control.mli +++ b/lib/pp_control.mli @@ -10,7 +10,7 @@ (* Parameters of pretty-printing. *) -type pp_global_params = { +type pp_global_params = { margin : int; max_indent : int; max_depth : int; @@ -25,7 +25,7 @@ val get_gp : Format.formatter -> pp_global_params (*s Output functions of pretty-printing. *) -type 'a pp_formatter_params = { +type 'a pp_formatter_params = { fp_output : out_channel; fp_output_function : string -> int -> int -> unit; fp_flush_function : unit -> unit } diff --git a/lib/predicate.ml b/lib/predicate.ml index b2e40d3cf1..af66c0f28d 100644 --- a/lib/predicate.ml +++ b/lib/predicate.ml @@ -44,7 +44,7 @@ module type S = module Make(Ord: OrderedType) = struct module EltSet = Set.Make(Ord) - + (* when bool is false, the denoted set is the complement of the given set *) type elt = Ord.t diff --git a/lib/profile.ml b/lib/profile.ml index 80ae6b4b45..fdea309b8c 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -113,12 +113,12 @@ let ajoute_to_list ((name,n) as e) l = with Not_found -> e::l let magic = 1249 - + let merge_profile filename (curr_table, curr_outside, curr_total as new_data) = let (old_table, old_outside, old_total) = - try + try let c = open_in filename in - if input_binary_int c <> magic + if input_binary_int c <> magic then Printf.printf "Incompatible recording file: %s\n" filename; let old_data = input_value c in close_in c; @@ -134,7 +134,7 @@ let merge_profile filename (curr_table, curr_outside, curr_total as new_data) = begin (try let c = - open_out_gen + open_out_gen [Open_creat;Open_wronly;Open_trunc;Open_binary] 0o644 filename in output_binary_int c magic; output_value c updated_data; @@ -186,7 +186,7 @@ overheadA| ... real 2' | ... ---------- end 2nd f2 overheadC| ... - ---------- [2'w2] 2nd call to get_time for 2nd f2 + ---------- [2'w2] 2nd call to get_time for 2nd f2 overheadD| ... ---------- end profile for f2 real 1 | ... @@ -242,7 +242,7 @@ let time_overhead_A_D () = ajoute_totalloc p (e.totalloc-.totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !dummy_stack with [] -> assert false | _::s -> stack := s); dummy_last_alloc := get_alloc () done; @@ -279,7 +279,7 @@ let compute_alloc lo = lo /. (float_of_int word_length) let format_profile (table, outside, total) = print_newline (); - Printf.printf + Printf.printf "%-23s %9s %9s %10s %10s %10s\n" "Function name" "Own time" "Tot. time" "Own alloc" "Tot. alloc" "Calls "; let l = Sort.list (fun (_,{tottime=p}) (_,{tottime=p'}) -> p > p') table in @@ -293,7 +293,7 @@ let format_profile (table, outside, total) = e.owncount e.intcount) l; Printf.printf "%-23s %9.2f %9.2f %10.0f %10.0f %6d\n" - "others" + "others" (float_of_time outside.owntime) (float_of_time outside.tottime) (compute_alloc outside.ownalloc) (compute_alloc outside.totalloc) @@ -305,7 +305,7 @@ let format_profile (table, outside, total) = (compute_alloc total.ownalloc) (compute_alloc total.totalloc); Printf.printf - "Time in seconds and allocation in words (1 word = %d bytes)\n" + "Time in seconds and allocation in words (1 word = %d bytes)\n" word_length let recording_file = ref "" @@ -319,7 +319,7 @@ let adjust_time ov_bc ov_ad e = tottime = e.tottime - int_of_float (abcd_all +. bc_imm); owntime = e.owntime - int_of_float (ad_imm +. bc_imm) } -let close_profile print = +let close_profile print = let dw = spent_alloc () in let t = get_time () in match !stack with @@ -390,7 +390,7 @@ let profile1 e f a = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r @@ -404,7 +404,7 @@ let profile1 e f a = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise exn @@ -432,7 +432,7 @@ let profile2 e f a b = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r @@ -446,7 +446,7 @@ let profile2 e f a b = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise exn @@ -474,7 +474,7 @@ let profile3 e f a b c = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r @@ -488,7 +488,7 @@ let profile3 e f a b c = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise exn @@ -516,7 +516,7 @@ let profile4 e f a b c d = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r @@ -530,7 +530,7 @@ let profile4 e f a b c d = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise exn @@ -558,7 +558,7 @@ let profile5 e f a b c d g = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r @@ -572,7 +572,7 @@ let profile5 e f a b c d g = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise exn @@ -600,7 +600,7 @@ let profile6 e f a b c d g h = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r @@ -614,7 +614,7 @@ let profile6 e f a b c d g h = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise exn @@ -642,7 +642,7 @@ let profile7 e f a b c d g h i = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); r @@ -656,7 +656,7 @@ let profile7 e f a b c d g h i = ajoute_totalloc p (e.totalloc -. totalloc0); p.intcount <- p.intcount + e.intcount - intcount0 + 1; p.immcount <- p.immcount + 1; - if not (p==e) then + if not (p==e) then (match !stack with [] -> assert false | _::s -> stack := s); last_alloc := get_alloc (); raise exn @@ -695,9 +695,9 @@ let obj_stats a = (!c, !s + !b, !m) module H = Hashtbl.Make( - struct - type t = Obj.t - let equal = (==) + struct + type t = Obj.t + let equal = (==) let hash o = Hashtbl.hash (magic o : int) end) diff --git a/lib/profile.mli b/lib/profile.mli index ab2af23985..3647756f71 100644 --- a/lib/profile.mli +++ b/lib/profile.mli @@ -49,7 +49,7 @@ let g = profile gkey g';; Before the program quits, you should call "print_profile ();;". It produces a result of the following kind: -Function name Own time Total time Own alloc Tot. alloc Calls +Function name Own time Total time Own alloc Tot. alloc Calls f 0.28 0.47 116 116 5 4 h 0.19 0.19 0 0 4 0 g 0.00 0.00 0 0 0 0 @@ -65,7 +65,7 @@ Est. overhead/total 0.00 0.47 2752 3260 the number of calls to profiled functions inside the scope of the current function -Remarks: +Remarks: - If a function has a polymorphic type, you need to supply it with at least one argument as in "let f a = profile1 fkey f a;;" (instead of @@ -103,7 +103,7 @@ val profile6 : -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g val profile7 : profile_key -> - ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) + ('a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h) -> 'a -> 'b -> 'c -> 'd -> 'e -> 'f -> 'g -> 'h diff --git a/lib/refutpat.ml4 b/lib/refutpat.ml4 index f2575def43..7c6801a8b9 100644 --- a/lib/refutpat.ml4 +++ b/lib/refutpat.ml4 @@ -15,7 +15,7 @@ open Pcaml This small camlp4 extension creates a "let*" variant of the "let" syntax that allow the use of a non-exhaustive pattern. The typical usage is: - + let* x::l = foo in ... when foo is already known to be non-empty. This way, no warnings by ocamlc. diff --git a/lib/rtree.ml b/lib/rtree.ml index 4832fe58df..ad4d313385 100644 --- a/lib/rtree.ml +++ b/lib/rtree.ml @@ -53,7 +53,7 @@ let rec subst_rtree_rec depth sub = function let subst_rtree sub t = subst_rtree_rec 0 [|sub|] t -(* To avoid looping, we must check that every body introduces a node +(* To avoid looping, we must check that every body introduces a node or a parameter *) let rec expand = function | Rec(j,defs) -> @@ -81,17 +81,17 @@ the last one should be accepted *) (* Tree destructors, expanding loops when necessary *) -let dest_param t = +let dest_param t = match expand t with Param (i,j) -> (i,j) | _ -> failwith "Rtree.dest_param" -let dest_node t = +let dest_node t = match expand t with Node (l,sons) -> (l,sons) | _ -> failwith "Rtree.dest_node" -let is_node t = +let is_node t = match expand t with Node _ -> true | _ -> false @@ -104,13 +104,13 @@ let rec map f t = match t with let rec smartmap f t = match t with Param _ -> t - | Node (a,sons) -> + | Node (a,sons) -> let a'=f a and sons' = Util.array_smartmap (map f) sons in if a'==a && sons'==sons then t else Node (a',sons') - | Rec(j,defs) -> + | Rec(j,defs) -> let defs' = Util.array_smartmap (map f) defs in if defs'==defs then t diff --git a/lib/rtree.mli b/lib/rtree.mli index db5475b795..de5a9aa386 100644 --- a/lib/rtree.mli +++ b/lib/rtree.mli @@ -11,7 +11,7 @@ (* Type of regular tree with nodes labelled by values of type 'a *) (* The implementation uses de Bruijn indices, so binding capture is avoided by the lift operator (see example below) *) -type 'a t +type 'a t (* Building trees *) @@ -40,7 +40,7 @@ val mk_rec_calls : int -> 'a t array val mk_rec : 'a t array -> 'a t array (* [lift k t] increases of [k] the free parameters of [t]. Needed - to avoid captures when a tree appears under [mk_rec] *) + to avoid captures when a tree appears under [mk_rec] *) val lift : int -> 'a t -> 'a t val is_node : 'a t -> bool diff --git a/lib/system.ml b/lib/system.ml index 982a607f94..4afae39188 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -15,7 +15,7 @@ open Unix (* Expanding shell variables and home-directories *) let safe_getenv_def var def = - try + try Sys.getenv var with Not_found -> warning ("Environment variable "^var^" not found: using '"^def^"' ."); @@ -38,7 +38,7 @@ let rec expand_macros s i = let l = String.length s in if i=l then s else match s.[i] with - | '$' -> + | '$' -> let n = expand_atom s (i+1) in let v = safe_getenv (String.sub s (i+1) (n-i-1)) in let s = (String.sub s 0 i)^v^(String.sub s n (l-n)) in @@ -64,7 +64,7 @@ let physical_path_of_string s = s let string_of_physical_path p = p (* Hints to partially detects if two paths refer to the same repertory *) -let rec remove_path_dot p = +let rec remove_path_dot p = let curdir = Filename.concat Filename.current_dir_name "" in (* Unix: "./" *) let n = String.length curdir in if String.length p > n && String.sub p 0 n = curdir then @@ -82,7 +82,7 @@ let strip_path p = let canonical_path_name p = let current = Sys.getcwd () in - try + try Sys.chdir p; let p' = Sys.getcwd () in Sys.chdir current; @@ -100,7 +100,7 @@ let skipped_dirnames = ref ["CVS"; "_darcs"] let exclude_search_in_dirname f = skipped_dirnames := f :: !skipped_dirnames -let ok_dirname f = +let ok_dirname f = f <> "" && f.[0] <> '.' && not (List.mem f !skipped_dirnames) && try ignore (check_ident f); true with _ -> false @@ -114,7 +114,7 @@ let all_subdirs ~unix_path:root = let f = readdir dirh in if ok_dirname f then let file = Filename.concat dir f in - try + try if (stat file).st_kind = S_DIR then begin let newrel = rel@[f] in add file newrel; @@ -132,14 +132,14 @@ let where_in_path ?(warn=true) path filename = let rec search = function | lpe :: rem -> let f = Filename.concat lpe filename in - if Sys.file_exists f + if Sys.file_exists f then (lpe,f) :: search rem else search rem | [] -> [] in let rec check_and_warn l = match l with | [] -> raise Not_found - | (lpe, f) :: l' -> + | (lpe, f) :: l' -> if warn & l' <> [] then msg_warning (str filename ++ str " has been found in" ++ spc () ++ @@ -159,11 +159,11 @@ let find_file_in_path ?(warn=true) paths filename = else errorlabstrm "System.find_file_in_path" (hov 0 (str "Can't find file" ++ spc () ++ str filename)) - else + else try where_in_path ~warn paths filename with Not_found -> errorlabstrm "System.find_file_in_path" - (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ + (hov 0 (str "Can't find file" ++ spc () ++ str filename ++ spc () ++ str "on loadpath")) let is_in_path lpath filename = @@ -192,40 +192,40 @@ let marshal_in ch = exception Bad_magic_number of string let raw_extern_intern magic suffix = - let extern_state name = + let extern_state name = let filename = make_suffix name suffix in let channel = open_trapping_failure filename in output_binary_int channel magic; filename,channel - and intern_state filename = + and intern_state filename = let channel = open_in_bin filename in if input_binary_int channel <> magic then raise (Bad_magic_number filename); channel - in + in (extern_state,intern_state) let extern_intern ?(warn=true) magic suffix = let (raw_extern,raw_intern) = raw_extern_intern magic suffix in - let extern_state name val_0 = + let extern_state name val_0 = try let (filename,channel) = raw_extern name in try marshal_out channel val_0; close_out channel - with e -> + with e -> begin try_remove filename; raise e end with Sys_error s -> error ("System error: " ^ s) - and intern_state paths name = + and intern_state paths name = try let _,filename = find_file_in_path ~warn paths (make_suffix name suffix) in let channel = raw_intern filename in let v = marshal_in channel in - close_in channel; + close_in channel; v - with Sys_error s -> + with Sys_error s -> error("System error: " ^ s) - in + in (extern_state,intern_state) (* Communication through files with another executable *) @@ -237,14 +237,14 @@ let connect writefun readfun com = let ch_to_in,ch_to_out = try open_in tmp_to, open_out tmp_to with Sys_error s -> error ("Cannot set connection to "^com^"("^s^")") in - let ch_from_in,ch_from_out = + let ch_from_in,ch_from_out = try open_in tmp_from, open_out tmp_from with Sys_error s -> - close_out ch_to_out; close_in ch_to_in; + close_out ch_to_out; close_in ch_to_in; error ("Cannot set connection from "^com^"("^s^")") in writefun ch_to_out; close_out ch_to_out; - let pid = + let pid = let ch_to' = Unix.descr_of_in_channel ch_to_in in let ch_from' = Unix.descr_of_out_channel ch_from_out in try Unix.create_process com [|com|] ch_to' ch_from' Unix.stdout @@ -272,15 +272,15 @@ let run_command converter f c = let n = ref 0 in let ne = ref 0 in - while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; + while n:= input cin buff 0 127 ; ne := input cerr buffe 0 127 ; !n+ !ne <> 0 - do - let r = converter (String.sub buff 0 !n) in + do + let r = converter (String.sub buff 0 !n) in f r; Buffer.add_string result r; - let r = converter (String.sub buffe 0 !ne) in + let r = converter (String.sub buffe 0 !ne) in f r; - Buffer.add_string result r + Buffer.add_string result r done; (Unix.close_process_full (cin,cout,cerr), Buffer.contents result) @@ -288,16 +288,16 @@ let run_command converter f c = type time = float * float * float -let process_time () = +let process_time () = let t = times () in (t.tms_utime, t.tms_stime) -let get_time () = +let get_time () = let t = times () in (time(), t.tms_utime, t.tms_stime) let time_difference (t1,_,_) (t2,_,_) = t2 -. t1 - + let fmt_time_difference (startreal,ustart,sstart) (stopreal,ustop,sstop) = real (stopreal -. startreal) ++ str " secs " ++ str "(" ++ diff --git a/lib/system.mli b/lib/system.mli index 7556ed9e4d..2932d7b669 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -48,22 +48,22 @@ val marshal_in : in_channel -> 'a exception Bad_magic_number of string -val raw_extern_intern : int -> string -> +val raw_extern_intern : int -> string -> (string -> string * out_channel) * (string -> in_channel) -val extern_intern : ?warn:bool -> int -> string -> +val extern_intern : ?warn:bool -> int -> string -> (string -> 'a -> unit) * (load_path -> string -> 'a) (*s Sending/receiving once with external executable *) -val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a +val connect : (out_channel -> unit) -> (in_channel -> 'a) -> string -> 'a (*s [run_command converter f com] launches command [com], and returns the contents of stdout and stderr that have been processed with [converter]; the processed contents of stdout and stderr is also passed to [f] *) -val run_command : (string -> string) -> (string -> unit) -> string -> +val run_command : (string -> string) -> (string -> unit) -> string -> Unix.process_status * string (*s Time stamps. *) diff --git a/lib/tlm.ml b/lib/tlm.ml index 95092a8859..1c1483ad49 100644 --- a/lib/tlm.ml +++ b/lib/tlm.ml @@ -23,41 +23,41 @@ let in_dom (Node (_,m)) lbl = Gmap.mem lbl m let is_empty_node (Node(a,b)) = (Gset.elements a = []) & (Gmap.to_list b = []) let assure_arc m lbl = - if Gmap.mem lbl m then + if Gmap.mem lbl m then m - else + else Gmap.add lbl (Node (Gset.empty,Gmap.empty)) m let cleanse_arcs (Node (hereset,m)) = - let l = Gmap.rng m in + let l = Gmap.rng m in Node(hereset, if List.for_all is_empty_node l then Gmap.empty else m) let rec at_path f (Node (hereset,m)) = function - | [] -> + | [] -> cleanse_arcs (Node(f hereset,m)) | h::t -> - let m = assure_arc m h in + let m = assure_arc m h in cleanse_arcs (Node(hereset, Gmap.add h (at_path f (Gmap.find h m) t) m)) let add tm (path,v) = at_path (fun hereset -> Gset.add v hereset) tm path - + let rmv tm (path,v) = at_path (fun hereset -> Gset.remove v hereset) tm path -let app f tlm = +let app f tlm = let rec apprec pfx (Node(hereset,m)) = - let path = List.rev pfx in + let path = List.rev pfx in Gset.iter (fun v -> f(path,v)) hereset; Gmap.iter (fun l tm -> apprec (l::pfx) tm) m - in + in apprec [] tlm - -let to_list tlm = + +let to_list tlm = let rec torec pfx (Node(hereset,m)) = - let path = List.rev pfx in + let path = List.rev pfx in List.flatten((List.map (fun v -> (path,v)) (Gset.elements hereset)):: (List.map (fun (l,tm) -> torec (l::pfx) tm) (Gmap.to_list m))) - in + in torec [] tlm diff --git a/lib/util.ml b/lib/util.ml index b161b966e1..ddf44eec37 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -36,7 +36,7 @@ let anomaly_loc (loc,s,strm) = Stdpp.raise_with_loc loc (Anomaly (s,strm)) let user_err_loc (loc,s,strm) = Stdpp.raise_with_loc loc (UserError (s,strm)) let invalid_arg_loc (loc,s) = Stdpp.raise_with_loc loc (Invalid_argument s) -let located_fold_left f x (_,a) = f x a +let located_fold_left f x (_,a) = f x a let located_iter2 f (_,a) (_,b) = f a b (* Like Exc_located, but specifies the outermost file read, the filename @@ -73,13 +73,13 @@ let is_blank = function (* Strings *) -let explode s = +let explode s = let rec explode_rec n = if n >= String.length s then [] - else + else String.make 1 (String.get s n) :: explode_rec (succ n) - in + in explode_rec 0 let implode sl = String.concat "" sl @@ -107,12 +107,12 @@ let drop_simple_quotes s = (* gdzie = where, co = what *) (* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *) -let rec is_sub gdzie gl gi co cl ci = +let rec is_sub gdzie gl gi co cl ci = (ci>=cl) || - ((String.unsafe_get gdzie gi = String.unsafe_get co ci) && + ((String.unsafe_get gdzie gi = String.unsafe_get co ci) && (is_sub gdzie gl (gi+1) co cl (ci+1))) -let rec raw_str_index i gdzie l c co cl = +let rec raw_str_index i gdzie l c co cl = (* First adapt to ocaml 3.11 new semantics of index_from *) if (i+cl > l) then raise Not_found; (* Then proceed as in ocaml < 3.11 *) @@ -120,7 +120,7 @@ let rec raw_str_index i gdzie l c co cl = if (i'+cl <= l) && (is_sub gdzie l i' co cl 0) then i' else raw_str_index (i'+1) gdzie l c co cl -let string_index_from gdzie i co = +let string_index_from gdzie i co = if co="" then i else raw_str_index i gdzie (String.length gdzie) (String.unsafe_get co 0) co (String.length co) @@ -142,7 +142,7 @@ let ordinal n = let split_string_at c s = let len = String.length s in let rec split n = - try + try let pos = String.index_from s n c in let dir = String.sub s n (pos-n) in dir :: split (succ pos) @@ -231,7 +231,7 @@ let classify_unicode unicode = begin match unicode with (* utf-8 general punctuation U2080-2089 *) (* Hyphens *) - | x when 0x2010 <= x & x <= 0x2011 -> UnicodeLetter + | x when 0x2010 <= x & x <= 0x2011 -> UnicodeLetter (* Dashes and other symbols *) | x when 0x2012 <= x & x <= 0x2027 -> UnicodeSymbol (* Per mille and per ten thousand signs *) @@ -243,9 +243,9 @@ let classify_unicode unicode = | x when 0x2058 <= x & x <= 0x205E -> UnicodeSymbol (* Invisible mathematical operators *) | x when 0x2061 <= x & x <= 0x2063 -> UnicodeSymbol - (* utf-8 superscript U2070-207C *) + (* utf-8 superscript U2070-207C *) | x when 0x2070 <= x & x <= 0x207C -> UnicodeSymbol - (* utf-8 subscript U2080-2089 *) + (* utf-8 subscript U2080-2089 *) | x when 0x2080 <= x & x <= 0x2089 -> UnicodeIdentPart (* utf-8 letter-like U2100-214F *) | x when 0x2100 <= x & x <= 0x214F -> UnicodeLetter @@ -296,7 +296,7 @@ let classify_unicode unicode = exception End_of_input let utf8_of_unicode n = - if n < 128 then + if n < 128 then String.make 1 (Char.chr n) else if n < 2048 then let s = String.make 2 (Char.chr (128 + n mod 64)) in @@ -306,18 +306,18 @@ let utf8_of_unicode n = end else if n < 65536 then let s = String.make 3 (Char.chr (128 + n mod 64)) in - begin + begin s.[1] <- Char.chr (128 + (n / 64) mod 64); - s.[0] <- Char.chr (224 + n / 4096); + s.[0] <- Char.chr (224 + n / 4096); s end else let s = String.make 4 (Char.chr (128 + n mod 64)) in - begin + begin s.[2] <- Char.chr (128 + (n / 64) mod 64); s.[1] <- Char.chr (128 + (n / 4096) mod 64); s.[0] <- Char.chr (240 + n / 262144); - s + s end let next_utf8 s i = @@ -370,7 +370,7 @@ let check_ident_gen handle s = i := !i + j done with End_of_input -> () - with + with | End_of_input -> error "The empty string is not an identifier." | UnsupportedUtf8 -> error (s^": unsupported character in utf8 sequence.") | Invalid_argument _ -> error (s^": invalid utf8 sequence.") @@ -411,18 +411,18 @@ let lowercase_unicode s unicode = | 0x038C -> 0x03CC | x when 0x038E <= x & x <= 0x038F -> x + 63 | x when 0x0390 <= x & x <= 0x03AB & x <> 0x03A2 -> x + 32 - (* utf-8 Greek lowercase letters U03B0-03CE *) + (* utf-8 Greek lowercase letters U03B0-03CE *) | x when 0x03AC <= x & x <= 0x03CE -> x | x when 0x03CF <= x & x <= 0x03FF -> warning ("Unable to decide which lowercase letter to map to "^s); x (* utf-8 Cyrillic letters U0400-0481 *) | x when 0x0400 <= x & x <= 0x040F -> x + 80 | x when 0x0410 <= x & x <= 0x042F -> x + 32 - | x when 0x0430 <= x & x <= 0x045F -> x + | x when 0x0430 <= x & x <= 0x045F -> x | x when 0x0460 <= x & x <= 0x0481 -> if x mod 2 = 1 then x else x + 1 (* utf-8 Cyrillic letters U048A-U4F9 (Warning: 04CF) *) - | x when 0x048A <= x & x <= 0x04F9 & x <> 0x04CF -> + | x when 0x048A <= x & x <= 0x04F9 & x <> 0x04CF -> if x mod 2 = 1 then x else x + 1 (* utf-8 Cyrillic supplement letters U0500-U050F *) | x when 0x0500 <= x & x <= 0x050F -> @@ -510,41 +510,41 @@ let rec list_compare cmp l1 l2 = | 0 -> list_compare cmp l1 l2 | c -> c) -let list_intersect l1 l2 = +let list_intersect l1 l2 = List.filter (fun x -> List.mem x l2) l1 -let list_union l1 l2 = +let list_union l1 l2 = let rec urec = function | [] -> l2 | a::l -> if List.mem a l2 then urec l else a::urec l - in + in urec l1 -let list_unionq l1 l2 = +let list_unionq l1 l2 = let rec urec = function | [] -> l2 | a::l -> if List.memq a l2 then urec l else a::urec l - in + in urec l1 let list_subtract l1 l2 = if l2 = [] then l1 else List.filter (fun x -> not (List.mem x l2)) l1 -let list_subtractq l1 l2 = +let list_subtractq l1 l2 = if l2 = [] then l1 else List.filter (fun x -> not (List.memq x l2)) l1 -let list_chop n l = +let list_chop n l = let rec chop_aux acc = function | (0, l2) -> (List.rev acc, l2) | (n, (h::t)) -> chop_aux (h::acc) (pred n, t) | (_, []) -> failwith "list_chop" - in + in chop_aux [] (n,l) -let list_tabulate f len = +let list_tabulate f len = let rec tabrec n = if n = len then [] else (f n)::(tabrec (n+1)) - in + in tabrec 0 let rec list_make n v = @@ -552,41 +552,41 @@ let rec list_make n v = else if n < 0 then invalid_arg "list_make" else v::list_make (n-1) v -let list_assign l n e = +let list_assign l n e = let rec assrec stk = function | ((h::t), 0) -> List.rev_append stk (e::t) | ((h::t), n) -> assrec (h::stk) (t, n-1) | ([], _) -> failwith "list_assign" - in + in assrec [] (l,n) let rec list_smartmap f l = match l with [] -> l - | h::tl -> + | h::tl -> let h' = f h and tl' = list_smartmap f tl in if h'==h && tl'==tl then l else h'::tl' let list_map_left f = (* ensures the order in case of side-effects *) let rec map_rec = function - | [] -> [] + | [] -> [] | x::l -> let v = f x in v :: map_rec l - in + in map_rec -let list_map_i f = +let list_map_i f = let rec map_i_rec i = function - | [] -> [] + | [] -> [] | x::l -> let v = f i x in v :: map_i_rec (i+1) l - in + in map_i_rec -let list_map2_i f i l1 l2 = +let list_map2_i f i l1 l2 = let rec map_i i = function | ([], []) -> [] | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2) | (_, _) -> invalid_arg "map2_i" - in + in map_i i (l1,l2) let list_map3 f l1 l2 l3 = @@ -594,7 +594,7 @@ let list_map3 f l1 l2 l3 = | ([], [], []) -> [] | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3) | (_, _, _) -> invalid_arg "map3" - in + in map (l1,l2,l3) let list_map4 f l1 l2 l3 l4 = @@ -602,41 +602,41 @@ let list_map4 f l1 l2 l3 l4 = | ([], [], [], []) -> [] | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4) | (_, _, _, _) -> invalid_arg "map4" - in + in map (l1,l2,l3,l4) -let list_index x = +let list_index x = let rec index_x n = function | y::l -> if x = y then n else index_x (succ n) l | [] -> raise Not_found - in + in index_x 1 -let list_index0 x l = list_index x l - 1 +let list_index0 x l = list_index x l - 1 -let list_unique_index x = +let list_unique_index x = let rec index_x n = function - | y::l -> - if x = y then + | y::l -> + if x = y then if List.mem x l then raise Not_found - else n + else n else index_x (succ n) l - | [] -> raise Not_found + | [] -> raise Not_found in index_x 1 let list_fold_right_i f i l = let rec it_list_f i l a = match l with | [] -> a | b::l -> f (i-1) b (it_list_f (i-1) l a) - in + in it_list_f (List.length l + i) l -let list_fold_left_i f = +let list_fold_left_i f = let rec it_list_f i a = function - | [] -> a + | [] -> a | b::l -> it_list_f (i+1) (f i a b) l - in - it_list_f + in + it_list_f let rec list_fold_left3 f accu l1 l2 l3 = match (l1, l2, l3) with @@ -667,16 +667,16 @@ let list_iter3 f l1 l2 l3 = | ([], [], []) -> () | ((h1::t1), (h2::t2), (h3::t3)) -> f h1 h2 h3; iter (t1,t2,t3) | (_, _, _) -> invalid_arg "map3" - in + in iter (l1,l2,l3) let list_iter_i f l = list_fold_left_i (fun i _ x -> f i x) 0 () l -let list_for_all_i p = +let list_for_all_i p = let rec for_all_p i = function - | [] -> true + | [] -> true | a::l -> p i a && for_all_p (i+1) l - in + in for_all_p let list_except x l = List.filter (fun y -> not (x = y)) l @@ -714,18 +714,18 @@ let rec list_sep_last = function | hd::[] -> (hd,[]) | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl) -let list_try_find_i f = +let list_try_find_i f = let rec try_find_f n = function | [] -> failwith "try_find_i" | h::t -> try f n h with Failure _ -> try_find_f (n+1) t - in + in try_find_f -let list_try_find f = +let list_try_find f = let rec try_find_f = function | [] -> failwith "try_find" | h::t -> try f h with Failure _ -> try_find_f t - in + in try_find_f let list_uniquize l = @@ -739,12 +739,12 @@ let list_uniquize l = | [] -> List.rev acc in aux [] l -let rec list_distinct l = +let rec list_distinct l = let visited = Hashtbl.create 23 in let rec loop = function | h::t -> if Hashtbl.mem visited h then false - else + else begin Hashtbl.add visited h h; loop t @@ -757,10 +757,10 @@ let rec list_merge_uniq cmp l1 l2 = | [], l2 -> l2 | l1, [] -> l1 | h1 :: t1, h2 :: t2 -> - let c = cmp h1 h2 in - if c = 0 + let c = cmp h1 h2 in + if c = 0 then h1 :: list_merge_uniq cmp t1 t2 - else if c <= 0 + else if c <= 0 then h1 :: list_merge_uniq cmp t1 l2 else h2 :: list_merge_uniq cmp l1 t2 @@ -789,13 +789,13 @@ let list_subset l1 l2 = let rec look = function | [] -> true | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false - in + in look l1 -(* [list_split_at i l] splits [l] into two lists [(l1,l2)] such that [l1++l2=l] +(* [list_split_at i l] splits [l] into two lists [(l1,l2)] such that [l1++l2=l] and [l1] has length [i]. It raises [Failure] when [i] is negative or greater than the length of [l] *) -let list_split_at index l = +let list_split_at index l = let rec aux i acc = function tl when i = index -> (List.rev acc), tl | hd :: tl -> aux (succ i) (hd :: acc) tl @@ -805,12 +805,12 @@ let list_split_at index l = (* [list_split_when p l] splits [l] into two lists [(l1,a::l2)] such that [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1]. If there is no such [a], then it returns [(l,[])] instead *) -let list_split_when p = - let rec split_when_loop x y = - match y with +let list_split_when p = + let rec split_when_loop x y = + match y with | [] -> ([],[]) | (a::l) -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l - in + in split_when_loop [] let rec list_split3 = function @@ -831,7 +831,7 @@ let list_firstn n l = | (0, l) -> List.rev acc | (n, (h::t)) -> aux (h::acc) (pred n, t) | _ -> failwith "firstn" - in + in aux [] (n,l) let rec list_last = function @@ -846,20 +846,20 @@ let list_lastn n l = in if len < n then failwith "lastn" else aux len l -let rec list_skipn n l = match n,l with - | 0, _ -> l +let rec list_skipn n l = match n,l with + | 0, _ -> l | _, [] -> failwith "list_fromn" | n, _::l -> list_skipn (pred n) l -let rec list_addn n x l = +let rec list_addn n x l = if n = 0 then l else x :: (list_addn (pred n) x l) -let list_prefix_of prefl l = +let list_prefix_of prefl l = let rec prefrec = function | (h1::t1, h2::t2) -> h1 = h2 && prefrec (t1,t2) | ([], _) -> true | (_, _) -> false - in + in prefrec (prefl,l) let list_drop_prefix p l = @@ -867,7 +867,7 @@ let list_drop_prefix p l = let rec list_drop_prefix_rec = function | ([], tl) -> Some tl | (_, []) -> None - | (h1::tp, h2::tl) -> + | (h1::tp, h2::tl) -> if h1 = h2 then list_drop_prefix_rec (tp,tl) else None in match list_drop_prefix_rec (p,l) with @@ -883,7 +883,7 @@ let list_share_tails l1 l2 = let rec shr_rev acc = function | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2) | (l1,l2) -> (List.rev l1, List.rev l2, acc) - in + in shr_rev [] (List.rev l1, List.rev l2) let rec list_fold_map f e = function @@ -894,10 +894,10 @@ let rec list_fold_map f e = function e'',h'::t' (* (* tail-recursive version of the above function *) -let list_fold_map f e l = - let g (e,b') h = +let list_fold_map f e l = + let g (e,b') h = let (e',h') = f e h in - (e',h'::b') + (e',h'::b') in let (e',lrev) = List.fold_left g (e,[]) l in (e',List.rev lrev) @@ -921,17 +921,17 @@ let list_union_map f l acc = acc l -(* A generic cartesian product: for any operator (**), - [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], +(* A generic cartesian product: for any operator (**), + [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], and so on if there are more elements in the lists. *) -let rec list_cartesian op l1 l2 = +let rec list_cartesian op l1 l2 = list_map_append (fun x -> List.map (op x) l2) l1 -(* [list_cartesians] is an n-ary cartesian product: it iterates +(* [list_cartesians] is an n-ary cartesian product: it iterates [list_cartesian] over a list of lists. *) -let list_cartesians op init ll = +let list_cartesians op init ll = List.fold_right (list_cartesian op) ll [init] (* list_combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *) @@ -940,12 +940,12 @@ let list_combinations l = list_cartesians (fun x l -> x::l) [] l (* Keep only those products that do not return None *) -let rec list_cartesian_filter op l1 l2 = +let rec list_cartesian_filter op l1 l2 = list_map_append (fun x -> list_map_filter (op x) l2) l1 (* Keep only those products that do not return None *) -let rec list_cartesians_filter op init ll = +let rec list_cartesians_filter op init ll = List.fold_right (list_cartesian_filter op) ll [init] (* Drop the last element of a list *) @@ -961,61 +961,61 @@ let array_compare item_cmp v1 v2 = -1 -> 0 | i -> let c' = item_cmp v1.(i) v2.(i) in - if c'<>0 then c' + if c'<>0 then c' else cmp (i-1) in cmp (Array.length v1 - 1) -let array_exists f v = +let array_exists f v = let rec exrec = function | -1 -> false | n -> (f v.(n)) || (exrec (n-1)) - in - exrec ((Array.length v)-1) + in + exrec ((Array.length v)-1) -let array_for_all f v = +let array_for_all f v = let rec allrec = function | -1 -> true | n -> (f v.(n)) && (allrec (n-1)) - in - allrec ((Array.length v)-1) + in + allrec ((Array.length v)-1) let array_for_all2 f v1 v2 = let rec allrec = function | -1 -> true | n -> (f v1.(n) v2.(n)) && (allrec (n-1)) - in + in let lv1 = Array.length v1 in - lv1 = Array.length v2 && allrec (pred lv1) + lv1 = Array.length v2 && allrec (pred lv1) let array_for_all3 f v1 v2 v3 = let rec allrec = function | -1 -> true | n -> (f v1.(n) v2.(n) v3.(n)) && (allrec (n-1)) - in + in let lv1 = Array.length v1 in - lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1) + lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1) let array_for_all4 f v1 v2 v3 v4 = let rec allrec = function | -1 -> true | n -> (f v1.(n) v2.(n) v3.(n) v4.(n)) && (allrec (n-1)) - in + in let lv1 = Array.length v1 in lv1 = Array.length v2 && lv1 = Array.length v3 && lv1 = Array.length v4 && - allrec (pred lv1) + allrec (pred lv1) -let array_for_all_i f i v = - let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in +let array_for_all_i f i v = + let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in allrec i 0 -let array_hd v = +let array_hd v = match Array.length v with | 0 -> failwith "array_hd" | _ -> v.(0) -let array_tl v = +let array_tl v = match Array.length v with | 0 -> failwith "array_tl" | n -> Array.sub v 1 (pred n) @@ -1027,12 +1027,12 @@ let array_last v = let array_cons e v = Array.append [|e|] v -let array_rev t = +let array_rev t = let n=Array.length t in - if n <=0 then () + if n <=0 then () else let tmp=ref t.(0) in - for i=0 to pred (n/2) do + for i=0 to pred (n/2) do tmp:=t.((pred n)-i); t.((pred n)-i)<- t.(i); t.(i)<- !tmp @@ -1063,7 +1063,7 @@ let array_fold_right2 f v1 v2 a = let array_fold_left2 f a v1 v2 = let lv1 = Array.length v1 in - let rec fold a n = + let rec fold a n = if n >= lv1 then a else fold (f a v1.(n) v2.(n)) (succ n) in if Array.length v2 <> lv1 then invalid_arg "array_fold_left2"; @@ -1071,25 +1071,25 @@ let array_fold_left2 f a v1 v2 = let array_fold_left2_i f a v1 v2 = let lv1 = Array.length v1 in - let rec fold a n = + let rec fold a n = if n >= lv1 then a else fold (f n a v1.(n) v2.(n)) (succ n) in if Array.length v2 <> lv1 then invalid_arg "array_fold_left2"; fold a 0 -let array_fold_left_from n f a v = +let array_fold_left_from n f a v = let rec fold a n = if n >= Array.length v then a else fold (f a v.(n)) (succ n) - in + in fold a n -let array_fold_right_from n f v a = +let array_fold_right_from n f v a = let rec fold n = if n >= Array.length v then a else f v.(n) (fold (succ n)) - in + in fold n -let array_app_tl v l = +let array_app_tl v l = if Array.length v = 0 then invalid_arg "array_app_tl"; array_fold_right_from 1 (fun e l -> e::l) v l @@ -1109,9 +1109,9 @@ exception Local of int (* If none of the elements is changed by f we return ar itself. The for loop looks for the first such an element. - If found it is temporarily stored in a ref and the new array is produced, + If found it is temporarily stored in a ref and the new array is produced, but f is not re-applied to elements that are already checked *) -let array_smartmap f ar = +let array_smartmap f ar = let ar_size = Array.length ar in let aux = ref None in try @@ -1125,10 +1125,10 @@ let array_smartmap f ar = done; ar with - Local i -> - let copy j = - if j + let copy j = + if j a' | None -> failwith "Error" else f (ar.(j)) in @@ -1136,8 +1136,8 @@ let array_smartmap f ar = let array_map2 f v1 v2 = if Array.length v1 <> Array.length v2 then invalid_arg "array_map2"; - if Array.length v1 == 0 then - [| |] + if Array.length v1 == 0 then + [| |] else begin let res = Array.create (Array.length v1) (f v1.(0) v2.(0)) in for i = 1 to pred (Array.length v1) do @@ -1148,8 +1148,8 @@ let array_map2 f v1 v2 = let array_map2_i f v1 v2 = if Array.length v1 <> Array.length v2 then invalid_arg "array_map2"; - if Array.length v1 == 0 then - [| |] + if Array.length v1 == 0 then + [| |] else begin let res = Array.create (Array.length v1) (f 0 v1.(0) v2.(0)) in for i = 1 to pred (Array.length v1) do @@ -1161,8 +1161,8 @@ let array_map2_i f v1 v2 = let array_map3 f v1 v2 v3 = if Array.length v1 <> Array.length v2 || Array.length v1 <> Array.length v3 then invalid_arg "array_map3"; - if Array.length v1 == 0 then - [| |] + if Array.length v1 == 0 then + [| |] else begin let res = Array.create (Array.length v1) (f v1.(0) v2.(0) v3.(0)) in for i = 1 to pred (Array.length v1) do @@ -1203,7 +1203,7 @@ let pure_functional = false let array_fold_map' f v e = if pure_functional then let (l,e) = - Array.fold_right + Array.fold_right (fun x (l,e) -> let (y,e) = f x e in (y::l,e)) v ([],e) in (Array.of_list l,e) @@ -1219,8 +1219,8 @@ let array_fold_map f e v = let array_fold_map2' f v1 v2 e = let e' = ref e in - let v' = - array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 + let v' = + array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 in (v',!e') @@ -1253,10 +1253,10 @@ let identity x = x let compose f g x = f (g x) -let iterate f = +let iterate f = let rec iterate_f n x = if n <= 0 then x else iterate_f (pred n) (f x) - in + in iterate_f let repeat n f x = @@ -1265,7 +1265,7 @@ let repeat n f x = let iterate_for a b f x = let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in iterate a x - + (* Misc *) type ('a,'b) union = Inl of 'a | Inr of 'b @@ -1281,22 +1281,22 @@ let intmap_to_list m = Intmap.fold (fun n v l -> (n,v)::l) m [] let intmap_inv m b = Intmap.fold (fun n v l -> if v = b then n::l else l) m [] -let interval n m = +let interval n m = let rec interval_n (l,m) = if n > m then l else interval_n (m::l,pred m) - in + in interval_n ([],m) -let map_succeed f = - let rec map_f = function +let map_succeed f = + let rec map_f = function | [] -> [] | h::t -> try (let x = f h in x :: map_f t) with Failure _ -> map_f t - in - map_f + in + map_f (* Pretty-printing *) - + let pr_spc = spc let pr_fnl = fnl let pr_int = int @@ -1312,7 +1312,7 @@ let nth n = str (ordinal n) (* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *) -let rec prlist elem l = match l with +let rec prlist elem l = match l with | [] -> mt () | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t) @@ -1320,7 +1320,7 @@ let rec prlist elem l = match l with if a strict behavior is needed, use [prlist_strict] instead. evaluation is done from left to right. *) -let rec prlist_strict elem l = match l with +let rec prlist_strict elem l = match l with | [] -> mt () | h::t -> let e = elem h in let r = prlist_strict elem t in e++r @@ -1344,7 +1344,7 @@ let rec pr_sequence elem = function let e = elem h and r = pr_sequence elem t in if e = mt () then r else e ++ spc () ++ r -(* [pr_enum pr [a ; b ; ... ; c]] outputs +(* [pr_enum pr [a ; b ; ... ; c]] outputs [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *) let pr_enum pr l = @@ -1355,11 +1355,11 @@ let pr_enum pr l = let pr_vertical_list pr = function | [] -> str "none" ++ fnl () | l -> fnl () ++ str " " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl () - + let prvecti elem v = let n = Array.length v in let rec pr i = - if i = 0 then + if i = 0 then elem 0 v.(0) else let r = pr (i-1) and e = elem i v.(i) in r ++ e @@ -1371,10 +1371,10 @@ let prvecti elem v = let prvect_with_sep sep elem v = let rec pr n = - if n = 0 then + if n = 0 then elem v.(0) - else - let r = pr (n-1) and s = sep() and e = elem v.(n) in + else + let r = pr (n-1) and s = sep() and e = elem v.(n) in r ++ s ++ e in let n = Array.length v in @@ -1428,34 +1428,34 @@ let memon_eq eq n f = (*s Size of ocaml values. *) module Size = struct - + open Obj (*s Pointers already visited are stored in a hash-table, where comparisons are done using physical equality. *) module H = Hashtbl.Make( - struct - type t = Obj.t - let equal = (==) + struct + type t = Obj.t + let equal = (==) let hash o = Hashtbl.hash (magic o : int) end) - + let node_table = (H.create 257 : unit H.t) - + let in_table o = try H.find node_table o; true with Not_found -> false - + let add_in_table o = H.add node_table o () - + let reset_table () = H.clear node_table - + (*s Objects are traversed recursively, as soon as their tags are less than [no_scan_tag]. [count] records the numbers of words already visited. *) let size_of_double = size (repr 1.0) - + let count = ref 0 - + let rec traverse t = if not (in_table t) then begin add_in_table t; @@ -1465,20 +1465,20 @@ module Size = struct if tag < no_scan_tag then begin count := !count + 1 + n; for i = 0 to n - 1 do - let f = field t i in + let f = field t i in if is_block f then traverse f done end else if tag = string_tag then - count := !count + 1 + n + count := !count + 1 + n else if tag = double_tag then count := !count + size_of_double else if tag = double_array_tag then - count := !count + 1 + size_of_double * n + count := !count + 1 + size_of_double * n else incr count end end - + (*s Sizes of objects in words and in bytes. The size in bytes is computed system-independently according to [Sys.word_size]. *) @@ -1511,6 +1511,6 @@ let heap_size_kb () = (heap_size () + 1023) / 1024 (*s interruption *) let interrupt = ref false -let check_for_interrupt () = +let check_for_interrupt () = if !interrupt then begin interrupt := false; raise Sys.Break end diff --git a/lib/util.mli b/lib/util.mli index 5e32a1b0ea..4579982bcf 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -128,7 +128,7 @@ val list_map_filter : ('a -> 'b option) -> 'a list -> 'b list val list_smartmap : ('a -> 'a) -> 'a list -> 'a list val list_map_left : ('a -> 'b) -> 'a list -> 'b list val list_map_i : (int -> 'a -> 'b) -> int -> 'a list -> 'b list -val list_map2_i : +val list_map2_i : (int -> 'a -> 'b -> 'c) -> int -> 'a list -> 'b list -> 'c list val list_map3 : ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list @@ -139,7 +139,7 @@ val list_filter_i : (* [list_index] returns the 1st index of an element in a list (counting from 1) *) val list_index : 'a -> 'a list -> int (* [list_unique_index x l] returns [Not_found] if [x] doesn't occur exactly once *) -val list_unique_index : 'a -> 'a list -> int +val list_unique_index : 'a -> 'a list -> int (* [list_index0] behaves as [list_index] except that it starts counting at 0 *) val list_index0 : 'a -> 'a list -> int val list_iter3 : ('a -> 'b -> 'c -> unit) -> 'a list -> 'b list -> 'c list -> unit @@ -169,7 +169,7 @@ val list_partition_by : ('a -> 'a -> bool) -> 'a list -> 'a list list val list_firstn : int -> 'a list -> 'a list val list_last : 'a list -> 'a val list_lastn : int -> 'a list -> 'a list -val list_skipn : int -> 'a list -> 'a list +val list_skipn : int -> 'a list -> 'a list val list_addn : int -> 'a -> 'a list -> 'a list val list_prefix_of : 'a list -> 'a list -> bool (* [list_drop_prefix p l] returns [t] if [l=p++t] else return [l] *) @@ -186,11 +186,11 @@ val list_share_tails : 'a list -> 'a list -> 'a list * 'a list * 'a list val list_fold_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list val list_fold_map' : ('b -> 'a -> 'c * 'a) -> 'b list -> 'a -> 'c list * 'a val list_map_assoc : ('a -> 'b) -> ('c * 'a) list -> ('c * 'b) list -(* A generic cartesian product: for any operator (**), - [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], +(* A generic cartesian product: for any operator (**), + [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], and so on if there are more elements in the lists. *) val list_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list -(* [list_cartesians] is an n-ary cartesian product: it iterates +(* [list_cartesians] is an n-ary cartesian product: it iterates [list_cartesian] over a list of lists. *) val list_cartesians : ('a -> 'b -> 'b) -> 'b -> 'a list list -> 'b list (* list_combinations [[a;b];[c;d]] returns [[a;c];[a;d];[b;c];[b;d]] *) @@ -219,14 +219,14 @@ val array_tl : 'a array -> 'a array val array_last : 'a array -> 'a val array_cons : 'a -> 'a array -> 'a array val array_rev : 'a array -> unit -val array_fold_right_i : +val array_fold_right_i : (int -> 'b -> 'a -> 'a) -> 'b array -> 'a -> 'a val array_fold_left_i : (int -> 'a -> 'b -> 'a) -> 'a -> 'b array -> 'a val array_fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c -val array_fold_left2 : +val array_fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a -val array_fold_left2_i : +val array_fold_left2_i : (int -> 'a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a val array_fold_left_from : int -> ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a val array_fold_right_from : int -> ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b @@ -237,7 +237,7 @@ val array_chop : int -> 'a array -> 'a array * 'a array val array_smartmap : ('a -> 'a) -> 'a array -> 'a array val array_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val array_map2_i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array -val array_map3 : +val array_map3 : ('a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val array_map_left : ('a -> 'b) -> 'a array -> 'b array val array_map_left_pair : ('a -> 'b) -> 'a array -> ('c -> 'd) -> 'c array -> diff --git a/library/decl_kinds.ml b/library/decl_kinds.ml index 03b14e31cd..5fd27f4675 100644 --- a/library/decl_kinds.ml +++ b/library/decl_kinds.ml @@ -44,7 +44,7 @@ type definition_object_kind = type assumption_object_kind = Definitional | Logical | Conjectural -(* [assumption_kind] +(* [assumption_kind] | Local | Global ------------------------------------ diff --git a/library/decl_kinds.mli b/library/decl_kinds.mli index e42cb9621d..0ebab9ca0e 100644 --- a/library/decl_kinds.mli +++ b/library/decl_kinds.mli @@ -44,7 +44,7 @@ type definition_object_kind = type assumption_object_kind = Definitional | Logical | Conjectural -(* [assumption_kind] +(* [assumption_kind] | Local | Global ------------------------------------ diff --git a/library/declare.ml b/library/declare.ml index 44536ce5b3..49b7d7ba2b 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -62,7 +62,7 @@ let cache_variable ((sp,_),o) = let cst = Global.push_named_assum (id,ty) in let impl = if impl then Lib.Implicit else Lib.Explicit in impl, true, cst - | SectionLocalDef (c,t,opaq) -> + | SectionLocalDef (c,t,opaq) -> let cst = Global.push_named_def (id,c,t) in Lib.Explicit, opaq, cst in Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); @@ -98,7 +98,7 @@ type constant_declaration = constant_entry * logical_kind (* section (if Remark or Fact) is needed to access a construction *) let load_constant i ((sp,kn),(_,_,kind)) = if Nametab.exists_cci sp then - errorlabstrm "cache_constant" + errorlabstrm "cache_constant" (pr_id (basename sp) ++ str " already exists"); Nametab.push (Nametab.Until i) sp (ConstRef (constant_of_kn kn)); add_constant_kind (constant_of_kn kn) kind @@ -150,7 +150,7 @@ let (inConstant,_) = classify_function = classify_constant; subst_function = ident_subst_function; discharge_function = discharge_constant; - export_function = export_constant } + export_function = export_constant } let hcons_constant_declaration = function | DefinitionEntry ce when !Flags.hash_cons_proofs -> @@ -158,7 +158,7 @@ let hcons_constant_declaration = function DefinitionEntry { const_entry_body = hcons1_constr ce.const_entry_body; const_entry_type = Option.map hcons1_constr ce.const_entry_type; - const_entry_opaque = ce.const_entry_opaque; + const_entry_opaque = ce.const_entry_opaque; const_entry_boxed = ce.const_entry_boxed } | cd -> cd @@ -190,14 +190,14 @@ let declare_inductive_argument_scopes kn mie = let inductive_names sp kn mie = let (dp,_) = repr_path sp in - let names, _ = + let names, _ = List.fold_left (fun (names, n) ind -> let ind_p = (kn,n) in let names, _ = List.fold_left (fun (names, p) l -> - let sp = + let sp = Libnames.make_path dp l in ((sp, ConstructRef (ind_p,p)) :: names, p+1)) @@ -262,14 +262,14 @@ let dummy_inductive_entry (_,m) = ([],{ let export_inductive x = Some (dummy_inductive_entry x) let (inInductive,_) = - declare_object {(default_object "INDUCTIVE") with + declare_object {(default_object "INDUCTIVE") with cache_function = cache_inductive; load_function = load_inductive; open_function = open_inductive; classify_function = (fun a -> Substitute (dummy_inductive_entry a)); subst_function = ident_subst_function; discharge_function = discharge_inductive; - export_function = export_inductive } + export_function = export_inductive } (* for initial declaration *) let declare_mind isrecord mie = diff --git a/library/declare.mli b/library/declare.mli index 94457a9f84..1a68f8e201 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -21,11 +21,11 @@ open Nametab open Decl_kinds (*i*) -(* This module provides the official functions to declare new variables, +(* This module provides the official functions to declare new variables, parameters, constants and inductive types. Using the following functions will add the entries in the global environment (module [Global]), will register the declarations in the library (module [Lib]) --- so that the - reset works properly --- and will fill some global tables such as + reset works properly --- and will fill some global tables such as [Nametab] and [Impargs]. *) open Nametab diff --git a/library/declaremods.ml b/library/declaremods.ml index 6275c4b779..37ee34d1f0 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -40,63 +40,63 @@ open Mod_subst therefore must be substitued with valid names before use. *) -type substitutive_objects = +type substitutive_objects = substitution * mod_bound_id list * mod_self_id * lib_objects (* For each module, we store the following things: - In modtab_substobjs: substitutive_objects - when we will do Module M:=N, the objects of N will be reloaded + In modtab_substobjs: substitutive_objects + when we will do Module M:=N, the objects of N will be reloaded with M after substitution In modtab_objects: "substituted objects" @ "keep objects" - substituted objects - - roughly the objects above after the substitution - we need to + substituted objects - + roughly the objects above after the substitution - we need to keep them to call open_object when the module is opened (imported) - + keep objects - - The list of non-substitutive objects - as above, for each of - them we will call open_object when the module is opened - + The list of non-substitutive objects - as above, for each of + them we will call open_object when the module is opened + (Some) Invariants: * If the module is a functor, the two latter lists are empty. - * Module objects in substitutive_objects part have empty substituted + * Module objects in substitutive_objects part have empty substituted objects. - * Modules which where created with Module M:=mexpr or with + * Modules which where created with Module M:=mexpr or with Module M:SIG. ... End M. have the keep list empty. *) -let modtab_substobjs = +let modtab_substobjs = ref (MPmap.empty : substitutive_objects MPmap.t) -let modtab_objects = +let modtab_objects = ref (MPmap.empty : (object_prefix * lib_objects) MPmap.t) (* currently started interactive module (if any) - its arguments (if it is a functor) and declared output type *) -let openmod_info = - ref (([],None,None) : mod_bound_id list * module_struct_entry option - * struct_expr_body option) +let openmod_info = + ref (([],None,None) : mod_bound_id list * module_struct_entry option + * struct_expr_body option) (* The library_cache here is needed to avoid recalculations of substituted modules object during "reloading" of libraries *) let library_cache = ref Dirmap.empty let _ = Summary.declare_summary "MODULE-INFO" - { Summary.freeze_function = (fun () -> + { Summary.freeze_function = (fun () -> !modtab_substobjs, !modtab_objects, !openmod_info, !library_cache); - Summary.unfreeze_function = (fun (sobjs,objs,info,libcache) -> + Summary.unfreeze_function = (fun (sobjs,objs,info,libcache) -> modtab_substobjs := sobjs; modtab_objects := objs; openmod_info := info; library_cache := libcache); - Summary.init_function = (fun () -> + Summary.init_function = (fun () -> modtab_substobjs := MPmap.empty; modtab_objects := MPmap.empty; openmod_info := ([],None,None); @@ -105,14 +105,14 @@ let _ = Summary.declare_summary "MODULE-INFO" (* auxiliary functions to transform full_path and kernel_name given by Lib into module_path and dir_path needed for modules *) -let mp_of_kn kn = - let mp,sec,l = repr_kn kn in - if sec=empty_dirpath then - MPdot (mp,l) +let mp_of_kn kn = + let mp,sec,l = repr_kn kn in + if sec=empty_dirpath then + MPdot (mp,l) else anomaly ("Non-empty section in module name!" ^ string_of_kn kn) -let dir_of_sp sp = +let dir_of_sp sp = let dir,id = repr_path sp in add_dirpath_suffix dir id @@ -120,34 +120,34 @@ let msid_of_mp = function MPself msid -> msid | _ -> anomaly "'Self' module path expected!" -let msid_of_prefix (_,(mp,sec)) = - if sec=empty_dirpath then +let msid_of_prefix (_,(mp,sec)) = + if sec=empty_dirpath then msid_of_mp mp else - anomaly ("Non-empty section in module name!" ^ + anomaly ("Non-empty section in module name!" ^ string_of_mp mp ^ "." ^ string_of_dirpath sec) let scrape_alias mp = Environ.scrape_alias mp (Global.env()) - + (* This function checks if the type calculated for the module [mp] is a subtype of [sub_mtb]. Uses only the global environment. *) let check_subtypes mp sub_mtb = let env = Global.env () in let mtb = Environ.lookup_modtype mp env in - let sub_mtb = + let sub_mtb = {typ_expr = sub_mtb; typ_strength = None; typ_alias = empty_subst} in - let _ = Environ.add_constraints - (Subtyping.check_subtypes env mtb sub_mtb) + let _ = Environ.add_constraints + (Subtyping.check_subtypes env mtb sub_mtb) in - () (* The constraints are checked and forgot immediately! *) + () (* The constraints are checked and forgot immediately! *) let compute_subst_objects mp (subst,mbids,msid,objs) = match mbids with - | [] -> + | [] -> let subst' = join_alias (map_msid msid mp) subst in Some (join (map_msid msid mp) (join subst' subst), objs) | _ -> @@ -164,15 +164,15 @@ let subst_substobjs dir mp substobjs = through its components. They are called by plenty module functions *) let compute_visibility exists what i dir dirinfo = - if exists then - if - try Nametab.locate_dir (qualid_of_dirpath dir) = dirinfo - with Not_found -> false + if exists then + if + try Nametab.locate_dir (qualid_of_dirpath dir) = dirinfo + with Not_found -> false then Nametab.Exactly i else errorlabstrm (what^"_module") - (pr_dirpath dir ++ str " should already exist!") + (pr_dirpath dir ++ str " should already exist!") else if Nametab.exists_dir dir then errorlabstrm (what^"_module") (pr_dirpath dir ++ str " already exists") @@ -202,12 +202,12 @@ let do_module exists what iter_objects i dir mp substobjs objects = Nametab.push_dir vis dir dirinfo; modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs; match objects with - Some seg -> + Some seg -> modtab_objects := MPmap.add mp (prefix,seg) !modtab_objects; - iter_objects (i+1) prefix seg + iter_objects (i+1) prefix seg | None -> () -let conv_names_do_module exists what iter_objects i +let conv_names_do_module exists what iter_objects i (sp,kn) substobjs substituted = let dir,mp = dir_of_sp sp, mp_of_kn kn in do_module exists what iter_objects i dir mp substobjs substituted @@ -222,19 +222,19 @@ let cache_module ((sp,kn as oname),(entry,substobjs,substituted)) = | None -> anomaly "You must not recache interactive modules!" | Some (me,sub_mte_o) -> - let sub_mtb_o = match sub_mte_o with + let sub_mtb_o = match sub_mte_o with None -> None | Some mte -> Some (Mod_typing.translate_struct_entry (Global.env()) mte) in - + let mp = Global.add_module (basename sp) me in if mp <> mp_of_kn kn then anomaly "Kernel and Library names do not match"; - + match sub_mtb_o with None -> () - | Some (sub_mtb,sub) -> + | Some (sub_mtb,sub) -> check_subtypes mp sub_mtb in @@ -246,7 +246,7 @@ let cache_module ((sp,kn as oname),(entry,substobjs,substituted)) = (* TODO: This check is not essential *) let check_empty s = function | None -> () - | Some _ -> + | Some _ -> anomaly ("We should never have full info in " ^ s^"!") @@ -302,9 +302,9 @@ let (in_module,out_module) = let rec replace_alias modalias_obj obj = let rec put_alias (id_alias,obj_alias) l = - match l with + match l with [] -> [] - | (id,o)::r + | (id,o)::r when ( object_tag o = "MODULE") -> if id = id_alias then (* let (entry,subst_o,substed_o) = out_module_alias obj_alias in @@ -312,7 +312,7 @@ let rec replace_alias modalias_obj obj = begin match substed_o,substed_o' with Some a,Some b -> - (id,in_module_alias + (id,in_module_alias (entry,subst_o',Some (dump_alias_object a b)))::r*) (id_alias,obj_alias)::r (* | _,_ -> (id,o)::r @@ -324,20 +324,20 @@ let rec replace_alias modalias_obj obj = | [] -> list_obj | o::r ->choose_obj_alias r (put_alias o list_obj) in choose_obj_alias modalias_obj obj - + and dump_alias_object alias_obj obj = let rec alias_in_obj seg = match seg with | [] -> [] - | (id,o)::r when (object_tag o = "MODULE ALIAS") -> + | (id,o)::r when (object_tag o = "MODULE ALIAS") -> (id,o)::(alias_in_obj r) | e::r -> (alias_in_obj r) in let modalias_obj = alias_in_obj alias_obj in replace_alias modalias_obj obj - + and do_module_alias exists what iter_objects i dir mp alias substobjs objects = let prefix = (dir,(alias,empty_dirpath)) in - let alias_objects = + let alias_objects = try Some (MPmap.find alias !modtab_objects) with Not_found -> None in let dirinfo = DirModule (dir,(mp,empty_dirpath)) in @@ -345,10 +345,10 @@ and do_module_alias exists what iter_objects i dir mp alias substobjs objects = Nametab.push_dir vis dir dirinfo; modtab_substobjs := MPmap.add mp substobjs !modtab_substobjs; match alias_objects,objects with - Some (_,seg), Some seg' -> + Some (_,seg), Some seg' -> let new_seg = dump_alias_object seg seg' in modtab_objects := MPmap.add mp (prefix,new_seg) !modtab_objects; - iter_objects (i+1) prefix new_seg + iter_objects (i+1) prefix new_seg | _,_-> () and cache_module_alias ((sp,kn),(entry,substobjs,substituted)) = @@ -356,36 +356,36 @@ and cache_module_alias ((sp,kn),(entry,substobjs,substituted)) = | None -> anomaly "You must not recache interactive modules!" | Some (me,sub_mte_o) -> - let sub_mtb_o = match sub_mte_o with + let sub_mtb_o = match sub_mte_o with None -> None | Some mte -> Some (Mod_typing.translate_struct_entry (Global.env()) mte) in - let mp' = match me with + let mp' = match me with | {mod_entry_type = None; mod_entry_expr = Some (MSEident mp)} -> - Global.add_alias (basename sp) mp + Global.add_alias (basename sp) mp | _ -> anomaly "cache module alias" in if mp' <> mp_of_kn kn then anomaly "Kernel and Library names do not match"; - + let _ = match sub_mtb_o with None -> () - | Some (sub_mtb,sub) -> + | Some (sub_mtb,sub) -> check_subtypes mp' sub_mtb in match me with | {mod_entry_type = None; mod_entry_expr = Some (MSEident mp)} -> - dir_of_sp sp,mp_of_kn kn,scrape_alias mp + dir_of_sp sp,mp_of_kn kn,scrape_alias mp | _ -> anomaly "cache module alias" in do_module_alias false "cache" load_objects 1 dir mp alias substobjs substituted and load_module_alias i ((sp,kn),(entry,substobjs,substituted)) = - let dir,mp,alias= - match entry with + let dir,mp,alias= + match entry with | Some (me,_)-> begin match me with @@ -400,7 +400,7 @@ and load_module_alias i ((sp,kn),(entry,substobjs,substituted)) = and open_module_alias i ((sp,kn),(entry,substobjs,substituted)) = let dir,mp,alias= - match entry with + match entry with | Some (me,_)-> begin match me with @@ -423,7 +423,7 @@ and subst_module_alias ((sp,kn),subst,(entry,substobjs,_)) = let substobjs = (subst',mbids,msid,objs) in (* if we are not a functor - calculate substitued. We add "msid |-> mp" to the substitution *) - match entry with + match entry with | Some (me,sub)-> begin match me with @@ -432,46 +432,46 @@ and subst_module_alias ((sp,kn),subst,(entry,substobjs,_)) = let mp' = subst_mp subst' mp' in let mp' = scrape_alias mp' in (Some ({mod_entry_type = None; - mod_entry_expr = + mod_entry_expr = Some (MSEident mp')},sub), substobjs, match mbids with | [] -> let subst = update_subst subst' (map_mp mp' mp) in - Some (subst_objects (dir,(mp',empty_dirpath)) + Some (subst_objects (dir,(mp',empty_dirpath)) (join (join subst' subst) (join (map_msid msid mp') (map_mp mp mp'))) objs) | _ -> None) - + | _ -> anomaly "Modops: Not an alias" end | None -> anomaly "Modops: Empty info" and classify_module_alias (entry,substobjs,_) = Substitute (entry,substobjs,None) - + let (in_module_alias,out_module_alias) = declare_object {(default_object "MODULE ALIAS") with cache_function = cache_module_alias; open_function = open_module_alias; classify_function = classify_module_alias; subst_function = subst_module_alias; - load_function = load_module_alias; + load_function = load_module_alias; export_function = (fun _ -> anomaly "No modules in sections!") } - + let cache_keep _ = anomaly "This module should not be cached!" -let load_keep i ((sp,kn),seg) = +let load_keep i ((sp,kn),seg) = let mp = mp_of_kn kn in let prefix = dir_of_sp sp, (mp,empty_dirpath) in - begin + begin try let prefix',objects = MPmap.find mp !modtab_objects in - if prefix' <> prefix then + if prefix' <> prefix then anomaly "Two different modules with the same path!"; modtab_objects := MPmap.add mp (prefix,objects@seg) !modtab_objects; with @@ -479,7 +479,7 @@ let load_keep i ((sp,kn),seg) = end; load_objects i prefix seg -let open_keep i ((sp,kn),seg) = +let open_keep i ((sp,kn),seg) = let dirpath,mp = dir_of_sp sp, mp_of_kn kn in open_objects i (dirpath,(mp,empty_dirpath)) seg @@ -514,7 +514,7 @@ let _ = Summary.declare_summary "MODTYPE-INFO" let cache_modtype ((sp,kn),(entry,modtypeobjs)) = - let _ = + let _ = match entry with | None -> anomaly "You must not recache interactive module types!" @@ -541,18 +541,18 @@ let load_modtype i ((sp,kn),(entry,modtypeobjs)) = (pr_path sp ++ str " already exists") ; Nametab.push_modtype (Nametab.Until i) sp (mp_of_kn kn); - + modtypetab := MPmap.add (mp_of_kn kn) modtypeobjs !modtypetab let open_modtype i ((sp,kn),(entry,_)) = check_empty "open_modtype" entry; - if - try Nametab.locate_modtype (qualid_of_path sp) <> (mp_of_kn kn) + if + try Nametab.locate_modtype (qualid_of_path sp) <> (mp_of_kn kn) with Not_found -> true then - errorlabstrm ("open_modtype") + errorlabstrm ("open_modtype") (pr_path sp ++ str " should already exist!"); Nametab.push_modtype (Nametab.Exactly i) sp (mp_of_kn kn) @@ -581,12 +581,12 @@ let rec replace_module_object idl (subst, mbids, msid, lib_stack) modobjs mp = let rec mp_rec = function | [] -> MPself msid | i::r -> MPdot(mp_rec r,label_of_id i) - in - if mbids<>[] then + in + if mbids<>[] then error "Unexpected functor objects" else - let rec replace_idl = function - | _,[] -> [] + let rec replace_idl = function + | _,[] -> [] | id::idl,(id',obj)::tail when id = id' -> let tag = object_tag obj in if tag = "MODULE" or tag ="MODULE ALIAS" then @@ -608,7 +608,7 @@ let rec replace_module_object idl (subst, mbids, msid, lib_stack) modobjs mp = | idl,lobj::tail -> lobj::replace_idl (idl,tail) in (join (map_mp (mp_rec (List.rev idl)) mp) subst, mbids, msid, replace_idl (idl,lib_stack)) - + let abstract_substobjs mbids1 (subst, mbids2, msid, lib_stack) = (subst, mbids1@mbids2, msid, lib_stack) @@ -618,19 +618,19 @@ let rec get_modtype_substobjs env = function let (subst, mbids, msid, objs) = get_modtype_substobjs env mte in (subst, mbid::mbids, msid, objs) | MSEwith (mty, With_Definition _) -> get_modtype_substobjs env mty - | MSEwith (mty, With_Module (idl,mp)) -> + | MSEwith (mty, With_Module (idl,mp)) -> let substobjs = get_modtype_substobjs env mty in let mp = Environ.scrape_alias mp env in let modobjs = MPmap.find mp !modtab_substobjs in replace_module_object idl substobjs modobjs mp | MSEapply (mexpr, MSEident mp) -> let ftb,sub1 = Mod_typing.translate_struct_entry env mexpr in - let farg_id, farg_b, fbody_b = Modops.destr_functor env + let farg_id, farg_b, fbody_b = Modops.destr_functor env (Modops.eval_struct env ftb) in let mp = Environ.scrape_alias mp env in let sub_alias = (Environ.lookup_modtype mp env).typ_alias in let sub_alias = match Modops.eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> join_alias + | SEBstruct (msid,sign) -> join_alias (subst_key (map_msid msid mp) sub_alias) (map_msid msid mp) | _ -> sub_alias in @@ -650,7 +650,7 @@ let rec get_modtype_substobjs env = function let sub3 = join sub3 (update_subst sub_alias (map_mbid farg_id mp None)) in (* application outside the kernel, only for substitutive objects (that are all non-logical objects) *) - ((join + ((join (join subst sub3) (map_mbid mbid mp (Some resolve))) , mbids, msid, objs) @@ -660,7 +660,7 @@ let rec get_modtype_substobjs env = function | MSEapply (_,mexpr) -> Modops.error_application_to_not_path mexpr - + (* push names of bound modules (and their components) to Nametab *) (* add objects associated to them *) let process_module_bindings argids args = @@ -672,14 +672,14 @@ let process_module_bindings argids args = in List.iter2 process_arg argids args -let intern_args interp_modtype (idl,arg) = +let intern_args interp_modtype (idl,arg) = let lib_dir = Lib.library_dp() in let mbids = List.map (fun (_,id) -> make_mbid lib_dir (string_of_id id)) idl in let mty = interp_modtype (Global.env()) arg in let dirs = List.map (fun (_,id) -> make_dirpath [id]) idl in let substobjs = get_modtype_substobjs (Global.env()) mty in List.map2 - (fun dir mbid -> + (fun dir mbid -> Global.add_module_parameter mbid mty; let mp = MPbound mbid in ignore (do_load_and_subst_module 1 dir mp substobjs []); @@ -701,9 +701,9 @@ let start_module interp_modtype export id args res_o = Some mte, None else let mtb,_ = Mod_typing.translate_struct_entry (Global.env()) mte in - let sub_mtb = - List.fold_right - (fun (arg_id,arg_t) mte -> + let sub_mtb = + List.fold_right + (fun (arg_id,arg_t) mte -> let arg_t,sub = Mod_typing.translate_struct_entry (Global.env()) arg_t in let arg_t = {typ_expr = arg_t; @@ -733,13 +733,13 @@ let end_module () = let substobjs, keep, special = try match res_o with - | None -> + | None -> (empty_subst, mbids, msid, substitute), keep, special | Some (MSEident ln) -> abstract_substobjs mbids (MPmap.find ln (!modtypetab)), [], [] | Some (MSEwith _ as mty) -> abstract_substobjs mbids (get_modtype_substobjs (Global.env()) mty), [], [] - | Some (MSEfunctor _) -> + | Some (MSEfunctor _) -> anomaly "Funsig cannot be here..." | Some (MSEapply _ as mty) -> abstract_substobjs mbids (get_modtype_substobjs (Global.env()) mty), [], [] @@ -759,8 +759,8 @@ let end_module () = let substituted = subst_substobjs dir mp substobjs in let node = in_module (None,substobjs,substituted) in - let objects = - if keep = [] || mbids <> [] then + let objects = + if keep = [] || mbids <> [] then special@[node] (* no keep objects or we are defining a functor *) else special@[node;in_modkeep keep] (* otherwise *) @@ -769,7 +769,7 @@ let end_module () = if (fst newoname) <> (fst oldoname) then anomaly "Names generated on start_ and end_module do not match"; - if mp_of_kn (snd newoname) <> mp then + if mp_of_kn (snd newoname) <> mp then anomaly "Kernel and Library names do not match"; Lib.add_frozen_state () (* to prevent recaching *); @@ -777,7 +777,7 @@ let end_module () = -let module_objects mp = +let module_objects mp = let prefix,objects = MPmap.find mp !modtab_objects in segment_of_objects prefix objects @@ -789,13 +789,13 @@ let module_objects mp = type library_name = dir_path (* The first two will form substitutive_objects, the last one is keep *) -type library_objects = +type library_objects = mod_self_id * lib_objects * lib_objects let register_library dir cenv objs digest = let mp = MPfile dir in - try + try ignore(Global.lookup_module mp); (* if it's in the environment, the cached objects should be correct *) let substobjs, objects = Dirmap.find dir !library_cache in @@ -809,7 +809,7 @@ let register_library dir cenv objs digest = let modobjs = substobjs, objects in library_cache := Dirmap.add dir modobjs !library_cache -let start_library dir = +let start_library dir = let mp = Global.start_library dir in openmod_info:=[],None,None; Lib.start_compilation dir mp; @@ -818,7 +818,7 @@ let start_library dir = let end_library_hook = ref ignore let set_end_library_hook f = end_library_hook := f -let end_library dir = +let end_library dir = !end_library_hook(); let prefix, lib_stack = Lib.end_compilation dir in let cenv = Global.export dir in @@ -830,24 +830,24 @@ let end_library dir = (* implementation of Export M and Import M *) -let really_import_module mp = +let really_import_module mp = let prefix,objects = MPmap.find mp !modtab_objects in open_objects 1 prefix objects -let cache_import (_,(_,mp)) = -(* for non-substitutive exports: +let cache_import (_,(_,mp)) = +(* for non-substitutive exports: let mp = Nametab.locate_module (qualid_of_dirpath dir) in *) really_import_module mp -let classify_import (export,_ as obj) = +let classify_import (export,_ as obj) = if export then Substitute obj else Dispose let subst_import (_,subst,(export,mp as obj)) = let mp' = subst_mp subst mp in if mp'==mp then obj else (export,mp') - + let (in_import,_) = declare_object {(default_object "IMPORT MODULE") with cache_function = cache_import; @@ -856,7 +856,7 @@ let (in_import,_) = classify_function = classify_import } -let import_module export mp = +let import_module export mp = Lib.add_anonymous_leaf (in_import (export,mp)) (************************************************************************) @@ -898,7 +898,7 @@ let end_modtype () = ln -let declare_modtype interp_modtype id args mty = +let declare_modtype interp_modtype id args mty = let fs = Summary.freeze_summaries () in try @@ -906,8 +906,8 @@ let declare_modtype interp_modtype id args mty = let arg_entries = List.concat (List.map (intern_args interp_modtype) args) in let base_mty = interp_modtype (Global.env()) mty in - let entry = - List.fold_right + let entry = + List.fold_right (fun (arg_id,arg_t) mte -> MSEfunctor(arg_id,arg_t,mte)) arg_entries base_mty @@ -916,27 +916,27 @@ let declare_modtype interp_modtype id args mty = (* Undo the simulated interactive building of the module type *) (* and declare the module type as a whole *) Summary.unfreeze_summaries fs; - + ignore (add_leaf id (in_modtype (Some entry, substobjs))); mmp with e -> (* Something wrong: undo the whole process *) Summary.unfreeze_summaries fs; raise e - + let rec get_module_substobjs env = function - | MSEident mp -> MPmap.find mp !modtab_substobjs + | MSEident mp -> MPmap.find mp !modtab_substobjs | MSEfunctor (mbid,mty,mexpr) -> let (subst, mbids, msid, objs) = get_module_substobjs env mexpr in (subst, mbid::mbids, msid, objs) | MSEapply (mexpr, MSEident mp) -> let ftb,sub1 = Mod_typing.translate_struct_entry env mexpr in - let farg_id, farg_b, fbody_b = Modops.destr_functor env + let farg_id, farg_b, fbody_b = Modops.destr_functor env (Modops.eval_struct env ftb) in let mp = Environ.scrape_alias mp env in let sub_alias = (Environ.lookup_modtype mp env).typ_alias in let sub_alias = match Modops.eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> join_alias + | SEBstruct (msid,sign) -> join_alias (subst_key (map_msid msid mp) sub_alias) (map_msid msid mp) | _ -> sub_alias in @@ -956,7 +956,7 @@ let rec get_module_substobjs env = function let sub3 = join sub3 (update_subst sub_alias (map_mbid farg_id mp None)) in (* application outside the kernel, only for substitutive objects (that are all non-logical objects) *) - ((join + ((join (join subst sub3) (map_mbid mbid mp (Some resolve))) , mbids, msid, objs) @@ -966,7 +966,7 @@ let rec get_module_substobjs env = function | MSEapply (_,mexpr) -> Modops.error_application_to_not_path mexpr | MSEwith (mty, With_Definition _) -> get_module_substobjs env mty - | MSEwith (mty, With_Module (idl,mp)) -> + | MSEwith (mty, With_Module (idl,mp)) -> let substobjs = get_module_substobjs env mty in let modobjs = MPmap.find mp !modtab_substobjs in replace_module_object idl substobjs modobjs mp @@ -984,9 +984,9 @@ let rec subst_inc_expr subst me = let const1 = Mod_subst.from_val const in let force = Mod_subst.force subst_mps in MSEwith (subst_inc_expr subst me, - With_Definition(idl,force (subst_substituted + With_Definition(idl,force (subst_substituted subst const1))) - | MSEapply (me1,me2) -> + | MSEapply (me1,me2) -> MSEapply (subst_inc_expr subst me1, subst_inc_expr subst me2) | _ -> anomaly "You cannot Include a high-order structure" @@ -1001,16 +1001,16 @@ let cache_include (oname,((me,is_mod),substobjs,substituted)) = let prefix = (dir,(mp1,empty_dirpath)) in Global.add_include me; match substituted with - Some seg -> + Some seg -> load_objects 1 prefix seg; - open_objects 1 prefix seg; + open_objects 1 prefix seg; | None -> () - + let load_include i (oname,((me,is_mod),substobjs,substituted)) = let dir,mp1 = lift_oname oname in let prefix = (dir,(mp1,empty_dirpath)) in match substituted with - Some seg -> + Some seg -> load_objects i prefix seg | None -> () @@ -1018,11 +1018,11 @@ let open_include i (oname,((me,is_mod),substobjs,substituted)) = let dir,mp1 = lift_oname oname in let prefix = (dir,(mp1,empty_dirpath)) in match substituted with - Some seg -> + Some seg -> if is_mod then open_objects i prefix seg - else - if i = 1 then + else + if i = 1 then open_objects i prefix seg | None -> () @@ -1048,7 +1048,7 @@ let (in_include,out_include) = let rec update_include (sub,mbids,msid,objs) = let rec replace_include = function - | [] -> [] + | [] -> [] | (id,obj)::tail -> if object_tag obj = "INCLUDE" then let ((me,is_mod),substobjs,substituted) = out_include obj in @@ -1059,10 +1059,10 @@ let rec update_include (sub,mbids,msid,objs) = (id,obj)::(replace_include tail) in (sub,mbids,msid,replace_include objs) - - + + let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o = - + let fs = Summary.freeze_summaries () in try @@ -1071,29 +1071,29 @@ let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o = let mty_entry_o, mty_sub_o = match mty_o with None -> None, None - | (Some (mty, true)) -> - Some (List.fold_right + | (Some (mty, true)) -> + Some (List.fold_right (fun (arg_id,arg_t) mte -> MSEfunctor(arg_id,arg_t,mte)) - arg_entries - (interp_modtype (Global.env()) mty)), + arg_entries + (interp_modtype (Global.env()) mty)), None - | (Some (mty, false)) -> - None, - Some (List.fold_right + | (Some (mty, false)) -> + None, + Some (List.fold_right (fun (arg_id,arg_t) mte -> MSEfunctor(arg_id,arg_t,mte)) - arg_entries + arg_entries (interp_modtype (Global.env()) mty)) in let mexpr_entry_o = match mexpr_o with None -> None - | Some mexpr -> - Some (List.fold_right + | Some mexpr -> + Some (List.fold_right (fun (mbid,mte) me -> MSEfunctor(mbid,mte,me)) arg_entries (interp_modexpr (Global.env()) mexpr)) in - let entry = - {mod_entry_type = mty_entry_o; + let entry = + {mod_entry_type = mty_entry_o; mod_entry_expr = mexpr_entry_o } in let env = Global.env() in @@ -1107,23 +1107,23 @@ let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o = (* Undo the simulated interactive building of the module *) (* and declare the module as a whole *) Summary.unfreeze_summaries fs; - match entry with - |{mod_entry_type = None; + match entry with + |{mod_entry_type = None; mod_entry_expr = Some (MSEident mp) } -> let dir,mp' = dir_of_sp (Lib.make_path id), mp_of_kn (Lib.make_kn id) in let (sub,mbids,msid,objs) = substobjs in let mp1 = Environ.scrape_alias mp env in let prefix = dir,(mp1,empty_dirpath) in - let substituted = + let substituted = match mbids with - | [] -> - Some (subst_objects prefix + | [] -> + Some (subst_objects prefix (join sub (join (map_msid msid mp1) (map_mp mp' mp1))) objs) | _ -> None in ignore (add_leaf id - (in_module_alias (Some ({mod_entry_type = None; - mod_entry_expr = Some (MSEident mp1) }, mty_sub_o), + (in_module_alias (Some ({mod_entry_type = None; + mod_entry_expr = Some (MSEident mp1) }, mty_sub_o), substobjs, substituted))); mmp | _ -> @@ -1136,20 +1136,20 @@ let declare_module interp_modtype interp_modexpr id args mty_o mexpr_o = id (in_module (Some (entry, mty_sub_o), substobjs, substituted))); mmp - - with e -> + + with e -> (* Something wrong: undo the whole process *) Summary.unfreeze_summaries fs; raise e - + let declare_include interp_struct me_ast is_mod = let fs = Summary.freeze_summaries () in - try + try let env = Global.env() in - let me = interp_struct env me_ast in - let substobjs = + let me = interp_struct env me_ast in + let substobjs = if is_mod then get_module_substobjs env me else @@ -1158,20 +1158,20 @@ let declare_include interp_struct me_ast is_mod = let dir = dir_of_sp (Lib.path_of_include()) in let substituted = subst_substobjs dir mp1 substobjs in let id = current_mod_id() in - + ignore (add_leaf id (in_include ((me,is_mod), substobjs, substituted))) - with e -> + with e -> (* Something wrong: undo the whole process *) Summary.unfreeze_summaries fs; raise e - - + + (*s Iterators. *) - + let iter_all_segments f = - let _ = - MPmap.iter - (fun _ (prefix,objects) -> + let _ = + MPmap.iter + (fun _ (prefix,objects) -> let apply_obj (id,obj) = f (make_oname prefix id) obj in List.iter apply_obj objects) !modtab_objects diff --git a/library/declaremods.mli b/library/declaremods.mli index 058bfa6ada..5cda0d28d2 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -30,19 +30,19 @@ open Lib constructed by [interp_modtype] from functor arguments [fargs] and by [interp_modexpr] from [expr]. At least one of [typ], [expr] must be non-empty. - + The [bool] in [typ] tells if the module must be abstracted [true] with respect to the module type or merely matched without any restriction [false]. *) -val declare_module : +val declare_module : (env -> 'modtype -> module_struct_entry) -> (env -> 'modexpr -> module_struct_entry) -> - identifier -> - (identifier located list * 'modtype) list -> ('modtype * bool) option -> + identifier -> + (identifier located list * 'modtype) list -> ('modtype * bool) option -> 'modexpr option -> module_path - -val start_module : (env -> 'modtype -> module_struct_entry) -> + +val start_module : (env -> 'modtype -> module_struct_entry) -> bool option -> identifier -> (identifier located list * 'modtype) list -> ('modtype * bool) option -> module_path @@ -52,10 +52,10 @@ val end_module : unit -> module_path (*s Module types *) -val declare_modtype : (env -> 'modtype -> module_struct_entry) -> +val declare_modtype : (env -> 'modtype -> module_struct_entry) -> identifier -> (identifier located list * 'modtype) list -> 'modtype -> module_path -val start_modtype : (env -> 'modtype -> module_struct_entry) -> +val start_modtype : (env -> 'modtype -> module_struct_entry) -> identifier -> (identifier located list * 'modtype) list -> module_path val end_modtype : unit -> module_path @@ -73,8 +73,8 @@ type library_name = dir_path type library_objects -val register_library : - library_name -> +val register_library : + library_name -> Safe_typing.compiled_library -> library_objects -> Digest.t -> unit val start_library : library_name -> unit @@ -99,7 +99,7 @@ val import_module : bool -> module_path -> unit (* Include *) -val declare_include : (env -> 'struct_expr -> module_struct_entry) -> +val declare_include : (env -> 'struct_expr -> module_struct_entry) -> 'struct_expr -> bool -> unit (*s [iter_all_segments] iterate over all segments, the modules' diff --git a/library/decls.ml b/library/decls.ml index d5d0cb0962..251c86aba8 100644 --- a/library/decls.ml +++ b/library/decls.ml @@ -55,7 +55,7 @@ let constant_kind kn = Cmap.find kn !csttab let clear_proofs sign = List.fold_right - (fun (id,c,t as d) signv -> + (fun (id,c,t as d) signv -> let d = if variable_opacity id then (id,None,t) else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val diff --git a/library/decls.mli b/library/decls.mli index 3ccff1f277..a9000604ff 100644 --- a/library/decls.mli +++ b/library/decls.mli @@ -27,7 +27,7 @@ open Decl_kinds (** Registration and access to the table of variable *) -type variable_data = +type variable_data = dir_path * bool (* opacity *) * Univ.constraints * logical_kind val add_variable_data : variable -> variable_data -> unit diff --git a/library/dischargedhypsmap.ml b/library/dischargedhypsmap.ml index ed375a831f..85de6ab8f1 100644 --- a/library/dischargedhypsmap.ml +++ b/library/dischargedhypsmap.ml @@ -24,7 +24,7 @@ type discharged_hyps = full_path list let discharged_hyps_map = ref Spmap.empty -let set_discharged_hyps sp hyps = +let set_discharged_hyps sp hyps = discharged_hyps_map := Spmap.add sp hyps !discharged_hyps_map let get_discharged_hyps sp = @@ -42,7 +42,7 @@ let freeze () = !discharged_hyps_map let unfreeze dhm = discharged_hyps_map := dhm -let _ = +let _ = Summary.declare_summary "discharged_hypothesis" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; diff --git a/library/global.ml b/library/global.ml index ec41c0706b..e228de23a7 100644 --- a/library/global.ml +++ b/library/global.ml @@ -27,7 +27,7 @@ let env () = env_of_safe_env !global_env let env_is_empty () = is_empty !global_env -let _ = +let _ = declare_summary "Global environment" { freeze_function = (fun () -> !global_env); unfreeze_function = (fun fr -> global_env := fr); @@ -57,12 +57,12 @@ let push_named_def d = anomaly "Kernel names do not match." *) -let add_thing add dir id thing = +let add_thing add dir id thing = let kn, newenv = add dir (label_of_id id) thing !global_env in global_env := newenv; kn -let add_constant = add_thing add_constant +let add_constant = add_thing add_constant let add_mind = add_thing add_mind let add_modtype = add_thing (fun _ -> add_modtype) () let add_module = add_thing (fun _ -> add_module) () @@ -120,16 +120,16 @@ let lookup_modtype kn = lookup_modtype kn (env()) -let start_library dir = +let start_library dir = let mp,newenv = start_library dir !global_env in - global_env := newenv; + global_env := newenv; mp let export s = snd (export !global_env s) -let import cenv digest = - let mp,newenv = import cenv digest !global_env in - global_env := newenv; +let import cenv digest = + let mp,newenv = import cenv digest !global_env in + global_env := newenv; mp @@ -137,13 +137,13 @@ let import cenv digest = (*s Function to get an environment from the constants part of the global environment and a given context. *) -let env_of_context hyps = +let env_of_context hyps = reset_with_named_context hyps (env()) open Libnames let type_of_reference env = function - | VarRef id -> Environ.named_type id env + | VarRef id -> Environ.named_type id env | ConstRef c -> Typeops.type_of_constant env c | IndRef ind -> let specif = Inductive.lookup_mind_specif env ind in diff --git a/library/global.mli b/library/global.mli index deafacba22..3c2317122c 100644 --- a/library/global.mli +++ b/library/global.mli @@ -44,9 +44,9 @@ val push_named_def : (identifier * constr * types option) -> Univ.constraints (*s Adding constants, inductives, modules and module types. All these functions verify that given names match those generated by kernel *) -val add_constant : +val add_constant : dir_path -> identifier -> global_declaration -> constant -val add_mind : +val add_mind : dir_path -> identifier -> mutual_inductive_entry -> kernel_name val add_module : identifier -> module_entry -> module_path @@ -59,7 +59,7 @@ val add_constraints : constraints -> unit val set_engagement : engagement -> unit (*s Interactive modules and module types *) -(* Both [start_*] functions take the [dir_path] argument to create a +(* Both [start_*] functions take the [dir_path] argument to create a [mod_self_id]. This should be the name of the compilation unit. *) (* [start_*] functions return the [module_path] valid for components @@ -91,7 +91,7 @@ val import : compiled_library -> Digest.t -> module_path (*s Function to get an environment from the constants part of the global * environment and a given context. *) - + val type_of_global : Libnames.global_reference -> types val env_of_context : Environ.named_context_val -> Environ.env diff --git a/library/goptions.ml b/library/goptions.ml index 86012b1135..e4c5a6155d 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -75,7 +75,7 @@ module MakeTable = let t = ref (MySet.empty : MySet.t) - let _ = + let _ = if A.synchronous then let freeze () = !t in let unfreeze c = t := c in @@ -91,7 +91,7 @@ module MakeTable = | GOadd -> t := MySet.add p !t | GOrmv -> t := MySet.remove p !t in let load_options i o = if i=1 then cache_options o in - let subst_options (_,subst,(f,p as obj)) = + let subst_options (_,subst,(f,p as obj)) = let p' = A.subst subst p in if p' == p then obj else (f,p') @@ -113,8 +113,8 @@ module MakeTable = (fun c -> t := MySet.remove c !t)) let print_table table_name printer table = - msg (str table_name ++ - (hov 0 + msg (str table_name ++ + (hov 0 (if MySet.is_empty table then str "None" ++ fnl () else MySet.fold (fun a b -> printer a ++ spc () ++ b) @@ -124,11 +124,11 @@ module MakeTable = object method add x = add_option (A.encode x) method remove x = remove_option (A.encode x) - method mem x = + method mem x = let y = A.encode x in let answer = MySet.mem y !t in msg (A.member_message y answer ++ fnl ()) - method print = print_table A.title A.printer !t + method print = print_table A.title A.printer !t end let _ = A.table := (nick,new table_of_A ())::!A.table @@ -181,7 +181,7 @@ sig val synchronous : bool end -module RefConvert = functor (A : RefConvertArg) -> +module RefConvert = functor (A : RefConvertArg) -> struct type t = A.t type key = reference @@ -208,7 +208,7 @@ type 'a option_sig = { optread : unit -> 'a; optwrite : 'a -> unit } -type option_type = bool * (unit -> value) -> (value -> unit) +type option_type = bool * (unit -> value) -> (value -> unit) module OptionMap = Map.Make (struct type t = option_name let compare = compare end) @@ -219,7 +219,7 @@ let value_tab = ref OptionMap.empty let get_option key = OptionMap.find key !value_tab -let check_key key = try +let check_key key = try let _ = get_option key in error "Sorry, this option name is already used" with Not_found -> @@ -231,25 +231,25 @@ open Summary open Libobject open Lib -let declare_option cast uncast +let declare_option cast uncast { optsync=sync; optname=name; optkey=key; optread=read; optwrite=write } = check_key key; let default = read() in (* spiwack: I use two spaces in the nicknames of "local" and "global" objects. That way I shouldn't collide with [nickname key] for any [key]. As [key]-s are lists of strings *without* spaces. *) - let (write,lwrite,gwrite) = if sync then + let (write,lwrite,gwrite) = if sync then let (ldecl_obj,_) = (* "Local": doesn't survive section or modules. *) declare_object {(default_object ("L "^nickname key)) with cache_function = (fun (_,v) -> write v); classify_function = (fun _ -> Dispose)} - in + in let (decl_obj,_) = (* default locality: survives sections but not modules. *) declare_object {(default_object (nickname key)) with cache_function = (fun (_,v) -> write v); classify_function = (fun _ -> Dispose); discharge_function = (fun (_,v) -> Some v)} - in + in let (gdecl_obj,_) = (* "Global": survives section and modules. *) declare_object {(default_object ("G "^nickname key)) with cache_function = (fun (_,v) -> write v); @@ -258,28 +258,28 @@ let declare_option cast uncast load_function = (fun _ (_,v) -> write v); (* spiwack: I'm unsure whether this function does anyting *) export_function = (fun v -> Some v)} - in - let _ = declare_summary (nickname key) + in + let _ = declare_summary (nickname key) { freeze_function = read; unfreeze_function = write; init_function = (fun () -> write default) } - in + in begin fun v -> add_anonymous_leaf (decl_obj v) end , begin fun v -> add_anonymous_leaf (ldecl_obj v) end , begin fun v -> add_anonymous_leaf (gdecl_obj v) end else write,write,write - in + in let cread () = cast (read ()) in - let cwrite v = write (uncast v) in - let clwrite v = lwrite (uncast v) in - let cgwrite v = gwrite (uncast v) in - value_tab := OptionMap.add key (name,(sync,cread,cwrite,clwrite,cgwrite)) !value_tab; - write + let cwrite v = write (uncast v) in + let clwrite v = lwrite (uncast v) in + let cgwrite v = gwrite (uncast v) in + value_tab := OptionMap.add key (name,(sync,cread,cwrite,clwrite,cgwrite)) !value_tab; + write type 'a write_function = 'a -> unit let declare_int_option = - declare_option + declare_option (fun v -> IntValue v) (function IntValue v -> v | _ -> anomaly "async_option") let declare_bool_option = @@ -310,15 +310,15 @@ let set_option_value locality check_and_cast key v = let bad_type_error () = error "Bad type of value for this option" let set_int_option_value_gen locality = set_option_value locality - (fun v -> function + (fun v -> function | (IntValue _) -> IntValue v | _ -> bad_type_error ()) let set_bool_option_value_gen locality = set_option_value locality - (fun v -> function + (fun v -> function | (BoolValue _) -> BoolValue v | _ -> bad_type_error ()) let set_string_option_value_gen locality = set_option_value locality - (fun v -> function + (fun v -> function | (StringValue _) -> StringValue v | _ -> bad_type_error ()) @@ -339,10 +339,10 @@ let msg_option_value (name,v) = let print_option_value key = let (name,(_,read,_,_,_)) = get_option key in - let s = read () in + let s = read () in match s with - | BoolValue b -> - msg (str ("The "^name^" mode is "^(if b then "on" else "off")) ++ + | BoolValue b -> + msg (str ("The "^name^" mode is "^(if b then "on" else "off")) ++ fnl ()) | _ -> msg (str ("Current value of "^name^" is ") ++ @@ -352,20 +352,20 @@ let print_option_value key = let print_tables () = msg (str "Synchronous options:" ++ fnl () ++ - OptionMap.fold - (fun key (name,(sync,read,_,_,_)) p -> - if sync then + OptionMap.fold + (fun key (name,(sync,read,_,_,_)) p -> + if sync then p ++ str (" "^(nickname key)^": ") ++ msg_option_value (name,read()) ++ fnl () - else + else p) !value_tab (mt ()) ++ str "Asynchronous options:" ++ fnl () ++ - OptionMap.fold - (fun key (name,(sync,read,_,_,_)) p -> - if sync then + OptionMap.fold + (fun key (name,(sync,read,_,_,_)) p -> + if sync then p - else + else p ++ str (" "^(nickname key)^": ") ++ msg_option_value (name,read()) ++ fnl ()) !value_tab (mt ()) ++ diff --git a/library/goptions.mli b/library/goptions.mli index eba44a896f..511986a57f 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -16,11 +16,11 @@ [declare_int_option], [declare_bool_option], ... functions. Each table/option is uniquely identified by a key of type [option_name] - which consists in a list of strings. Note that for parsing constraints, + which consists in a list of strings. Note that for parsing constraints, table names must not be made of more than 2 strings while option names can be of arbitrary length. - The declaration of a table, say of name [["Toto";"Titi"]] + The declaration of a table, say of name [["Toto";"Titi"]] automatically makes available the following vernacular commands: Add Toto Titi foo. @@ -116,18 +116,18 @@ module MakeRefTable : (*s Options. *) (* These types and function are for declaring a new option of name [key] - and access functions [read] and [write]; the parameter [name] is the option name + and access functions [read] and [write]; the parameter [name] is the option name used when printing the option value (command "Print Toto Titi." *) type 'a option_sig = { - optsync : bool; + optsync : bool; optname : string; optkey : option_name; optread : unit -> 'a; optwrite : 'a -> unit } -(* When an option is declared synchronous ([optsync] is [true]), the output is +(* When an option is declared synchronous ([optsync] is [true]), the output is a synchronous write function. Otherwise it is [optwrite] *) type 'a write_function = 'a -> unit diff --git a/library/heads.ml b/library/heads.ml index c636344589..bca6b6502f 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -22,8 +22,8 @@ open Lib (** Characterization of the head of a term *) (* We only compute an approximation to ensure the computation is not - arbitrary long (e.g. the head constant of [h] defined to be - [g (fun x -> phi(x))] where [g] is [fun f => g O] does not launch + arbitrary long (e.g. the head constant of [h] defined to be + [g (fun x -> phi(x))] where [g] is [fun f => g O] does not launch the evaluation of [phi(0)] and the head of [h] is declared unknown). *) type rigid_head_kind = @@ -50,7 +50,7 @@ let freeze () = !head_map let unfreeze hm = head_map := hm -let _ = +let _ = Summary.declare_summary "Head_decl" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; @@ -63,7 +63,7 @@ let kind_of_head env t = let rec aux k l t b = match kind_of_term (Reduction.whd_betaiotazeta t) with | Rel n when n > k -> NotImmediatelyComputableHead | Rel n -> FlexibleHead (k,k+1-n,List.length l,b) - | Var id -> + | Var id -> (try on_subterm k l b (variable_head id) with Not_found -> (* a goal variable *) @@ -71,7 +71,7 @@ let kind_of_head env t = | Some c -> aux k l c b | None -> NotImmediatelyComputableHead) | Const cst -> on_subterm k l b (constant_head cst) - | Construct _ | CoFix _ -> + | Construct _ | CoFix _ -> if b then NotImmediatelyComputableHead else ConstructorHead | Sort _ | Ind _ | Prod _ -> RigidHead RigidType | Cast (c,_,_) -> aux k l c b @@ -88,7 +88,7 @@ let kind_of_head env t = and on_subterm k l with_case = function | FlexibleHead (n,i,q,with_subcase) -> let m = List.length l in - let k',rest,a = + let k',rest,a = if n > m then (* eta-expansion *) let a = @@ -115,12 +115,12 @@ let compute_head = function | Some c -> kind_of_head (Global.env()) c) | EvalVarRef id -> (match pi2 (Global.lookup_named id) with - | Some c when not (Decls.variable_opacity id) -> + | Some c when not (Decls.variable_opacity id) -> kind_of_head (Global.env()) c - | _ -> + | _ -> RigidHead (RigidVar id)) -let is_rigid env t = +let is_rigid env t = match kind_of_head env t with | RigidHead _ | ConstructorHead -> true | _ -> false @@ -129,7 +129,7 @@ let is_rigid env t = let load_head _ (_,(ref,(k:head_approximation))) = head_map := Evalrefmap.add ref k !head_map - + let cache_head o = load_head 1 o @@ -158,7 +158,7 @@ let rebuild_head (ref,k) = let export_head o = Some o let (inHead, _) = - declare_object {(default_object "HEAD") with + declare_object {(default_object "HEAD") with cache_function = cache_head; load_function = load_head; subst_function = subst_head; diff --git a/library/impargs.ml b/library/impargs.ml index aedb2d5a8e..edd0aba0ec 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -36,7 +36,7 @@ type implicits_flags = { (* les implicites sont stricts par défaut en v8 *) -let implicit_args = ref { +let implicit_args = ref { auto = false; strict = true; strongly_strict = false; @@ -72,7 +72,7 @@ let is_maximal_implicit_args () = !implicit_args.maximal let with_implicits flags f x = let oflags = !implicit_args in - try + try implicit_args := flags; let rslt = f x in implicit_args := oflags; @@ -169,7 +169,7 @@ let is_flexible_reference env bound depth f = let push_lift d (e,n) = (push_rel d e,n+1) let is_reversible_pattern bound depth f l = - isRel f & let n = destRel f in (n < bound+depth) & (n >= depth) & + isRel f & let n = destRel f in (n < bound+depth) & (n >= depth) & array_for_all (fun c -> isRel c & destRel c < depth) l & array_distinct l @@ -194,7 +194,7 @@ let add_free_rels_until strict strongly_strict revpat bound env m pos acc = | Evar _ -> () | _ -> iter_constr_with_full_binders push_lift (frec rig) ed c - in + in frec true (env,1) m; acc (* calcule la liste des arguments implicites *) @@ -215,14 +215,14 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t = let na',avoid' = concrete_name None avoid names na all b in add_free_rels_until strict strongly_strict revpat n env a (Hyp (n+1)) (aux (push_rel (na',None,a) env) avoid' (n+1) (na'::names) b) - | _ -> + | _ -> let names = List.rev names in let v = Array.map (fun na -> na,None) (Array.of_list names) in if contextual then add_free_rels_until strict strongly_strict revpat n env t Conclusion v else v - in - match kind_of_term (whd_betadeltaiota env t) with + in + match kind_of_term (whd_betadeltaiota env t) with | Prod (na,a,b) -> let na',avoid = concrete_name None [] [] na all b in let v = aux (push_rel (na',None,a) env) avoid 1 [na'] b in @@ -232,16 +232,16 @@ let compute_implicits_gen strict strongly_strict revpat contextual all env t = let rec prepare_implicits f = function | [] -> [] | (Anonymous, Some _)::_ -> anomaly "Unnamed implicit" - | (Name id, Some imp)::imps -> + | (Name id, Some imp)::imps -> let imps' = prepare_implicits f imps in Some (id,imp,(set_maximality imps' f.maximal,true)) :: imps' | _::imps -> None :: prepare_implicits f imps -let compute_implicits_flags env f all t = - compute_implicits_gen +let compute_implicits_flags env f all t = + compute_implicits_gen (f.strict or f.strongly_strict) f.strongly_strict f.reversible_pattern f.contextual all env t - + let set_implicit id imp insmax = (id,(match imp with None -> Manual | Some imp -> imp),insmax) @@ -256,7 +256,7 @@ let compute_manual_implicits env flags t enriching l = else compute_implicits_gen false false false true true env t in let n = List.length autoimps in let try_forced k l = - try + try let (id, (b, fi, fo)), l' = assoc_by_pos k l in if fo then let id = match id with Some id -> id | None -> id_of_string ("arg_" ^ string_of_int k) in @@ -264,17 +264,17 @@ let compute_manual_implicits env flags t enriching l = else l, None with Not_found -> l, None in - if not (list_distinct l) then + if not (list_distinct l) then error ("Some parameters are referred more than once"); (* Compare with automatic implicits to recover printing data and names *) let rec merge k l = function | (Name id,imp)::imps -> let l',imp,m = - try + try let (b, fi, fo) = List.assoc (ExplByName id) l in List.remove_assoc (ExplByName id) l, (Some Manual), (Some (b, fi)) with Not_found -> - try + try let (id, (b, fi, fo)), l' = assoc_by_pos k l in l', (Some Manual), (Some (b,fi)) with Not_found -> @@ -288,12 +288,12 @@ let compute_manual_implicits env flags t enriching l = forced :: merge (k+1) l' imps | [] when l = [] -> [] | [] -> - List.iter (function - | ExplByName id,(b,fi,forced) -> + List.iter (function + | ExplByName id,(b,fi,forced) -> if not forced then error ("Wrong or not dependent implicit argument name: "^(string_of_id id)) | ExplByPos (i,_id),_t -> - if i<1 or i>n then + if i<1 or i>n then error ("Bad implicit argument number: "^(string_of_int i)) else errorlabstrm "" @@ -307,12 +307,12 @@ let const v _ = v let compute_implicits_auto env f manual t = match manual with - | [] -> + | [] -> if not f.auto then [] else let l = compute_implicits_flags env f false t in prepare_implicits f l | _ -> compute_manual_implicits env f t f.auto manual - + let compute_implicits env t = compute_implicits_auto env !implicit_args [] t type maximal_insertion = bool (* true = maximal contextual insertion *) @@ -366,7 +366,7 @@ let compute_constant_implicits flags manual cst = (*s Inductives and constructors. Their implicit arguments are stored in an array, indexed by the inductive number, of pairs $(i,v)$ where - $i$ are the implicit arguments of the inductive and $v$ the array of + $i$ are the implicit arguments of the inductive and $v$ the array of implicit arguments of the constructors. *) let compute_mib_implicits flags manual kn = @@ -391,7 +391,7 @@ let compute_mib_implicits flags manual kn = let compute_all_mib_implicits flags manual kn = let imps = compute_mib_implicits flags manual kn in - List.flatten + List.flatten (array_map_to_list (fun (ind,cstrs) -> ind::Array.to_list cstrs) imps) (*s Variables. *) @@ -406,18 +406,18 @@ let compute_var_implicits flags manual id = let compute_global_implicits flags manual = function | VarRef id -> compute_var_implicits flags manual id | ConstRef kn -> compute_constant_implicits flags manual kn - | IndRef (kn,i) -> + | IndRef (kn,i) -> let ((_,imps),_) = (compute_mib_implicits flags manual kn).(i) in imps - | ConstructRef ((kn,i),j) -> + | ConstructRef ((kn,i),j) -> let (_,cimps) = (compute_mib_implicits flags manual kn).(i) in snd cimps.(j-1) (* Merge a manual explicitation with an implicit_status list *) - + let merge_impls oldimpls newimpls = - let (before, news), olds = + let (before, news), olds = let len = List.length newimpls - List.length oldimpls in if len >= 0 then list_split_at len newimpls, oldimpls - else + else let before, after = list_split_at (-len) oldimpls in (before, newimpls), after in @@ -436,7 +436,7 @@ type implicit_discharge_request = | ImplLocal | ImplConstant of constant * implicits_flags | ImplMutualInductive of kernel_name * implicits_flags - | ImplInteractive of global_reference * implicits_flags * + | ImplInteractive of global_reference * implicits_flags * implicit_interactive_request let implicits_table = ref Refmap.empty @@ -471,7 +471,7 @@ let section_segment_of_reference = function let discharge_implicits (_,(req,l)) = match req with | ImplLocal -> None - | ImplInteractive (ref,flags,exp) -> + | ImplInteractive (ref,flags,exp) -> let vars = section_segment_of_reference ref in let ref' = pop_global_reference ref in let l' = [ref', impls_of_context vars @ snd (List.hd l)] in @@ -481,22 +481,22 @@ let discharge_implicits (_,(req,l)) = let l' = [ConstRef con',impls_of_context (section_segment_of_constant con) @ snd (List.hd l)] in Some (ImplConstant (con',flags),l') | ImplMutualInductive (kn,flags) -> - let l' = List.map (fun (gr, l) -> + let l' = List.map (fun (gr, l) -> let vars = section_segment_of_reference gr in - (pop_global_reference gr, impls_of_context vars @ l)) l + (pop_global_reference gr, impls_of_context vars @ l)) l in Some (ImplMutualInductive (pop_kn kn,flags),l') let rebuild_implicits (req,l) = let l' = match req with | ImplLocal -> assert false - | ImplConstant (con,flags) -> + | ImplConstant (con,flags) -> let oldimpls = snd (List.hd l) in let newimpls = compute_constant_implicits flags [] con in [ConstRef con, merge_impls oldimpls newimpls] | ImplMutualInductive (kn,flags) -> let newimpls = compute_all_mib_implicits flags [] kn in - let rec aux olds news = + let rec aux olds news = match olds, news with | (_, oldimpls) :: old, (gr, newimpls) :: tl -> (gr, merge_impls oldimpls newimpls) :: aux old tl @@ -506,13 +506,13 @@ let rebuild_implicits (req,l) = | ImplInteractive (ref,flags,o) -> match o with - | ImplAuto -> + | ImplAuto -> let oldimpls = snd (List.hd l) in let newimpls = compute_global_implicits flags [] ref in [ref,merge_impls oldimpls newimpls] - | ImplManual m -> + | ImplManual m -> let oldimpls = snd (List.hd l) in - let auto = + let auto = if flags.auto then let newimpls = compute_global_implicits flags [] ref in merge_impls oldimpls newimpls @@ -521,11 +521,11 @@ let rebuild_implicits (req,l) = let l' = merge_impls auto m in [ref,l'] in (req,l') -let export_implicits (req,_ as x) = +let export_implicits (req,_ as x) = if req = ImplLocal then None else Some x let (inImplicits, _) = - declare_object {(default_object "IMPLICITS") with + declare_object {(default_object "IMPLICITS") with cache_function = cache_implicits; load_function = load_implicits; subst_function = subst_implicits; @@ -540,10 +540,10 @@ let declare_implicits_gen req flags ref = let declare_implicits local ref = let flags = { !implicit_args with auto = true } in - let req = + let req = if local then ImplLocal else ImplInteractive(ref,flags,ImplAuto) in declare_implicits_gen req flags ref - + let declare_var_implicits id = let flags = !implicit_args in declare_implicits_gen ImplLocal flags (VarRef id) @@ -559,11 +559,11 @@ let declare_mib_implicits kn = (compute_mib_implicits flags [] kn) in add_anonymous_leaf (inImplicits (ImplMutualInductive (kn,flags),List.flatten imps)) - + (* Declare manual implicits *) -type manual_explicitation = Topconstr.explicitation * (bool * bool * bool) - -let compute_implicits_with_manual env typ enriching l = +type manual_explicitation = Topconstr.explicitation * (bool * bool * bool) + +let compute_implicits_with_manual env typ enriching l = compute_manual_implicits env !implicit_args typ enriching l let declare_manual_implicits local ref ?enriching l = @@ -582,9 +582,9 @@ let maybe_declare_manual_implicits local ref ?enriching l = if l = [] then () else declare_manual_implicits local ref ?enriching l -let lift_implicits n = - List.map (fun x -> - match fst x with +let lift_implicits n = + List.map (fun x -> + match fst x with ExplByPos (k, id) -> ExplByPos (k + n, id), snd x | _ -> x) @@ -594,7 +594,7 @@ let init () = implicits_table := Refmap.empty let freeze () = !implicits_table let unfreeze t = implicits_table := t -let _ = +let _ = Summary.declare_summary "implicits" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; diff --git a/library/impargs.mli b/library/impargs.mli index 9f67eb4624..6d2b01e8f5 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -16,7 +16,7 @@ open Environ open Nametab (*i*) -(*s Implicit arguments. Here we store the implicit arguments. Notice that we +(*s Implicit arguments. Here we store the implicit arguments. Notice that we are outside the kernel, which knows nothing about implicit arguments. *) val make_implicit_args : bool -> unit @@ -66,11 +66,11 @@ val positions_of_implicits : implicits_list -> int list val compute_implicits : env -> types -> implicits_list (* A [manual_explicitation] is a tuple of a positional or named explicitation with - maximal insertion, force inference and force usage flags. Forcing usage makes + maximal insertion, force inference and force usage flags. Forcing usage makes the argument implicit even if the automatic inference considers it not inferable. *) type manual_explicitation = Topconstr.explicitation * (bool * bool * bool) -val compute_implicits_with_manual : env -> types -> bool -> +val compute_implicits_with_manual : env -> types -> bool -> manual_explicitation list -> implicits_list (*s Computation of implicits (done using the global environment). *) @@ -109,6 +109,6 @@ type implicit_discharge_request = | ImplLocal | ImplConstant of constant * implicits_flags | ImplMutualInductive of kernel_name * implicits_flags - | ImplInteractive of global_reference * implicits_flags * + | ImplInteractive of global_reference * implicits_flags * implicit_interactive_request diff --git a/library/lib.ml b/library/lib.ml index 197e4c3f1e..20c6bf1e49 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -17,7 +17,7 @@ open Summary -type node = +type node = | Leaf of obj | CompilingLibrary of object_prefix | OpenedModule of bool option * object_prefix * Summary.frozen @@ -40,7 +40,7 @@ let iter_objects f i prefix = let load_objects = iter_objects load_object let open_objects = iter_objects open_object -let subst_objects prefix subst seg = +let subst_objects prefix subst seg = let subst_one = fun (id,obj as node) -> let obj' = subst_object (make_oname prefix id, subst, obj) in if obj' == obj then node else @@ -58,13 +58,13 @@ let load_and_subst_objects i prefix subst seg = let classify_segment seg = let rec clean ((substl,keepl,anticipl) as acc) = function | (_,CompilingLibrary _) :: _ | [] -> acc - | ((sp,kn),Leaf o) :: stk -> + | ((sp,kn),Leaf o) :: stk -> let id = Names.id_of_label (Names.label kn) in - (match classify_object o with + (match classify_object o with | Dispose -> clean acc stk - | Keep o' -> + | Keep o' -> clean (substl, (id,o')::keepl, anticipl) stk - | Substitute o' -> + | Substitute o' -> clean ((id,o')::substl, keepl, anticipl) stk | Anticipate o' -> clean (substl, keepl, o'::anticipl) stk) @@ -84,12 +84,12 @@ let classify_segment seg = let segment_of_objects prefix = List.map (fun (id,obj) -> (make_oname prefix id, Leaf obj)) -(* We keep trace of operations in the stack [lib_stk]. - [path_prefix] is the current path of sections, where sections are stored in - ``correct'' order, the oldest coming first in the list. It may seems +(* We keep trace of operations in the stack [lib_stk]. + [path_prefix] is the current path of sections, where sections are stored in + ``correct'' order, the oldest coming first in the list. It may seems costly, but in practice there is not so many openings and closings of sections, but on the contrary there are many constructions of section - paths based on the library path. *) + paths based on the library path. *) let initial_prefix = default_library,(Names.initial_path,Names.empty_dirpath) @@ -115,10 +115,10 @@ let sections_are_opened () = let cwd () = fst !path_prefix let current_dirpath sec = - Libnames.drop_dirpath_prefix (library_dp ()) - (if sec then cwd () + Libnames.drop_dirpath_prefix (library_dp ()) + (if sec then cwd () else Libnames.pop_dirpath_n (sections_depth ()) (cwd ())) - + let make_path id = Libnames.make_path (cwd ()) id let path_of_include () = @@ -129,11 +129,11 @@ let path_of_include () = let current_prefix () = snd !path_prefix -let make_kn id = +let make_kn id = let mp,dir = current_prefix () in Names.make_kn mp dir (Names.label_of_id id) -let make_con id = +let make_con id = let mp,dir = current_prefix () in Names.make_con mp dir (Names.label_of_id id) @@ -151,25 +151,25 @@ let recalc_path_prefix () = in path_prefix := recalc !lib_stk -let pop_path_prefix () = +let pop_path_prefix () = let dir,(mp,sec) = !path_prefix in path_prefix := fst (split_dirpath dir), (mp, fst (split_dirpath sec)) -let find_entry_p p = +let find_entry_p p = let rec find = function | [] -> raise Not_found | ent::l -> if p ent then ent else find l in find !lib_stk -let find_split_p p = +let find_split_p p = let rec find = function | [] -> raise Not_found | ent::l -> if p ent then ent,l else find l in find !lib_stk -let split_lib_gen test = +let split_lib_gen test = let rec collect after equal = function | hd::strict_before as before -> if test hd then collect after (hd::equal) strict_before else after,equal,before @@ -201,7 +201,7 @@ let split_lib sp = split_lib_gen (fun x -> (fst x) = sp) let add_entry sp node = lib_stk := (sp,node) :: !lib_stk -let anonymous_id = +let anonymous_id = let n = ref 0 in fun () -> incr n; Names.id_of_string ("_" ^ (string_of_int !n)) @@ -212,7 +212,7 @@ let add_anonymous_entry node = name let add_leaf id obj = - if fst (current_prefix ()) = Names.initial_path then + if fst (current_prefix ()) = Names.initial_path then error ("No session module started (use -top dir)"); let oname = make_oname id in cache_object (oname,obj); @@ -227,9 +227,9 @@ let add_discharged_leaf id obj = let add_leaves id objs = let oname = make_oname id in - let add_obj obj = + let add_obj obj = add_entry oname (Leaf obj); - load_object 1 (oname,obj) + load_object 1 (oname,obj) in List.iter add_obj objs; oname @@ -246,28 +246,28 @@ let add_frozen_state () = (* Modules. *) -let is_opened id = function +let is_opened id = function oname,(OpenedSection _ | OpenedModule _ | OpenedModtype _) when basename (fst oname) = id -> true | _ -> false -let is_opening_node = function +let is_opening_node = function _,(OpenedSection _ | OpenedModule _ | OpenedModtype _) -> true | _ -> false -let current_mod_id () = +let current_mod_id () = try match find_entry_p is_opening_node with - | oname,OpenedModule (_,_,fs) -> + | oname,OpenedModule (_,_,fs) -> basename (fst oname) - | oname,OpenedModtype (_,fs) -> + | oname,OpenedModtype (_,fs) -> basename (fst oname) | _ -> error "you are not in a module" with Not_found -> error "no opened modules" -let start_module export id mp fs = +let start_module export id mp fs = let dir = add_dirpath_suffix (fst !path_prefix) id in let prefix = dir,(mp,Names.empty_dirpath) in let oname = make_path id, make_kn id in @@ -281,9 +281,9 @@ let start_module export id mp fs = let error_still_opened string oname = let id = basename (fst oname) in errorlabstrm "" (str string ++ spc () ++ pr_id id ++ str " is still opened.") - -let end_module () = - let oname,fs = + +let end_module () = + let oname,fs = try match find_entry_p is_opening_node with | oname,OpenedModule (_,_,fs) -> oname,fs | oname,OpenedModtype _ -> error_still_opened "Module Type" oname @@ -302,11 +302,11 @@ let end_module () = TODO *) recalc_path_prefix (); - (* add_frozen_state must be called after processing the module, - because we cannot recache interactive modules *) + (* add_frozen_state must be called after processing the module, + because we cannot recache interactive modules *) (oname, prefix, fs, after) -let start_modtype id mp fs = +let start_modtype id mp fs = let dir = add_dirpath_suffix (fst !path_prefix) id in let prefix = dir,(mp,Names.empty_dirpath) in let sp = make_path id in @@ -317,8 +317,8 @@ let start_modtype id mp fs = path_prefix := prefix; prefix -let end_modtype () = - let oname,fs = +let end_modtype () = + let oname,fs = try match find_entry_p is_opening_node with | oname,OpenedModtype (_,fs) -> oname,fs | oname,OpenedModule _ -> error_still_opened "Module" oname @@ -333,7 +333,7 @@ let end_modtype () = let dir = !path_prefix in recalc_path_prefix (); (* add_frozen_state must be called after processing the module type. - This is because we cannot recache interactive module types *) + This is because we cannot recache interactive module types *) (oname,dir,fs,after) @@ -369,24 +369,24 @@ let end_compilation dir = | OpenedModtype _ -> error "There are some open module types." | _ -> assert false with - Not_found -> () + Not_found -> () in let module_p = function (_,CompilingLibrary _) -> true | x -> is_opening_node x in - let oname = + let oname = try match find_entry_p module_p with (oname, CompilingLibrary prefix) -> oname | _ -> assert false with Not_found -> anomaly "No module declared" in - let _ = + let _ = match !comp_name with | None -> anomaly "There should be a module name..." | Some m -> - if m <> dir then anomaly - ("The current open module has name "^ (Names.string_of_dirpath m) ^ + if m <> dir then anomaly + ("The current open module has name "^ (Names.string_of_dirpath m) ^ " and not " ^ (Names.string_of_dirpath m)); in let (after,_,before) = split_lib oname in @@ -394,23 +394,23 @@ let end_compilation dir = !path_prefix,after (* Returns true if we are inside an opened module type *) -let is_modtype () = +let is_modtype () = let opened_p = function - | _, OpenedModtype _ -> true + | _, OpenedModtype _ -> true | _ -> false in - try + try let _ = find_entry_p opened_p in true with Not_found -> false (* Returns true if we are inside an opened module *) -let is_module () = +let is_module () = let opened_p = function - | _, OpenedModule _ -> true + | _, OpenedModule _ -> true | _ -> false in - try + try let _ = find_entry_p opened_p in true with Not_found -> false @@ -419,7 +419,7 @@ let is_module () = (* Returns the opening node of a given name *) let find_opening_node id = try snd (find_entry_p (is_opened id)) - with Not_found -> + with Not_found -> try ignore (find_entry_p is_opening_node); error "There is nothing to end." with Not_found -> error "Nothing to end of this name." @@ -429,7 +429,7 @@ let find_opening_node id = - the list of variables in this section - the list of variables on which each constant depends in this section - the list of variables on which each inductive depends in this section - - the list of substitution to do at section closing + - the list of substitution to do at section closing *) type binding_kind = Explicit | Implicit @@ -472,7 +472,7 @@ let add_section_replacement f g hyps = let sechyps = extract_hyps (vars,hyps) in let args = instance_from_variable_context (List.rev sechyps) in sectab := (vars,f args exps,g sechyps abs)::sl - + let add_section_kn kn = let f x (l1,l2) = (l1,Names.KNmap.add kn x l2) in add_section_replacement f f @@ -511,7 +511,7 @@ let init_sectab () = sectab := [] let freeze_sectab () = !sectab let unfreeze_sectab s = sectab := s -let _ = +let _ = Summary.declare_summary "section-context" { Summary.freeze_function = freeze_sectab; Summary.unfreeze_function = unfreeze_sectab; @@ -556,10 +556,10 @@ let discharge_item ((sp,_ as oname),e) = anomaly "discharge_item" let close_section () = - let oname,fs = + let oname,fs = try match find_entry_p is_opening_node with | oname,OpenedSection (_,fs) -> oname,fs - | _ -> assert false + | _ -> assert false with Not_found -> error "No opened section." in @@ -597,7 +597,7 @@ let has_top_frozen_state () = | (sp, FrozenState _)::_ -> Some sp | (sp, Leaf o)::t when object_tag o = "DOT" -> aux t | _ -> None - in aux !lib_stk + in aux !lib_stk let set_lib_stk new_lib_stk = lib_stk := new_lib_stk; @@ -646,7 +646,7 @@ let delete_gen test = let delete sp = delete_gen (fun x -> (fst x) = sp) let reset_name (loc,id) = - let (sp,_) = + let (sp,_) = try find_entry_p (fun (sp,_) -> let (_,spi) = repr_path (fst sp) in id = spi) with Not_found -> @@ -663,21 +663,21 @@ let remove_name (loc,id) = in delete sp -let is_mod_node = function - | OpenedModule _ | OpenedModtype _ | OpenedSection _ - | ClosedModule _ | ClosedModtype _ | ClosedSection _ -> true - | Leaf o -> let t = object_tag o in t = "MODULE" || t = "MODULE TYPE" +let is_mod_node = function + | OpenedModule _ | OpenedModtype _ | OpenedSection _ + | ClosedModule _ | ClosedModtype _ | ClosedSection _ -> true + | Leaf o -> let t = object_tag o in t = "MODULE" || t = "MODULE TYPE" || t = "MODULE ALIAS" | _ -> false -(* Reset on a module or section name in order to bypass constants with - the same name *) +(* Reset on a module or section name in order to bypass constants with + the same name *) let reset_mod (loc,id) = - let (_,before) = + let (_,before) = try - find_split_p (fun (sp,node) -> - let (_,spi) = repr_path (fst sp) in id = spi + find_split_p (fun (sp,node) -> + let (_,spi) = repr_path (fst sp) in id = spi && is_mod_node node) with Not_found -> user_err_loc (loc,"reset_mod",pr_id id ++ str ": no such entry") @@ -699,7 +699,7 @@ let is_label_n n x = | _ -> false (* Reset the label registered by [mark_end_of_command()] with number n. *) -let reset_label n = +let reset_label n = let current = current_command_label() in if n < current then let res = reset_to_gen (is_label_n n) in @@ -709,7 +709,7 @@ let reset_label n = match !lib_stk with | [] -> () | x :: ls -> (lib_stk := ls;set_command_label (n-1)) - + let rec back_stk n stk = match stk with (sp,Leaf o)::tail when object_tag o = "DOT" -> @@ -741,15 +741,15 @@ let init () = let initial_state = ref None -let declare_initial_state () = +let declare_initial_state () = let name = add_anonymous_entry (FrozenState (freeze_summaries())) in initial_state := Some name let reset_initial () = match !initial_state with - | None -> + | None -> error "Resetting to the initial state is possible only interactively" - | Some sp -> + | Some sp -> begin match split_lib sp with | (_,[_,FrozenState fs as hd],before) -> lib_stk := hd::before; @@ -762,7 +762,7 @@ let reset_initial () = (* Misc *) -let mp_of_global ref = +let mp_of_global ref = match ref with | VarRef id -> fst (current_prefix ()) | ConstRef cst -> Names.con_modpath cst @@ -775,11 +775,11 @@ let rec dp_of_mp modp = | Names.MPbound _ | Names.MPself _ -> library_dp () | Names.MPdot (mp,_) -> dp_of_mp mp -let rec split_mp mp = - match mp with +let rec split_mp mp = + match mp with | Names.MPfile dp -> dp, Names.empty_dirpath - | Names.MPdot (prfx, lbl) -> - let mprec, dprec = split_mp prfx in + | Names.MPdot (prfx, lbl) -> + let mprec, dprec = split_mp prfx in mprec, Names.make_dirpath (Names.id_of_string (Names.string_of_label lbl) :: (Names.repr_dirpath dprec)) | Names.MPself msid -> let (_, id, dp) = Names.repr_msid msid in library_dp(), Names.make_dirpath [Names.id_of_string id] | Names.MPbound mbid -> let (_, id, dp) = Names.repr_mbid mbid in library_dp(), Names.make_dirpath [Names.id_of_string id] @@ -787,17 +787,17 @@ let rec split_mp mp = let split_modpath mp = let rec aux = function | Names.MPfile dp -> dp, [] - | Names.MPbound mbid -> + | Names.MPbound mbid -> library_dp (), [Names.id_of_mbid mbid] | Names.MPself msid -> library_dp (), [Names.id_of_msid msid] | Names.MPdot (mp,l) -> let (mp', lab) = aux mp in (mp', Names.id_of_label l :: lab) - in + in let (mp, l) = aux mp in mp, l - + let library_part ref = - match ref with + match ref with | VarRef id -> library_dp () | _ -> dp_of_mp (mp_of_global ref) @@ -805,7 +805,7 @@ let remove_section_part ref = let sp = Nametab.path_of_global ref in let dir,_ = repr_path sp in match ref with - | VarRef id -> + | VarRef id -> anomaly "remove_section_part not supported on local variables" | _ -> if is_dirpath_prefix_of dir (cwd ()) then @@ -822,15 +822,15 @@ let pop_kn kn = let (mp,dir,l) = Names.repr_kn kn in Names.make_kn mp (pop_dirpath dir) l -let pop_con con = +let pop_con con = let (mp,dir,l) = Names.repr_con con in Names.make_con mp (pop_dirpath dir) l -let con_defined_in_sec kn = +let con_defined_in_sec kn = let _,dir,_ = Names.repr_con kn in dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ()) -let defined_in_sec kn = +let defined_in_sec kn = let _,dir,_ = Names.repr_kn kn in dir <> Names.empty_dirpath && fst (split_dirpath dir) = snd (current_prefix ()) @@ -843,10 +843,10 @@ let discharge_global = function ConstructRef ((pop_kn kn,i),j) | r -> r -let discharge_kn kn = +let discharge_kn kn = if defined_in_sec kn then pop_kn kn else kn -let discharge_con cst = +let discharge_con cst = if con_defined_in_sec cst then pop_con cst else cst let discharge_inductive (kn,i) = diff --git a/library/lib.mli b/library/lib.mli index f4d4900c32..0e2e304cdf 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -13,7 +13,7 @@ and to backtrack (undo) those operations. It provides also the section mechanism (at a low level; discharge is not known at this step). *) -type node = +type node = | Leaf of Libobject.obj | CompilingLibrary of Libnames.object_prefix | OpenedModule of bool option * Libnames.object_prefix * Summary.frozen @@ -40,7 +40,7 @@ val load_and_subst_objects : int -> Libnames.object_prefix -> Mod_subst.substitu to their answers to the [classify_object] function in three groups: [Substitute], [Keep], [Anticipate] respectively. The order of each returned list is the same as in the input list. *) -val classify_segment : +val classify_segment : library_segment -> lib_objects * lib_objects * Libobject.obj list (* [segment_of_objects prefix objs] forms a list of Leafs *) @@ -69,7 +69,7 @@ val current_command_label : unit -> int registered after it. *) val reset_label : int -> unit -(*s The function [contents_after] returns the current library segment, +(*s The function [contents_after] returns the current library segment, starting from a given section path. If not given, the entire segment is returned. *) @@ -102,12 +102,12 @@ val find_opening_node : Names.identifier -> node (*s Modules and module types *) -val start_module : +val start_module : bool option -> Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix val end_module : unit -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment -val start_modtype : +val start_modtype : Names.module_ident -> Names.module_path -> Summary.frozen -> Libnames.object_prefix val end_modtype : unit -> Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment @@ -144,7 +144,7 @@ val reset_to_state : Libnames.object_name -> unit val has_top_frozen_state : unit -> Libnames.object_name option -(* [back n] resets to the place corresponding to the $n$-th call of +(* [back n] resets to the place corresponding to the $n$-th call of [mark_end_of_command] (counting backwards) *) val back : int -> unit diff --git a/library/libnames.ml b/library/libnames.ml index 0404d7cd8a..2b335ea6c9 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -33,10 +33,10 @@ let destIndRef = function IndRef ind -> ind | _ -> failwith "destIndRef" let destConstructRef = function ConstructRef ind -> ind | _ -> failwith "destConstructRef" let subst_constructor subst ((kn,i),j as ref) = - let kn' = subst_kn subst kn in + let kn' = subst_kn subst kn in if kn==kn' then ref, mkConstruct ref else ((kn',i),j), mkConstruct ((kn',i),j) - + let subst_global subst ref = match ref with | VarRef var -> ref, mkVar var | ConstRef kn -> @@ -125,12 +125,12 @@ let parse_dir s = if n >= len then dirs else let pos = try - String.index_from s n '.' + String.index_from s n '.' with Not_found -> len in if pos = n then error (s ^ " is an invalid path."); let dir = String.sub s n (pos-n) in - decoupe_dirs ((id_of_string dir)::dirs) (pos+1) + decoupe_dirs ((id_of_string dir)::dirs) (pos+1) in decoupe_dirs [] 0 @@ -184,7 +184,7 @@ let path_of_string s = with | Invalid_argument _ -> invalid_arg "path_of_string" -let pr_path sp = str (string_of_path sp) +let pr_path sp = str (string_of_path sp) let restrict_path n sp = let dir, s = repr_path sp in @@ -195,17 +195,17 @@ let encode_kn dir id = make_kn (MPfile dir) empty_dirpath (label_of_id id) let encode_con dir id = make_con (MPfile dir) empty_dirpath (label_of_id id) -let decode_kn kn = +let decode_kn kn = let rec dirpath_of_module = function | MPfile dir -> repr_dirpath dir - | MPbound mbid -> + | MPbound mbid -> let _,_,dp = repr_mbid mbid in let id = id_of_mbid mbid in id::(repr_dirpath dp) - | MPself msid -> + | MPself msid -> let _,_,dp = repr_msid msid in let id = id_of_msid msid in - id::(repr_dirpath dp) + id::(repr_dirpath dp) | MPdot(mp,l) -> (id_of_label l)::(dirpath_of_module mp) in let mp,sec_dir,l = repr_kn kn in @@ -214,7 +214,7 @@ let decode_kn kn = else anomaly "Section part should be empty!" -let decode_con kn = +let decode_con kn = let mp,sec_dir,l = repr_con kn in match mp,(repr_dirpath sec_dir) with MPfile dir,[] -> (dir,id_of_label l) @@ -234,7 +234,7 @@ let qualid_of_string = path_of_string let qualid_of_path sp = sp let qualid_of_ident id = make_qualid empty_dirpath id -let qualid_of_dirpath dir = +let qualid_of_dirpath dir = let (l,a) = split_dirpath dir in make_qualid l a @@ -242,11 +242,11 @@ type object_name = full_path * kernel_name type object_prefix = dir_path * (module_path * dir_path) -let make_oname (dirpath,(mp,dir)) id = +let make_oname (dirpath,(mp,dir)) id = make_path dirpath id, make_kn mp dir (label_of_id id) (* to this type are mapped dir_path's in the nametab *) -type global_dir_reference = +type global_dir_reference = | DirOpenModule of object_prefix | DirOpenModtype of object_prefix | DirOpenSection of object_prefix @@ -262,7 +262,7 @@ type global_dir_reference = ModTypeRef kn' *) -type reference = +type reference = | Qualid of qualid located | Ident of identifier located @@ -274,7 +274,7 @@ let string_of_reference = function | Qualid (loc,qid) -> string_of_qualid qid | Ident (loc,id) -> string_of_id id -let pr_reference = function +let pr_reference = function | Qualid (_,qid) -> pr_qualid qid | Ident (_,id) -> pr_id id diff --git a/library/libnames.mli b/library/libnames.mli index b93ee87ee1..43ca252c1c 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -47,7 +47,7 @@ val global_of_constr : constr -> global_reference val constr_of_reference : global_reference -> constr val reference_of_constr : constr -> global_reference -module Refset : Set.S with type elt = global_reference +module Refset : Set.S with type elt = global_reference module Refmap : Map.S with type key = global_reference (*s Extended global references *) @@ -65,7 +65,7 @@ val dirpath_of_string : string -> dir_path val string_of_dirpath : dir_path -> string (* Pop the suffix of a [dir_path] *) -val pop_dirpath : dir_path -> dir_path +val pop_dirpath : dir_path -> dir_path (* Pop the suffix n times *) val pop_dirpath_n : int -> dir_path -> dir_path @@ -146,7 +146,7 @@ type object_prefix = dir_path * (module_path * dir_path) val make_oname : object_prefix -> identifier -> object_name (* to this type are mapped [dir_path]'s in the nametab *) -type global_dir_reference = +type global_dir_reference = | DirOpenModule of object_prefix | DirOpenModtype of object_prefix | DirOpenSection of object_prefix @@ -158,7 +158,7 @@ type global_dir_reference = global name (referred either by a qualified name or by a single name) or a variable *) -type reference = +type reference = | Qualid of qualid located | Ident of identifier located diff --git a/library/libobject.ml b/library/libobject.ml index 504c1ffdd1..95894294b1 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -25,7 +25,7 @@ let relax_flag = ref false;; let relax b = relax_flag := b;; -type 'a substitutivity = +type 'a substitutivity = Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a type 'a object_declaration = { @@ -46,12 +46,12 @@ let default_object s = { cache_function = (fun _ -> ()); load_function = (fun _ _ -> ()); open_function = (fun _ _ -> ()); - subst_function = (fun _ -> + subst_function = (fun _ -> yell ("The object "^s^" does not know how to substitute!")); classify_function = (fun obj -> Keep obj); discharge_function = (fun _ -> None); rebuild_function = (fun x -> x); - export_function = (fun _ -> None)} + export_function = (fun _ -> None)} (* The suggested object declaration is the following: @@ -59,7 +59,7 @@ let default_object s = { declare_object { (default_object "MY OBJECT") with cache_function = fun (sp,a) -> Mytbl.add sp a} - and the listed functions are only those which definitions accually + and the listed functions are only those which definitions accually differ from the default. This helps introducing new functions in objects. @@ -81,7 +81,7 @@ type dynamic_object_declaration = { let object_tag lobj = Dyn.tag lobj -let cache_tab = +let cache_tab = (Hashtbl.create 17 : (string,dynamic_object_declaration) Hashtbl.t) let declare_object odecl = @@ -96,34 +96,34 @@ let declare_object odecl = and opener i (oname,lobj) = if Dyn.tag lobj = na then odecl.open_function i (oname,outfun lobj) else anomaly "somehow we got the wrong dynamic object in the openfun" - and substituter (oname,sub,lobj) = - if Dyn.tag lobj = na then + and substituter (oname,sub,lobj) = + if Dyn.tag lobj = na then infun (odecl.subst_function (oname,sub,outfun lobj)) else anomaly "somehow we got the wrong dynamic object in the substfun" - and classifier lobj = - if Dyn.tag lobj = na then + and classifier lobj = + if Dyn.tag lobj = na then match odecl.classify_function (outfun lobj) with | Dispose -> Dispose | Substitute obj -> Substitute (infun obj) | Keep obj -> Keep (infun obj) | Anticipate (obj) -> Anticipate (infun obj) - else + else anomaly "somehow we got the wrong dynamic object in the classifyfun" - and discharge (oname,lobj) = - if Dyn.tag lobj = na then + and discharge (oname,lobj) = + if Dyn.tag lobj = na then Option.map infun (odecl.discharge_function (oname,outfun lobj)) - else + else anomaly "somehow we got the wrong dynamic object in the dischargefun" - and rebuild lobj = + and rebuild lobj = if Dyn.tag lobj = na then infun (odecl.rebuild_function (outfun lobj)) else anomaly "somehow we got the wrong dynamic object in the rebuildfun" - and exporter lobj = - if Dyn.tag lobj = na then + and exporter lobj = + if Dyn.tag lobj = na then Option.map infun (odecl.export_function (outfun lobj)) - else + else anomaly "somehow we got the wrong dynamic object in the exportfun" - in + in Hashtbl.add cache_tab na { dyn_cache_function = cacher; dyn_load_function = loader; dyn_open_function = opener; @@ -144,13 +144,13 @@ let apply_dyn_fun deflt f lobj = let dodecl = try Hashtbl.find cache_tab tag - with Not_found -> + with Not_found -> if !relax_flag then failwith "local to_apply_dyn_fun" else error ("Cannot find library functions for an object with tag "^tag^ - " (maybe a plugin is missing)") in + " (maybe a plugin is missing)") in f dodecl with Failure "local to_apply_dyn_fun" -> deflt;; @@ -158,19 +158,19 @@ let apply_dyn_fun deflt f lobj = let cache_object ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_cache_function node) lobj -let load_object i ((_,lobj) as node) = +let load_object i ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_load_function i node) lobj -let open_object i ((_,lobj) as node) = +let open_object i ((_,lobj) as node) = apply_dyn_fun () (fun d -> d.dyn_open_function i node) lobj -let subst_object ((_,_,lobj) as node) = +let subst_object ((_,_,lobj) as node) = apply_dyn_fun lobj (fun d -> d.dyn_subst_function node) lobj -let classify_object lobj = +let classify_object lobj = apply_dyn_fun Dispose (fun d -> d.dyn_classify_function lobj) lobj -let discharge_object ((_,lobj) as node) = +let discharge_object ((_,lobj) as node) = apply_dyn_fun None (fun d -> d.dyn_discharge_function node) lobj let rebuild_object lobj = diff --git a/library/libobject.mli b/library/libobject.mli index 41442fe532..6211ab3782 100644 --- a/library/libobject.mli +++ b/library/libobject.mli @@ -18,7 +18,7 @@ open Mod_subst * a caching function specifying how to add the object in the current scope; - If the object wishes to register its visibility in the Nametab, + If the object wishes to register its visibility in the Nametab, it should do so for all possible sufixes. * a loading function, specifying what to do when the module @@ -26,9 +26,9 @@ open Mod_subst If the object wishes to register its visibility in the Nametab, it should do so for all sufixes no shorter than the "int" argument - * an opening function, specifying what to do when the module + * an opening function, specifying what to do when the module containing the object is opened (imported); - If the object wishes to register its visibility in the Nametab, + If the object wishes to register its visibility in the Nametab, it should do so for the suffix of the length the "int" argument * a classification function, specifying what to do with the object, @@ -44,11 +44,11 @@ open Mod_subst and Read markers) The classification function is also an occasion for a cleanup - (if this function returns Keep or Substitute of some object, the + (if this function returns Keep or Substitute of some object, the cache method is never called for it) - * a substitution function, performing the substitution; - this function should be declared for substitutive objects + * a substitution function, performing the substitution; + this function should be declared for substitutive objects only (see above) * a discharge function, that is applied at section closing time to @@ -63,12 +63,12 @@ open Mod_subst to disk (.vo). This function is also the opportunity to remove redundant information in order to keep .vo size small - The export function is a little obsolete and will be removed - in the near future... + The export function is a little obsolete and will be removed + in the near future... *) -type 'a substitutivity = +type 'a substitutivity = Dispose | Substitute of 'a | Keep of 'a | Anticipate of 'a type 'a object_declaration = { @@ -82,7 +82,7 @@ type 'a object_declaration = { rebuild_function : 'a -> 'a; export_function : 'a -> 'a option } -(* The default object is a "Keep" object with empty methods. +(* The default object is a "Keep" object with empty methods. Object creators are advised to use the construction [{(default_object "MY_OBJECT") with cache_function = ... diff --git a/library/library.ml b/library/library.ml index 831687723f..9604a990cd 100644 --- a/library/library.ml +++ b/library/library.ml @@ -39,7 +39,7 @@ let is_in_load_paths phys_dir = let dir = System.canonical_path_name phys_dir in let lp = get_load_paths () in let check_p = fun p -> (String.compare dir p) == 0 in - List.exists check_p lp + List.exists check_p lp let remove_load_path dir = load_paths := List.filter (fun (p,d,_) -> p <> dir) !load_paths @@ -48,7 +48,7 @@ let add_load_path isroot (phys_path,coq_path) = let phys_path = System.canonical_path_name phys_path in match List.filter (fun (p,d,_) -> p = phys_path) !load_paths with | [_,dir,_] -> - if coq_path <> dir + if coq_path <> dir (* If this is not the default -I . to coqtop *) && not (phys_path = System.canonical_path_name Filename.current_dir_name @@ -71,7 +71,7 @@ let add_load_path isroot (phys_path,coq_path) = let physical_paths (dp,lp) = dp let extend_path_with_dirpath p dir = - List.fold_left Filename.concat p + List.fold_left Filename.concat p (List.map string_of_id (List.rev (repr_dirpath dir))) let root_paths_matching_dir_path dir = @@ -112,12 +112,12 @@ let loadpaths_matching_dir_path dir = let get_full_load_paths () = List.map (fun (a,b,c) -> (a,b)) !load_paths (************************************************************************) -(*s Modules on disk contain the following informations (after the magic +(*s Modules on disk contain the following informations (after the magic number, and before the digest). *) type compilation_unit_name = dir_path -type library_disk = { +type library_disk = { md_name : compilation_unit_name; md_compiled : compiled_library; md_objects : Declaremods.library_objects; @@ -135,7 +135,7 @@ type library_t = { library_imports : compilation_unit_name list; library_digest : Digest.t } -module LibraryOrdered = +module LibraryOrdered = struct type t = dir_path let compare d1 d2 = @@ -164,7 +164,7 @@ let freeze () = !libraries_imports_list, !libraries_exports_list -let unfreeze (mt,mo,mi,me) = +let unfreeze (mt,mo,mi,me) = libraries_table := mt; libraries_loaded_list := mo; libraries_imports_list := mi; @@ -176,7 +176,7 @@ let init () = libraries_imports_list := []; libraries_exports_list := [] -let _ = +let _ = Summary.declare_summary "MODULES" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; @@ -195,7 +195,7 @@ let try_find_library dir = let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) (* from a previous play of the session *) - libraries_filename_table := + libraries_filename_table := LibraryFilenameMap.add dir f !libraries_filename_table let library_full_filename dir = @@ -212,13 +212,13 @@ let library_is_loaded dir = try let _ = find_library dir in true with Not_found -> false -let library_is_opened dir = +let library_is_opened dir = List.exists (fun m -> m.library_name = dir) !libraries_imports_list let library_is_exported dir = List.exists (fun m -> m.library_name = dir) !libraries_exports_list -let loaded_libraries () = +let loaded_libraries () = List.map (fun m -> m.library_name) !libraries_loaded_list let opened_libraries () = @@ -249,7 +249,7 @@ let rec remember_last_of_each l m = let register_open_library export m = libraries_imports_list := remember_last_of_each !libraries_imports_list m; - if export then + if export then libraries_exports_list := remember_last_of_each !libraries_exports_list m (************************************************************************) @@ -271,14 +271,14 @@ let open_library export explicit_libs m = Declaremods.really_import_module (MPfile m.library_name) end else - if export then + if export then libraries_exports_list := remember_last_of_each !libraries_exports_list m -(* open_libraries recursively open a list of libraries but opens only once +(* open_libraries recursively open a list of libraries but opens only once a library that is re-exported many times *) let open_libraries export modl = - let to_open_list = + let to_open_list = List.fold_left (fun l m -> let subimport = @@ -299,19 +299,19 @@ let open_import i (_,(dir,export)) = (* if not (library_is_opened dir) then *) open_libraries export [try_find_library dir] -let cache_import obj = +let cache_import obj = open_import 1 obj let subst_import (_,_,o) = o let export_import o = Some o -let classify_import (_,export as obj) = +let classify_import (_,export as obj) = if export then Substitute obj else Dispose let (in_import, out_import) = - declare_object {(default_object "IMPORT LIBRARY") with + declare_object {(default_object "IMPORT LIBRARY") with cache_function = cache_import; open_function = open_import; subst_function = subst_import; @@ -376,7 +376,7 @@ let explain_locate_library_error qid = function | LibUnmappedDir -> let prefix, _ = repr_qualid qid in errorlabstrm "load_absolute_library_from" - (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ + (str "Cannot load " ++ pr_qualid qid ++ str ":" ++ spc () ++ str "no physical path bound to" ++ spc () ++ pr_dirpath prefix ++ fnl ()) | LibNotFound -> errorlabstrm "load_absolute_library_from" @@ -393,14 +393,14 @@ let try_locate_qualified_library (loc,qid) = try let (_,dir,f) = locate_qualified_library (Flags.is_verbose()) qid in dir,f - with e -> + with e -> explain_locate_library_error qid e (************************************************************************) (* Internalise libraries *) -let lighten_library m = +let lighten_library m = if !Flags.dont_load_proofs then lighten_library m else m let mk_library md digest = { @@ -464,7 +464,7 @@ let rec_intern_by_filename_only id f = (* We check no other file containing same library is loaded *) if library_is_loaded m.library_name then begin - Flags.if_verbose warning + Flags.if_verbose warning ((string_of_dirpath m.library_name)^" is already loaded from file "^ library_full_filename m.library_name); m.library_name, [] @@ -476,15 +476,15 @@ let rec_intern_by_filename_only id f = let rec_intern_library_from_file idopt f = (* A name is specified, we have to check it contains library id *) let paths = get_load_paths () in - let _, f = + let _, f = System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".vo") in rec_intern_by_filename_only idopt f (**********************************************************************) -(*s [require_library] loads and possibly opens a library. This is a +(*s [require_library] loads and possibly opens a library. This is a synchronized operation. It is performed as follows: - preparation phase: (functions require_library* ) the library and its + preparation phase: (functions require_library* ) the library and its dependencies are read from to disk (using intern_* ) [they are read from disk to ensure that at section/module discharging time, the physical library referred to outside the @@ -492,8 +492,8 @@ let rec_intern_library_from_file idopt f = the section/module] execution phase: (through add_leaf and cache_require) - the library is loaded in the environment and Nametab, the objects are - registered etc, using functions from Declaremods (via load_library, + the library is loaded in the environment and Nametab, the objects are + registered etc, using functions from Declaremods (via load_library, which recursively loads its dependencies) *) @@ -501,14 +501,14 @@ type library_reference = dir_path list * bool option let register_library (dir,m) = Declaremods.register_library - m.library_name - m.library_compiled - m.library_objects + m.library_name + m.library_compiled + m.library_objects m.library_digest; register_loaded_library m (* Follow the semantics of Anticipate object: - - called at module or module type closing when a Require occurs in + - called at module or module type closing when a Require occurs in the module or module type - not called from a library (i.e. a module identified with a file) *) let load_require _ (_,(needed,modl,_)) = @@ -529,7 +529,7 @@ let export_require (_,l,e) = Some ([],l,e) let discharge_require (_,o) = Some o -(* open_function is never called from here because an Anticipate object *) +(* open_function is never called from here because an Anticipate object *) let (in_require, out_require) = declare_object {(default_object "REQUIRE") with @@ -549,7 +549,7 @@ let set_xml_require f = xml_require := f let require_library_from_dirpath modrefl export = let needed = List.rev (List.fold_left rec_intern_library [] modrefl) in let modrefl = List.map fst modrefl in - if Lib.is_modtype () || Lib.is_module () then + if Lib.is_modtype () || Lib.is_module () then begin add_anonymous_leaf (in_require (needed,modrefl,None)); Option.iter (fun exp -> @@ -583,7 +583,7 @@ let require_library_from_file idopt file export = let import_module export (loc,qid) = try match Nametab.locate_module qid with - | MPfile dir -> + | MPfile dir -> if Lib.is_modtype () || Lib.is_module () || not export then add_anonymous_leaf (in_import (dir, export)) else @@ -595,7 +595,7 @@ let import_module export (loc,qid) = user_err_loc (loc,"import_library", str ((string_of_qualid qid)^" is not a module")) - + (************************************************************************) (*s Initializing the compilation of a library. *) @@ -606,7 +606,7 @@ let check_coq_overwriting p id = (strbrk ("Cannot build module "^string_of_dirpath p^"."^string_of_id id^ ": it starts with prefix \"Coq\" which is reserved for the Coq library.")) -let start_library f = +let start_library f = let paths = get_load_paths () in let _,longf = System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in @@ -628,15 +628,15 @@ let current_reexports () = let error_recursively_dependent_library dir = errorlabstrm "" - (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ + (strbrk "Unable to use logical name " ++ pr_dirpath dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") (* Security weakness: file might have been changed on disk between - writing the content and computing the checksum... *) + writing the content and computing the checksum... *) let save_library_to dir f = let cenv, seg = Declaremods.end_library dir in - let md = { + let md = { md_name = dir; md_compiled = cenv; md_objects = seg; @@ -661,5 +661,5 @@ open Printf let mem s = let m = try_find_library s in h 0 (str (sprintf "%dk (cenv = %dk / seg = %dk)" - (size_kb m) (size_kb m.library_compiled) + (size_kb m) (size_kb m.library_compiled) (size_kb m.library_objects))) diff --git a/library/library.mllib b/library/library.mllib index 1fc63929f4..4efb69a21f 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -1,7 +1,7 @@ Nameops Libnames Libobject -Summary +Summary Nametab Global Lib diff --git a/library/nameops.ml b/library/nameops.ml index 563fa02102..bc28ed98c2 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -30,14 +30,14 @@ let cut_ident skip_quote s = let slen = String.length s in (* [n'] is the position of the first non nullary digit *) let rec numpart n n' = - if n = 0 then + if n = 0 then (* ident made of _ and digits only [and ' if skip_quote]: don't cut it *) slen - else + else let c = Char.code (String.get s (n-1)) in - if c = code_of_0 && n <> slen then - numpart (n-1) n' - else if code_of_0 <= c && c <= code_of_9 then + if c = code_of_0 && n <> slen then + numpart (n-1) n' + else if code_of_0 <= c && c <= code_of_9 then numpart (n-1) (n-1) else if skip_quote & (c = Char.code '\'' || c = Char.code '_') then numpart (n-1) (n-1) @@ -50,14 +50,14 @@ let repr_ident s = let numstart = cut_ident false s in let s = string_of_id s in let slen = String.length s in - if numstart = slen then + if numstart = slen then (s, None) else (String.sub s 0 numstart, Some (int_of_string (String.sub s numstart (slen - numstart)))) let make_ident sa = function - | Some n -> + | Some n -> let c = Char.code (String.get sa (String.length sa -1)) in let s = if c < code_of_0 or c > code_of_9 then sa ^ (string_of_int n) @@ -116,21 +116,21 @@ let atompart_of_id id = fst (repr_ident id) let lift_ident = lift_subscript -let next_ident_away id avoid = +let next_ident_away id avoid = if List.mem id avoid then - let id0 = if not (has_subscript id) then id else - (* Ce serait sans doute mieux avec quelque chose inspiré de + let id0 = if not (has_subscript id) then id else + (* Ce serait sans doute mieux avec quelque chose inspiré de *** make_ident id (Some 0) *** mais ça brise la compatibilité... *) forget_subscript id in let rec name_rec id = - if List.mem id avoid then name_rec (lift_ident id) else id in + if List.mem id avoid then name_rec (lift_ident id) else id in name_rec id0 else id -let next_ident_away_from id avoid = +let next_ident_away_from id avoid = let rec name_rec id = - if List.mem id avoid then name_rec (lift_ident id) else id in - name_rec id + if List.mem id avoid then name_rec (lift_ident id) else id in + name_rec id (* Names *) @@ -147,7 +147,7 @@ let name_iter f na = name_fold (fun x () -> f x) na () let name_cons na l = match na with - | Anonymous -> l + | Anonymous -> l | Name id -> id::l let name_app f = function @@ -158,7 +158,7 @@ let name_fold_map f e = function | Name id -> let (e,id) = f e id in (e,Name id) | Anonymous -> e,Anonymous -let next_name_away_with_default default name l = +let next_name_away_with_default default name l = match name with | Name str -> next_ident_away str l | Anonymous -> next_ident_away (id_of_string default) l diff --git a/library/nametab.ml b/library/nametab.ml index 0743864171..31915c95a0 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -31,12 +31,12 @@ let error_global_not_found q = raise (GlobalizationError q) type ltac_constant = kernel_name -(* The visibility can be registered either +(* The visibility can be registered either - for all suffixes not shorter then a given int - when the object is loaded inside a module or - for a precise suffix, when the module containing (the module - containing ...) the object is open (imported) + containing ...) the object is open (imported) *) type visibility = Until of int | Exactly of int @@ -46,7 +46,7 @@ type visibility = Until of int | Exactly of int (* This module type will be instantiated by [full_path] of [dir_path] *) (* The [repr] function is assumed to return the reversed list of idents. *) -module type UserName = sig +module type UserName = sig type t val to_string : t -> string val repr : t -> identifier * module_ident list @@ -57,15 +57,15 @@ end partially qualified names of type [qualid]. The mapping of partially qualified names to ['a] is determined by the [visibility] parameter of [push]. - + The [shortest_qualid] function given a user_name Coq.A.B.x, tries to find the shortest among x, B.x, A.B.x and Coq.A.B.x that denotes - the same object. + the same object. *) module type NAMETREE = sig type 'a t type user_name - + val empty : 'a t val push : visibility -> user_name -> 'a -> 'a t -> 'a t val locate : qualid -> 'a t -> 'a @@ -76,15 +76,15 @@ module type NAMETREE = sig val find_prefixes : qualid -> 'a t -> 'a list end -module Make(U:UserName) : NAMETREE with type user_name = U.t - = +module Make(U:UserName) : NAMETREE with type user_name = U.t + = struct type user_name = U.t - type 'a path_status = - Nothing - | Relative of user_name * 'a + type 'a path_status = + Nothing + | Relative of user_name * 'a | Absolute of user_name * 'a (* Dictionaries of short names *) @@ -93,38 +93,38 @@ struct type 'a t = 'a nametree Idmap.t let empty = Idmap.empty - - (* [push_until] is used to register [Until vis] visibility and + + (* [push_until] is used to register [Until vis] visibility and [push_exactly] to [Exactly vis] and [push_tree] chooses the right one*) let rec push_until uname o level (current,dirmap) = function | modid :: path -> - let mc = + let mc = try ModIdmap.find modid dirmap with Not_found -> (Nothing, ModIdmap.empty) in let this = if level <= 0 then match current with - | Absolute (n,_) -> - (* This is an absolute name, we must keep it + | Absolute (n,_) -> + (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) Flags.if_verbose - warning ("Trying to mask the absolute name \"" - ^ U.to_string n ^ "\"!"); + warning ("Trying to mask the absolute name \"" + ^ U.to_string n ^ "\"!"); current | Nothing | Relative _ -> Relative (uname,o) - else current + else current in let ptab' = push_until uname o (level-1) mc path in (this, ModIdmap.add modid ptab' dirmap) - | [] -> + | [] -> match current with - | Absolute (uname',o') -> + | Absolute (uname',o') -> if o'=o then begin assert (uname=uname'); - current, dirmap + current, dirmap (* we are putting the same thing for the second time :) *) end else @@ -139,15 +139,15 @@ struct let rec push_exactly uname o level (current,dirmap) = function | modid :: path -> - let mc = + let mc = try ModIdmap.find modid dirmap with Not_found -> (Nothing, ModIdmap.empty) in if level = 0 then let this = match current with - | Absolute (n,_) -> - (* This is an absolute name, we must keep it + | Absolute (n,_) -> + (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) Flags.if_verbose warning ("Trying to mask the absolute name \"" @@ -160,7 +160,7 @@ let rec push_exactly uname o level (current,dirmap) = function else (* not right level *) let ptab' = push_exactly uname o (level-1) mc path in (current, ModIdmap.add modid ptab' dirmap) - | [] -> + | [] -> anomaly "Prefix longer than path! Impossible!" @@ -168,7 +168,7 @@ let push visibility uname o tab = let id,dir = U.repr uname in let ptab = try Idmap.find id tab - with Not_found -> (Nothing, ModIdmap.empty) + with Not_found -> (Nothing, ModIdmap.empty) in let ptab' = match visibility with | Until i -> push_until uname o (i-1) ptab dir @@ -180,46 +180,46 @@ let push visibility uname o tab = let rec search (current,modidtab) = function | modid :: path -> search (ModIdmap.find modid modidtab) path | [] -> current - + let find_node qid tab = let (dir,id) = repr_qualid qid in search (Idmap.find id tab) (repr_dirpath dir) -let locate qid tab = +let locate qid tab = let o = match find_node qid tab with | Absolute (uname,o) | Relative (uname,o) -> o - | Nothing -> raise Not_found + | Nothing -> raise Not_found in o let user_name qid tab = let uname = match find_node qid tab with | Absolute (uname,o) | Relative (uname,o) -> uname - | Nothing -> raise Not_found + | Nothing -> raise Not_found in uname - -let find uname tab = + +let find uname tab = let id,l = U.repr uname in match search (Idmap.find id tab) l with Absolute (_,o) -> o | _ -> raise Not_found let exists uname tab = - try + try let _ = find uname tab in true with Not_found -> false -let shortest_qualid ctx uname tab = +let shortest_qualid ctx uname tab = let id,dir = U.repr uname in let hidden = Idset.mem id ctx in let rec find_uname pos dir (path,tab) = match path with | Absolute (u,_) | Relative (u,_) when u=uname && not(pos=[] && hidden) -> List.rev pos - | _ -> - match dir with + | _ -> + match dir with [] -> raise Not_found | id::dir -> find_uname (id::pos) dir (ModIdmap.find id tab) in @@ -239,7 +239,7 @@ let rec flatten_idmap tab l = let rec search_prefixes (current,modidtab) = function | modid :: path -> search_prefixes (ModIdmap.find modid modidtab) path | [] -> List.rev (flatten_idmap modidtab (push_node current [])) - + let find_prefixes qid tab = try let (dir,id) = repr_qualid qid in @@ -252,10 +252,10 @@ end (* Global name tables *************************************************) -module SpTab = Make (struct +module SpTab = Make (struct type t = full_path let to_string = string_of_path - let repr sp = + let repr sp = let dir,id = repr_path sp in id, (repr_dirpath dir) end) @@ -271,7 +271,7 @@ type mptab = module_path SpTab.t let the_modtypetab = ref (SpTab.empty : mptab) -module DirTab = Make(struct +module DirTab = Make(struct type t = dir_path let to_string = string_of_dirpath let repr dir = match repr_dirpath dir with @@ -288,9 +288,9 @@ let the_dirtab = ref (DirTab.empty : dirtab) (* Reversed name tables ***************************************************) (* This table translates extended_global_references back to section paths *) -module Globrevtab = Map.Make(struct - type t=extended_global_reference - let compare = compare +module Globrevtab = Map.Make(struct + type t=extended_global_reference + let compare = compare end) type globrevtab = full_path Globrevtab.t @@ -316,7 +316,7 @@ let the_tacticrevtab = ref (KNmap.empty : knrevtab) let push_xref visibility sp xref = the_ccitab := SpTab.push visibility sp xref !the_ccitab; match visibility with - | Until _ -> + | Until _ -> if Globrevtab.mem xref !the_globrevtab then () else @@ -332,19 +332,19 @@ let push_syndef visibility sp kn = let push = push_cci -let push_modtype vis sp kn = +let push_modtype vis sp kn = the_modtypetab := SpTab.push vis sp kn !the_modtypetab; the_modtyperevtab := MPmap.add kn sp !the_modtyperevtab (* This is for tactic definition names *) -let push_tactic vis sp kn = +let push_tactic vis sp kn = the_tactictab := SpTab.push vis sp kn !the_tactictab; the_tacticrevtab := KNmap.add kn sp !the_tacticrevtab (* This is to remember absolute Section/Module names and to avoid redundancy *) -let push_dir vis dir dir_ref = +let push_dir vis dir dir_ref = the_dirtab := DirTab.push vis dir dir_ref !the_dirtab; match dir_ref with DirModule (_,(mp,_)) -> the_modrevtab := MPmap.add mp dir !the_modrevtab @@ -375,23 +375,23 @@ let full_name_tactic qid = SpTab.user_name qid !the_tactictab let locate_dir qid = DirTab.locate qid !the_dirtab -let locate_module qid = +let locate_module qid = match locate_dir qid with | DirModule (_,(mp,_)) -> mp | _ -> raise Not_found -let full_name_module qid = +let full_name_module qid = match locate_dir qid with | DirModule (dir,_) -> dir | _ -> raise Not_found let locate_section qid = match locate_dir qid with - | DirOpenSection (dir, _) + | DirOpenSection (dir, _) | DirClosedSection dir -> dir | _ -> raise Not_found -let locate_all qid = +let locate_all qid = List.fold_right (fun a l -> match a with TrueGlobal a -> a::l | _ -> l) (SpTab.find_prefixes qid !the_ccitab) [] @@ -404,7 +404,7 @@ let locate_constant qid = | TrueGlobal (ConstRef kn) -> kn | _ -> raise Not_found -let locate_mind qid = +let locate_mind qid = match locate_extended qid with | TrueGlobal (IndRef (kn,0)) -> kn | _ -> raise Not_found @@ -423,7 +423,7 @@ let global r = let (loc,qid) = qualid_of_reference r in try match locate_extended qid with | TrueGlobal ref -> ref - | SynDef _ -> + | SynDef _ -> user_err_loc (loc,"global", str "Unexpected reference to a notation: " ++ pr_qualid qid) @@ -433,7 +433,7 @@ let global r = (* Exists functions ********************************************************) let exists_cci sp = SpTab.exists sp !the_ccitab - + let exists_dir dir = DirTab.exists dir !the_dirtab let exists_section = exists_dir @@ -446,18 +446,18 @@ let exists_tactic sp = SpTab.exists sp !the_tactictab (* Reverse locate functions ***********************************************) -let path_of_global ref = +let path_of_global ref = match ref with | VarRef id -> make_path empty_dirpath id | _ -> Globrevtab.find (TrueGlobal ref) !the_globrevtab -let dirpath_of_global ref = +let dirpath_of_global ref = fst (repr_path (path_of_global ref)) -let basename_of_global ref = +let basename_of_global ref = snd (repr_path (path_of_global ref)) -let path_of_syndef kn = +let path_of_syndef kn = Globrevtab.find (SynDef kn) !the_globrevtab let dirpath_of_module mp = @@ -466,18 +466,18 @@ let dirpath_of_module mp = (* Shortest qualid functions **********************************************) -let shortest_qualid_of_global ctx ref = +let shortest_qualid_of_global ctx ref = match ref with | VarRef id -> make_qualid empty_dirpath id | _ -> let sp = Globrevtab.find (TrueGlobal ref) !the_globrevtab in SpTab.shortest_qualid ctx sp !the_ccitab -let shortest_qualid_of_syndef ctx kn = +let shortest_qualid_of_syndef ctx kn = let sp = path_of_syndef kn in SpTab.shortest_qualid ctx sp !the_ccitab -let shortest_qualid_of_module mp = +let shortest_qualid_of_module mp = let dir = MPmap.find mp !the_modrevtab in DirTab.shortest_qualid Idset.empty dir !the_dirtab @@ -512,8 +512,8 @@ let global_inductive r = type frozen = ccitab * dirtab * kntab * kntab * globrevtab * mprevtab * knrevtab * knrevtab -let init () = - the_ccitab := SpTab.empty; +let init () = + the_ccitab := SpTab.empty; the_dirtab := DirTab.empty; the_modtypetab := SpTab.empty; the_tactictab := SpTab.empty; @@ -525,7 +525,7 @@ let init () = let freeze () = - !the_ccitab, + !the_ccitab, !the_dirtab, !the_modtypetab, !the_tactictab, @@ -544,7 +544,7 @@ let unfreeze (ccit,dirt,mtyt,tact,globr,modr,mtyr,tacr) = the_modtyperevtab := mtyr; the_tacticrevtab := tacr -let _ = +let _ = Summary.declare_summary "names" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; diff --git a/library/nametab.mli b/library/nametab.mli index 774b148a56..98a482896c 100755 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -35,15 +35,15 @@ open Libnames (* Most functions in this module fall into one of the following categories: \begin{itemize} \item [push : visibility -> full_user_name -> object_reference -> unit] - + Registers the [object_reference] to be referred to by the [full_user_name] (and its suffixes according to [visibility]). [full_user_name] can either be a [full_path] or a [dir_path]. - \item [exists : full_user_name -> bool] - + \item [exists : full_user_name -> bool] + Is the [full_user_name] already atributed as an absolute user name - of some object? + of some object? \item [locate : qualid -> object_reference] @@ -52,16 +52,16 @@ open Libnames \item [full_name : qualid -> full_user_name] Finds the full user name referred to by [qualid] or raises [Not_found] - + \item [shortest_qualid_of : object_reference -> user_name] - The [user_name] can be for example the shortest non ambiguous [qualid] or - the [full_user_name] or [identifier]. Such a function can also have a - local context argument. + The [user_name] can be for example the shortest non ambiguous [qualid] or + the [full_user_name] or [identifier]. Such a function can also have a + local context argument. \end{itemize} *) - - + + exception GlobalizationError of qualid exception GlobalizationConstantError of qualid @@ -79,7 +79,7 @@ val error_global_constant_not_found_loc : loc -> qualid -> 'a object is loaded inside a module -- or \item for a precise suffix, when the module containing (the module - containing ...) the object is opened (imported) + containing ...) the object is opened (imported) \end{itemize} *) diff --git a/library/states.ml b/library/states.ml index 4fbc4c8866..c4e766095b 100644 --- a/library/states.ml +++ b/library/states.ml @@ -31,14 +31,14 @@ let (extern_state,intern_state) = let with_heavy_rollback f x = let st = freeze () in - try + try f x with reraise -> (unfreeze st; raise reraise) let with_state_protection f x = let st = freeze () in - try + try let a = f x in unfreeze st; a with reraise -> (unfreeze st; raise reraise) diff --git a/library/states.mli b/library/states.mli index 17f62b5129..782e41ca77 100644 --- a/library/states.mli +++ b/library/states.mli @@ -10,7 +10,7 @@ (*s States of the system. In that module, we provide functions to get and set the state of the whole system. Internally, it is done by - freezing the states of both [Lib] and [Summary]. We provide functions + freezing the states of both [Lib] and [Summary]. We provide functions to write and restore state to and from a given file. *) val intern_state : string -> unit @@ -21,7 +21,7 @@ val freeze : unit -> state val unfreeze : state -> unit (*s Rollback. [with_heavy_rollback f x] applies [f] to [x] and restores the - state of the whole system as it was before the evaluation if an exception + state of the whole system as it was before the evaluation if an exception is raised. *) val with_heavy_rollback : ('a -> 'b) -> 'a -> 'b diff --git a/library/summary.ml b/library/summary.ml index 784d79d876..e9b0bbd367 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -16,7 +16,7 @@ type 'a summary_declaration = { unfreeze_function : 'a -> unit; init_function : unit -> unit } -let summaries = +let summaries = (Hashtbl.create 17 : (string, Dyn.t summary_declaration) Hashtbl.t) let internal_declare_summary sumname sdecl = @@ -34,22 +34,22 @@ let internal_declare_summary sumname sdecl = (str "Cannot declare a summary twice: " ++ str sumname); Hashtbl.add summaries sumname ddecl -let declare_summary sumname decl = +let declare_summary sumname decl = internal_declare_summary (sumname^"-SUMMARY") decl type frozen = Dyn.t Stringmap.t let freeze_summaries () = let m = ref Stringmap.empty in - Hashtbl.iter + Hashtbl.iter (fun id decl -> m := Stringmap.add id (decl.freeze_function()) !m) summaries; !m -let unfreeze_summaries fs = +let unfreeze_summaries fs = Hashtbl.iter - (fun id decl -> + (fun id decl -> try decl.unfreeze_function (Stringmap.find id fs) with Not_found -> decl.init_function()) summaries diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 104231f972..963adcc7c1 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -11,7 +11,7 @@ open Scanf is progressively added. Tested only on linux + ocaml 3.11 + local + natdynlink for now. - Usage: + Usage: ./configure -local -opt ./build (which launches ocamlbuild coq.otarget) @@ -256,7 +256,7 @@ let extra_rules () = begin flag_and_dep ["is_ml4"; "p4mod"; "use_constr"] (P qconstr); flag_and_dep ["is_ml4"; "p4mod"; "use_refutpat"] (P refutpat); -(** Special case of toplevel/mltop.ml4: +(** Special case of toplevel/mltop.ml4: - mltop.ml will be the old mltop.optml and be used to obtain mltop.cmx - we add a special mltop.ml4 --> mltop.cmo rule, before all the others *) @@ -276,7 +276,7 @@ let extra_rules () = begin A"-DByte";A"-DHasDynlink";camlp4compat;A"-impl"]); A"-rectypes"; camlp4incl; incl ml4; A"-impl"; P ml4])); -(** All caml files are compiled with -rectypes and +camlp4/5 +(** All caml files are compiled with -rectypes and +camlp4/5 and ide files need +lablgtk2 *) flag ["compile"; "ocaml"] (S [A"-rectypes"; camlp4incl]); diff --git a/parsing/argextend.ml4 b/parsing/argextend.ml4 index 539b203d01..89edbb1230 100644 --- a/parsing/argextend.ml4 +++ b/parsing/argextend.ml4 @@ -40,7 +40,7 @@ let rec make_rawwit loc = function | List0ArgType t -> <:expr< Genarg.wit_list0 $make_rawwit loc t$ >> | List1ArgType t -> <:expr< Genarg.wit_list1 $make_rawwit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_rawwit loc t$ >> - | PairArgType (t1,t2) -> + | PairArgType (t1,t2) -> <:expr< Genarg.wit_pair $make_rawwit loc t1$ $make_rawwit loc t2$ >> | ExtraArgType s -> <:expr< $lid:"rawwit_"^s$ >> @@ -65,7 +65,7 @@ let rec make_globwit loc = function | List0ArgType t -> <:expr< Genarg.wit_list0 $make_globwit loc t$ >> | List1ArgType t -> <:expr< Genarg.wit_list1 $make_globwit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_globwit loc t$ >> - | PairArgType (t1,t2) -> + | PairArgType (t1,t2) -> <:expr< Genarg.wit_pair $make_globwit loc t1$ $make_globwit loc t2$ >> | ExtraArgType s -> <:expr< $lid:"globwit_"^s$ >> @@ -90,7 +90,7 @@ let rec make_wit loc = function | List0ArgType t -> <:expr< Genarg.wit_list0 $make_wit loc t$ >> | List1ArgType t -> <:expr< Genarg.wit_list1 $make_wit loc t$ >> | OptArgType t -> <:expr< Genarg.wit_opt $make_wit loc t$ >> - | PairArgType (t1,t2) -> + | PairArgType (t1,t2) -> <:expr< Genarg.wit_pair $make_wit loc t1$ $make_wit loc t2$ >> | ExtraArgType s -> <:expr< $lid:"wit_"^s$ >> @@ -100,7 +100,7 @@ let make_act loc act pil = | GramNonTerminal (_,t,_,Some p) :: tl -> let p = Names.string_of_id p in <:expr< - Gramext.action + Gramext.action (fun $lid:p$ -> let _ = Genarg.in_gen $make_rawwit loc t$ $lid:p$ in $make tl$) >> @@ -131,14 +131,14 @@ let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl = (Genarg.in_gen $make_rawwit loc rawtyp$ x)) >> | Some f -> <:expr< $lid:f$>> in let interp = match f with - | None -> + | None -> <:expr< fun ist gl x -> out_gen $make_wit loc typ$ (Tacinterp.interp_genarg ist gl (Genarg.in_gen $make_globwit loc globtyp$ x)) >> | Some f -> <:expr< $lid:f$>> in let substitute = match h with - | None -> + | None -> <:expr< fun s x -> out_gen $make_globwit loc globtyp$ (Tacinterp.subst_genarg s @@ -163,7 +163,7 @@ let declare_tactic_argument loc s typ pr f g h rawtyppr globtyppr cl = (Genarg.in_gen $wit$ ($interp$ ist gl (out_gen $globwit$ x)))), (fun subst x -> (Genarg.in_gen $globwit$ ($substitute$ subst (out_gen $globwit$ x))))); - Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None + Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None [(None, None, $rules$)]; Pptactic.declare_extra_genarg_pprule ($rawwit$, $lid:rawpr$) @@ -189,7 +189,7 @@ let declare_vernac_argument loc s pr cl = ($lid:"globwit_"^s$:Genarg.abstract_argument_type unit Genarg.glevel), $lid:"rawwit_"^s$) = Genarg.create_arg $se$; value $lid:s$ = Pcoq.create_generic_entry $se$ $rawwit$; - Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None + Pcoq.Gram.extend ($lid:s$ : Pcoq.Gram.Entry.e 'a) None [(None, None, $rules$)]; Pptactic.declare_extra_genarg_pprule ($rawwit$, $pr_rules$) @@ -213,10 +213,10 @@ EXTEND h = OPT [ "SUBSTITUTED"; "BY"; f = LIDENT -> f ]; rawtyppr = (* Necessary if the globalized type is different from the final type *) - OPT [ "RAW_TYPED"; "AS"; t = argtype; + OPT [ "RAW_TYPED"; "AS"; t = argtype; "RAW_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; globtyppr = - OPT [ "GLOB_TYPED"; "AS"; t = argtype; + OPT [ "GLOB_TYPED"; "AS"; t = argtype; "GLOB_PRINTED"; "BY"; pr = LIDENT -> (t,pr) ]; OPT "|"; l = LIST1 argrule SEP "|"; "END" -> @@ -232,7 +232,7 @@ EXTEND declare_vernac_argument loc s pr l ] ] ; argtype: - [ "2" + [ "2" [ e1 = argtype; "*"; e2 = argtype -> PairArgType (e1, e2) ] | "1" [ e = argtype; LIDENT "list" -> List0ArgType e diff --git a/parsing/egrammar.ml b/parsing/egrammar.ml index 87e8e1deb2..8d90499dc2 100644 --- a/parsing/egrammar.ml +++ b/parsing/egrammar.ml @@ -22,9 +22,9 @@ open Names open Vernacexpr (**************************************************************************) -(* +(* * --- Note on the mapping of grammar productions to camlp4 actions --- - * + * * Translation of environments: a production * [ nt1(x1) ... nti(xi) ] -> act(x1..xi) * is written (with camlp4 conventions): @@ -34,9 +34,9 @@ open Vernacexpr * the make_*_action family build the following closure: * * ((fun env -> - * (fun vi -> + * (fun vi -> * (fun env -> ... - * + * * (fun v1 -> * (fun env -> gram_action .. env act) * ((x1,v1)::env)) @@ -81,7 +81,7 @@ let make_constr_action make (CPrim (dummy_loc,Numeral v) :: env, envlist) tl) | Some (p, ETConstrList _) :: tl -> Gramext.action (fun (v:constr_expr list) -> make (env, v::envlist) tl) - | Some (p, ETPattern) :: tl -> + | Some (p, ETPattern) :: tl -> failwith "Unexpected entry of type cases pattern" in make ([],[]) (List.rev pil) @@ -106,7 +106,7 @@ let make_cases_pattern_action | Some (p, ETConstrList _) :: tl -> Gramext.action (fun (v:cases_pattern_expr list) -> make (env, v :: envlist) tl) - | Some (p, (ETPattern | ETOther _)) :: tl -> + | Some (p, (ETPattern | ETOther _)) :: tl -> failwith "Unexpected entry of type cases pattern or other" in make ([],[]) (List.rev pil) @@ -153,7 +153,7 @@ let extend_constr_notation (n,assoc,ntn,rule) = let make_generic_action (f:loc -> ('b * raw_generic_argument) list -> 'a) pil = let rec make env = function - | [] -> + | [] -> Gramext.action (fun loc -> f loc env) | None :: tl -> (* parse a non-binding item *) Gramext.action (fun _ -> make env tl) @@ -167,7 +167,7 @@ let make_rule univ f g pt = (symbs, act) (**********************************************************************) -(** Grammar extensions declared at ML level *) +(** Grammar extensions declared at ML level *) type grammar_prod_item = | GramTerminal of string @@ -200,7 +200,7 @@ let extend_vernac_command_grammar s gl = Gram.extend Vernac_.command None [(None, None, List.rev rules)] (**********************************************************************) -(** Grammar declaration for Tactic Notation (Coq level) *) +(** Grammar declaration for Tactic Notation (Coq level) *) let get_tactic_entry n = if n = 0 then @@ -209,7 +209,7 @@ let get_tactic_entry n = weaken_entry Tactic.binder_tactic, None else if 1<=n && n<5 then weaken_entry Tactic.tactic_expr, Some (Gramext.Level (string_of_int n)) - else + else error ("Invalid Tactic Notation level: "^(string_of_int n)^".") (* Declaration of the tactic grammar rule *) @@ -219,7 +219,7 @@ let head_is_ident = function GramTerminal _::_ -> true | _ -> false let add_tactic_entry (key,lev,prods,tac) = let univ = get_univ "tactic" in let entry, pos = get_tactic_entry lev in - let rules = + let rules = if lev = 0 then begin if not (head_is_ident prods) then error "Notation for simple tactic must start with an identifier."; @@ -228,7 +228,7 @@ let add_tactic_entry (key,lev,prods,tac) = make_rule univ (mkact key tac) make_prod_item prods end else - let mkact s tac loc l = + let mkact s tac loc l = (TacAtom(loc,TacAlias(loc,s,l,tac)):raw_tactic_expr) in make_rule univ (mkact key tac) make_prod_item prods in synchronize_level_positions (); @@ -237,7 +237,7 @@ let add_tactic_entry (key,lev,prods,tac) = (**********************************************************************) (** State of the grammar extensions *) -type notation_grammar = +type notation_grammar = int * Gramext.g_assoc option * notation * grammar_constr_prod_item list type all_grammar_command = @@ -268,7 +268,7 @@ type frozen_t = all_grammar_command list * Lexer.frozen_t let freeze () = (!grammar_state, Lexer.freeze ()) -(* We compare the current state of the grammar and the state to unfreeze, +(* We compare the current state of the grammar and the state to unfreeze, by computing the longest common suffixes *) let factorize_grams l1 l2 = if l1 == l2 then ([], [], l1) else list_share_tails l1 l2 @@ -288,7 +288,7 @@ let unfreeze (grams, lex) = grammar_state := common; Lexer.unfreeze lex; List.iter extend_grammar (List.rev redo) - + let init_grammar () = remove_grammars (number_of_entries !grammar_state); grammar_state := [] @@ -298,7 +298,7 @@ let init () = open Summary -let _ = +let _ = declare_summary "GRAMMAR_LEXER" { freeze_function = freeze; unfreeze_function = unfreeze; diff --git a/parsing/egrammar.mli b/parsing/egrammar.mli index e632e5bb81..14e4cfd37e 100644 --- a/parsing/egrammar.mli +++ b/parsing/egrammar.mli @@ -22,7 +22,7 @@ open Mod_subst (*i*) (** Mapping of grammar productions to camlp4 actions - Used for Coq-level Notation and Tactic Notation, + Used for Coq-level Notation and Tactic Notation, and for ML-level tactic and vernac extensions *) @@ -32,14 +32,14 @@ type grammar_constr_prod_item = | GramConstrTerminal of Token.pattern | GramConstrNonTerminal of constr_prod_entry_key * identifier option -type notation_grammar = +type notation_grammar = int * Gramext.g_assoc option * notation * grammar_constr_prod_item list (* For tactic and vernac notations *) type grammar_prod_item = | GramTerminal of string - | GramNonTerminal of loc * argument_type * + | GramNonTerminal of loc * argument_type * Gram.te prod_entry_key * identifier option (* Adding notations *) diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index f91f0170c7..7e2b41926c 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -22,7 +22,7 @@ open Topconstr open Util let constr_kw = - [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; + [ "forall"; "fun"; "match"; "fix"; "cofix"; "with"; "in"; "for"; "end"; "as"; "let"; "if"; "then"; "else"; "return"; "Prop"; "Set"; "Type"; ".("; "_"; ".."; "`{"; "`("; "{|"; "|}" ] @@ -39,10 +39,10 @@ let loc_of_binder_let = function | _ -> dummy_loc let binders_of_lidents l = - List.map (fun (loc, id) -> - LocalRawAssum ([loc, Name id], Default Rawterm.Explicit, + List.map (fun (loc, id) -> + LocalRawAssum ([loc, Name id], Default Rawterm.Explicit, CHole (loc, Some (Evd.BinderType (Name id))))) l - + let rec index_and_rec_order_of_annot loc bl ann = match names_of_local_assums bl,ann with | [loc,Name id], (None, r) -> Some (loc, id), r @@ -70,7 +70,7 @@ let mk_cofixb (id,bl,ann,body,(loc,tyc)) = (id,bl,ty,body) let mk_fix(loc,kw,id,dcls) = - if kw then + if kw then let fb = List.map mk_fixb dcls in CFix(loc,id,fb) else @@ -101,16 +101,16 @@ let impl_ident = Gram.Entry.of_parser "impl_ident" (fun strm -> match Stream.npeek 1 strm with - | [(_,"{")] -> + | [(_,"{")] -> (match Stream.npeek 2 strm with | [_;("IDENT",("wf"|"struct"|"measure"))] -> raise Stream.Failure - | [_;("IDENT",s)] -> + | [_;("IDENT",s)] -> Stream.junk strm; Stream.junk strm; Names.id_of_string s | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) - + let ident_colon = Gram.Entry.of_parser "ident_colon" (fun strm -> @@ -134,7 +134,7 @@ let ident_with = Names.id_of_string s | _ -> raise Stream.Failure) | _ -> raise Stream.Failure) - + let aliasvar = function CPatAlias (_, _, id) -> Some (Name id) | _ -> None GEXTEND Gram @@ -169,21 +169,21 @@ GEXTEND Gram [ [ c = operconstr LEVEL "200" -> c ] ] ; constr: - [ [ c = operconstr LEVEL "8" -> c + [ [ c = operconstr LEVEL "8" -> c | "@"; f=global -> CAppExpl(loc,(None,f),[]) ] ] ; operconstr: [ "200" RIGHTA [ c = binder_constr -> c ] | "100" RIGHTA - [ c1 = operconstr; "<:"; c2 = binder_constr -> + [ c1 = operconstr; "<:"; c2 = binder_constr -> CCast(loc,c1, CastConv (VMcast,c2)) - | c1 = operconstr; "<:"; c2 = SELF -> + | c1 = operconstr; "<:"; c2 = SELF -> CCast(loc,c1, CastConv (VMcast,c2)) - | c1 = operconstr; ":";c2 = binder_constr -> + | c1 = operconstr; ":";c2 = binder_constr -> + CCast(loc,c1, CastConv (DEFAULTcast,c2)) + | c1 = operconstr; ":"; c2 = SELF -> CCast(loc,c1, CastConv (DEFAULTcast,c2)) - | c1 = operconstr; ":"; c2 = SELF -> - CCast(loc,c1, CastConv (DEFAULTcast,c2)) | c1 = operconstr; ":>" -> CCast(loc,c1, CastCoerce) ] | "99" RIGHTA [ ] @@ -205,7 +205,7 @@ GEXTEND Gram CApp(loc,(Some (List.length args+1),CRef f),args@[c,None]) | c=operconstr; ".("; "@"; f=global; args=LIST0 (operconstr LEVEL "9"); ")" -> - CAppExpl(loc,(Some (List.length args+1),f),args@[c]) + CAppExpl(loc,(Some (List.length args+1),f),args@[c]) | c=operconstr; "%"; key=IDENT -> CDelimiters (loc,key,c) ] | "0" [ c=atomic_constr -> c @@ -222,13 +222,13 @@ GEXTEND Gram CGeneralization (loc, Explicit, None, c) ] ] ; - forall: - [ [ "forall" -> () + forall: + [ [ "forall" -> () | IDENT "Π" -> () ] ] ; - lambda: - [ [ "fun" -> () + lambda: + [ [ "fun" -> () | IDENT "λ" -> () ] ] ; @@ -239,7 +239,7 @@ GEXTEND Gram ] ] ; record_field_declaration: - [ [ id = identref; params = LIST0 identref; ":="; c = lconstr -> + [ [ id = identref; params = LIST0 identref; ":="; c = lconstr -> (id, Topconstr.abstract_constr_expr c (binders_of_lidents params)) ] ] ; binder_constr: @@ -266,10 +266,10 @@ GEXTEND Gram | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> CCases (loc, LetPatternStyle, None, [(c1,(None,None))], [(loc, [(loc,[p])], c2)]) - | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; + | "let"; "'"; p=pattern; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> CCases (loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, None))], [(loc, [(loc, [p])], c2)]) - | "let"; "'"; p=pattern; "in"; t = operconstr LEVEL "200"; + | "let"; "'"; p=pattern; "in"; t = operconstr LEVEL "200"; ":="; c1 = operconstr LEVEL "200"; rt = case_type; "in"; c2 = operconstr LEVEL "200" -> CCases (loc, LetPatternStyle, Some rt, [(c1, (aliasvar p, Some t))], [(loc, [(loc, [p])], c2)]) @@ -326,8 +326,8 @@ GEXTEND Gram ; return_type: [ [ a = OPT [ na = OPT["as"; id=name -> snd id]; - ty = case_type -> (na,ty) ] -> - match a with + ty = case_type -> (na,ty) ] -> + match a with | None -> None, None | Some (na,t) -> (na, Some t) ] ] @@ -351,7 +351,7 @@ GEXTEND Gram [ p = pattern; lp = LIST1 NEXT -> (match p with | CPatAtom (_, Some r) -> CPatCstr (loc, r, lp) - | _ -> Util.user_err_loc + | _ -> Util.user_err_loc (cases_pattern_expr_loc p, "compound_pattern", Pp.str "Constructor expected.")) | p = pattern; "as"; id = ident -> @@ -370,9 +370,9 @@ GEXTEND Gram | s = string -> CPatPrim (loc, String s) ] ] ; binder_list: - [ [ idl=LIST1 name; bl=binders_let -> + [ [ idl=LIST1 name; bl=binders_let -> LocalRawAssum (idl,Default Explicit,CHole (loc, Some (Evd.BinderType (snd (List.hd idl)))))::bl - | idl=LIST1 name; ":"; c=lconstr -> + | idl=LIST1 name; ":"; c=lconstr -> [LocalRawAssum (idl,Default Explicit,c)] | cl = binders_let -> cl ] ] @@ -390,15 +390,15 @@ GEXTEND Gram fixannot: [ [ "{"; IDENT "struct"; id=identref; "}" -> (Some id, CStructRec) | "{"; IDENT "wf"; rel=constr; id=OPT identref; "}" -> (id, CWfRec rel) - | "{"; IDENT "measure"; m=constr; id=OPT identref; + | "{"; IDENT "measure"; m=constr; id=OPT identref; rel=OPT constr; "}" -> (id, CMeasureRec (m,rel)) ] ] ; binders_let_fixannot: - [ [ id=impl_ident; assum=binder_assum; bl = binders_let_fixannot -> + [ [ id=impl_ident; assum=binder_assum; bl = binders_let_fixannot -> (assum (loc, Name id) :: fst bl), snd bl | f = fixannot -> [], f - | b = binder_let; bl = binders_let_fixannot -> + | b = binder_let; bl = binders_let_fixannot -> b @ fst bl, snd bl | -> [], (None, CStructRec) ] ] @@ -410,21 +410,21 @@ GEXTEND Gram binder_let: [ [ id=name -> [LocalRawAssum ([id],Default Explicit,CHole (loc, None))] - | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> + | "("; id=name; idl=LIST1 name; ":"; c=lconstr; ")" -> [LocalRawAssum (id::idl,Default Explicit,c)] - | "("; id=name; ":"; c=lconstr; ")" -> + | "("; id=name; ":"; c=lconstr; ")" -> [LocalRawAssum ([id],Default Explicit,c)] | "("; id=name; ":="; c=lconstr; ")" -> [LocalRawDef (id,c)] - | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> + | "("; id=name; ":"; t=lconstr; ":="; c=lconstr; ")" -> [LocalRawDef (id,CCast (join_loc (constr_loc t) loc,c, CastConv (DEFAULTcast,t)))] | "{"; id=name; "}" -> [LocalRawAssum ([id],Default Implicit,CHole (loc, None))] - | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" -> + | "{"; id=name; idl=LIST1 name; ":"; c=lconstr; "}" -> [LocalRawAssum (id::idl,Default Implicit,c)] - | "{"; id=name; ":"; c=lconstr; "}" -> + | "{"; id=name; ":"; c=lconstr; "}" -> [LocalRawAssum ([id],Default Implicit,c)] - | "{"; id=name; idl=LIST1 name; "}" -> + | "{"; id=name; idl=LIST1 name; "}" -> List.map (fun id -> LocalRawAssum ([id],Default Implicit,CHole (loc, None))) (id::idl) | "`("; tc = LIST1 typeclass_constraint SEP "," ; ")" -> List.map (fun (n, b, t) -> LocalRawAssum ([n], Generalized (Implicit, Explicit, b), t)) tc @@ -434,8 +434,8 @@ GEXTEND Gram ; binder: [ [ id=name -> ([id],Default Explicit,CHole (loc, None)) - | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,Default Explicit,c) - | "{"; idl=LIST1 name; ":"; c=lconstr; "}" -> (idl,Default Implicit,c) + | "("; idl=LIST1 name; ":"; c=lconstr; ")" -> (idl,Default Explicit,c) + | "{"; idl=LIST1 name; ":"; c=lconstr; "}" -> (idl,Default Implicit,c) ] ] ; typeclass_constraint: @@ -448,7 +448,7 @@ GEXTEND Gram (loc, Anonymous), false, c ] ] ; - + type_cstr: [ [ c=OPT [":"; c=lconstr -> c] -> (loc,c) ] ] ; diff --git a/parsing/g_decl_mode.ml4 b/parsing/g_decl_mode.ml4 index 91433b8a63..e812faeaca 100644 --- a/parsing/g_decl_mode.ml4 +++ b/parsing/g_decl_mode.ml4 @@ -29,7 +29,7 @@ let none_is_empty = function GEXTEND Gram GLOBAL: proof_instr; thesis : - [[ "thesis" -> Plain + [[ "thesis" -> Plain | "thesis"; "for"; i=ident -> (For i) ]]; statement : @@ -42,9 +42,9 @@ GLOBAL: proof_instr; [[ t=thesis -> Thesis t ] | [ c=constr -> This c ]]; - statement_or_thesis : + statement_or_thesis : [ - [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] + [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] | [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} | i=ident -> {st_label=Anonymous; @@ -52,25 +52,25 @@ GLOBAL: proof_instr; | c=constr -> {st_label=Anonymous;st_it=This c} ] ]; - justification_items : - [[ -> Some [] + justification_items : + [[ -> Some [] | IDENT "by"; l=LIST1 constr SEP "," -> Some l | IDENT "by"; "*" -> None ]] ; - justification_method : - [[ -> None + justification_method : + [[ -> None | "using"; tac = tactic -> Some tac ]] ; simple_cut_or_thesis : [[ ls = statement_or_thesis; j = justification_items; - taco = justification_method + taco = justification_method -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] ; simple_cut : [[ ls = statement; j = justification_items; - taco = justification_method + taco = justification_method -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] ; elim_type: @@ -82,40 +82,40 @@ GLOBAL: proof_instr; | IDENT "focus" -> B_focus | IDENT "proof" -> B_proof | et=elim_type -> B_elim et ]] - ; + ; elim_obj: [[ IDENT "on"; c=constr -> Real c | IDENT "of"; c=simple_cut -> Virtual c ]] - ; + ; elim_step: - [[ IDENT "consider" ; + [[ IDENT "consider" ; h=consider_vars ; IDENT "from" ; c=constr -> Pconsider (c,h) | IDENT "per"; et=elim_type; obj=elim_obj -> Pper (et,obj) | IDENT "suffices"; ls=suff_clause; j = justification_items; - taco = justification_method - -> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] + taco = justification_method + -> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] ; rew_step : - [[ "~=" ; c=simple_cut -> (Rhs,c) + [[ "~=" ; c=simple_cut -> (Rhs,c) | "=~" ; c=simple_cut -> (Lhs,c)]] ; cut_step: [[ "then"; tt=elim_step -> Pthen tt | "then"; c=simple_cut_or_thesis -> Pthen (Pcut c) - | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) + | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) | IDENT "thus"; c=simple_cut_or_thesis -> Pthus (Pcut c) | IDENT "hence"; c=simple_cut_or_thesis -> Phence (Pcut c) | tt=elim_step -> tt - | tt=rew_step -> let s,c=tt in Prew (s,c); + | tt=rew_step -> let s,c=tt in Prew (s,c); | IDENT "have"; c=simple_cut_or_thesis -> Pcut c; | IDENT "claim"; c=statement -> Pclaim c; - | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c; + | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c; | "end"; bt = block_type -> Pend bt; | IDENT "escape" -> Pescape ]] ; (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*) - loc_id: + loc_id: [[ id=ident -> fun x -> (loc,(id,x)) ]]; hyp: [[ id=loc_id -> id None ; @@ -124,27 +124,27 @@ GLOBAL: proof_instr; consider_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=consider_vars -> (Hvar name) :: v - | name=hyp; + | name=hyp; IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h ]] ; - consider_hyps: + consider_hyps: [[ st=statement; IDENT "and"; h=consider_hyps -> Hprop st::h - | st=statement; IDENT "and"; + | st=statement; IDENT "and"; IDENT "consider" ; v=consider_vars -> Hprop st::v | st=statement -> [Hprop st] ]] - ; + ; assume_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=assume_vars -> (Hvar name) :: v - | name=hyp; + | name=hyp; IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h ]] ; - assume_hyps: + assume_hyps: [[ st=statement; IDENT "and"; h=assume_hyps -> Hprop st::h - | st=statement; IDENT "and"; + | st=statement; IDENT "and"; IDENT "we"; IDENT "have" ; v=assume_vars -> Hprop st::v | st=statement -> [Hprop st] ]] @@ -152,38 +152,38 @@ GLOBAL: proof_instr; assume_clause: [[ IDENT "we" ; IDENT "have" ; v=assume_vars -> v | h=assume_hyps -> h ]] - ; + ; suff_vars: [[ name=hyp; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> [Hvar name],c - | name=hyp; ","; v=suff_vars -> + | name=hyp; ","; v=suff_vars -> let (q,c) = v in ((Hvar name) :: q),c - | name=hyp; - IDENT "such"; IDENT "that"; h=suff_hyps -> + | name=hyp; + IDENT "such"; IDENT "that"; h=suff_hyps -> let (q,c) = h in ((Hvar name) :: q),c ]]; - suff_hyps: - [[ st=statement; IDENT "and"; h=suff_hyps -> + suff_hyps: + [[ st=statement; IDENT "and"; h=suff_hyps -> let (q,c) = h in (Hprop st::q),c - | st=statement; IDENT "and"; - IDENT "to" ; IDENT "have" ; v=suff_vars -> + | st=statement; IDENT "and"; + IDENT "to" ; IDENT "have" ; v=suff_vars -> let (q,c) = v in (Hprop st::q),c - | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> + | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> [Hprop st],c ]] ; suff_clause: [[ IDENT "to" ; IDENT "have" ; v=suff_vars -> v | h=suff_hyps -> h ]] - ; + ; let_vars: [[ name=hyp -> [Hvar name] | name=hyp; ","; v=let_vars -> (Hvar name) :: v - | name=hyp; IDENT "be"; + | name=hyp; IDENT "be"; IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h ]] ; - let_hyps: + let_hyps: [[ st=statement; IDENT "and"; h=let_hyps -> Hprop st::h | st=statement; IDENT "and"; "let"; v=let_vars -> Hprop st::v | st=statement -> [Hprop st] @@ -194,19 +194,19 @@ GLOBAL: proof_instr; | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h ]] ; - given_hyps: + given_hyps: [[ st=statement; IDENT "and"; h=given_hyps -> Hprop st::h | st=statement; IDENT "and"; IDENT "given"; v=given_vars -> Hprop st::v | st=statement -> [Hprop st] ]]; suppose_vars: - [[name=hyp -> [Hvar name] + [[name=hyp -> [Hvar name] |name=hyp; ","; v=suppose_vars -> (Hvar name) :: v - |name=hyp; OPT[IDENT "be"]; + |name=hyp; OPT[IDENT "be"]; IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h ]] ; - suppose_hyps: + suppose_hyps: [[ st=statement_or_thesis; IDENT "and"; h=suppose_hyps -> Hprop st::h | st=statement_or_thesis; IDENT "and"; IDENT "we"; IDENT "have"; v=suppose_vars -> Hprop st::v @@ -220,20 +220,20 @@ GLOBAL: proof_instr; intro_step: [[ IDENT "suppose" ; h=assume_clause -> Psuppose h | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ; - po=OPT[ IDENT "with"; p=LIST1 hyp -> p ] ; - ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> + po=OPT[ IDENT "with"; p=LIST1 hyp -> p ] ; + ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> Pcase (none_is_empty po,c,none_is_empty ho) - | "let" ; v=let_vars -> Plet v + | "let" ; v=let_vars -> Plet v | IDENT "take"; witnesses = LIST1 constr SEP "," -> Ptake witnesses | IDENT "assume"; h=assume_clause -> Passume h | IDENT "given"; h=given_vars -> Pgiven h - | IDENT "define"; id=ident; args=LIST0 hyp; + | IDENT "define"; id=ident; args=LIST0 hyp; "as"; body=constr -> Pdefine(id,args,body) | IDENT "reconsider"; id=ident; "as" ; typ=constr -> Pcast (This id,typ) | IDENT "reconsider"; t=thesis; "as" ; typ=constr -> Pcast (Thesis t ,typ) ]] ; - emphasis : + emphasis : [[ -> 0 | "*" -> 1 | "**" -> 2 @@ -249,4 +249,4 @@ GLOBAL: proof_instr; ; END;; - + diff --git a/parsing/g_ltac.ml4 b/parsing/g_ltac.ml4 index f869dc8e8d..7f63428c83 100644 --- a/parsing/g_ltac.ml4 +++ b/parsing/g_ltac.ml4 @@ -35,7 +35,7 @@ GEXTEND Gram tactic_then_last: [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) - | -> [||] + | -> [||] ] ] ; tactic_then_gen: @@ -54,7 +54,7 @@ GEXTEND Gram [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, [||], ta1, [||]) | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0, [||], ta1, [||]) | ta0 = tactic_expr; ";"; "["; (first,tail) = tactic_then_gen; "]" -> - match tail with + match tail with | Some (t,last) -> TacThen (ta0, Array.of_list first, t, last) | None -> TacThens (ta0,first) ] | "3" RIGHTA @@ -94,7 +94,7 @@ GEXTEND Gram TacArg(MetaIdArg (loc,false,id)) | IDENT "constr"; ":"; c = Constr.constr -> TacArg(ConstrMayEval(ConstrTerm c)) - | IDENT "ipattern"; ":"; ipat = simple_intropattern -> + | IDENT "ipattern"; ":"; ipat = simple_intropattern -> TacArg(IntroPattern ipat) | r = reference; la = LIST0 tactic_arg -> TacArg(TacCall (loc,r,la)) ] @@ -107,7 +107,7 @@ GEXTEND Gram [ RIGHTA [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> TacFun (it,body) - | "let"; isrec = [IDENT "rec" -> true | -> false]; + | "let"; isrec = [IDENT "rec" -> true | -> false]; llc = LIST1 let_clause SEP "with"; "in"; body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] @@ -153,7 +153,7 @@ GEXTEND Gram [ [ "match" -> false | "lazymatch" -> true ] ] ; input_fun: - [ [ "_" -> None + [ [ "_" -> None | l = ident -> Some l ] ] ; let_clause: @@ -172,11 +172,11 @@ GEXTEND Gram | pc = Constr.lconstr_pattern -> Term pc ] ] ; match_hyps: - [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) - | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) - | na = name; ":="; mpv = match_pattern -> + [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) + | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) + | na = name; ":="; mpv = match_pattern -> let t, ty = - match mpv with + match mpv with | Term t -> (match t with | CCast (loc, t, CastConv (_, ty)) -> Term t, Some (Term ty) | _ -> mpv, None) @@ -213,7 +213,7 @@ GEXTEND Gram [ [ ":=" -> false | "::=" -> true ] ] ; - + (* Definitions for tactics *) tacdef_body: [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> @@ -224,7 +224,7 @@ GEXTEND Gram tactic: [ [ tac = tactic_expr -> tac ] ] ; - Vernac_.command: + Vernac_.command: [ [ IDENT "Ltac"; l = LIST1 tacdef_body SEP "with" -> VernacDeclareTacticDefinition (true, l) ] ] diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 168e532a81..8446bf50ca 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -34,7 +34,7 @@ let my_int_of_string loc s = Util.user_err_loc (loc,"",Pp.str "Cannot support a so large number.") GEXTEND Gram - GLOBAL: + GLOBAL: bigint natural integer identref name ident var preident fullyqualid qualid reference dirpath ne_string string pattern_ident pattern_identref by_notation smart_global; @@ -95,7 +95,7 @@ GEXTEND Gram [ [ qid = basequalid -> loc, qid ] ] ; ne_string: - [ [ s = STRING -> + [ [ s = STRING -> if s="" then Util.user_err_loc(loc,"",Pp.str"Empty string."); s ] ] ; diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index d4232eb959..90245fa454 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -53,7 +53,7 @@ GEXTEND Gram | IDENT "Save"; id = identref -> VernacEndProof (Proved (true,Some (id,None))) | IDENT "Defined" -> VernacEndProof (Proved (false,None)) - | IDENT "Defined"; id=identref -> + | IDENT "Defined"; id=identref -> VernacEndProof (Proved (false,Some (id,None))) | IDENT "Suspend" -> VernacSuspend | IDENT "Resume" -> VernacResume None @@ -82,7 +82,7 @@ GEXTEND Gram | IDENT "Show"; IDENT "Thesis" -> VernacShow ShowThesis | IDENT "Explain"; IDENT "Proof"; l = LIST0 integer -> VernacShow (ExplainProof l) - | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer -> + | IDENT "Explain"; IDENT "Proof"; IDENT "Tree"; l = LIST0 integer -> VernacShow (ExplainTree l) | IDENT "Go"; n = natural -> VernacGo (GoTo n) | IDENT "Go"; IDENT "top" -> VernacGo GoTop @@ -90,22 +90,22 @@ GEXTEND Gram | IDENT "Go"; IDENT "next" -> VernacGo GoNext | IDENT "Guarded" -> VernacCheckGuard (* Hints for Auto and EAuto *) - | IDENT "Create"; IDENT "HintDb" ; + | IDENT "Create"; IDENT "HintDb" ; id = IDENT ; b = [ "discriminated" -> true | -> false ] -> VernacCreateHintDb (use_locality (), id, b) - | IDENT "Hint"; local = obsolete_locality; h = hint; + | IDENT "Hint"; local = obsolete_locality; h = hint; dbnames = opt_hintbases -> VernacHints (enforce_locality_of local,dbnames, h) -(* Declare "Resolve" directly so as to be able to later extend with +(* Declare "Resolve" directly so as to be able to later extend with "Resolve ->" and "Resolve <-" *) - | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 constr; n = OPT natural; + | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 constr; n = OPT natural; dbnames = opt_hintbases -> VernacHints (enforce_locality_of false,dbnames, HintsResolve (List.map (fun x -> (n, true, x)) lc)) (*This entry is not commented, only for debug*) - | IDENT "PrintConstr"; c = constr -> + | IDENT "PrintConstr"; c = constr -> VernacExtend ("PrintConstr", [Genarg.in_gen Genarg.rawwit_constr c]) ] ]; @@ -114,7 +114,7 @@ GEXTEND Gram [ [ IDENT "Local" -> true | -> false ] ] ; hint: - [ [ IDENT "Resolve"; lc = LIST1 constr; n = OPT natural -> + [ [ IDENT "Resolve"; lc = LIST1 constr; n = OPT natural -> HintsResolve (List.map (fun x -> (n, true, x)) lc) | IDENT "Immediate"; lc = LIST1 constr -> HintsImmediate lc | IDENT "Transparent"; lc = LIST1 global -> HintsTransparency (lc, true) @@ -124,7 +124,7 @@ GEXTEND Gram | IDENT "Extern"; n = natural; c = OPT constr_pattern ; "=>"; tac = tactic -> HintsExtern (n,c,tac) - | IDENT "Destruct"; + | IDENT "Destruct"; id = ident; ":="; pri = natural; dloc = destruct_location; diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 846246ed06..c61bff02d7 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -149,7 +149,7 @@ let induction_arg_of_constr (c,lbind as clbind) = let rec mkCLambdaN_simple_loc loc bll c = match bll with - | ((loc1,_)::_ as idl,bk,t) :: bll -> + | ((loc1,_)::_ as idl,bk,t) :: bll -> CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (join_loc loc1 loc) bll c) | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c | [] -> c @@ -170,7 +170,7 @@ let map_int_or_var f = function GEXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis - bindings red_expr int_or_var open_constr casted_open_constr + bindings red_expr int_or_var open_constr casted_open_constr simple_intropattern; int_or_var: @@ -183,7 +183,7 @@ GEXTEND Gram ; (* An identifier or a quotation meta-variable *) id_or_meta: - [ [ id = identref -> AI id + [ [ id = identref -> AI id (* This is used in quotations *) | id = METAIDENT -> MetaId (loc,id) ] ] @@ -220,7 +220,7 @@ GEXTEND Gram | "-"; n = nat_or_var; nl = LIST0 int_or_var -> (* have used int_or_var instead of nat_or_var for compatibility *) all_occurrences_expr_but (List.map (map_int_or_var abs) (n::nl)) ] ] - ; + ; occs: [ [ "at"; occs = occs_nums -> occs | -> all_occurrences_expr_but [] ] ] ; @@ -237,13 +237,13 @@ GEXTEND Gram [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> loc,IntroOrAndPattern tc | "()" -> loc,IntroOrAndPattern [[]] | "("; si = simple_intropattern; ")" -> loc,IntroOrAndPattern [[si]] - | "("; si = simple_intropattern; ","; - tc = LIST1 simple_intropattern SEP "," ; ")" -> + | "("; si = simple_intropattern; ","; + tc = LIST1 simple_intropattern SEP "," ; ")" -> loc,IntroOrAndPattern [si::tc] - | "("; si = simple_intropattern; "&"; - tc = LIST1 simple_intropattern SEP "&" ; ")" -> + | "("; si = simple_intropattern; "&"; + tc = LIST1 simple_intropattern SEP "&" ; ")" -> (* (A & B & C) is translated into (A,(B,C)) *) - let rec pairify = function + let rec pairify = function | ([]|[_]|[_;_]) as l -> IntroOrAndPattern [l] | t::q -> IntroOrAndPattern [[t;(loc_of_ne_list q,pairify q)]] in loc,pairify (si::tc) ] ] @@ -256,7 +256,7 @@ GEXTEND Gram | "**" -> loc, IntroForthcoming false ] ] ; intropattern_modifier: - [ [ IDENT "_eqn"; + [ [ IDENT "_eqn"; id = [ ":"; id = naming_intropattern -> id | -> loc, IntroAnonymous ] -> id ] ] ; @@ -375,14 +375,14 @@ GEXTEND Gram [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) | -> None ] ] ; - orient: - [ [ "->" -> true + orient: + [ [ "->" -> true | "<-" -> false | -> true ]] ; simple_binder: [ [ na=name -> ([na],Default Explicit,CHole (loc, None)) - | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) + | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) ] ] ; fixdecl: @@ -398,7 +398,7 @@ GEXTEND Gram (loc,id,bl,None,ty) ] ] ; bindings_with_parameters: - [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; + [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] ; hintbases: @@ -437,10 +437,10 @@ GEXTEND Gram [ [ IDENT "by"; tac = tactic_expr LEVEL "3" -> Some tac | -> None ] ] ; - rename : + rename : [ [ id1 = id_or_meta; IDENT "into"; id2 = id_or_meta -> (id1,id2) ] ] ; - rewriter : + rewriter : [ [ "!"; c = constr_with_bindings -> (RepeatPlus,c) | ["?"| LEFTQMARK]; c = constr_with_bindings -> (RepeatStar,c) | n = natural; "!"; c = constr_with_bindings -> (Precisely n,c) @@ -449,11 +449,11 @@ GEXTEND Gram | c = constr_with_bindings -> (Precisely 1, c) ] ] ; - oriented_rewriter : + oriented_rewriter : [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ] - ; + ; induction_clause: - [ [ lc = LIST1 induction_arg; ipats = with_induction_names; + [ [ lc = LIST1 induction_arg; ipats = with_induction_names; el = OPT eliminator; cl = opt_clause -> (lc,el,ipats,cl) ] ] ; move_location: @@ -463,9 +463,9 @@ GEXTEND Gram | "at"; IDENT "top" -> MoveToEnd false ] ] ; simple_tactic: - [ [ + [ [ (* Basic tactics *) - IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> + IDENT "intros"; IDENT "until"; id = quantified_hypothesis -> TacIntrosUntil id | IDENT "intros"; pl = intropatterns -> TacIntroPattern pl | IDENT "intro"; id = ident; hto = move_location -> @@ -479,7 +479,7 @@ GEXTEND Gram | IDENT "exact_no_check"; c = constr -> TacExactNoCheck c | IDENT "vm_cast_no_check"; c = constr -> TacVmCastNoCheck c - | IDENT "apply"; cl = LIST1 constr_with_bindings SEP ","; + | IDENT "apply"; cl = LIST1 constr_with_bindings SEP ","; inhyp = in_hyp_as -> TacApply (true,false,cl,inhyp) | IDENT "eapply"; cl = LIST1 constr_with_bindings SEP ","; inhyp = in_hyp_as -> TacApply (true,true,cl,inhyp) @@ -516,11 +516,11 @@ GEXTEND Gram TacLetTac (na,c,p,false) (* Begin compatibility *) - | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; - c = lconstr; ")" -> + | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; + c = lconstr; ")" -> TacAssert (None,Some (loc,IntroIdentifier id),c) - | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; - c = lconstr; ")"; tac=by_tactic -> + | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> TacAssert (Some tac,Some (loc,IntroIdentifier id),c) (* End compatibility *) @@ -535,8 +535,8 @@ GEXTEND Gram | IDENT "generalize"; c = constr; l = LIST1 constr -> let gen_everywhere c = ((all_occurrences_expr,c),Names.Anonymous) in TacGeneralize (List.map gen_everywhere (c::l)) - | IDENT "generalize"; c = constr; lookup_at_as_coma; nl = occs; - na = as_name; + | IDENT "generalize"; c = constr; lookup_at_as_coma; nl = occs; + na = as_name; l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> TacGeneralize (((nl,c),na)::l) | IDENT "generalize"; IDENT "dependent"; c = constr -> TacGeneralizeDep c @@ -616,30 +616,30 @@ GEXTEND Gram | IDENT "etransitivity" -> TacTransitivity None (* Equality and inversion *) - | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; + | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; cl = clause_dft_concl; t=opt_by_tactic -> TacRewrite (false,l,cl,t) - | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; + | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; cl = clause_dft_concl; t=opt_by_tactic -> TacRewrite (true,l,cl,t) | IDENT "dependent"; k = [ IDENT "simple"; IDENT "inversion" -> SimpleInversion | IDENT "inversion" -> FullInversion | IDENT "inversion_clear" -> FullInversionClear ]; - hyp = quantified_hypothesis; + hyp = quantified_hypothesis; ids = with_inversion_names; co = OPT ["with"; c = constr -> c] -> TacInversion (DepInversion (k,co,ids),hyp) | IDENT "simple"; IDENT "inversion"; hyp = quantified_hypothesis; ids = with_inversion_names; cl = in_hyp_list -> TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp) - | IDENT "inversion"; + | IDENT "inversion"; hyp = quantified_hypothesis; ids = with_inversion_names; cl = in_hyp_list -> TacInversion (NonDepInversion (FullInversion, cl, ids), hyp) - | IDENT "inversion_clear"; - hyp = quantified_hypothesis; ids = with_inversion_names; + | IDENT "inversion_clear"; + hyp = quantified_hypothesis; ids = with_inversion_names; cl = in_hyp_list -> TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp) - | IDENT "inversion"; hyp = quantified_hypothesis; + | IDENT "inversion"; hyp = quantified_hypothesis; "using"; c = constr; cl = in_hyp_list -> TacInversion (InversionUsing (c,cl), hyp) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 0ebbaba924..4cd798e3e1 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -58,28 +58,28 @@ let get_command_entry () = | Mode_none -> noedit_mode let default_command_entry = - Gram.Entry.of_parser "command_entry" + Gram.Entry.of_parser "command_entry" (fun strm -> Gram.Entry.parse_token (get_command_entry ()) strm) let no_hook _ _ = () GEXTEND Gram GLOBAL: vernac gallina_ext tactic_mode proof_mode noedit_mode; vernac: FIRST - [ [ IDENT "Time"; v = vernac -> VernacTime v + [ [ IDENT "Time"; v = vernac -> VernacTime v | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) | locality; v = vernac_aux -> v ] ] ; vernac_aux: (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *) (* "." is still in the stream and discard_to_dot works correctly *) - [ [ g = gallina; "." -> g + [ [ g = gallina; "." -> g | g = gallina_ext; "." -> g - | c = command; "." -> c + | c = command; "." -> c | c = syntax; "." -> c | "["; l = LIST1 located_vernac; "]"; "." -> VernacList l ] ] ; - vernac_aux: LAST + vernac_aux: LAST [ [ prfcom = default_command_entry -> prfcom ] ] ; locality: @@ -103,11 +103,11 @@ GEXTEND Gram VernacSolve(g,tac,use_dft_tac)) ] ] ; proof_mode: - [ [ instr = proof_instr; "." -> VernacProofInstr instr ] ] + [ [ instr = proof_instr; "." -> VernacProofInstr instr ] ] ; proof_mode: LAST [ [ c=subgoal_command -> c (Some 1) ] ] - ; + ; located_vernac: [ [ v = vernac -> loc, v ] ] ; @@ -127,20 +127,20 @@ GEXTEND Gram gallina: (* Definition, Theorem, Variable, Axiom, ... *) [ [ thm = thm_token; id = identref; bl = binders_let; ":"; c = lconstr; - l = LIST0 + l = LIST0 [ "with"; id = identref; bl = binders_let; ":"; c = lconstr -> (Some id,(bl,c)) ] -> VernacStartTheoremProof (thm,(Some id,(bl,c))::l, false, no_hook) - | stre = assumption_token; nl = inline; bl = assum_list -> + | stre = assumption_token; nl = inline; bl = assum_list -> VernacAssumption (stre, nl, bl) | stre = assumptions_token; nl = inline; bl = assum_list -> test_plurial_form bl; VernacAssumption (stre, nl, bl) - | IDENT "Boxed";"Definition";id = identref; b = def_body -> + | IDENT "Boxed";"Definition";id = identref; b = def_body -> VernacDefinition ((Global,true,Definition), id, b, no_hook) - | IDENT "Unboxed";"Definition";id = identref; b = def_body -> + | IDENT "Unboxed";"Definition";id = identref; b = def_body -> VernacDefinition ((Global,false,Definition), id, b, no_hook) - | (f,d) = def_token; id = identref; b = def_body -> + | (f,d) = def_token; id = identref; b = def_body -> VernacDefinition (d, id, b, f) (* Gallina inductive declarations *) | f = finite_token; @@ -157,12 +157,12 @@ GEXTEND Gram | "CoFixpoint"; corecs = LIST1 corec_definition SEP "with" -> VernacCoFixpoint (corecs,false) | IDENT "Scheme"; l = LIST1 scheme SEP "with" -> VernacScheme l - | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; + | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; l = LIST1 identref SEP "," -> VernacCombinedScheme (id, l) ] ] ; gallina_ext: [ [ b = record_token; infer = infer_token; oc = opt_coercion; name = identref; - ps = binders_let; + ps = binders_let; s = OPT [ ":"; s = lconstr -> s ]; cfs = [ ":="; l = constructor_list_or_record_decl -> l | -> RecordDecl (None, []) ] -> @@ -171,7 +171,7 @@ GEXTEND Gram ] ] ; typeclass_context: - [ [ "["; l=LIST1 typeclass_constraint SEP ","; "]" -> l + [ [ "["; l=LIST1 typeclass_constraint SEP ","; "]" -> l | -> [] ] ] ; thm_token: @@ -184,14 +184,14 @@ GEXTEND Gram | IDENT "Property" -> Property ] ] ; def_token: - [ [ "Definition" -> + [ [ "Definition" -> no_hook, (Global, Flags.boxed_definitions(), Definition) - | IDENT "Let" -> + | IDENT "Let" -> no_hook, (Local, Flags.boxed_definitions(), Definition) - | IDENT "Example" -> + | IDENT "Example" -> no_hook, (Global, Flags.boxed_definitions(), Example) | IDENT "SubClass" -> - Class.add_subclass_hook, (use_locality_exp (), false, SubClass) ] ] + Class.add_subclass_hook, (use_locality_exp (), false, SubClass) ] ] ; assumption_token: [ [ "Hypothesis" -> (Local, Logical) @@ -218,7 +218,7 @@ GEXTEND Gram ; record_token: [ [ IDENT "Record" -> (Record,BiFinite) - | IDENT "Structure" -> (Structure,BiFinite) + | IDENT "Structure" -> (Structure,BiFinite) | IDENT "Class" -> (Class true,BiFinite) ] ] ; (* Simple definitions *) @@ -237,24 +237,24 @@ GEXTEND Gram | -> None ] ] ; decl_notation: - [ [ OPT [ "where"; ntn = ne_string; ":="; c = constr; + [ [ OPT [ "where"; ntn = ne_string; ":="; c = constr; scopt = OPT [ ":"; sc = IDENT -> sc] -> (ntn,c,scopt) ] ] ] ; (* Inductives and records *) inductive_definition: - [ [ id = identref; oc = opt_coercion; indpar = binders_let; + [ [ id = identref; oc = opt_coercion; indpar = binders_let; c = OPT [ ":"; c = lconstr -> c ]; ":="; lc = constructor_list_or_record_decl; ntn = decl_notation -> (((oc,id),indpar,c,lc),ntn) ] ] ; constructor_list_or_record_decl: [ [ "|"; l = LIST1 constructor SEP "|" -> Constructors l - | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" -> + | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" -> Constructors ((c id)::l) | id = identref ; c = constructor_type -> Constructors [ c id ] - | cstr = identref; "{"; fs = LIST0 record_field SEP ";"; "}" -> - RecordDecl (Some cstr,fs) - | "{";fs = LIST0 record_field SEP ";"; "}" -> RecordDecl (None,fs) + | cstr = identref; "{"; fs = LIST0 record_field SEP ";"; "}" -> + RecordDecl (Some cstr,fs) + | "{";fs = LIST0 record_field SEP ";"; "}" -> RecordDecl (None,fs) | -> Constructors [] ] ] ; (* @@ -268,9 +268,9 @@ GEXTEND Gram ; (* (co)-fixpoints *) rec_definition: - [ [ id = identref; + [ [ id = identref; bl = binders_let_fixannot; - ty = type_cstr; + ty = type_cstr; ":="; def = lconstr; ntn = decl_notation -> let bl, annot = bl in let names = names_of_local_assums bl in @@ -282,13 +282,13 @@ GEXTEND Gram else Util.user_err_loc (loc,"Fixpoint", str "No argument named " ++ Nameops.pr_id id ++ str".")) - | None -> - (* If there is only one argument, it is the recursive one, + | None -> + (* If there is only one argument, it is the recursive one, otherwise, we search the recursive index later *) match names with | [(loc, Name na)] -> Some (loc, na) - | _ -> None - in + | _ -> None + in ((id,(ni,snd annot),bl,ty,def),ntn) ] ] ; corec_definition: @@ -297,7 +297,7 @@ GEXTEND Gram ((id,bl,ty,def),ntn) ] ] ; type_cstr: - [ [ ":"; c=lconstr -> c + [ [ ":"; c=lconstr -> c | -> CHole (loc, None) ] ] ; (* Inductive schemes *) @@ -329,7 +329,7 @@ GEXTEND Gram [ [ bd = record_binder; ntn = decl_notation -> bd,ntn ] ] ; record_binder_body: - [ [ l = binders_let; oc = of_type_with_opt_coercion; + [ [ l = binders_let; oc = of_type_with_opt_coercion; t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN loc l t)) | l = binders_let; oc = of_type_with_opt_coercion; t = lconstr; ":="; b = lconstr -> fun id -> @@ -352,12 +352,12 @@ GEXTEND Gram [ [ "("; a = simple_assum_coe; ")" -> a ] ] ; simple_assum_coe: - [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> + [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> (oc,(idl,c)) ] ] ; constructor_type: - [[ l = binders_let; + [[ l = binders_let; t= [ coe = of_type_with_opt_coercion; c = lconstr -> fun l id -> (coe,(id,mkCProdN loc l c)) | -> @@ -383,16 +383,16 @@ GEXTEND Gram gallina_ext: [ [ (* Interactive module declaration *) - IDENT "Module"; export = export_token; id = identref; - bl = LIST0 module_binder; mty_o = OPT of_module_type; + IDENT "Module"; export = export_token; id = identref; + bl = LIST0 module_binder; mty_o = OPT of_module_type; mexpr_o = OPT is_module_expr -> VernacDefineModule (export, id, bl, mty_o, mexpr_o) - - | IDENT "Module"; "Type"; id = identref; + + | IDENT "Module"; "Type"; id = identref; bl = LIST0 module_binder; mty_o = OPT is_module_type -> VernacDeclareModuleType (id, bl, mty_o) - - | IDENT "Declare"; IDENT "Module"; export = export_token; id = identref; + + | IDENT "Declare"; IDENT "Module"; export = export_token; id = identref; bl = LIST0 module_binder; ":"; mty = module_type -> VernacDeclareModule (export, id, bl, (mty,true)) (* Section beginning *) @@ -405,10 +405,10 @@ GEXTEND Gram (* Requiring an already compiled module *) | IDENT "Require"; export = export_token; qidl = LIST1 global -> VernacRequire (export, None, qidl) - | IDENT "Require"; export = export_token; filename = ne_string -> + | IDENT "Require"; export = export_token; filename = ne_string -> VernacRequireFrom (export, None, filename) | IDENT "Import"; qidl = LIST1 global -> VernacImport (false,qidl) - | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) + | IDENT "Export"; qidl = LIST1 global -> VernacImport (true,qidl) | IDENT "Include"; expr = module_expr -> VernacInclude(CIME(expr)) | IDENT "Include"; "Type"; expr = module_type -> VernacInclude(CIMTE(expr)) ] ] ; @@ -418,7 +418,7 @@ GEXTEND Gram | -> None ] ] ; of_module_type: - [ [ ":"; mty = module_type -> (mty, true) + [ [ ":"; mty = module_type -> (mty, true) | "<:"; mty = module_type -> (mty, false) ] ] ; is_module_type: @@ -453,13 +453,13 @@ GEXTEND Gram module_type: [ [ qid = qualid -> CMTEident qid (* ... *) - | mty = module_type; me = module_expr_atom -> CMTEapply (mty,me) + | mty = module_type; me = module_expr_atom -> CMTEapply (mty,me) | mty = module_type; "with"; decl = with_declaration -> CMTEwith (mty,decl) ] ] ; END -(* Extensions: implicits, coercions, etc. *) +(* Extensions: implicits, coercions, etc. *) GEXTEND Gram GLOBAL: gallina_ext; @@ -480,7 +480,7 @@ GEXTEND Gram | IDENT "Canonical"; IDENT "Structure"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition + VernacDefinition ((Global,false,CanonicalStructure),(dummy_loc,s),d, (fun _ -> Recordops.declare_canonical_structure)) @@ -492,16 +492,16 @@ GEXTEND Gram let s = coerce_reference_to_id qid in VernacDefinition ((enforce_locality_exp (),false,Coercion),(dummy_loc,s),d,Class.add_coercion_hook) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; - ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> + ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (enforce_locality_exp (), f, s, t) | IDENT "Identity"; IDENT "Coercion"; f = identref; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> + s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (use_locality_exp (), f, s, t) | IDENT "Coercion"; IDENT "Local"; qid = global; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> + s = class_rawexpr; ">->"; t = class_rawexpr -> VernacCoercion (enforce_locality_exp (), AN qid, s, t) | IDENT "Coercion"; IDENT "Local"; ntn = by_notation; ":"; - s = class_rawexpr; ">->"; t = class_rawexpr -> + s = class_rawexpr; ">->"; t = class_rawexpr -> VernacCoercion (enforce_locality_exp (), ByNotation ntn, s, t) | IDENT "Coercion"; qid = global; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> @@ -509,29 +509,29 @@ GEXTEND Gram | IDENT "Coercion"; ntn = by_notation; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacCoercion (use_locality_exp (), ByNotation ntn, s, t) - - | IDENT "Context"; c = binders_let -> + + | IDENT "Context"; c = binders_let -> VernacContext c - + | IDENT "Instance"; ":"; expl = [ "!" -> Rawterm.Implicit | -> Rawterm.Explicit ] ; t = operconstr LEVEL "200"; - pri = OPT [ "|"; i = natural -> i ] ; - props = [ ":="; "{"; r = record_declaration; "}" -> r | + pri = OPT [ "|"; i = natural -> i ] ; + props = [ ":="; "{"; r = record_declaration; "}" -> r | ":="; c = lconstr -> c | -> CRecord (loc, None, []) ] -> VernacInstance (not (use_non_locality ()), [], ((loc,Anonymous), expl, t), props, pri) | IDENT "Instance"; name = identref; sup = OPT binders_let; ":"; expl = [ "!" -> Rawterm.Implicit | -> Rawterm.Explicit ] ; t = operconstr LEVEL "200"; - pri = OPT [ "|"; i = natural -> i ] ; - props = [ ":="; "{"; r = record_declaration; "}" -> r | + pri = OPT [ "|"; i = natural -> i ] ; + props = [ ":="; "{"; r = record_declaration; "}" -> r | ":="; c = lconstr -> c | -> CRecord (loc, None, []) ] -> let sup = match sup with None -> [] | Some l -> l in - let n = - let (loc, id) = name in + let n = + let (loc, id) = name in (loc, Name id) in VernacInstance (not (use_non_locality ()), sup, (n, expl, t), props, pri) @@ -539,8 +539,8 @@ GEXTEND Gram | IDENT "Existing"; IDENT "Instance"; is = identref -> VernacDeclareInstance is (* Implicit *) - | IDENT "Implicit"; IDENT "Arguments"; qid = smart_global; - pos = OPT [ "["; l = LIST0 implicit_name; "]" -> + | IDENT "Implicit"; IDENT "Arguments"; qid = smart_global; + pos = OPT [ "["; l = LIST0 implicit_name; "]" -> List.map (fun (id,b,f) -> (ExplByName id,b,f)) l ] -> VernacDeclareImplicits (use_section_locality (),qid,pos) @@ -550,7 +550,7 @@ GEXTEND Gram implicit_name: [ [ "!"; id = ident -> (id, false, true) | id = ident -> (id,false,false) - | "["; "!"; id = ident; "]" -> (id,true,true) + | "["; "!"; id = ident; "]" -> (id,true,true) | "["; id = ident; "]" -> (id,true, false) ] ] ; strategy_level: @@ -592,7 +592,7 @@ GEXTEND Gram (* Managing load paths *) | IDENT "Add"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath -> VernacAddLoadPath (false, dir, alias) - | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; + | IDENT "Add"; IDENT "Rec"; IDENT "LoadPath"; dir = ne_string; alias = as_dirpath -> VernacAddLoadPath (true, dir, alias) | IDENT "Remove"; IDENT "LoadPath"; dir = ne_string -> VernacRemoveLoadPath dir @@ -611,23 +611,23 @@ GEXTEND Gram (* Printing (careful factorization of entries) *) | IDENT "Print"; p = printable -> VernacPrint p | IDENT "Print"; qid = smart_global -> VernacPrint (PrintName qid) - | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> + | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> VernacPrint (PrintModuleType qid) - | IDENT "Print"; IDENT "Module"; qid = global -> + | IDENT "Print"; IDENT "Module"; qid = global -> VernacPrint (PrintModule qid) | IDENT "Inspect"; n = natural -> VernacPrint (PrintInspect n) | IDENT "About"; qid = smart_global -> VernacPrint (PrintAbout qid) (* Searching the environment *) - | IDENT "Search"; c = constr_pattern; l = in_or_out_modules -> + | IDENT "Search"; c = constr_pattern; l = in_or_out_modules -> VernacSearch (SearchHead c, l) | IDENT "SearchPattern"; c = constr_pattern; l = in_or_out_modules -> VernacSearch (SearchPattern c, l) | IDENT "SearchRewrite"; c = constr_pattern; l = in_or_out_modules -> VernacSearch (SearchRewrite c, l) - | IDENT "SearchAbout"; + | IDENT "SearchAbout"; sl = [ "["; - l = LIST1 [ + l = LIST1 [ b = positive_search_mark; s = ne_string; sc = OPT scope -> b, SearchString (s,sc) | b = positive_search_mark; p = constr_pattern @@ -635,7 +635,7 @@ GEXTEND Gram ]; "]" -> l | p = constr_pattern -> [true,SearchSubPattern p] | s = ne_string; sc = OPT scope -> [true,SearchString (s,sc)] ]; - l = in_or_out_modules -> + l = in_or_out_modules -> VernacSearch (SearchAbout sl, l) | IDENT "Add"; IDENT "ML"; IDENT "Path"; dir = ne_string -> @@ -671,7 +671,7 @@ GEXTEND Gram | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value -> VernacRemoveOption ([table;field], v) | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> - VernacRemoveOption ([table], v) + VernacRemoveOption ([table], v) | IDENT "proof" -> VernacDeclProof | "return" -> VernacReturn ]] @@ -690,7 +690,7 @@ GEXTEND Gram (* This should be in "syntax" section but is here for factorization*) PrintGrammar ent | IDENT "LoadPath"; dir = OPT dirpath -> PrintLoadPath dir - | IDENT "Modules" -> + | IDENT "Modules" -> error "Print Modules is obsolete; use Print Libraries instead" | IDENT "Libraries" -> PrintModules @@ -764,7 +764,7 @@ END; GEXTEND Gram command: - [ [ + [ [ (* State management *) IDENT "Write"; IDENT "State"; s = IDENT -> VernacWriteState s | IDENT "Write"; IDENT "State"; s = ne_string -> VernacWriteState s @@ -778,11 +778,11 @@ GEXTEND Gram | IDENT "Back" -> VernacBack 1 | IDENT "Back"; n = natural -> VernacBack n | IDENT "BackTo"; n = natural -> VernacBackTo n - | IDENT "Backtrack"; n = natural ; m = natural ; p = natural -> + | IDENT "Backtrack"; n = natural ; m = natural ; p = natural -> VernacBacktrack (n,m,p) (* Tactic Debugger *) - | IDENT "Debug"; IDENT "On" -> + | IDENT "Debug"; IDENT "On" -> VernacSetOption (None,["Ltac";"Debug"], BoolValue true) | IDENT "Debug"; IDENT "Off" -> @@ -798,38 +798,38 @@ GEXTEND Gram GLOBAL: syntax; syntax: - [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> + [ [ IDENT "Open"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> VernacOpenCloseScope (enforce_locality_of local,true,sc) - | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> + | IDENT "Close"; local = obsolete_locality; IDENT "Scope"; sc = IDENT -> VernacOpenCloseScope (enforce_locality_of local,false,sc) | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> VernacDelimiters (sc,key) - | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; + | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; refl = LIST1 class_rawexpr -> VernacBindScope (sc,refl) | IDENT "Arguments"; IDENT "Scope"; qid = smart_global; - "["; scl = LIST0 opt_scope; "]" -> + "["; scl = LIST0 opt_scope; "]" -> VernacArgumentsScope (use_non_locality (),qid,scl) | IDENT "Infix"; local = obsolete_locality; - op = ne_string; ":="; p = constr; + op = ne_string; ":="; p = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> VernacInfix (enforce_locality_of local,(op,modl),p,sc) - | IDENT "Notation"; local = obsolete_locality; id = identref; + | IDENT "Notation"; local = obsolete_locality; id = identref; idl = LIST0 ident; ":="; c = constr; b = [ "("; IDENT "only"; IDENT "parsing"; ")" -> true | -> false ] -> VernacSyntacticDefinition (id,(idl,c),enforce_locality_of local,b) - | IDENT "Notation"; local = obsolete_locality; s = ne_string; ":="; + | IDENT "Notation"; local = obsolete_locality; s = ne_string; ":="; c = constr; modl = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ]; sc = OPT [ ":"; sc = IDENT -> sc ] -> VernacNotation (enforce_locality_of local,c,(s,modl),sc) - | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; + | IDENT "Tactic"; IDENT "Notation"; n = tactic_level; pil = LIST1 production_item; ":="; t = Tactic.tactic -> VernacTacticNotation (n,pil,t) @@ -838,12 +838,12 @@ GEXTEND Gram Metasyntax.check_infix_modifiers l; VernacSyntaxExtension (use_locality (),("x '"^s^"' y",l)) - | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; - s = ne_string; + | IDENT "Reserved"; IDENT "Notation"; local = obsolete_locality; + s = ne_string; l = [ "("; l = LIST1 syntax_modifier SEP ","; ")" -> l | -> [] ] -> VernacSyntaxExtension (enforce_locality_of local,(s,l)) - (* "Print" "Grammar" should be here but is in "command" entry in order + (* "Print" "Grammar" should be here but is in "command" entry in order to factorize with other "Print"-based vernac entries *) ] ] ; @@ -859,7 +859,7 @@ GEXTEND Gram ; syntax_modifier: [ [ x = IDENT; "at"; lev = level -> SetItemLevel ([x],lev) - | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at"; + | x = IDENT; ","; l = LIST1 IDENT SEP ","; "at"; lev = level -> SetItemLevel (x::l,lev) | "at"; IDENT "level"; n = natural -> SetLevel n | IDENT "left"; IDENT "associativity" -> SetAssoc Gramext.LeftA @@ -871,7 +871,7 @@ GEXTEND Gram ; syntax_extension_type: [ [ IDENT "ident" -> ETName | IDENT "global" -> ETReference - | IDENT "bigint" -> ETBigint + | IDENT "bigint" -> ETBigint ] ] ; opt_scope: @@ -879,8 +879,8 @@ GEXTEND Gram ; production_item: [ [ s = ne_string -> TacTerm s - | nt = IDENT; - po = OPT [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; + | nt = IDENT; + po = OPT [ "("; p = ident; sep = [ -> "" | ","; sep = STRING -> sep ]; ")" -> (p,sep) ] -> TacNonTerm (loc,nt,po) ] ] ; END diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 index 8142368358..0f70290419 100644 --- a/parsing/g_xml.ml4 +++ b/parsing/g_xml.ml4 @@ -30,7 +30,7 @@ type xml = XmlTag of loc * string * attribute list * xml list let check_tags loc otag ctag = if otag <> ctag then - user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++ + user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++ str "does not match open xml tag " ++ str otag ++ str ".") let xml_eoi = (Gram.Entry.create "xml_eoi" : xml Gram.Entry.e) @@ -72,7 +72,7 @@ let nmtoken (loc,a) = try int_of_string a with Failure _ -> user_err_loc (loc,"",str "nmtoken expected.") -let get_xml_attr s al = +let get_xml_attr s al = try List.assoc s al with Not_found -> error ("No attribute "^s) @@ -143,7 +143,7 @@ let compute_inductive_nargs ind = let rec interp_xml_constr = function | XmlTag (loc,"REL",al,[]) -> RVar (loc, get_xml_ident al) - | XmlTag (loc,"VAR",al,[]) -> + | XmlTag (loc,"VAR",al,[]) -> error "XML parser: unable to interp free variables" | XmlTag (loc,"LAMBDA",al,(_::_ as xl)) -> let body,decls = list_sep_last xl in @@ -200,7 +200,7 @@ let rec interp_xml_constr = function and interp_xml_tag s = function | XmlTag (loc,tag,al,xl) when tag=s -> (loc,al,xl) - | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "", + | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "", str "Expect tag " ++ str s ++ str " but find " ++ str s ++ str ".") and interp_xml_constr_alias s x = @@ -231,14 +231,14 @@ and interp_xml_recursionOrder x = let (loc, al, l) = interp_xml_tag "RecursionOrder" x in let (locs, s) = get_xml_attr "type" al in match s with - "Structural" -> + "Structural" -> (match l with [] -> RStructRec | _ -> error_expect_no_argument loc) - | "WellFounded" -> + | "WellFounded" -> (match l with [c] -> RWfRec (interp_xml_type c) | _ -> error_expect_one_argument loc) - | "Measure" -> + | "Measure" -> (match l with [m;r] -> RMeasureRec (interp_xml_type m, Some (interp_xml_type r)) | _ -> error_expect_two_arguments loc) @@ -261,7 +261,7 @@ and interp_xml_CoFixFunction x = match interp_xml_tag "CoFixFunction" x with | (loc,al,[x1;x2]) -> (get_xml_name al, interp_xml_type x1, interp_xml_body x2) - | (loc,_,_) -> + | (loc,_,_) -> error_expect_one_argument loc (* Interpreting tactic argument *) diff --git a/parsing/grammar.mllib b/parsing/grammar.mllib index 4356db844e..0c815d2623 100644 --- a/parsing/grammar.mllib +++ b/parsing/grammar.mllib @@ -1,7 +1,7 @@ Coq_config Profile -Pp_control +Pp_control Pp Compat Flags @@ -49,7 +49,7 @@ Nametab Libobject Lib Goptions -Decl_kinds +Decl_kinds Global Termops Evd @@ -68,7 +68,7 @@ Vernacexpr Extrawit Pcoq Q_util -Q_coqast +Q_coqast Egrammar Argextend diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 4b40102eed..4edfbc748d 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4use: "pr_o.cmo pa_macro.cmo" i*) +(*i camlp4use: "pr_o.cmo pa_macro.cmo" i*) (* Add pr_o.cmo to circumvent a useless-warning bug when preprocessed with * ast-based camlp4 *) @@ -21,7 +21,7 @@ open Token module CharMap = Map.Make (struct type t = char let compare = compare end) -type ttree = { +type ttree = { node : string option; branch : ttree CharMap.t } @@ -29,7 +29,7 @@ let empty_ttree = { node = None; branch = CharMap.empty } let ttree_add ttree str = let rec insert tt i = - if i == String.length str then + if i == String.length str then {node = Some str; branch = tt.branch} else let c = str.[i] in @@ -42,7 +42,7 @@ let ttree_add ttree str = CharMap.add c (insert tt' (i + 1)) tt.branch in { node = tt.node; branch = br } - in + in insert ttree 0 (* Search a string in a dictionary: raises [Not_found] @@ -52,14 +52,14 @@ let ttree_find ttree str = let rec proc_rec tt i = if i == String.length str then tt else proc_rec (CharMap.find str.[i] tt.branch) (i+1) - in + in proc_rec ttree 0 (* Removes a string from a dictionary: returns an equal dictionary if the word not present. *) let ttree_remove ttree str = let rec remove tt i = - if i == String.length str then + if i == String.length str then {node = None; branch = tt.branch} else let c = str.[i] in @@ -70,7 +70,7 @@ let ttree_remove ttree str = | None -> tt.branch in { node = tt.node; branch = br } - in + in remove ttree 0 @@ -114,7 +114,7 @@ let check_utf8_trailing_byte cs c = (* but don't certify full utf8 compliance (e.g. no emptyness check) *) let lookup_utf8_tail c cs = let c1 = Char.code c in - if c1 land 0x40 = 0 or c1 land 0x38 = 0x38 then error_utf8 cs + if c1 land 0x40 = 0 or c1 land 0x38 = 0x38 then error_utf8 cs else let n, unicode = if c1 land 0x20 = 0 then @@ -127,20 +127,20 @@ let lookup_utf8_tail c cs = match Stream.npeek 3 cs with | [_;c2;c3] -> check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3; - 3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 + + 3, (c1 land 0x0F) lsl 12 + (Char.code c2 land 0x3F) lsl 6 + (Char.code c3 land 0x3F) | _ -> error_utf8 cs else match Stream.npeek 4 cs with | [_;c2;c3;c4] -> check_utf8_trailing_byte cs c2; check_utf8_trailing_byte cs c3; - check_utf8_trailing_byte cs c4; + check_utf8_trailing_byte cs c4; 4, (c1 land 0x07) lsl 18 + (Char.code c2 land 0x3F) lsl 12 + (Char.code c3 land 0x3F) lsl 6 + (Char.code c4 land 0x3F) | _ -> error_utf8 cs in try classify_unicode unicode, n with UnsupportedUtf8 -> error_unsupported_unicode_character n cs - + let lookup_utf8 cs = match Stream.peek cs with | Some ('\x00'..'\x7F') -> AsciiChar @@ -177,15 +177,15 @@ let check_keyword str = (* Keyword and symbol dictionary *) let token_tree = ref empty_ttree -let is_keyword s = - try match (ttree_find !token_tree s).node with None -> false | Some _ -> true +let is_keyword s = + try match (ttree_find !token_tree s).node with None -> false | Some _ -> true with Not_found -> false let add_keyword str = check_keyword str; token_tree := ttree_add !token_tree str -let remove_keyword str = +let remove_keyword str = token_tree := ttree_remove !token_tree str (* Adding a new token (keyword or special token). *) @@ -248,13 +248,13 @@ let rec string in_comments bp len = parser if esc then string in_comments bp (store len '"') s else len | [< ''*'; s >] -> (parser - | [< '')'; s >] -> + | [< '')'; s >] -> if in_comments then warning "Not interpreting \"*)\" as the end of current non-terminated comment because it occurs in a non-terminated string of the comment."; - string in_comments bp (store (store len '*') ')') s + string in_comments bp (store (store len '*') ')') s | [< >] -> string in_comments bp (store len '*') s) s - | [< 'c; s >] -> string in_comments bp (store len c) s + | [< 'c; s >] -> string in_comments bp (store len c) s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string (* Hook for exporting comment into xml theory files *) @@ -270,8 +270,8 @@ let between_com = ref true type com_state = int option * string * bool let restore_com_state (o,s,b) = - comment_begin := o; - Buffer.clear current; Buffer.add_string current s; + comment_begin := o; + Buffer.clear current; Buffer.add_string current s; between_com := b let dflt_com = (None,"",true) let com_state () = @@ -326,13 +326,13 @@ let rec comm_string bp = parser | [< >] -> real_push_char '\\'); s >] -> comm_string bp s | [< _ = Stream.empty >] ep -> err (bp, ep) Unterminated_string - | [< 'c; s >] -> real_push_char c; comm_string bp s + | [< 'c; s >] -> real_push_char c; comm_string bp s let rec comment bp = parser bp2 | [< ''('; _ = (parser | [< ''*'; s >] -> push_string "(*"; comment bp s - | [< >] -> push_string "(" ); + | [< >] -> push_string "(" ); s >] -> comment bp s | [< ''*'; _ = parser @@ -356,7 +356,7 @@ let rec progress_further last nj tt cs = and update_longest_valid_token last nj tt cs = match tt.node with | Some _ as last' -> - for i=1 to nj do Stream.junk cs done; + for i=1 to nj do Stream.junk cs done; progress_further last' 0 tt cs | None -> progress_further last nj tt cs @@ -374,7 +374,7 @@ and progress_utf8 last nj n c tt cs = List.iter (check_utf8_trailing_byte cs) l; let tt = List.fold_left (fun tt c -> CharMap.find c tt.branch) tt l in update_longest_valid_token last (nj+n) tt cs - | _ -> + | _ -> error_utf8 cs with Not_found -> last @@ -404,7 +404,7 @@ let process_chars bp c cs = let parse_after_dollar bp = parser - | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] -> + | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c) >] -> ("METAIDENT", get_buff len) | [< s >] -> match lookup_utf8 s with @@ -419,9 +419,9 @@ let parse_after_dot bp c = ("FIELD", get_buff len) | [< s >] -> match lookup_utf8 s with - | Utf8Token (UnicodeLetter, n) -> + | Utf8Token (UnicodeLetter, n) -> ("FIELD", get_buff (ident_tail (nstore n 0 s) s)) - | AsciiChar | Utf8Token _ | EmptyStream -> + | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars bp c s) (* Parse what follows a question mark *) @@ -449,7 +449,7 @@ let rec next_token = parser bp let t = parse_after_qmark bp s in comment_stop bp; (t, (ep, bp)) | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail (store 0 c); s >] ep -> - let id = get_buff len in + let id = get_buff len in comment_stop bp; (try ("", find_keyword id s) with Not_found -> ("IDENT", id)), (bp, ep) | [< ' ('0'..'9' as c); len = number (store 0 c) >] ep -> @@ -475,7 +475,7 @@ let rec next_token = parser bp let ep = Stream.count s in comment_stop bp; (try ("",find_keyword id s) with Not_found -> ("IDENT",id)), (bp, ep) - | AsciiChar | Utf8Token ((UnicodeSymbol | UnicodeIdentPart), _) -> + | AsciiChar | Utf8Token ((UnicodeSymbol | UnicodeIdentPart), _) -> let t = process_chars bp (Stream.next s) s in comment_stop bp; t | EmptyStream -> @@ -540,7 +540,7 @@ let token_text = function | ("STRING", "") -> "string" | ("EOI", "") -> "end of input" | (con, "") -> con - | (con, prm) -> con ^ " \"" ^ prm ^ "\"" + | (con, prm) -> con ^ " \"" ^ prm ^ "\"" (* The lexer of Coq *) @@ -552,7 +552,7 @@ let token_text = function we unfreeze the state of the lexer. This restores the behaviour of the lexer. B.B. *) -IFDEF CAMLP5 THEN +IFDEF CAMLP5 THEN let lexer = { Token.tok_func = func; @@ -562,7 +562,7 @@ let lexer = { Token.tok_comm = None; Token.tok_text = token_text } -ELSE +ELSE let lexer = { Token.func = func; @@ -582,7 +582,7 @@ let is_ident_not_keyword s = let is_number s = let rec aux i = - String.length s = i or + String.length s = i or match s.[i] with '0'..'9' -> aux (i+1) | _ -> false in aux 0 diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 6b5d03d912..1b53772f42 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -24,7 +24,7 @@ open Ppextend (* The parser of Coq *) -IFDEF CAMLP5 THEN +IFDEF CAMLP5 THEN module L = struct @@ -34,7 +34,7 @@ module L = module G = Grammar.GMake(L) -ELSE +ELSE module L = struct @@ -55,7 +55,7 @@ let grammar_delete e pos reinit rls = 99 and 200. We didn't find a good solution to this problem (e.g. using G.extend to know if the level exists results in a printed error message as side effect). As a consequence an - extension at 99 or 8 (and for pattern 200 too) inside a section + extension at 99 or 8 (and for pattern 200 too) inside a section corrupts the parser. *) List.iter (fun (pil,_) -> G.delete_rule e pil) (List.rev lev)) @@ -63,7 +63,7 @@ let grammar_delete e pos reinit rls = if reinit <> None then let lev = match pos with Some (Gramext.Level n) -> n | _ -> assert false in let pos = - if lev = "200" then Gramext.First + if lev = "200" then Gramext.First else Gramext.After (string_of_int (int_of_string lev + 1)) in G.extend e (Some pos) [Some lev,reinit,[]]; @@ -116,7 +116,7 @@ type camlp4_entry_rules = type ext_kind = | ByGrammar of - grammar_object G.Entry.e * Gramext.position option * + grammar_object G.Entry.e * Gramext.position option * camlp4_entry_rules list * Gramext.g_assoc option | ByGEXTEND of (unit -> unit) * (unit -> unit) @@ -215,16 +215,16 @@ let uconstr = create_univ "constr" let utactic = create_univ "tactic" let uvernac = create_univ "vernac" -let get_univ s = +let get_univ s = try Hashtbl.find univ_tab s with Not_found -> anomaly ("Unknown grammar universe: "^s) -let get_entry (u, utab) s = Hashtbl.find utab s +let get_entry (u, utab) s = Hashtbl.find utab s let get_entry_type (u, utab) s = - try + try type_of_typed_entry (get_entry (u, utab) s) with Not_found -> errorlabstrm "Pcoq.get_entry" @@ -263,7 +263,7 @@ let make_gen_entry (u,univ) rawwit s = module Prim = struct let gec_gen x = make_gen_entry uprim x - + (* Entries that can be refered via the string -> Gram.Entry.e table *) (* Typically for tactic or vernac extensions *) let preident = gec_gen rawwit_pre_ident "preident" @@ -334,7 +334,7 @@ module Tactic = (* Entries that can be refered via the string -> Gram.Entry.e table *) (* Typically for tactic user extensions *) - let open_constr = + let open_constr = make_gen_entry utactic (rawwit_open_constr_gen false) "open_constr" let casted_open_constr = make_gen_entry utactic (rawwit_open_constr_gen true) "casted_open_constr" @@ -347,7 +347,7 @@ module Tactic = make_gen_entry utactic rawwit_quant_hyp "quantified_hypothesis" let int_or_var = make_gen_entry utactic rawwit_int_or_var "int_or_var" let red_expr = make_gen_entry utactic rawwit_red_expr "red_expr" - let simple_intropattern = + let simple_intropattern = make_gen_entry utactic rawwit_intro_pattern "simple_intropattern" (* Main entries for ltac *) @@ -395,7 +395,7 @@ let main_entry = Vernac_.main_entry left border and into "constr LEVEL n" elsewhere), to the level below (to be translated into "NEXT") or to an below wrt associativity (to be translated in camlp4 into "constr" without level) or to another level - (to be translated into "constr LEVEL n") + (to be translated into "constr LEVEL n") The boolean is true if the entry was existing _and_ empty; this to circumvent a weakness of camlp4/camlp5 whose undo mechanism is not the @@ -422,7 +422,7 @@ let default_pattern_levels = 1,Gramext.LeftA,false; 0,Gramext.RightA,false] -let level_stack = +let level_stack = ref [(default_levels, default_pattern_levels)] (* At a same level, LeftA takes precedence over RightA and NoneA *) @@ -442,7 +442,7 @@ let create_assoc = function let error_level_assoc p current expected = let pr_assoc = function | Gramext.LeftA -> str "left" - | Gramext.RightA -> str "right" + | Gramext.RightA -> str "right" | Gramext.NonA -> str "non" in errorlabstrm "" (str "Level " ++ int p ++ str " is already declared " ++ @@ -508,7 +508,7 @@ let register_empty_levels forpat levels = let find_position forpat assoc level = find_position_gen forpat false assoc level -(* Synchronise the stack of level updates *) +(* Synchronise the stack of level updates *) let synchronize_level_positions () = let _ = find_position true None None in () @@ -517,7 +517,7 @@ let synchronize_level_positions () = (* Camlp4 levels do not treat NonA: use RightA with a NEXT on the left *) let camlp4_assoc = function - | Some Gramext.NonA | Some Gramext.RightA -> Gramext.RightA + | Some Gramext.NonA | Some Gramext.RightA -> Gramext.RightA | None | Some Gramext.LeftA -> Gramext.LeftA (* [adjust_level assoc from prod] where [assoc] and [from] are the name @@ -628,7 +628,7 @@ let rec symbol_of_constr_prod_entry_key assoc from forpat typ = match interp_constr_prod_entry_key assoc from forpat typ with | (eobj,None,_) -> Gramext.Snterm (Gram.Entry.obj eobj) | (eobj,Some None,_) -> Gramext.Snext - | (eobj,Some (Some (lev,cur)),_) -> + | (eobj,Some (Some (lev,cur)),_) -> Gramext.Snterml (Gram.Entry.obj eobj,constr_level lev) (**********************************************************************) diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index cfd05f4f7e..b625480863 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -55,7 +55,7 @@ module Gram : Grammar.S with type te = Compat.token [GramConstrNonTerminal (ETConstr (NextLevel,(BorderProd Left,LeftA)), Some "x"); GramConstrTerminal ("","+"); - GramConstrNonTerminal (ETConstr (NextLevel,(BorderProd Right,LeftA)), + GramConstrNonTerminal (ETConstr (NextLevel,(BorderProd Right,LeftA)), Some "y")] : grammar_constr_prod_item list | @@ -75,7 +75,7 @@ module Gram : Grammar.S with type te = Compat.token | | Metasyntax.interp_prod_item V - [GramTerminal "f"; + [GramTerminal "f"; GramNonTerminal (ConstrArgType, Aentry ("constr","constr"), Some "x")] : grammar_prod_item list | @@ -110,7 +110,7 @@ type camlp4_entry_rules = (* Add one extension at some camlp4 position of some camlp4 entry *) val grammar_extend : - grammar_object Gram.Entry.e -> Gramext.position option -> + grammar_object Gram.Entry.e -> Gramext.position option -> (* for reinitialization if ever needed: *) Gramext.g_assoc option -> camlp4_entry_rules list -> unit @@ -211,7 +211,7 @@ module Constr : val appl_arg : (constr_expr * explicitation located option) Gram.Entry.e end -module Module : +module Module : sig val module_expr : module_ast Gram.Entry.e val module_type : module_type_ast Gram.Entry.e @@ -257,16 +257,16 @@ val main_entry : (loc * vernac_expr) option Gram.Entry.e (* Binding constr entry keys to entries and symbols *) -val interp_constr_entry_key : bool (* true for cases_pattern *) -> +val interp_constr_entry_key : bool (* true for cases_pattern *) -> constr_entry_key -> grammar_object Gram.Entry.e * int option -val symbol_of_constr_prod_entry_key : Gramext.g_assoc option -> - constr_entry_key -> bool -> constr_prod_entry_key -> +val symbol_of_constr_prod_entry_key : Gramext.g_assoc option -> + constr_entry_key -> bool -> constr_prod_entry_key -> Compat.token Gramext.g_symbol (* Binding general entry keys to symbols *) -val symbol_of_prod_entry_key : +val symbol_of_prod_entry_key : Gram.te prod_entry_key -> Gram.te Gramext.g_symbol (**********************************************************************) @@ -278,10 +278,10 @@ val interp_entry_name : bool (* true to fail on unknown entry *) -> (**********************************************************************) (* Registering/resetting the level of a constr entry *) -val find_position : +val find_position : bool (* true if for creation in pattern entry; false if in constr entry *) -> Gramext.g_assoc option -> int option -> - Gramext.position option * Gramext.g_assoc option * string option * + Gramext.position option * Gramext.g_assoc option * string option * (* for reinitialization: *) Gramext.g_assoc option val synchronize_level_positions : unit -> unit @@ -290,4 +290,4 @@ val register_empty_levels : bool -> int list -> (Gramext.position option * Gramext.g_assoc option * string option * Gramext.g_assoc option) list -val remove_levels : int -> unit +val remove_levels : int -> unit diff --git a/parsing/ppconstr.ml b/parsing/ppconstr.ml index 74a4d5e5dc..80e1eb144d 100644 --- a/parsing/ppconstr.ml +++ b/parsing/ppconstr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id$ *) (*i*) open Util @@ -94,14 +94,14 @@ let pr_delimiters key strm = let pr_generalization bk ak c = let hd, tl = - match bk with + match bk with | Implicit -> "{", "}" | Explicit -> "(", ")" - in (* TODO: syntax Abstraction Kind *) + in (* TODO: syntax Abstraction Kind *) str "`" ++ str hd ++ c ++ str tl let pr_com_at n = - if Flags.do_beautify() && n <> 0 then comment n + if Flags.do_beautify() && n <> 0 then comment n else mt() let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp) @@ -114,7 +114,7 @@ let pr_optc pr = function let pr_in_comment pr x = str "(* " ++ pr x ++ str " *)" -let pr_universe = Univ.pr_uni +let pr_universe = Univ.pr_uni let pr_rawsort = function | RProp Term.Null -> str "Prop" @@ -130,7 +130,7 @@ let pr_expl_args pr (a,expl) = | None -> pr (lapp,L) a | Some (_,ExplByPos (n,_id)) -> anomaly("Explicitation by position not implemented") - | Some (_,ExplByName id) -> + | Some (_,ExplByName id) -> str "(" ++ pr_id id ++ str ":=" ++ pr ltop a ++ str ")" let pr_opt_type pr = function @@ -164,7 +164,7 @@ let pr_evar pr n l = (match l with | Some l -> spc () ++ pr_in_comment - (fun l -> + (fun l -> str"[" ++ hov 0 (prlist_with_sep pr_coma (pr ltop) l) ++ str"]") (List.rev l) | None -> mt())) @@ -200,7 +200,7 @@ let pr_eqn pr (loc,pl,rhs) = spc() ++ hov 4 (pr_with_comments loc (str "| " ++ - hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl + hov 0 (prlist_with_sep pr_bar (prlist_with_sep sep_v (pr_patt ltop)) pl ++ str " =>") ++ pr_sep_com spc (pr ltop) rhs)) @@ -213,22 +213,22 @@ let begin_of_binders = function | b::_ -> begin_of_binder b | _ -> 0 -let surround_impl k p = +let surround_impl k p = match k with | Explicit -> str"(" ++ p ++ str")" | Implicit -> str"{" ++ p ++ str"}" -let surround_binder k p = +let surround_binder k p = match k with | Default b -> hov 1 (surround_impl b p) - | Generalized (b, b', t) -> + | Generalized (b, b', t) -> hov 1 (surround_impl b' (surround_impl b p)) - + let surround_implicit k p = match k with | Default Explicit -> p | Default Implicit -> (str"{" ++ p ++ str"}") - | Generalized (b, b', t) -> + | Generalized (b, b', t) -> surround_impl b' (surround_impl b p) let pr_binder many pr (nal,k,t) = @@ -281,7 +281,7 @@ let rec extract_lam_binders = function let bl,c = extract_lam_binders (CLambdaN(loc,bl,c)) in LocalRawAssum (nal,bk,t) :: bl, c | c -> [], c - + let split_lambda = function | CLambdaN (loc,[[na],bk,t],c) -> (na,t,c) | CLambdaN (loc,([na],bk,t)::bl,c) -> (na,t,CLambdaN(loc,bl,c)) @@ -293,7 +293,7 @@ let rename na na' t c = | (_,Name id), (_,Name id') -> (na',t,replace_vars_constr_expr [id,id'] c) | (_,Name id), (_,Anonymous) -> (na,t,c) | _ -> (na',t,c) - + let split_product na' = function | CArrow (loc,t,c) -> (na',t,c) | CProdN (loc,[[na],bk,t],c) -> rename na na' t c @@ -324,7 +324,7 @@ let merge_binders (na1,bk1,ty1) cofun (na2,bk2,ty2) codom = Constrextern.check_same_type ty1 ty2; ty2 in (LocalRawAssum ([na],bk1,ty), codom) - + let rec strip_domain bvar cofun c = match c with | CArrow(loc,a,b) -> @@ -401,13 +401,13 @@ let pr_fixdecl pr prd dangling_with_for ((_,id),(n,ro),bl,t,c) = let annot = match ro with CStructRec -> - if List.length bl > 1 && n <> None then + if List.length bl > 1 && n <> None then spc() ++ str "{struct " ++ pr_id (snd (Option.get n)) ++ str"}" - else mt() + else mt() | CWfRec c -> spc () ++ str "{wf " ++ pr lsimple c ++ pr_id (snd (Option.get n)) ++ str"}" | CMeasureRec (m,r) -> - spc () ++ str "{measure " ++ pr lsimple m ++ pr_id (snd (Option.get n)) ++ + spc () ++ str "{measure " ++ pr lsimple m ++ pr_id (snd (Option.get n)) ++ (match r with None -> mt() | Some r -> str" on " ++ pr lsimple r) ++ str"}" in pr_recursive_decl pr prd dangling_with_for id bl annot t c @@ -428,11 +428,11 @@ let is_var id = function | _ -> false let tm_clash = function - | (CRef (Ident (_,id)), Some (CApp (_,_,nal))) + | (CRef (Ident (_,id)), Some (CApp (_,_,nal))) when List.exists (function CRef (Ident (_,id')),_ -> id=id' | _ -> false) nal -> Some id - | (CRef (Ident (_,id)), Some (CAppExpl (_,_,nal))) + | (CRef (Ident (_,id)), Some (CAppExpl (_,_,nal))) when List.exists (function CRef (Ident (_,id')) -> id=id' | _ -> false) nal -> Some id @@ -445,7 +445,7 @@ let pr_asin pr (na,indnalopt) = (match indnalopt with | None -> mt () | Some t -> spc () ++ str "in " ++ pr lsimple t) - + let pr_case_item pr (tm,asin) = hov 0 (pr (lcast,E) tm ++ pr_asin pr asin) @@ -474,7 +474,7 @@ let pr_appexpl pr f l = let pr_app pr a l = hov 2 ( - pr (lapp,L) a ++ + pr (lapp,L) a ++ prlist (fun a -> spc () ++ pr_expl_args pr a) l) let pr_forall () = @@ -554,28 +554,28 @@ let pr pr sep inherited a = let c,l1 = list_sep_last l1 in assert (snd c = None); let p = pr_proj (pr mt) pr_app (fst c) f l1 in - if l2<>[] then + if l2<>[] then p ++ prlist (fun a -> spc () ++ pr_expl_args (pr mt) a) l2, lapp else p, lproj | CApp (_,(None,a),l) -> pr_app (pr mt) a l, lapp | CRecord (_,w,l) -> - let beg = + let beg = match w with - | None -> spc () + | None -> spc () | Some t -> spc () ++ pr spc ltop t ++ spc () ++ str"with" ++ spc () in - hv 0 (str"{" ++ beg ++ + hv 0 (str"{" ++ beg ++ prlist_with_sep (fun () -> spc () ++ str";" ++ spc ()) (fun ((_,id), c) -> pr_id id ++ spc () ++ str":=" ++ spc () ++ pr spc ltop c) l), latom | CCases (_,LetPatternStyle,rtntypopt,[c,asin],[(_,[(loc,[p])],b)]) -> hv 0 ( - str "let '" ++ - hov 0 (pr_patt ltop p ++ + str "let '" ++ + hov 0 (pr_patt ltop p ++ pr_asin (pr_dangling_with_for mt pr) asin ++ - str " :=" ++ pr spc ltop c ++ + str " :=" ++ pr spc ltop c ++ pr_case_type (pr_dangling_with_for mt pr) rtntypopt ++ str " in" ++ pr spc ltop b)), lletpattern @@ -608,7 +608,7 @@ let pr pr sep inherited a = hov 0 (str "then" ++ pr (fun () -> brk (1,1)) ltop b1) ++ spc () ++ hov 0 (str "else" ++ pr (fun () -> brk (1,1)) ltop b2)), lif - + | CHole _ -> str "_", latom | CEvar (_,n,l) -> pr_evar (pr mt) n l, latom | CPatVar (_,(_,p)) -> str "?" ++ pr_patvar p, latom @@ -645,7 +645,7 @@ let rec strip_context n iscast t = else let bl', c = strip_context (n-n') iscast (if bll=[] then c else CLambdaN (loc,bll,c)) in - LocalRawAssum (nal,bk,t) :: bl', c + LocalRawAssum (nal,bk,t) :: bl', c | CProdN (loc,(nal,bk,t)::bll,c) -> let n' = List.length nal in if n' > n then @@ -654,12 +654,12 @@ let rec strip_context n iscast t = else let bl', c = strip_context (n-n') iscast (if bll=[] then c else CProdN (loc,bll,c)) in - LocalRawAssum (nal,bk,t) :: bl', c + LocalRawAssum (nal,bk,t) :: bl', c | CArrow (loc,t,c) -> let bl', c = strip_context (n-1) iscast c in LocalRawAssum ([loc,Anonymous],default_binder_kind,t) :: bl', c | CCast (_,c,_) -> strip_context n false c - | CLetIn (_,na,b,c) -> + | CLetIn (_,na,b,c) -> let bl', c = strip_context (n-1) iscast c in LocalRawDef (na,b) :: bl', c | _ -> anomaly "strip_context" @@ -704,7 +704,7 @@ let pr_with_occurrences_with_trailer pr occs trailer = (if nowhere_except_in then mt() else str "- ") ++ hov 0 (prlist_with_sep spc (pr_or_var int) nl) ++ trailer) -let pr_with_occurrences pr occs = +let pr_with_occurrences pr occs = pr_with_occurrences_with_trailer pr occs (mt()) let pr_red_flag pr r = @@ -725,13 +725,13 @@ let pr_metaid id = str"?" ++ pr_id id let pr_red_expr (pr_constr,pr_lconstr,pr_ref) = function | Red false -> str "red" | Hnf -> str "hnf" - | Simpl o -> str "simpl" ++ pr_opt (pr_with_occurrences pr_constr) o + | Simpl o -> str "simpl" ++ pr_opt (pr_with_occurrences pr_constr) o | Cbv f -> if f = {rBeta=true;rIota=true;rZeta=true;rDelta=true;rConst=[]} then str "compute" else hov 1 (str "cbv" ++ pr_red_flag pr_ref f) - | Lazy f -> + | Lazy f -> hov 1 (str "lazy" ++ pr_red_flag pr_ref f) | Unfold l -> hov 1 (str "unfold" ++ spc() ++ @@ -740,7 +740,7 @@ let pr_red_expr (pr_constr,pr_lconstr,pr_ref) = function | Pattern l -> hov 1 (str "pattern" ++ pr_arg (prlist_with_sep pr_coma (pr_with_occurrences pr_constr)) l) - + | Red true -> error "Shouldn't be accessible from user." | ExtraRedExpr s -> str s | CbvVm -> str "vm_compute" diff --git a/parsing/ppconstr.mli b/parsing/ppconstr.mli index ad2afa97d2..5767c9955c 100644 --- a/parsing/ppconstr.mli +++ b/parsing/ppconstr.mli @@ -6,7 +6,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - + (*i $Id$ i*) open Pp @@ -28,11 +28,11 @@ val extract_def_binders : constr_expr -> constr_expr -> local_binder list * constr_expr * constr_expr val split_fix : - int -> constr_expr -> constr_expr -> + int -> constr_expr -> constr_expr -> local_binder list * constr_expr * constr_expr val prec_less : int -> int * Ppextend.parenRelation -> bool - + val pr_tight_coma : unit -> std_ppcmds val pr_or_var : ('a -> std_ppcmds) -> 'a or_var -> std_ppcmds @@ -60,7 +60,7 @@ val pr_red_expr : ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) -> ('a,'b) red_expr_gen -> std_ppcmds val pr_may_eval : - ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> ('a,'b) may_eval -> std_ppcmds val pr_rawsort : rawsort -> std_ppcmds @@ -82,9 +82,9 @@ type term_pr = { val set_term_pr : term_pr -> unit val default_term_pr : term_pr -(* The modular constr printer. +(* The modular constr printer. [modular_constr_pr pr s p t] prints the head of the term [t] and calls - [pr] on its subterms. + [pr] on its subterms. [s] is typically {!Pp.mt} and [p] is [lsimple] for "constr" printers and [ltop] for "lconstr" printers (spiwack: we might need more specification here). We can make a new modular constr printer by overriding certain branches, @@ -92,13 +92,13 @@ val default_term_pr : term_pr instead we can proceed as follows: let my_modular_constr_pr pr s p = function | CSort (_,RProp Null) -> str "Omega" - | t -> modular_constr_pr pr s p t + | t -> modular_constr_pr pr s p t Which has the same type. We can turn a modular printer into a printer by taking its fixpoint. *) type precedence val lsimple : precedence val ltop : precedence -val modular_constr_pr : - ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) -> +val modular_constr_pr : + ((unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds) -> (unit->std_ppcmds) -> precedence -> constr_expr -> std_ppcmds diff --git a/parsing/ppdecl_proof.ml b/parsing/ppdecl_proof.ml index 31fd4561e6..40c712cdff 100644 --- a/parsing/ppdecl_proof.ml +++ b/parsing/ppdecl_proof.ml @@ -8,43 +8,43 @@ (* $Id$ *) -open Util +open Util open Pp open Decl_expr -open Names +open Names open Nameops let pr_constr = Printer.pr_constr_env let pr_tac = Pptactic.pr_glob_tactic -let pr_pat mpat = Ppconstr.pr_cases_pattern_expr mpat.pat_expr +let pr_pat mpat = Ppconstr.pr_cases_pattern_expr mpat.pat_expr let pr_label = function Anonymous -> mt () - | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () + | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () let pr_justification_items env = function Some [] -> mt () - | Some (_::_ as l) -> - spc () ++ str "by" ++ spc () ++ + | Some (_::_ as l) -> + spc () ++ str "by" ++ spc () ++ prlist_with_sep (fun () -> str ",") (pr_constr env) l | None -> spc () ++ str "by *" let pr_justification_method env = function None -> mt () - | Some tac -> + | Some tac -> spc () ++ str "using" ++ spc () ++ pr_tac env tac -let pr_statement pr_it env st = +let pr_statement pr_it env st = pr_label st.st_label ++ pr_it env st.st_it let pr_or_thesis pr_this env = function Thesis Plain -> str "thesis" - | Thesis (For id) -> - str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id + | Thesis (For id) -> + str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id | This c -> pr_this env c -let pr_cut pr_it env c = - hov 1 (pr_it env c.cut_stat) ++ +let pr_cut pr_it env c = + hov 1 (pr_it env c.cut_stat) ++ pr_justification_items env c.cut_by ++ pr_justification_method env c.cut_using @@ -54,28 +54,28 @@ let type_or_thesis = function let _I x = x -let rec print_hyps pconstr gtyp env sep _be _have hyps = +let rec print_hyps pconstr gtyp env sep _be _have hyps = let pr_sep = if sep then str "and" ++ spc () else mt () in - match hyps with - (Hvar _ ::_) as rest -> - spc () ++ pr_sep ++ str _have ++ + match hyps with + (Hvar _ ::_) as rest -> + spc () ++ pr_sep ++ str _have ++ print_vars pconstr gtyp env false _be _have rest - | Hprop st :: rest -> + | Hprop st :: rest -> begin let nenv = match st.st_label with Anonymous -> env | Name id -> Environ.push_named (id,None,gtyp st.st_it) env in - spc() ++ pr_sep ++ pr_statement pconstr env st ++ + spc() ++ pr_sep ++ pr_statement pconstr env st ++ print_hyps pconstr gtyp nenv true _be _have rest end | [] -> mt () and print_vars pconstr gtyp env sep _be _have vars = match vars with - Hvar st :: rest -> + Hvar st :: rest -> begin - let nenv = + let nenv = match st.st_label with Anonymous -> anomaly "anonymous variable" | Name id -> Environ.push_named (id,None,st.st_it) env in @@ -85,14 +85,14 @@ and print_vars pconstr gtyp env sep _be _have vars = print_vars pconstr gtyp nenv true _be _have rest end | (Hprop _ :: _) as rest -> - let _st = if _be then - str "be such that" - else + let _st = if _be then + str "be such that" + else str "such that" in spc() ++ _st ++ print_hyps pconstr gtyp env false _be _have rest | [] -> mt () -let pr_suffices_clause env (hyps,c) = +let pr_suffices_clause env (hyps,c) = print_hyps pr_constr _I env false false "to have" hyps ++ spc () ++ str "to show" ++ spc () ++ pr_or_thesis pr_constr env c @@ -110,68 +110,68 @@ let pr_side = function let rec pr_bare_proof_instr _then _thus env = function | Pescape -> str "escape" - | Pthen i -> pr_bare_proof_instr true _thus env i - | Pthus i -> pr_bare_proof_instr _then true env i + | Pthen i -> pr_bare_proof_instr true _thus env i + | Pthus i -> pr_bare_proof_instr _then true env i | Phence i -> pr_bare_proof_instr true true env i - | Pcut c -> + | Pcut c -> begin match _then,_thus with - false,false -> str "have" ++ spc () ++ + false,false -> str "have" ++ spc () ++ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c - | false,true -> str "thus" ++ spc () ++ + | false,true -> str "thus" ++ spc () ++ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c | true,false -> str "then" ++ spc () ++ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c - | true,true -> str "hence" ++ spc () ++ + | true,true -> str "hence" ++ spc () ++ pr_cut (pr_statement (pr_or_thesis pr_constr)) env c end | Psuffices c -> - str "suffices" ++ pr_cut pr_suffices_clause env c + str "suffices" ++ pr_cut pr_suffices_clause env c | Prew (sid,c) -> (if _thus then str "thus" else str " ") ++ spc () ++ pr_side sid ++ spc () ++ pr_cut (pr_statement pr_constr) env c - | Passume hyps -> + | Passume hyps -> str "assume" ++ print_hyps pr_constr _I env false false "we have" hyps - | Plet hyps -> + | Plet hyps -> str "let" ++ print_vars pr_constr _I env false true "let" hyps | Pclaim st -> str "claim" ++ spc () ++ pr_statement pr_constr env st | Pfocus st -> str "focus on" ++ spc () ++ pr_statement pr_constr env st | Pconsider (id,hyps) -> - str "consider" ++ print_vars pr_constr _I env false false "consider" hyps - ++ spc () ++ str "from " ++ pr_constr env id + str "consider" ++ print_vars pr_constr _I env false false "consider" hyps + ++ spc () ++ str "from " ++ pr_constr env id | Pgiven hyps -> str "given" ++ print_vars pr_constr _I env false false "given" hyps - | Ptake witl -> - str "take" ++ spc () ++ + | Ptake witl -> + str "take" ++ spc () ++ prlist_with_sep pr_coma (pr_constr env) witl | Pdefine (id,args,body) -> - str "define" ++ spc () ++ pr_id id ++ spc () ++ - prlist_with_sep spc - (fun st -> str "(" ++ - pr_statement pr_constr env st ++ str ")") args ++ spc () ++ - str "as" ++ (pr_constr env body) - | Pcast (id,typ) -> - str "reconsider" ++ spc () ++ - pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++ - str "as" ++ spc () ++ (pr_constr env typ) - | Psuppose hyps -> - str "suppose" ++ + str "define" ++ spc () ++ pr_id id ++ spc () ++ + prlist_with_sep spc + (fun st -> str "(" ++ + pr_statement pr_constr env st ++ str ")") args ++ spc () ++ + str "as" ++ (pr_constr env body) + | Pcast (id,typ) -> + str "reconsider" ++ spc () ++ + pr_or_thesis (fun _ -> pr_id) env id ++ spc () ++ + str "as" ++ spc () ++ (pr_constr env typ) + | Psuppose hyps -> + str "suppose" ++ print_hyps pr_constr _I env false false "we have" hyps | Pcase (params,pat,hyps) -> str "suppose it is" ++ spc () ++ pr_pat pat ++ - (if params = [] then mt () else - (spc () ++ str "with" ++ spc () ++ - prlist_with_sep spc - (fun st -> str "(" ++ - pr_statement pr_constr env st ++ str ")") params ++ spc ())) + (if params = [] then mt () else + (spc () ++ str "with" ++ spc () ++ + prlist_with_sep spc + (fun st -> str "(" ++ + pr_statement pr_constr env st ++ str ")") params ++ spc ())) ++ - (if hyps = [] then mt () else - (spc () ++ str "and" ++ + (if hyps = [] then mt () else + (spc () ++ str "and" ++ print_hyps (pr_or_thesis pr_constr) type_or_thesis env false false "we have" hyps)) - | Pper (et,c) -> + | Pper (et,c) -> str "per" ++ spc () ++ pr_elim_type et ++ spc () ++ pr_casee env c | Pend (B_elim et) -> str "end" ++ spc () ++ pr_elim_type et @@ -184,7 +184,7 @@ let pr_emph = function | 3 -> str "*** " | _ -> anomaly "unknown emphasis" -let pr_proof_instr env instr = - pr_emph instr.emph ++ spc () ++ +let pr_proof_instr env instr = + pr_emph instr.emph ++ spc () ++ pr_bare_proof_instr false false env instr.instr diff --git a/parsing/ppdecl_proof.mli b/parsing/ppdecl_proof.mli index b0f0e110ce..fd6fb66376 100644 --- a/parsing/ppdecl_proof.mli +++ b/parsing/ppdecl_proof.mli @@ -1,2 +1,2 @@ -val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds +val pr_proof_instr : Environ.env -> Decl_expr.proof_instr -> Pp.std_ppcmds diff --git a/parsing/pptactic.ml b/parsing/pptactic.ml index bed5e1b286..f113908f89 100644 --- a/parsing/pptactic.ml +++ b/parsing/pptactic.ml @@ -36,8 +36,8 @@ let declare_extra_tactic_pprule (s,tags,prods) = let exists_extra_tactic_pprule s tags = Hashtbl.mem prtac_tab (s,tags) type 'a raw_extra_genarg_printer = - (constr_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> (tolerability -> raw_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds @@ -48,8 +48,8 @@ type 'a glob_extra_genarg_printer = 'a -> std_ppcmds type 'a extra_genarg_printer = - (Term.constr -> std_ppcmds) -> - (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds @@ -57,7 +57,7 @@ let genarg_pprule = ref Stringmap.empty let declare_extra_genarg_pprule (rawwit, f) (globwit, g) (wit, h) = let s = match unquote wit with - | ExtraArgType s -> s + | ExtraArgType s -> s | _ -> error "Can declare a pretty-printing rule only for extra argument types." in @@ -84,13 +84,13 @@ let pr_or_by_notation f = function let pr_located pr (loc,x) = pr x -let pr_evaluable_reference = function +let pr_evaluable_reference = function | EvalVarRef id -> pr_id id | EvalConstRef sp -> pr_global (Libnames.ConstRef sp) let pr_quantified_hypothesis = function | AnonHyp n -> int n - | NamedHyp id -> pr_id id + | NamedHyp id -> pr_id id let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h @@ -103,7 +103,7 @@ let pr_bindings prc prlc = function brk (1,1) ++ str "with" ++ brk (1,1) ++ prlist_with_sep spc prc l | ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ + brk (1,1) ++ str "with" ++ brk (1,1) ++ prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | NoBindings -> mt () @@ -112,7 +112,7 @@ let pr_bindings_no_with prc prlc = function brk (1,1) ++ prlist_with_sep spc prc l | ExplicitBindings l -> - brk (1,1) ++ + brk (1,1) ++ prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | NoBindings -> mt () @@ -160,11 +160,11 @@ let rec pr_raw_generic prc prlc prtac prref (x:Genarg.rlevel Genarg.generic_argu pr_red_expr (prc,prlc,pr_or_by_notation prref) (out_gen rawwit_red_expr x) | OpenConstrArgType b -> prc (snd (out_gen (rawwit_open_constr_gen b) x)) - | ConstrWithBindingsArgType -> + | ConstrWithBindingsArgType -> pr_with_bindings prc prlc (out_gen rawwit_constr_with_bindings x) - | BindingsArgType -> + | BindingsArgType -> pr_bindings_no_with prc prlc (out_gen rawwit_bindings x) - | List0ArgType _ -> + | List0ArgType _ -> hov 0 (pr_sequence (pr_raw_generic prc prlc prtac prref) (fold_list0 (fun a l -> a::l) x [])) | List1ArgType _ -> @@ -176,7 +176,7 @@ let rec pr_raw_generic prc prlc prtac prref (x:Genarg.rlevel Genarg.generic_argu (fold_pair (fun a b -> pr_sequence (pr_raw_generic prc prlc prtac prref) [a;b]) x) - | ExtraArgType s -> + | ExtraArgType s -> try pi1 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str "[no printer for " ++ str s ++ str "]" @@ -201,15 +201,15 @@ let rec pr_glob_generic prc prlc prtac x = | QuantHypArgType -> pr_quantified_hypothesis (out_gen globwit_quant_hyp x) | RedExprArgType -> - pr_red_expr + pr_red_expr (prc,prlc,pr_or_var (pr_and_short_name pr_evaluable_reference)) (out_gen globwit_red_expr x) | OpenConstrArgType b -> prc (snd (out_gen (globwit_open_constr_gen b) x)) - | ConstrWithBindingsArgType -> + | ConstrWithBindingsArgType -> pr_with_bindings prc prlc (out_gen globwit_constr_with_bindings x) - | BindingsArgType -> + | BindingsArgType -> pr_bindings_no_with prc prlc (out_gen globwit_bindings x) - | List0ArgType _ -> + | List0ArgType _ -> hov 0 (pr_sequence (pr_glob_generic prc prlc prtac) (fold_list0 (fun a l -> a::l) x [])) | List1ArgType _ -> @@ -221,7 +221,7 @@ let rec pr_glob_generic prc prlc prtac x = (fold_pair (fun a b -> pr_sequence (pr_glob_generic prc prlc prtac) [a;b]) x) - | ExtraArgType s -> + | ExtraArgType s -> try pi2 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str "[no printer for " ++ str s ++ str "]" @@ -248,7 +248,7 @@ let rec pr_generic prc prlc prtac x = | ConstrWithBindingsArgType -> let (c,b) = out_gen wit_constr_with_bindings x in pr_with_bindings prc prlc (c,out_bindings b) - | BindingsArgType -> + | BindingsArgType -> pr_bindings_no_with prc prlc (out_bindings (out_gen wit_bindings x)) | List0ArgType _ -> hov 0 (pr_sequence (pr_generic prc prlc prtac) @@ -261,7 +261,7 @@ let rec pr_generic prc prlc prtac x = hov 0 (fold_pair (fun a b -> pr_sequence (pr_generic prc prlc prtac) [a;b]) x) - | ExtraArgType s -> + | ExtraArgType s -> try pi3 (Stringmap.find s !genarg_pprule) prc prlc prtac x with Not_found -> str "[no printer for " ++ str s ++ str "]" @@ -275,7 +275,7 @@ let pr_tacarg_using_rule pr_gen l= pr_sequence (fun x -> x) (tacarg_using_rule_token pr_gen l) let pr_extend_gen pr_gen lev s l = - try + try let tags = List.map genarg_tag l in let (lev',pl) = Hashtbl.find prtac_tab (s,tags) in let p = pr_tacarg_using_rule pr_gen (pl,l) in @@ -283,7 +283,7 @@ let pr_extend_gen pr_gen lev s l = with Not_found -> str s ++ spc() ++ pr_sequence pr_gen l ++ str" (* Generic printer *)" -let pr_raw_extend prc prlc prtac = +let pr_raw_extend prc prlc prtac = pr_extend_gen (pr_raw_generic prc prlc prtac pr_reference) let pr_glob_extend prc prlc prtac = pr_extend_gen (pr_glob_generic prc prlc prtac) @@ -320,14 +320,14 @@ let pr_arg pr x = spc () ++ pr x let pr_ltac_constant sp = pr_qualid (Nametab.shortest_qualid_of_tactic sp) -let pr_evaluable_reference_env env = function +let pr_evaluable_reference_env env = function | EvalVarRef id -> pr_id id - | EvalConstRef sp -> + | EvalConstRef sp -> Nametab.pr_global_env (Termops.vars_of_env env) (Libnames.ConstRef sp) let pr_quantified_hypothesis = function | AnonHyp n -> int n - | NamedHyp id -> pr_id id + | NamedHyp id -> pr_id id let pr_quantified_hypothesis_arg h = spc () ++ pr_quantified_hypothesis h @@ -362,7 +362,7 @@ let pr_with_constr prc = function let pr_with_induction_names = function | None, None -> mt () | eqpat, ipat -> - spc () ++ hov 1 (str "as" ++ pr_opt pr_intro_pattern eqpat ++ + spc () ++ hov 1 (str "as" ++ pr_opt pr_intro_pattern eqpat ++ pr_opt pr_intro_pattern ipat) let pr_as_intro_pattern ipat = @@ -410,10 +410,10 @@ let pr_by_tactic prt = function let pr_hyp_location pr_id = function | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs | occs, InHypTypeOnly -> - spc () ++ + spc () ++ pr_with_occurrences (fun id -> str "(type of " ++ pr_id id ++ str ")") occs | occs, InHypValueOnly -> - spc () ++ + spc () ++ pr_with_occurrences (fun id -> str "(value of " ++ pr_id id ++ str ")") occs let pr_in pp = spc () ++ hov 0 (str "in" ++ pp) @@ -441,13 +441,13 @@ let pr_clause_pattern pr_id = function | (glopt,l) -> str " in" ++ prlist - (fun (id,nl) -> prlist (pr_arg int) nl + (fun (id,nl) -> prlist (pr_arg int) nl ++ spc () ++ pr_id id) l ++ pr_opt (fun nl -> prlist_with_sep spc int nl ++ str " Goal") glopt let pr_orient b = if b then mt () else str " <-" -let pr_multi = function +let pr_multi = function | Precisely 1 -> mt () | Precisely n -> pr_int n ++ str "!" | UpTo n -> pr_int n ++ str "?" @@ -486,14 +486,14 @@ let pr_match_rule m pr pr_pat = function (* | Pat (rl,mp,t) -> hv 0 (prlist_with_sep pr_coma (pr_match_hyps pr_pat) rl ++ - (if rl <> [] then spc () else mt ()) ++ + (if rl <> [] then spc () else mt ()) ++ hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t)) *) | Pat (rl,mp,t) -> hov 0 ( hv 0 (prlist_with_sep pr_coma (pr_match_hyps pr_pat) rl) ++ - (if rl <> [] then spc () else mt ()) ++ + (if rl <> [] then spc () else mt ()) ++ hov 0 ( str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t)) @@ -504,7 +504,7 @@ let pr_funvar = function | Some id -> spc () ++ pr_id id let pr_let_clause k pr (id,(bl,t)) = - hov 0 (str k ++ pr_lident id ++ prlist pr_funvar bl ++ + hov 0 (str k ++ pr_lident id ++ prlist pr_funvar bl ++ str " :=" ++ brk (1,1) ++ pr (TacArg t)) let pr_let_clauses recflag pr = function @@ -538,7 +538,7 @@ let pr_hintbases = function let pr_auto_using prc = function | [] -> mt () - | l -> spc () ++ + | l -> spc () ++ hov 2 (str "using" ++ spc () ++ prlist_with_sep pr_coma prc l) let pr_autoarg_adding = function @@ -581,7 +581,7 @@ open Closure used only at the glob and typed level: it is used to feed the constr printers *) -let make_pr_tac +let make_pr_tac (pr_tac_level,pr_constr,pr_lconstr,pr_pat, pr_cst,pr_ind,pr_ref,pr_ident, pr_extend,strip_prod_binders) env = @@ -644,7 +644,7 @@ let pr_fix_tac (id,n,c) = let annot = if List.length names = 1 then mt() else spc() ++ str"{struct " ++ pr_id idarg ++ str"}" in - hov 1 (str"(" ++ pr_id id ++ + hov 1 (str"(" ++ pr_id id ++ prlist pr_binder_fix bll ++ annot ++ str" :" ++ pr_lconstrarg ty ++ str")") in (* spc() ++ @@ -681,7 +681,7 @@ and pr_atom1 = function (* Basic tactics *) | TacIntroPattern [] as t -> pr_atom0 t - | TacIntroPattern (_::_ as p) -> + | TacIntroPattern (_::_ as p) -> hov 1 (str "intros" ++ spc () ++ prlist_with_sep spc pr_intro_pattern p) | TacIntrosUntil h -> hv 1 (str "intros until" ++ pr_arg pr_quantified_hypothesis h) @@ -695,11 +695,11 @@ and pr_atom1 = function | TacVmCastNoCheck c -> hov 1 (str "vm_cast_no_check" ++ pr_constrarg c) | TacApply (a,ev,cb,inhyp) -> hov 1 ((if a then mt() else str "simple ") ++ - str (with_evars ev "apply") ++ spc () ++ + str (with_evars ev "apply") ++ spc () ++ prlist_with_sep pr_coma pr_with_bindings cb ++ pr_in_hyp_as pr_ident inhyp) | TacElim (ev,cb,cbo) -> - hov 1 (str (with_evars ev "elim") ++ pr_arg pr_with_bindings cb ++ + hov 1 (str (with_evars ev "elim") ++ pr_arg pr_with_bindings cb ++ pr_opt pr_eliminator cbo) | TacElimType c -> hov 1 (str "elimtype" ++ pr_constrarg c) | TacCase (ev,cb) -> @@ -716,16 +716,16 @@ and pr_atom1 = function hov 1 (str "cofix" ++ spc () ++ pr_id id ++ spc() ++ str"with " ++ prlist_with_sep spc pr_cofix_tac l) | TacCut c -> hov 1 (str "cut" ++ pr_constrarg c) - | TacAssert (Some tac,ipat,c) -> - hov 1 (str "assert" ++ - pr_assumption pr_lconstr pr_constr ipat c ++ + | TacAssert (Some tac,ipat,c) -> + hov 1 (str "assert" ++ + pr_assumption pr_lconstr pr_constr ipat c ++ pr_by_tactic (pr_tac_level ltop) tac) - | TacAssert (None,ipat,c) -> + | TacAssert (None,ipat,c) -> hov 1 (str "pose proof" ++ pr_assertion pr_lconstr pr_constr ipat c) | TacGeneralize l -> hov 1 (str "generalize" ++ spc () ++ - prlist_with_sep pr_coma (fun (cl,na) -> + prlist_with_sep pr_coma (fun (cl,na) -> pr_with_occurrences pr_constr cl ++ pr_as_name na) l) | TacGeneralizeDep c -> @@ -745,7 +745,7 @@ and pr_atom1 = function | TacInstantiate (n,c,HypLocation (id,hloc)) -> hov 1 (str "instantiate" ++ spc() ++ hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ - pr_lconstrarg c ++ str ")" ) + pr_lconstrarg c ++ str ")" ) ++ str "in" ++ pr_hyp_location pr_ident (id,[],(hloc,ref None))) *) (* Derived basic tactics *) @@ -762,7 +762,7 @@ and pr_atom1 = function pr_opt_no_spc (pr_clauses pr_ident) cl) l) | TacDoubleInduction (h1,h2) -> hov 1 - (str "double induction" ++ + (str "double induction" ++ pr_arg pr_quantified_hypothesis h1 ++ pr_arg pr_quantified_hypothesis h2) | TacDecomposeAnd c -> @@ -774,22 +774,22 @@ and pr_atom1 = function hov 0 (str "[" ++ prlist_with_sep spc pr_ind l ++ str "]" ++ pr_constrarg c)) | TacSpecialize (n,c) -> - hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ + hov 1 (str "specialize" ++ spc () ++ pr_opt int n ++ pr_with_bindings c) - | TacLApply c -> + | TacLApply c -> hov 1 (str "lapply" ++ pr_constrarg c) (* Automation tactics *) | TacTrivial ([],Some []) as x -> pr_atom0 x | TacTrivial (lems,db) -> - hov 0 (str "trivial" ++ + hov 0 (str "trivial" ++ pr_auto_using pr_constr lems ++ pr_hintbases db) | TacAuto (None,[],Some []) as x -> pr_atom0 x | TacAuto (n,lems,db) -> - hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++ + hov 0 (str "auto" ++ pr_opt (pr_or_var int) n ++ pr_auto_using pr_constr lems ++ pr_hintbases db) | TacDAuto (n,p,lems) -> - hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++ + hov 1 (str "auto" ++ pr_opt (pr_or_var int) n ++ str "decomp" ++ pr_opt int p ++ pr_auto_using pr_constr lems) (* Context management *) @@ -803,18 +803,18 @@ and pr_atom1 = function (* Rem: only b = true is available for users *) assert b; hov 1 - (str "move" ++ brk (1,1) ++ pr_ident id1 ++ + (str "move" ++ brk (1,1) ++ pr_ident id1 ++ pr_move_location pr_ident id2) | TacRename l -> hov 1 (str "rename" ++ brk (1,1) ++ - prlist_with_sep + prlist_with_sep (fun () -> str "," ++ brk (1,1)) - (fun (i1,i2) -> + (fun (i1,i2) -> pr_ident i1 ++ spc () ++ str "into" ++ spc () ++ pr_ident i2) l) - | TacRevert l -> - hov 1 (str "revert" ++ spc () ++ prlist_with_sep spc pr_ident l) + | TacRevert l -> + hov 1 (str "revert" ++ spc () ++ prlist_with_sep spc pr_ident l) (* Constructors *) | TacLeft (ev,l) -> hov 1 (str (with_evars ev "left") ++ pr_bindings l) @@ -825,10 +825,10 @@ and pr_atom1 = function hov 1 (str (with_evars ev "constructor") ++ pr_arg (pr_tac_level (latom,E)) t) | TacAnyConstructor (ev,None) as t -> pr_atom0 t | TacConstructor (ev,n,l) -> - hov 1 (str (with_evars ev "constructor") ++ + hov 1 (str (with_evars ev "constructor") ++ pr_or_metaid pr_intarg n ++ pr_bindings l) - (* Conversion *) + (* Conversion *) | TacReduce (r,h) -> hov 1 (pr_red_expr r ++ pr_clauses pr_ident h) @@ -837,7 +837,7 @@ and pr_atom1 = function (match occ with None -> mt() | Some occlc -> - pr_with_occurrences_with_trailer pr_constr occlc + pr_with_occurrences_with_trailer pr_constr occlc (spc () ++ str "with ")) ++ pr_constr c ++ pr_clauses pr_ident h) @@ -848,15 +848,15 @@ and pr_atom1 = function | TacTransitivity None -> str "etransitivity" (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - hov 1 (str (with_evars ev "rewrite") ++ + | TacRewrite (ev,l,cl,by) -> + hov 1 (str (with_evars ev "rewrite") ++ prlist_with_sep (fun () -> str ","++spc()) - (fun (b,m,c) -> + (fun (b,m,c) -> pr_orient b ++ spc() ++ pr_multi m ++ pr_with_bindings c) l ++ pr_clauses pr_ident cl - ++ (match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt())) + ++ (match by with Some by -> pr_by_tactic (pr_tac_level ltop) by | None -> mt())) | TacInversion (DepInversion (k,c,ids),hyp) -> hov 1 (str "dependent " ++ pr_induction_kind k ++ spc () ++ pr_quantified_hypothesis hyp ++ @@ -866,8 +866,8 @@ and pr_atom1 = function pr_quantified_hypothesis hyp ++ pr_with_inversion_names ids ++ pr_simple_hyp_clause pr_ident cl) | TacInversion (InversionUsing (c,cl),hyp) -> - hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ - spc () ++ str "using" ++ spc () ++ pr_constr c ++ + hov 1 (str "inversion" ++ spc() ++ pr_quantified_hypothesis hyp ++ + spc () ++ str "using" ++ spc () ++ pr_constr c ++ pr_simple_hyp_clause pr_ident cl) in @@ -876,7 +876,7 @@ let rec pr_tac inherited tac = let (strm,prec) = match tac with | TacAbstract (t,None) -> str "abstract " ++ pr_tac (labstract,L) t, labstract - | TacAbstract (t,Some s) -> + | TacAbstract (t,Some s) -> hov 0 (str "abstract (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () ++ str "using " ++ pr_id s), @@ -896,7 +896,7 @@ let rec pr_tac inherited tac = ++ fnl() ++ str "end"), lmatch | TacMatchGoal (lz,lr,lrul) -> - hov 0 (pr_lazy lz ++ + hov 0 (pr_lazy lz ++ str (if lr then "match reverse goal with" else "match goal with") ++ prlist (fun r -> fnl () ++ str "| " ++ @@ -909,7 +909,7 @@ let rec pr_tac inherited tac = prlist pr_funvar lvar ++ str " =>" ++ spc () ++ pr_tac (lfun,E) body), lfun - | TacThens (t,tl) -> + | TacThens (t,tl) -> hov 1 (pr_tac (lseq,E) t ++ pr_then () ++ spc () ++ pr_seq_body (pr_tac ltop) tl), lseq @@ -925,7 +925,7 @@ let rec pr_tac inherited tac = hov 1 (str "try" ++ spc () ++ pr_tac (ltactical,E) t), ltactical | TacDo (n,t) -> - hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ + hov 1 (str "do " ++ pr_or_var int n ++ spc () ++ pr_tac (ltactical,E) t), ltactical | TacRepeat t -> @@ -941,7 +941,7 @@ let rec pr_tac inherited tac = hov 1 (pr_tac (lorelse,L) t1 ++ str " ||" ++ brk (1,1) ++ pr_tac (lorelse,E) t2), lorelse - | TacFail (n,l) -> + | TacFail (n,l) -> str "fail" ++ (if n=ArgArg 0 then mt () else pr_arg (pr_or_var int) n) ++ prlist (pr_arg (pr_message_token pr_ident)) l, latom | TacFirst tl -> @@ -988,7 +988,7 @@ and pr_tacarg = function pr_may_eval pr_constr pr_lconstr pr_cst c | TacFreshId l -> str "fresh" ++ pr_fresh_ids l | TacExternal (_,com,req,la) -> - str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++ + str "external" ++ spc() ++ qs com ++ spc() ++ qs req ++ spc() ++ prlist_with_sep spc pr_tacarg la | (TacCall _|Tacexp _|Integer _) as a -> str "ltac:" ++ pr_tac (latom,E) (TacArg a) @@ -1016,7 +1016,7 @@ let strip_prod_binders_constr n (sigma,ty) = let drop_env f _env = f let rec raw_printers = - (pr_raw_tactic_level, + (pr_raw_tactic_level, drop_env pr_constr_expr, drop_env pr_lconstr_expr, pr_lconstr_pattern_expr, @@ -1036,7 +1036,7 @@ and pr_raw_match_rule env t = let pr_and_constr_expr pr (c,_) = pr c let rec glob_printers = - (pr_glob_tactic_level, + (pr_glob_tactic_level, (fun env -> pr_and_constr_expr (pr_rawconstr_env env)), (fun env -> pr_and_constr_expr (pr_lrawconstr_env env)), (fun c -> pr_lconstr_pattern_env (Global.env()) c), diff --git a/parsing/pptactic.mli b/parsing/pptactic.mli index b672e9c23e..081d5fd3be 100644 --- a/parsing/pptactic.mli +++ b/parsing/pptactic.mli @@ -25,8 +25,8 @@ val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds type 'a raw_extra_genarg_printer = - (constr_expr -> std_ppcmds) -> - (constr_expr -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> (tolerability -> raw_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds @@ -37,13 +37,13 @@ type 'a glob_extra_genarg_printer = 'a -> std_ppcmds type 'a extra_genarg_printer = - (Term.constr -> std_ppcmds) -> - (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> + (Term.constr -> std_ppcmds) -> (tolerability -> glob_tactic_expr -> std_ppcmds) -> 'a -> std_ppcmds (* if the boolean is false then the extension applies only to old syntax *) -val declare_extra_genarg_pprule : +val declare_extra_genarg_pprule : ('c raw_abstract_argument_type * 'c raw_extra_genarg_printer) -> ('a glob_abstract_argument_type * 'a glob_extra_genarg_printer) -> ('b typed_abstract_argument_type * 'b extra_genarg_printer) -> unit @@ -51,12 +51,12 @@ val declare_extra_genarg_pprule : type grammar_terminals = string option list (* if the boolean is false then the extension applies only to old syntax *) -val declare_extra_tactic_pprule : +val declare_extra_tactic_pprule : string * argument_type list * (int * grammar_terminals) -> unit val exists_extra_tactic_pprule : string -> argument_type list -> bool -val pr_raw_generic : +val pr_raw_generic : (constr_expr -> std_ppcmds) -> (constr_expr -> std_ppcmds) -> (tolerability -> raw_tactic_expr -> std_ppcmds) -> @@ -83,7 +83,7 @@ val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds val pr_raw_tactic : env -> raw_tactic_expr -> std_ppcmds val pr_raw_tactic_level : env -> tolerability -> raw_tactic_expr -> std_ppcmds - + val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds val pr_tactic : env -> Proof_type.tactic_expr -> std_ppcmds diff --git a/parsing/ppvernac.ml b/parsing/ppvernac.ml index 26fa535506..95e921a24b 100644 --- a/parsing/ppvernac.ml +++ b/parsing/ppvernac.ml @@ -6,12 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id$ *) +(* $Id$ *) open Pp open Names open Nameops -open Nametab +open Nametab open Util open Extend open Vernacexpr @@ -62,11 +62,11 @@ let sep_end () = str"." (* Warning: [pr_raw_tactic] globalises and fails if globalisation fails *) -let pr_raw_tactic_env l env t = +let pr_raw_tactic_env l env t = pr_glob_tactic env (Tacinterp.glob_tactic_env l env t) let pr_gen env t = - pr_raw_generic + pr_raw_generic pr_constr_expr pr_lconstr_expr (pr_raw_tactic_level env) pr_reference t @@ -137,7 +137,7 @@ let pr_in_out_modules = function | SearchOutside [] -> mt() | SearchOutside l -> spc() ++ str"outside" ++ spc() ++ prlist_with_sep sep pr_module l -let pr_search_about (b,c) = +let pr_search_about (b,c) = (if b then str "-" else mt()) ++ match c with | SearchSubPattern p -> pr_constr_pattern_expr p @@ -176,8 +176,8 @@ let pr_printoption table b = prlist_with_sep spc str table ++ pr_opt (prlist_with_sep sep pr_option_ref_value) b -let pr_set_option a b = - let pr_opt_value = function +let pr_set_option a b = + let pr_opt_value = function | IntValue n -> spc() ++ int n | StringValue s -> spc() ++ str s | BoolValue b -> mt() @@ -193,13 +193,13 @@ let pr_opt_hintbases l = match l with | [] -> mt() | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z -let pr_hints local db h pr_c pr_pat = +let pr_hints local db h pr_c pr_pat = let opth = pr_opt_hintbases db in let pph = match h with | HintsResolve l -> - str "Resolve " ++ prlist_with_sep sep - (fun (pri, _, c) -> pr_c c ++ + str "Resolve " ++ prlist_with_sep sep + (fun (pri, _, c) -> pr_c c ++ match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ()) l | HintsImmediate l -> @@ -207,11 +207,11 @@ let pr_hints local db h pr_c pr_pat = | HintsUnfold l -> str "Unfold " ++ prlist_with_sep sep pr_reference l | HintsTransparency (l, b) -> - str (if b then "Transparent " else "Opaque ") ++ prlist_with_sep sep + str (if b then "Transparent " else "Opaque ") ++ prlist_with_sep sep pr_reference l | HintsConstructors c -> str"Constructors" ++ spc() ++ prlist_with_sep spc pr_reference c - | HintsExtern (n,c,tac) -> + | HintsExtern (n,c,tac) -> let pat = match c with None -> mt () | Some pat -> pr_pat pat in str "Extern" ++ spc() ++ int n ++ spc() ++ pat ++ str" =>" ++ spc() ++ pr_raw_tactic tac @@ -239,8 +239,8 @@ let rec pr_module_type pr_c = function | CMTEapply (fexpr,mexpr)-> let f = pr_module_type pr_c fexpr in let m = pr_module_expr mexpr in - f ++ spc () ++ m - + f ++ spc () ++ m + and pr_module_expr = function | CMEident qid -> pr_located pr_qualid qid | CMEapply (me1,(CMEident _ as me2)) -> @@ -271,7 +271,7 @@ let pr_module_vardecls pr_c (export,idl,mty) = hov 1 (str"(" ++ pr_require_token export ++ prlist_with_sep spc pr_lident idl ++ str":" ++ m ++ str")") -let pr_module_binders l pr_c = +let pr_module_binders l pr_c = (* Effet de bord complexe pour garantir la declaration des noms des modules parametres dans la Nametab des l'appel de pr_module_binders malgre l'aspect paresseux des streams *) @@ -299,16 +299,16 @@ let pr_and_type_binders_arg bl = pr_binders_arg bl let pr_onescheme (idop,schem) = - match schem with + match schem with | InductionScheme (dep,ind,s) -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() | None -> spc () ) ++ hov 0 ((if dep then str"Induction for" else str"Minimality for") - ++ spc() ++ pr_smart_global ind) ++ spc() ++ + ++ spc() ++ pr_smart_global ind) ++ spc() ++ hov 0 (str"Sort" ++ spc() ++ pr_rawsort s) - | EqualityScheme ind -> + | EqualityScheme ind -> (match idop with | Some id -> hov 0 (pr_lident id ++ str" :=") ++ spc() | None -> spc() @@ -332,10 +332,10 @@ let pr_assumption_token many = function str (if many then "Variables" else "Variable") | (Global,Logical) -> str (if many then "Axioms" else "Axiom") - | (Global,Definitional) -> + | (Global,Definitional) -> str (if many then "Parameters" else "Parameter") | (Global,Conjectural) -> str"Conjecture" - | (Local,Conjectural) -> + | (Local,Conjectural) -> anomaly "Don't know how to beautify a local conjecture" let pr_params pr_c (xl,(c,t)) = @@ -379,14 +379,14 @@ let pr_syntax_modifier = function let pr_syntax_modifiers = function | [] -> mt() - | l -> spc() ++ + | l -> spc() ++ hov 1 (str"(" ++ prlist_with_sep sep_v2 pr_syntax_modifier l ++ str")") let print_level n = if n <> 0 then str " (at level " ++ int n ++ str ")" else mt () let pr_grammar_tactic_rule n (_,pil,t) = - hov 2 (str "Tactic Notation" ++ print_level n ++ spc() ++ + hov 2 (str "Tactic Notation" ++ print_level n ++ spc() ++ hov 0 (prlist_with_sep sep pr_production_item pil ++ spc() ++ str":=" ++ spc() ++ pr_raw_tactic t)) @@ -397,7 +397,7 @@ let pr_box b = let pr_boxkind = function | PpHOVB n -> str"hov" ++ spc() ++ int n | PpTB -> str"t" in str"<" ++ pr_boxkind b ++ str">" - + let pr_paren_reln_or_extern = function | None,L -> str"L" | None,E -> str"E" @@ -414,7 +414,7 @@ let pr_constrarg c = spc () ++ pr_constr c in let pr_lconstrarg c = spc () ++ pr_lconstr c in let pr_intarg n = spc () ++ int n in (* let pr_lident_constr sep (i,c) = pr_lident i ++ sep ++ pr_constrarg c in *) -let pr_record_field (x, ntn) = +let pr_record_field (x, ntn) = let prx = match x with | (oc,AssumExpr (id,t)) -> hov 1 (pr_lname id ++ @@ -430,13 +430,13 @@ let pr_record_field (x, ntn) = pr_lconstr b)) in prx ++ pr_decl_notation pr_constr ntn in -let pr_record_decl b c fs = +let pr_record_decl b c fs = pr_opt pr_lident c ++ str"{" ++ hv 0 (prlist_with_sep pr_semicolon pr_record_field fs ++ str"}") in let rec pr_vernac = function - + (* Proof management *) | VernacAbortAll -> str "Abort All" | VernacRestart -> str"Restart" @@ -447,17 +447,17 @@ let rec pr_vernac = function | VernacResume id -> str"Resume" ++ pr_opt pr_lident id | VernacUndo i -> if i=1 then str"Undo" else str"Undo" ++ pr_intarg i | VernacUndoTo i -> str"Undo" ++ spc() ++ str"To" ++ pr_intarg i - | VernacBacktrack (i,j,k) -> + | VernacBacktrack (i,j,k) -> str "Backtrack" ++ spc() ++ prlist_with_sep sep int [i;j;k] | VernacFocus i -> str"Focus" ++ pr_opt int i - | VernacGo g -> + | VernacGo g -> let pr_goable = function | GoTo i -> int i | GoTop -> str"top" | GoNext -> str"next" - | GoPrev -> str"prev" + | GoPrev -> str"prev" in str"Go" ++ spc() ++ pr_goable g - | VernacShow s -> + | VernacShow s -> let pr_showable = function | ShowGoal n -> str"Show" ++ pr_opt int n | ShowGoalImplicitly n -> str"Show Implicit Arguments" ++ pr_opt int n @@ -471,7 +471,7 @@ let rec pr_vernac = function | ShowMatch id -> str"Show Match " ++ pr_lident id | ShowThesis -> str "Show Thesis" | ExplainProof l -> str"Explain Proof" ++ spc() ++ prlist_with_sep sep int l - | ExplainTree l -> str"Explain Proof Tree" ++ spc() ++ prlist_with_sep sep int l + | ExplainTree l -> str"Explain Proof Tree" ++ spc() ++ prlist_with_sep sep int l in pr_showable s | VernacCheckGuard -> str"Guarded" @@ -490,13 +490,13 @@ let rec pr_vernac = function | VernacList l -> hov 2 (str"[" ++ spc() ++ prlist (fun v -> pr_located pr_vernac v ++ sep_end () ++ fnl()) l - ++ spc() ++ str"]") + ++ spc() ++ str"]") | VernacLoad (f,s) -> str"Load" ++ if f then (spc() ++ str"Verbose" ++ spc()) else spc() ++ qs s | VernacTime v -> str"Time" ++ spc() ++ pr_vernac v | VernacTimeout(n,v) -> str"Timeout " ++ int n ++ spc() ++ pr_vernac v - - (* Syntax *) + + (* Syntax *) | VernacTacticNotation (n,r,e) -> pr_grammar_tactic_rule n ("",r,e) | VernacOpenCloseScope (local,opening,sc) -> str (if opening then "Open " else "Close ") ++ pr_locality local ++ @@ -507,11 +507,11 @@ let rec pr_vernac = function | VernacBindScope (sc,cll) -> str"Bind Scope" ++ spc () ++ str sc ++ spc() ++ str "with " ++ prlist_with_sep spc pr_class_rawexpr cll - | VernacArgumentsScope (local,q,scl) -> let pr_opt_scope = function + | VernacArgumentsScope (local,q,scl) -> let pr_opt_scope = function | None -> str"_" - | Some sc -> str sc in - str"Arguments Scope" ++ spc() ++ pr_non_locality local ++ - pr_smart_global q + | Some sc -> str sc in + str"Arguments Scope" ++ spc() ++ pr_non_locality local ++ + pr_smart_global q ++ spc() ++ str"[" ++ prlist_with_sep sep pr_opt_scope scl ++ str"]" | VernacInfix (local,(s,mv),q,sn) -> (* A Verifier *) hov 0 (hov 0 (str"Infix " ++ pr_locality local @@ -523,7 +523,7 @@ let rec pr_vernac = function | VernacNotation (local,c,(s,l),opt) -> let ps = let n = String.length s in - if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' + if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then let s' = String.sub s 1 (n-2) in if String.contains s' '\'' then qs s else str s' @@ -575,13 +575,13 @@ let rec pr_vernac = function | None -> if opac then str"Qed" else str"Defined" | Some (id,th) -> (match th with | None -> (if opac then str"Save" else str"Defined") ++ spc() ++ pr_lident id - | Some tok -> str"Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)) + | Some tok -> str"Save" ++ spc() ++ pr_thm_token tok ++ spc() ++ pr_lident id)) | VernacExactProof c -> hov 2 (str"Proof" ++ pr_lconstrarg c) | VernacAssumption (stre,_,l) -> let n = List.length (List.flatten (List.map fst (List.map snd l))) in hov 2 - (pr_assumption_token (n > 1) stre ++ spc() ++ + (pr_assumption_token (n > 1) stre ++ spc() ++ pr_ne_params_list pr_lconstr_expr l) | VernacInductive (f,i,l) -> @@ -595,13 +595,13 @@ let rec pr_vernac = function pr_com_at (begin_of_inductive l) ++ fnl() ++ str (if List.length l = 1 then " " else " | ") ++ - prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l - | RecordDecl (c,fs) -> + prlist_with_sep (fun _ -> fnl() ++ str" | ") pr_constructor l + | RecordDecl (c,fs) -> spc() ++ pr_record_decl b c fs in let pr_oneind key (((coe,id),indpar,s,k,lc),ntn) = let kw = - str (match k with Record -> "Record" | Structure -> "Structure" + str (match k with Record -> "Record" | Structure -> "Structure" | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" | Class b -> if b then "Definitional Class" else "Class") in @@ -609,13 +609,13 @@ let rec pr_vernac = function kw ++ spc() ++ (if i then str"Infer" else str"") ++ (if coe then str" > " else str" ") ++ pr_lident id ++ - pr_and_type_binders_arg indpar ++ spc() ++ - Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++ - str" :=") ++ pr_constructor_list k lc ++ - pr_decl_notation pr_constr ntn + pr_and_type_binders_arg indpar ++ spc() ++ + Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++ + str" :=") ++ pr_constructor_list k lc ++ + pr_decl_notation pr_constr ntn in hov 1 (pr_oneind (if (Decl_kinds.recursivity_flag_of_kind f) then "Inductive" else "CoInductive") (List.hd l)) - ++ + ++ (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) @@ -631,25 +631,25 @@ let rec pr_vernac = function let bl = bl @ bl' in let ids = List.flatten (List.map name_of_binder bl) in let annot = - match n with - | None -> mt () - | Some (loc, id) -> + match n with + | None -> mt () + | Some (loc, id) -> match (ro : Topconstr.recursion_order_expr) with - CStructRec -> - if List.length ids > 1 then + CStructRec -> + if List.length ids > 1 then spc() ++ str "{struct " ++ pr_id id ++ str"}" else mt() - | CWfRec c -> - spc() ++ str "{wf " ++ pr_lconstr_expr c ++ spc() ++ + | CWfRec c -> + spc() ++ str "{wf " ++ pr_lconstr_expr c ++ spc() ++ pr_id id ++ str"}" - | CMeasureRec (m,r) -> - spc() ++ str "{measure " ++ pr_lconstr_expr m ++ spc() ++ - pr_id id ++ (match r with None -> mt() | Some r -> str" on " ++ + | CMeasureRec (m,r) -> + spc() ++ str "{measure " ++ pr_lconstr_expr m ++ spc() ++ + pr_id id ++ (match r with None -> mt() | Some r -> str" on " ++ pr_lconstr_expr r) ++ str"}" in pr_id id ++ pr_binders_arg bl ++ annot ++ spc() ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ - ++ str" :=" ++ brk(1,1) ++ pr_lconstr def ++ + ++ str" :=" ++ brk(1,1) ++ pr_lconstr def ++ pr_decl_notation pr_constr ntn in let start = if b then "Boxed Fixpoint" else "Fixpoint" in @@ -664,12 +664,12 @@ let rec pr_vernac = function let bl = bl @ bl' in pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ spc() ++ pr_lconstr_expr c ++ - str" :=" ++ brk(1,1) ++ pr_lconstr def ++ + str" :=" ++ brk(1,1) ++ pr_lconstr def ++ pr_decl_notation pr_constr ntn in let start = if b then "Boxed CoFixpoint" else "CoFixpoint" in hov 1 (str start ++ spc() ++ - prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs) + prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onecorec corecs) | VernacScheme l -> hov 2 (str"Scheme" ++ spc() ++ prlist_with_sep (fun _ -> fnl() ++ str"with ") pr_onescheme l) @@ -677,7 +677,7 @@ let rec pr_vernac = function hov 2 (str"Combined Scheme" ++ spc() ++ pr_lident id ++ spc() ++ str"from" ++ spc() ++ prlist_with_sep (fun _ -> fnl() ++ str", ") pr_lident l) - + (* Gallina extensions *) | VernacBeginSection id -> hov 2 (str"Section" ++ spc () ++ pr_lident id) @@ -703,7 +703,7 @@ let rec pr_vernac = function | VernacIdentityCoercion (s,id,c1,c2) -> hov 1 ( str"Identity Coercion" ++ (match s with | Local -> spc() ++ - str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++ + str"Local" ++ spc() | Global -> spc()) ++ pr_lident id ++ spc() ++ str":" ++ spc() ++ pr_class_rawexpr c1 ++ spc() ++ str">->" ++ spc() ++ pr_class_rawexpr c2) @@ -717,13 +717,13 @@ let rec pr_vernac = function (* spc () ++ str":=" ++ spc () ++ *) (* prlist_with_sep (fun () -> str";" ++ spc()) *) (* (fun (lid,oc,c) -> pr_lident_constr ((if oc then str" :>" else str" :") ++ spc()) (lid,c)) props ) *) - - | VernacInstance (glob, sup, (instid, bk, cl), props, pri) -> + + | VernacInstance (glob, sup, (instid, bk, cl), props, pri) -> hov 1 ( pr_non_locality (not glob) ++ - str"Instance" ++ spc () ++ + str"Instance" ++ spc () ++ pr_and_type_binders_arg sup ++ - str"=>" ++ spc () ++ + str"=>" ++ spc () ++ (match snd instid with Name id -> pr_lident (fst instid, id) ++ spc () ++ str":" ++ spc () | Anonymous -> mt ()) ++ pr_constr_expr cl ++ spc () ++ spc () ++ str":=" ++ spc () ++ @@ -733,35 +733,35 @@ let rec pr_vernac = function hov 1 ( str"Context" ++ spc () ++ str"[" ++ spc () ++ pr_and_type_binders_arg l ++ spc () ++ str "]") - + | VernacDeclareInstance id -> hov 1 (str"Instance" ++ spc () ++ pr_lident id) - + (* Modules and Module Types *) | VernacDefineModule (export,m,bl,ty,bd) -> - let b = pr_module_binders_list bl pr_lconstr in + let b = pr_module_binders_list bl pr_lconstr in hov 2 (str"Module" ++ spc() ++ pr_require_token export ++ pr_lident m ++ b ++ pr_opt (pr_of_module_type pr_lconstr) ty ++ pr_opt (fun me -> str ":= " ++ pr_module_expr me) bd) | VernacDeclareModule (export,id,bl,m1) -> - let b = pr_module_binders_list bl pr_lconstr in + let b = pr_module_binders_list bl pr_lconstr in hov 2 (str"Declare Module" ++ spc() ++ pr_require_token export ++ pr_lident id ++ b ++ pr_of_module_type pr_lconstr m1) | VernacDeclareModuleType (id,bl,m) -> - let b = pr_module_binders_list bl pr_lconstr in + let b = pr_module_binders_list bl pr_lconstr in hov 2 (str"Module Type " ++ pr_lident id ++ b ++ pr_opt (fun mt -> str ":= " ++ pr_module_type pr_lconstr mt) m) | VernacInclude (in_ast) -> begin match in_ast with | CIMTE mty -> - hov 2 (str"Include" ++ + hov 2 (str"Include" ++ (fun mt -> str " " ++ pr_module_type pr_lconstr mt) mty) | CIME mexpr -> - hov 2 (str"Include" ++ + hov 2 (str"Include" ++ (fun me -> str " " ++ pr_module_expr me) mexpr) end (* Solving *) @@ -775,12 +775,12 @@ let rec pr_vernac = function str"Existential " ++ int i ++ pr_lconstrarg c (* MMode *) - + | VernacProofInstr instr -> anomaly "Not implemented" - | VernacDeclProof -> str "proof" + | VernacDeclProof -> str "proof" | VernacReturn -> str "return" - (* /MMode *) + (* /MMode *) (* Auxiliary file and library management *) | VernacRequireFrom (exp,spe,f) -> hov 2 @@ -794,9 +794,9 @@ let rec pr_vernac = function (str"Add" ++ (if fl then str" Rec " else spc()) ++ str"LoadPath" ++ spc() ++ qs s ++ - (match d with + (match d with | None -> mt() - | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir)) + | Some dir -> spc() ++ str"as" ++ spc() ++ pr_dirpath dir)) | VernacRemoveLoadPath s -> str"Remove LoadPath" ++ qs s | VernacAddMLPath (fl,s) -> str"Add" ++ (if fl then str" Rec " else spc()) ++ str"ML Path" ++ qs s @@ -811,13 +811,13 @@ let rec pr_vernac = function match body with | Tacexpr.TacFun (idl,b) -> idl,b | _ -> [], body in - pr_ltac_id id ++ + pr_ltac_id id ++ prlist (function None -> str " _" | Some id -> spc () ++ pr_id id) idl ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ let idl = List.map Option.get (List.filter (fun x -> not (x=None)) idl)in - pr_raw_tactic_env - (idl @ List.map coerce_reference_to_id + pr_raw_tactic_env + (idl @ List.map coerce_reference_to_id (List.map (fun (x, _, _) -> x) (List.filter (fun (_, redef, _) -> not redef) l))) (Global.env()) body in @@ -830,7 +830,7 @@ let rec pr_vernac = function pr_hints local dbnames h pr_constr pr_constr_pattern_expr | VernacSyntacticDefinition (id,(ids,c),local,onlyparsing) -> hov 2 - (str"Notation " ++ pr_locality local ++ pr_lident id ++ + (str"Notation " ++ pr_locality local ++ pr_lident id ++ prlist_with_sep spc pr_id ids ++ str" :=" ++ pr_constrarg c ++ pr_syntax_modifiers (if onlyparsing then [SetOnlyParsing] else [])) | VernacDeclareImplicits (local,q,None) -> @@ -863,24 +863,24 @@ let rec pr_vernac = function hv 0 (prlist_with_sep sep pr_line l)) | VernacUnsetOption (l,na) -> hov 1 (pr_locality_full l ++ str"Unset" ++ spc() ++ pr_printoption na None) - | VernacSetOption (l,na,v) -> + | VernacSetOption (l,na,v) -> hov 2 (pr_locality_full l ++ str"Set" ++ spc() ++ pr_set_option na v) | VernacAddOption (na,l) -> hov 2 (str"Add" ++ spc() ++ pr_printoption na (Some l)) | VernacRemoveOption (na,l) -> hov 2 (str"Remove" ++ spc() ++ pr_printoption na (Some l)) | VernacMemOption (na,l) -> hov 2 (str"Test" ++ spc() ++ pr_printoption na (Some l)) | VernacPrintOption na -> hov 2 (str"Test" ++ spc() ++ pr_printoption na None) - | VernacCheckMayEval (r,io,c) -> - let pr_mayeval r c = match r with + | VernacCheckMayEval (r,io,c) -> + let pr_mayeval r c = match r with | Some r0 -> hov 2 (str"Eval" ++ spc() ++ pr_red_expr (pr_constr,pr_lconstr,pr_smart_global) r0 ++ spc() ++ str"in" ++ spc () ++ pr_constr c) - | None -> hov 2 (str"Check" ++ spc() ++ pr_constr c) - in - (if io = None then mt() else int (Option.get io) ++ str ": ") ++ + | None -> hov 2 (str"Check" ++ spc() ++ pr_constr c) + in + (if io = None then mt() else int (Option.get io) ++ str ": ") ++ pr_mayeval r c | VernacGlobalCheck c -> hov 2 (str"Type" ++ pr_constrarg c) - | VernacPrint p -> + | VernacPrint p -> let pr_printable = function | PrintFullContext -> str"Print All" | PrintSectionContext s -> @@ -911,17 +911,17 @@ let rec pr_vernac = function | PrintModule qid -> str"Print Module" ++ spc() ++ pr_reference qid | PrintInspect n -> str"Inspect" ++ spc() ++ int n | PrintScopes -> str"Print Scopes" - | PrintScope s -> str"Print Scope" ++ spc() ++ str s - | PrintVisibility s -> str"Print Visibility" ++ pr_opt str s + | PrintScope s -> str"Print Scope" ++ spc() ++ str s + | PrintVisibility s -> str"Print Visibility" ++ pr_opt str s | PrintAbout qid -> str"About" ++ spc() ++ pr_smart_global qid | PrintImplicit qid -> str"Print Implicit" ++ spc() ++ pr_smart_global qid -(* spiwack: command printing all the axioms and section variables used in a +(* spiwack: command printing all the axioms and section variables used in a term *) | PrintAssumptions (b,qid) -> (if b then str"Print Assumptions" else str"Print Opaque Dependencies") ++ spc() ++ pr_smart_global qid in pr_printable p | VernacSearch (sea,sea_r) -> pr_search sea sea_r pr_constr_pattern_expr - | VernacLocate loc -> + | VernacLocate loc -> let pr_locate =function | LocateTerm qid -> pr_smart_global qid | LocateFile f -> str"File" ++ spc() ++ qs f @@ -932,14 +932,14 @@ let rec pr_vernac = function hov 2 (str"Comments" ++ spc() ++ prlist_with_sep sep (pr_comment pr_constr) l) | VernacNop -> mt() - + (* Toplevel control *) | VernacToplevelControl exn -> pr_topcmd exn (* For extension *) | VernacExtend (s,c) -> pr_extend s c | VernacProof (Tacexpr.TacId _) -> str "Proof" - | VernacProof te -> str "Proof with" ++ spc() ++ pr_raw_tactic te + | VernacProof te -> str "Proof with" ++ spc() ++ pr_raw_tactic te and pr_extend s cl = let pr_arg a = @@ -951,7 +951,7 @@ and pr_extend s cl = let start,rl,cl = match rl with | Egrammar.GramTerminal s :: rl -> str s, rl, cl - | Egrammar.GramNonTerminal _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl + | Egrammar.GramNonTerminal _ :: rl -> pr_arg (List.hd cl), rl, List.tl cl | [] -> anomaly "Empty entry" in let (pp,_) = List.fold_left diff --git a/parsing/ppvernac.mli b/parsing/ppvernac.mli index 48e3698d43..c24744f300 100644 --- a/parsing/ppvernac.mli +++ b/parsing/ppvernac.mli @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - + (*i $Id$ i*) open Pp diff --git a/parsing/prettyp.ml b/parsing/prettyp.ml index 0518da327b..12a3bb572e 100644 --- a/parsing/prettyp.ml +++ b/parsing/prettyp.ml @@ -62,20 +62,20 @@ let with_line_skip p = if ismt p then mt() else (fnl () ++ p) (********************************) (** Printing implicit arguments *) - + let conjugate_to_be = function [_] -> "is" | _ -> "are" let pr_implicit imp = pr_id (name_of_implicit imp) let print_impl_args_by_name max = function | [] -> mt () - | impls -> - hov 0 (str (plural (List.length impls) "Argument") ++ spc() ++ - prlist_with_sep pr_coma pr_implicit impls ++ spc() ++ + | impls -> + hov 0 (str (plural (List.length impls) "Argument") ++ spc() ++ + prlist_with_sep pr_coma pr_implicit impls ++ spc() ++ str (conjugate_to_be impls) ++ str" implicit" ++ (if max then strbrk " and maximally inserted" else mt())) ++ fnl() -let print_impl_args l = +let print_impl_args l = let imps = List.filter is_status_implicit l in let maximps = List.filter Impargs.maximal_insertion_of imps in let nonmaximps = list_subtract imps maximps in @@ -87,23 +87,23 @@ let print_impl_args l = let print_ref reduce ref = let typ = Global.type_of_global ref in - let typ = + let typ = if reduce then let ctx,ccl = Reductionops.splay_prod_assum (Global.env()) Evd.empty typ - in it_mkProd_or_LetIn ccl ctx + in it_mkProd_or_LetIn ccl ctx else typ in hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ) ++ fnl () let print_argument_scopes = function | [Some sc] -> str"Argument scope is [" ++ str sc ++ str"]" ++ fnl() | l when not (List.for_all ((=) None) l) -> - hov 2 (str"Argument scopes are" ++ spc() ++ - str "[" ++ + hov 2 (str"Argument scopes are" ++ spc() ++ + str "[" ++ prlist_with_sep spc (function Some sc -> str sc | None -> str "_") l ++ str "]") ++ fnl() | _ -> mt() -let need_expansion impl ref = +let need_expansion impl ref = let typ = Global.type_of_global ref in let ctx = (prod_assum typ) in let nprods = List.length (List.filter (fun (_,b,_) -> b=None) ctx) in @@ -116,7 +116,7 @@ type opacity = | TransparentMaybeOpacified of Conv_oracle.level let opacity env = function - | VarRef v when pi2 (Environ.lookup_named v env) <> None -> + | VarRef v when pi2 (Environ.lookup_named v env) <> None -> Some(TransparentMaybeOpacified (Conv_oracle.get_strategy(VarKey v))) | ConstRef cst -> let cb = Environ.lookup_constant cst env in @@ -129,7 +129,7 @@ let opacity env = function let print_opacity ref = match opacity (Global.env()) ref with | None -> mt () - | Some s -> pr_global ref ++ str " is " ++ + | Some s -> pr_global ref ++ str " is " ++ str (match s with | FullyOpaque -> "opaque" | TransparentMaybeOpacified Conv_oracle.Opaque -> @@ -140,14 +140,14 @@ let print_opacity ref = "transparent (with expansion weight "^string_of_int n^")" | TransparentMaybeOpacified Conv_oracle.Expand -> "transparent (with minimal expansion weight)") ++ fnl() - + let print_name_infos ref = let impl = implicits_of_global ref in let scopes = Notation.find_arguments_scope ref in - let type_for_implicit = + let type_for_implicit = if need_expansion impl ref then (* Need to reduce since implicits are computed with products flattened *) - str "Expanded type for implicit arguments" ++ fnl () ++ + str "Expanded type for implicit arguments" ++ fnl () ++ print_ref true ref ++ fnl() else mt() in type_for_implicit ++ print_impl_args impl ++ print_argument_scopes scopes @@ -155,14 +155,14 @@ let print_name_infos ref = let print_id_args_data test pr id l = if List.exists test l then str"For " ++ pr_id id ++ str": " ++ pr l - else + else mt() let print_args_data_of_inductive_ids get test pr sp mipv = prvecti - (fun i mip -> + (fun i mip -> print_id_args_data test pr mip.mind_typename (get (IndRef (sp,i))) ++ - prvecti + prvecti (fun j idc -> print_id_args_data test pr idc (get (ConstructRef ((sp,i),j+1)))) mip.mind_consnames) @@ -173,7 +173,7 @@ let print_inductive_implicit_args = implicits_of_global is_status_implicit print_impl_args let print_inductive_argument_scopes = - print_args_data_of_inductive_ids + print_args_data_of_inductive_ids Notation.find_arguments_scope ((<>) None) print_argument_scopes (*********************) @@ -190,7 +190,7 @@ let locate_any_name ref = let module N = Nametab in let (loc,qid) = qualid_of_reference ref in try Term (N.locate qid) - with Not_found -> + with Not_found -> try Syntactic (N.locate_syndef qid) with Not_found -> try Dir (N.locate_dir qid) @@ -219,7 +219,7 @@ let pr_located_qualid = function str s ++ spc () ++ pr_dirpath dir | ModuleType (qid,_) -> str "Module Type" ++ spc () ++ pr_path (Nametab.full_name_modtype qid) - | Undefined qid -> + | Undefined qid -> pr_qualid qid ++ spc () ++ str "not a defined object." let print_located_qualid ref = @@ -231,7 +231,7 @@ let print_located_qualid ref = | SynDef kn -> Syntactic kn, N.shortest_qualid_of_syndef Idset.empty kn in match List.map expand (N.locate_extended_all qid) with - | [] -> + | [] -> let (dir,id) = repr_qualid qid in if dir = empty_dirpath then str "No object of basename " ++ pr_id id @@ -291,7 +291,7 @@ let print_constructors envpar names types = prlist_with_sep (fun () -> brk(1,0) ++ str "| ") (fun (id,c) -> pr_id id ++ str " : " ++ pr_lconstr_env envpar c) (Array.to_list (array_map2 (fun n t -> (n,t)) names types)) - in + in hv 0 (str " " ++ pc) let build_inductive sp tyi = @@ -300,7 +300,7 @@ let build_inductive sp tyi = let args = extended_rel_list 0 params in let env = Global.env() in let fullarity = match mip.mind_arity with - | Monomorphic ar -> ar.mind_user_arity + | Monomorphic ar -> ar.mind_user_arity | Polymorphic ar -> it_mkProd_or_LetIn (mkSort (Type ar.poly_level)) mip.mind_arity_ctxt in let arity = hnf_prod_applist env fullarity args in @@ -335,7 +335,7 @@ let get_fields = let id = match na with Name id -> id | Anonymous -> id_of_string "_" in prodec_rec ((id,false,substl subst b)::l) (mkVar id::subst) c | _ -> List.rev l - in + in prodec_rec [] [] let pr_record (sp,tyi) = @@ -345,15 +345,15 @@ let pr_record (sp,tyi) = let fields = get_fields cstrtypes.(0) in hov 0 ( hov 0 ( - str "Record " ++ pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++ + str "Record " ++ pr_global (IndRef (sp,tyi)) ++ brk(1,4) ++ print_params env params ++ - str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++ - str ":= " ++ pr_id cstrnames.(0)) ++ + str ": " ++ pr_lconstr_env envpar arity ++ brk(1,2) ++ + str ":= " ++ pr_id cstrnames.(0)) ++ brk(1,2) ++ hv 2 (str "{ " ++ prlist_with_sep (fun () -> str ";" ++ brk(2,0)) - (fun (id,b,c) -> - pr_id id ++ str (if b then " : " else " := ") ++ + (fun (id,b,c) -> + pr_id id ++ str (if b then " : " else " := ") ++ pr_lconstr_env envpar c) fields) ++ str" }") let gallina_print_inductive sp = @@ -364,11 +364,11 @@ let gallina_print_inductive sp = pr_record (List.hd names) else pr_mutual_inductive mib.mind_finite names) ++ fnl () ++ - with_line_skip + with_line_skip (print_inductive_implicit_args sp mipv ++ print_inductive_argument_scopes sp mipv) -let print_named_decl id = +let print_named_decl id = gallina_print_named_decl (Global.lookup_named id) ++ fnl () let gallina_print_section_variable id = @@ -391,26 +391,26 @@ let print_constant with_values sep sp = let val_0 = cb.const_body in let typ = ungeneralized_type_of_constant_type cb.const_type in hov 0 ( - match val_0 with - | None -> - str"*** [ " ++ - print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ + match val_0 with + | None -> + str"*** [ " ++ + print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" - | _ -> + | _ -> print_basename sp ++ str sep ++ cut () ++ (if with_values then print_typed_body (val_0,typ) else pr_ltype typ)) ++ fnl () let gallina_print_constant_with_infos sp = - print_constant true " = " sp ++ + print_constant true " = " sp ++ with_line_skip (print_name_infos (ConstRef sp)) let gallina_print_syntactic_def kn = let sep = " := " and qid = Nametab.shortest_qualid_of_syndef Idset.empty kn - and (vars,a) = Syntax_def.search_syntactic_definition dummy_loc kn in + and (vars,a) = Syntax_def.search_syntactic_definition dummy_loc kn in let c = Topconstr.rawconstr_of_aconstr dummy_loc a in - str "Notation " ++ pr_qualid qid ++ + str "Notation " ++ pr_qualid qid ++ prlist_with_sep spc pr_id (List.map fst vars) ++ str sep ++ Constrextern.without_symbols pr_lrawconstr c ++ fnl () @@ -419,7 +419,7 @@ let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) = and tag = object_tag lobj in match (oname,tag) with | (_,"VARIABLE") -> - (* Outside sections, VARIABLES still exist but only with universes + (* Outside sections, VARIABLES still exist but only with universes constraints *) (try Some(print_named_decl (basename sp)) with Not_found -> None) | (_,"CONSTANT") -> @@ -427,34 +427,34 @@ let gallina_print_leaf_entry with_values ((sp,kn as oname),lobj) = | (_,"INDUCTIVE") -> Some (gallina_print_inductive kn) | (_,"MODULE") -> - let (mp,_,l) = repr_kn kn in + let (mp,_,l) = repr_kn kn in Some (print_module with_values (MPdot (mp,l))) | (_,"MODULE TYPE") -> - let (mp,_,l) = repr_kn kn in + let (mp,_,l) = repr_kn kn in Some (print_modtype (MPdot (mp,l))) | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"| "COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None (* To deal with forgotten cases... *) | (_,s) -> None -let gallina_print_library_entry with_values ent = +let gallina_print_library_entry with_values ent = let pr_name (sp,_) = pr_id (basename sp) in match ent with - | (oname,Lib.Leaf lobj) -> + | (oname,Lib.Leaf lobj) -> gallina_print_leaf_entry with_values (oname,lobj) - | (oname,Lib.OpenedSection (dir,_)) -> + | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) - | (oname,Lib.ClosedSection _) -> + | (oname,Lib.ClosedSection _) -> Some (str " >>>>>>> Closed Section " ++ pr_name oname) | (_,Lib.CompilingLibrary (dir,_)) -> Some (str " >>>>>>> Library " ++ pr_dirpath dir) | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) - | (oname,Lib.ClosedModule _) -> + | (oname,Lib.ClosedModule _) -> Some (str " >>>>>>> Closed Module " ++ pr_name oname) | (oname,Lib.OpenedModtype _) -> Some (str " >>>>>>> Module Type " ++ pr_name oname) - | (oname,Lib.ClosedModtype _) -> + | (oname,Lib.ClosedModtype _) -> Some (str " >>>>>>> Closed Module Type " ++ pr_name oname) | (_,Lib.FrozenState _) -> None @@ -464,14 +464,14 @@ let gallina_print_leaf_entry with_values c = | None -> mt () | Some pp -> pp ++ fnl() -let gallina_print_context with_values = +let gallina_print_context with_values = let rec prec n = function - | h::rest when n = None or Option.get n > 0 -> + | h::rest when n = None or Option.get n > 0 -> (match gallina_print_library_entry with_values h with | None -> prec n rest | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) | _ -> mt () - in + in prec let gallina_print_eval red_fun env evmap _ {uj_val=trm;uj_type=typ} = @@ -520,16 +520,16 @@ let print_typed_value x = print_typed_value_in_env (Global.env ()) x let print_judgment env {uj_val=trm;uj_type=typ} = print_typed_value_in_env env (trm, typ) - + let print_safe_judgment env j = let trm = Safe_typing.j_val j in let typ = Safe_typing.j_type j in print_typed_value_in_env env (trm, typ) - + (*********************) (* *) -let print_full_context () = +let print_full_context () = print_context true None (Lib.contents_after None) let print_full_context_typ () = @@ -545,28 +545,28 @@ let print_full_pure_context () = let val_0 = cb.const_body in let typ = ungeneralized_type_of_constant_type cb.const_type in hov 0 ( - match val_0 with + match val_0 with | None -> str (if cb.const_opaque then "Axiom " else "Parameter ") ++ print_basename con ++ str " : " ++ cut () ++ pr_ltype typ | Some v -> if cb.const_opaque then - str "Theorem " ++ print_basename con ++ cut () ++ + str "Theorem " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype typ ++ str "." ++ fnl () ++ str "Proof " ++ print_body val_0 else - str "Definition " ++ print_basename con ++ cut () ++ + str "Definition " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype typ ++ cut () ++ str " := " ++ print_body val_0) ++ str "." ++ fnl () ++ fnl () | "INDUCTIVE" -> let (mib,mip) = Global.lookup_inductive (kn,0) in let mipv = mib.mind_packets in let names = list_tabulate (fun x -> (kn,x)) (Array.length mipv) in - pr_mutual_inductive mib.mind_finite names ++ str "." ++ + pr_mutual_inductive mib.mind_finite names ++ str "." ++ fnl () ++ fnl () | "MODULE" -> (* TODO: make it reparsable *) - let (mp,_,l) = repr_kn kn in + let (mp,_,l) = repr_kn kn in print_module true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | "MODULE TYPE" -> (* TODO: make it reparsable *) @@ -576,7 +576,7 @@ let print_full_pure_context () = | _ -> mt () in prec rest ++ pp | _::rest -> prec rest - | _ -> mt () in + | _ -> mt () in prec (Lib.contents_after None) (* For printing an inductive definition with @@ -584,14 +584,14 @@ let print_full_pure_context () = assume that the declaration of constructors and eliminations follows the definition of the inductive type *) -let list_filter_vec f vec = - let rec frec n lf = - if n < 0 then lf - else if f vec.(n) then +let list_filter_vec f vec = + let rec frec n lf = + if n < 0 then lf + else if f vec.(n) then frec (n-1) (vec.(n)::lf) - else + else frec (n-1) lf - in + in frec (Array.length vec -1) [] (* This is designed to print the contents of an opened section *) @@ -608,12 +608,12 @@ let read_sec_context r = error "Cannot print the contents of a closed section." (* LEM: Actually, we could if we wanted to. *) | [] -> [] - | hd::rest -> get_cxt (hd::in_cxt) rest + | hd::rest -> get_cxt (hd::in_cxt) rest in let cxt = (Lib.contents_after None) in List.rev (get_cxt [] cxt) -let print_sec_context sec = +let print_sec_context sec = print_context true None (read_sec_context sec) let print_sec_context_typ sec = @@ -630,9 +630,9 @@ let print_any_name = function | ModuleType (_,kn) -> print_modtype kn | Undefined qid -> try (* Var locale de but, pas var de section... donc pas d'implicits *) - let dir,str = repr_qualid qid in + let dir,str = repr_qualid qid in if (repr_dirpath dir) <> [] then raise Not_found; - let (_,c,typ) = Global.lookup_named str in + let (_,c,typ) = Global.lookup_named str in (print_named_decl (str,c,typ)) with Not_found -> errorlabstrm @@ -641,33 +641,33 @@ let print_any_name = function let print_name = function | Genarg.ByNotation (loc,ntn,sc) -> print_any_name - (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true) + (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true) ntn sc)) | Genarg.AN ref -> print_any_name (locate_any_name ref) -let print_opaque_name qid = +let print_opaque_name qid = let env = Global.env () in match global qid with | ConstRef cst -> let cb = Global.lookup_constant cst in if cb.const_body <> None then print_constant_with_infos cst - else + else error "Not a defined constant." | IndRef (sp,_) -> print_inductive sp - | ConstructRef cstr -> + | ConstructRef cstr -> let ty = Inductiveops.type_of_constructor env cstr in print_typed_value (mkConstruct cstr, ty) | VarRef id -> - let (_,c,ty) = lookup_named id env in + let (_,c,ty) = lookup_named id env in print_named_decl (id,c,ty) let print_about_any k = begin match k with | Term ref -> - print_ref false ref ++ fnl () ++ print_name_infos ref ++ + print_ref false ref ++ fnl () ++ print_name_infos ref ++ print_opacity ref | Syntactic kn -> print_syntactic_def kn @@ -679,7 +679,7 @@ let print_about_any k = let print_about = function | Genarg.ByNotation (loc,ntn,sc) -> print_about_any - (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true) + (Term (Notation.interp_notation_as_global_reference loc (fun _ -> true) ntn sc)) | Genarg.AN ref -> print_about_any (locate_any_name ref) @@ -690,20 +690,20 @@ let print_impargs ref = let has_impl = List.filter is_status_implicit impl <> [] in (* Need to reduce since implicits are computed with products flattened *) print_ref (need_expansion impl ref) ref ++ fnl() ++ - (if has_impl then print_impl_args impl + (if has_impl then print_impl_args impl else (str "No implicit arguments" ++ fnl ())) -let unfold_head_fconst = +let unfold_head_fconst = let rec unfrec k = match kind_of_term k with - | Const cst -> constant_value (Global.env ()) cst + | Const cst -> constant_value (Global.env ()) cst | Lambda (na,t,b) -> mkLambda (na,t,unfrec b) | App (f,v) -> appvect (unfrec f,v) | _ -> k - in + in unfrec (* for debug *) -let inspect depth = +let inspect depth = print_context false (Some depth) (Lib.contents_after None) @@ -717,8 +717,8 @@ let print_coercion_value v = pr_lconstr (get_coercion_value v) let print_class i = let cl,_ = class_info_from_index i in pr_class cl - -let print_path ((i,j),p) = + +let print_path ((i,j),p) = hov 2 ( str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++ str"] : ") ++ @@ -726,45 +726,45 @@ let print_path ((i,j),p) = let _ = Classops.install_path_printer print_path -let print_graph () = +let print_graph () = prlist_with_sep pr_fnl print_path (inheritance_graph()) -let print_classes () = +let print_classes () = prlist_with_sep pr_spc pr_class (classes()) -let print_coercions () = +let print_coercions () = prlist_with_sep pr_spc print_coercion_value (coercions()) - + let index_of_class cl = - try + try fst (class_info cl) - with _ -> + with _ -> errorlabstrm "index_of_class" (pr_class cl ++ spc() ++ str "not a defined class.") -let print_path_between cls clt = +let print_path_between cls clt = let i = index_of_class cls in let j = index_of_class clt in - let p = - try - lookup_path_between_class (i,j) - with _ -> + let p = + try + lookup_path_between_class (i,j) + with _ -> errorlabstrm "index_cl_of_id" (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") in print_path ((i,j),p) -let pr_cs_pattern = function +let pr_cs_pattern = function Const_cs c -> pr_global c | Prod_cs -> str "_ -> _" | Default_cs -> str "_" | Sort_cs s -> pr_sort_family s let print_canonical_projections () = - prlist_with_sep pr_fnl - (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ - str " <- " ++ + prlist_with_sep pr_fnl + (fun ((r1,r2),o) -> pr_cs_pattern r2 ++ + str " <- " ++ pr_global r1 ++ str " ( " ++ pr_lconstr o.o_DEF ++ str " )") (canonical_projections ()) @@ -775,25 +775,25 @@ let print_canonical_projections () = open Typeclasses -let pr_typeclass env t = +let pr_typeclass env t = print_ref false t.cl_impl let print_typeclasses () = let env = Global.env () in prlist_with_sep fnl (pr_typeclass env) (typeclasses ()) - -let pr_instance env i = + +let pr_instance env i = (* gallina_print_constant_with_infos i.is_impl *) (* lighter *) print_ref false (ConstRef (instance_impl i)) - + let print_all_instances () = let env = Global.env () in - let inst = all_instances () in + let inst = all_instances () in prlist_with_sep fnl (pr_instance env) inst let print_instances r = let env = Global.env () in - let inst = instances r in + let inst = instances r in prlist_with_sep fnl (pr_instance env) inst - + diff --git a/parsing/printer.ml b/parsing/printer.ml index b23f94a70f..eacad74c4c 100644 --- a/parsing/printer.ml +++ b/parsing/printer.ml @@ -29,11 +29,11 @@ open Ppconstr open Constrextern open Tacexpr -let emacs_str s alts = +let emacs_str s alts = match !Flags.print_emacs, !Flags.print_emacs_safechar with | true, true -> alts | true , false -> s - | false,_ -> "" + | false,_ -> "" (**********************************************************************) (** Terms *) @@ -77,7 +77,7 @@ let pr_ljudge j = pr_ljudge_env (Global.env()) j let pr_lrawconstr_env env c = pr_lconstr_expr (extern_rawconstr (vars_of_env env) c) -let pr_rawconstr_env env c = +let pr_rawconstr_env env c = pr_constr_expr (extern_rawconstr (vars_of_env env) c) let pr_lrawconstr c = @@ -130,7 +130,7 @@ let pr_var_decl env (id,c,typ) = let pbody = match c with | None -> (mt ()) | Some c -> - (* Force evaluation *) + (* Force evaluation *) let pb = pr_lconstr_env env c in let pb = if isCast c then surround pb else pb in (str" := " ++ pb ++ cut () ) in @@ -142,7 +142,7 @@ let pr_rel_decl env (na,c,typ) = let pbody = match c with | None -> mt () | Some c -> - (* Force evaluation *) + (* Force evaluation *) let pb = pr_lconstr_env env c in let pb = if isCast c then surround pb else pb in (str":=" ++ spc () ++ pb ++ spc ()) in @@ -162,7 +162,7 @@ let pr_named_context_of env = let psl = List.rev (fold_named_context make_decl_list env ~init:[]) in hv 0 (prlist_with_sep (fun _ -> ws 2) (fun x -> x) psl) -let pr_named_context env ne_context = +let pr_named_context env ne_context = hv 0 (Sign.fold_named_context (fun d pps -> pps ++ ws 2 ++ pr_var_decl env d) ne_context ~init:(mt ())) @@ -179,14 +179,14 @@ let pr_context_unlimited env = fold_named_context (fun env d pps -> let pidt = pr_var_decl env d in (pps ++ fnl () ++ pidt)) - env ~init:(mt ()) + env ~init:(mt ()) in let db_env = fold_rel_context (fun env d pps -> let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat)) env ~init:(mt ()) - in + in (sign_env ++ db_env) let pr_ne_context_of header env = @@ -197,21 +197,21 @@ let pr_ne_context_of header env = let pr_context_limit n env = let named_context = Environ.named_context env in let lgsign = List.length named_context in - if n >= lgsign then + if n >= lgsign then pr_context_unlimited env else let k = lgsign-n in let _,sign_env = fold_named_context (fun env d (i,pps) -> - if i < k then + if i < k then (i+1, (pps ++str ".")) else let pidt = pr_var_decl env d in (i+1, (pps ++ fnl () ++ str (emacs_str (String.make 1 (Char.chr 253)) "") ++ pidt))) - env ~init:(0,(mt ())) + env ~init:(0,(mt ())) in let db_env = fold_rel_context @@ -221,10 +221,10 @@ let pr_context_limit n env = str (emacs_str (String.make 1 (Char.chr 253)) "") ++ pnat)) env ~init:(mt ()) - in + in (sign_env ++ db_env) -let pr_context_of env = match Flags.print_hyps_limit () with +let pr_context_of env = match Flags.print_hyps_limit () with | None -> hv 0 (pr_context_unlimited env) | Some n -> hv 0 (pr_context_limit n env) @@ -234,33 +234,33 @@ let pr_restricted_named_context among env = hv 0 (fold_named_context (fun env ((id,_,_) as d) pps -> if true || Idset.mem id among then - pps ++ + pps ++ fnl () ++ str (emacs_str (String.make 1 (Char.chr 253)) "") ++ pr_var_decl env d - else + else pps) env ~init:(mt ())) -let pr_predicate pr_elt (b, elts) = +let pr_predicate pr_elt (b, elts) = let pr_elts = prlist_with_sep spc pr_elt elts in if b then - str"all" ++ + str"all" ++ (if elts = [] then mt () else str" except: " ++ pr_elts) else if elts = [] then str"none" else pr_elts - + let pr_cpred p = pr_predicate pr_con (Cpred.elements p) let pr_idpred p = pr_predicate Nameops.pr_id (Idpred.elements p) -let pr_transparent_state (ids, csts) = +let pr_transparent_state (ids, csts) = hv 0 (str"VARIABLES: " ++ pr_idpred ids ++ fnl () ++ str"CONSTANTS: " ++ pr_cpred csts ++ fnl ()) let pr_subgoal_metas metas env= - let pr_one (meta,typ) = - str "?" ++ int meta ++ str " : " ++ - hov 0 (pr_ltype_env_at_top env typ) ++ fnl () ++ + let pr_one (meta,typ) = + str "?" ++ int meta ++ str " : " ++ + hov 0 (pr_ltype_env_at_top env typ) ++ fnl () ++ str (emacs_str (String.make 1 (Char.chr 253)) "") in hv 0 (prlist_with_sep mt pr_one metas) @@ -272,7 +272,7 @@ let default_pr_goal g = mt (), mt (), pr_context_of env, pr_ltype_env_at_top env g.evar_concl - else + else (str " *** Declarative Mode ***" ++ fnl ()++fnl ()), (str "thesis := " ++ fnl ()), pr_context_of env, @@ -283,7 +283,7 @@ let default_pr_goal g = str (emacs_str (String.make 1 (Char.chr 253)) "") ++ str "============================" ++ fnl () ++ thesis ++ str " " ++ pc) ++ fnl () - + (* display the conclusion of a goal *) let pr_concl n g = let env = evar_env g in @@ -292,7 +292,7 @@ let pr_concl n g = str "subgoal " ++ int n ++ str " is:" ++ cut () ++ str" " ++ pc (* display evar type: a context and a type *) -let pr_evgl_sign gl = +let pr_evgl_sign gl = let ps = pr_named_context_of (evar_unfiltered_env gl) in let _,l = list_filter2 (fun b c -> not b) (evar_filter gl,evar_context gl) in let ids = List.rev (List.map pi1 l) in @@ -307,10 +307,10 @@ let pr_evgl_sign gl = let rec pr_evars_int i = function | [] -> (mt ()) | (ev,evd)::rest -> - let pegl = pr_evgl_sign evd in + let pegl = pr_evgl_sign evd in let pei = pr_evars_int (i+1) rest in (hov 0 (str "Existential " ++ int i ++ str " =" ++ spc () ++ - str (string_of_existential ev) ++ str " : " ++ pegl)) ++ + str (string_of_existential ev) ++ str " : " ++ pegl)) ++ fnl () ++ pei let default_pr_subgoal n = @@ -320,22 +320,22 @@ let default_pr_subgoal n = if p = 1 then let pg = default_pr_goal g in v 0 (str "subgoal " ++ int n ++ str " is:" ++ cut () ++ pg) - else + else prrec (p-1) rest - in + in prrec n (* Print open subgoals. Checks for uninstantiated existential variables *) -let default_pr_subgoals close_cmd sigma = function - | [] -> +let default_pr_subgoals close_cmd sigma = function + | [] -> begin match close_cmd with Some cmd -> - (str "Subproof completed, now type " ++ str cmd ++ + (str "Subproof completed, now type " ++ str cmd ++ str "." ++ fnl ()) | None -> - let exl = Evarutil.non_instantiated sigma in - if exl = [] then + let exl = Evarutil.non_instantiated sigma in + if exl = [] then (str"Proof completed." ++ fnl ()) else let pei = pr_evars_int 1 exl in @@ -351,11 +351,11 @@ let default_pr_subgoals close_cmd sigma = function | g::rest -> let pc = pr_concl n g in let prest = pr_rec (n+1) rest in - (cut () ++ pc ++ prest) + (cut () ++ pc ++ prest) in let pg1 = default_pr_goal g1 in let prest = pr_rec 2 rest in - v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () + v 0 (int(List.length rest+1) ++ str" subgoals" ++ cut () ++ pg1 ++ prest ++ fnl ()) @@ -388,17 +388,17 @@ let pr_goal x = !printer_pr.pr_goal x let pr_open_subgoals () = let pfts = get_pftreestate () in - let gls = fst (frontier (proof_of_pftreestate pfts)) in + let gls = fst (frontier (proof_of_pftreestate pfts)) in match focus() with - | 0 -> + | 0 -> let sigma = (top_goal_of_pftreestate pfts).sigma in let close_cmd = Decl_mode.get_end_command pfts in pr_subgoals close_cmd sigma gls - | n -> + | n -> assert (n > List.length gls); - if List.length gls < 2 then + if List.length gls < 2 then pr_subgoal n gls - else + else (* LEM TODO: this way of saying how many subgoals has to be abstracted out*) v 0 (int(List.length gls) ++ str" subgoals" ++ cut () ++ pr_subgoal n gls) @@ -410,25 +410,25 @@ let pr_nth_open_subgoal n = (* Elementary tactics *) let pr_prim_rule = function - | Intro id -> + | Intro id -> str"intro " ++ pr_id id - + | Cut (b,replace,id,t) -> if b then (* TODO: express "replace" *) (str"assert " ++ str"(" ++ pr_id id ++ str":" ++ pr_lconstr t ++ str")") else let cl = if replace then str"clear " ++ pr_id id ++ str"; " else mt() in - (str"cut " ++ pr_constr t ++ + (str"cut " ++ pr_constr t ++ str ";[" ++ cl ++ str"intro " ++ pr_id id ++ str"|idtac]") - + | FixRule (f,n,[],_) -> (str"fix " ++ pr_id f ++ str"/" ++ int n) - - | FixRule (f,n,others,j) -> + + | FixRule (f,n,others,j) -> if j<>0 then warning "Unsupported printing of \"fix\""; let rec print_mut = function - | (f,n,ar)::oth -> + | (f,n,ar)::oth -> pr_id f ++ str"/" ++ int n ++ str" : " ++ pr_lconstr ar ++ print_mut oth | [] -> mt () in (str"fix " ++ pr_id f ++ str"/" ++ int n ++ @@ -444,26 +444,26 @@ let pr_prim_rule = function (pr_id f ++ str" : " ++ pr_lconstr ar ++ print_mut oth) | [] -> mt () in (str"cofix " ++ pr_id f ++ str" with " ++ print_mut others) - | Refine c -> + | Refine c -> str(if occur_meta c then "refine " else "exact ") ++ Constrextern.with_meta_as_hole pr_constr c - + | Convert_concl (c,_) -> (str"change " ++ pr_constr c) - + | Convert_hyp (id,None,t) -> (str"change " ++ pr_constr t ++ spc () ++ str"in " ++ pr_id id) | Convert_hyp (id,Some c,t) -> (str"change " ++ pr_constr c ++ spc () ++ str"in " ++ pr_id id ++ str" (type of " ++ pr_id id ++ str ")") - + | Thin ids -> (str"clear " ++ prlist_with_sep pr_spc pr_id ids) - + | ThinBody ids -> (str"clearbody " ++ prlist_with_sep pr_spc pr_id ids) - + | Move (withdep,id1,id2) -> (str (if withdep then "dependent " else "") ++ str"move " ++ pr_id id1 ++ pr_move_location pr_id id2) @@ -488,7 +488,7 @@ let prterm = pr_lconstr (* spiwack: printer function for sets of Environ.assumption. It is used primarily by the Print Assumption command. *) -let pr_assumptionset env s = +let pr_assumptionset env s = if (Environ.ContextObjectMap.is_empty s) then str "Closed under the global context" else @@ -497,7 +497,7 @@ let pr_assumptionset env s = let (v,a,o) = r in match t with | Variable id -> ( Some ( - Option.default (fnl ()) v + Option.default (fnl ()) v ++ str (string_of_id id) ++ str " : " ++ pr_ltype typ @@ -527,7 +527,7 @@ let pr_assumptionset env s = ) s (None,None,None) in - let (vars,axioms,opaque) = + let (vars,axioms,opaque) = ( Option.map (fun p -> str "Section Variables:" ++ p) vars , Option.map (fun p -> str "Axioms:" ++ p) axioms , Option.map (fun p -> str "Opaque constants:" ++ p) opaque @@ -540,9 +540,9 @@ let cmap_to_list m = Cmap.fold (fun k v acc -> v :: acc) m [] open Typeclasses -let pr_instance i = +let pr_instance i = pr_global (ConstRef (instance_impl i)) - + let pr_instance_gmap insts = prlist_with_sep fnl (fun (gr, insts) -> prlist_with_sep fnl pr_instance (cmap_to_list insts)) diff --git a/parsing/printer.mli b/parsing/printer.mli index 32f0519480..1797eaf22b 100644 --- a/parsing/printer.mli +++ b/parsing/printer.mli @@ -112,8 +112,8 @@ val pr_evars_int : int -> (evar * evar_info) list -> std_ppcmds val pr_prim_rule : prim_rule -> std_ppcmds (* Emacs/proof general support *) -(* (emacs_str s alts) outputs - - s if emacs mode & unicode allowed, +(* (emacs_str s alts) outputs + - s if emacs mode & unicode allowed, - alts if emacs mode and & unicode not allowed - nothing otherwise *) val emacs_str : string -> string -> string diff --git a/parsing/printmod.ml b/parsing/printmod.ml index 2ec914d6cd..a5470a8924 100644 --- a/parsing/printmod.ml +++ b/parsing/printmod.ml @@ -13,8 +13,8 @@ open Declarations open Nameops open Libnames -let get_new_id locals id = - let rec get_id l id = +let get_new_id locals id = + let rec get_id l id = let dir = make_dirpath [id] in if not (Nametab.exists_module dir) then id @@ -29,19 +29,19 @@ let rec print_local_modpath locals = function print_local_modpath locals mp ++ str "." ++ pr_lab l | MPself _ | MPfile _ -> raise Not_found -let print_modpath locals mp = +let print_modpath locals mp = try (* must be with let because streams are lazy! *) - let qid = Nametab.shortest_qualid_of_module mp in + let qid = Nametab.shortest_qualid_of_module mp in pr_qualid qid with | Not_found -> print_local_modpath locals mp -let print_kn locals kn = +let print_kn locals kn = try - let qid = Nametab.shortest_qualid_of_modtype kn in + let qid = Nametab.shortest_qualid_of_modtype kn in pr_qualid qid with - Not_found -> + Not_found -> try print_local_modpath locals kn with @@ -52,50 +52,50 @@ let rec flatten_app mexpr l = match mexpr with | mexpr -> mexpr::l let rec print_module name locals with_body mb = - let body = match with_body, mb.mod_expr with - | false, _ + let body = match with_body, mb.mod_expr with + | false, _ | true, None -> mt() - | true, Some mexpr -> + | true, Some mexpr -> spc () ++ str ":= " ++ print_modexpr locals mexpr in let modtype = match mb.mod_type with None -> str "" - | Some t -> spc () ++ str": " ++ + | Some t -> spc () ++ str": " ++ print_modtype locals t in hv 2 (str "Module " ++ name ++ modtype ++ body) -and print_modtype locals mty = +and print_modtype locals mty = match mty with | SEBident kn -> print_kn locals kn | SEBfunctor (mbid,mtb1,mtb2) -> - (* let env' = Modops.add_module (MPbid mbid) - (Modops.body_of_type mtb) env - in *) + (* let env' = Modops.add_module (MPbid mbid) + (Modops.body_of_type mtb) env + in *) let locals' = (mbid, get_new_id locals (id_of_mbid mbid)) ::locals in - hov 2 (str "Funsig" ++ spc () ++ str "(" ++ - pr_id (id_of_mbid mbid) ++ str " : " ++ - print_modtype locals mtb1.typ_expr ++ + hov 2 (str "Funsig" ++ spc () ++ str "(" ++ + pr_id (id_of_mbid mbid) ++ str " : " ++ + print_modtype locals mtb1.typ_expr ++ str ")" ++ spc() ++ print_modtype locals' mtb2) - | SEBstruct (msid,sign) -> + | SEBstruct (msid,sign) -> hv 2 (str "Sig" ++ spc () ++ print_sig locals msid sign ++ brk (1,-2) ++ str "End") - | SEBapply (mexpr,marg,_) -> + | SEBapply (mexpr,marg,_) -> let lapp = flatten_app mexpr [marg] in let fapp = List.hd lapp in let mapp = List.tl lapp in - hov 3 (str"(" ++ (print_modtype locals fapp) ++ spc () ++ + hov 3 (str"(" ++ (print_modtype locals fapp) ++ spc () ++ prlist_with_sep spc (print_modexpr locals) mapp ++ str")") | SEBwith(seb,With_definition_body(idl,cb))-> let s = (String.concat "." (List.map string_of_id idl)) in - hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ + hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ str "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) | SEBwith(seb,With_module_body(idl,mp,_,_))-> let s =(String.concat "." (List.map string_of_id idl)) in - hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ + hov 2 (print_modtype locals seb ++ spc() ++ str "with" ++ spc() ++ str "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) -and print_sig locals msid sign = +and print_sig locals msid sign = let print_spec (l,spec) = (match spec with | SFBconst {const_body=Some _; const_opaque=false} -> str "Definition " | SFBconst {const_body=None} @@ -107,7 +107,7 @@ and print_sig locals msid sign = in prlist_with_sep spc print_spec sign -and print_struct locals msid struc = +and print_struct locals msid struc = let print_body (l,body) = (match body with | SFBconst {const_body=Some _; const_opaque=false} -> str "Definition " | SFBconst {const_body=Some _; const_opaque=true} -> str "Theorem " @@ -119,41 +119,41 @@ and print_struct locals msid struc = in prlist_with_sep spc print_body struc -and print_modexpr locals mexpr = match mexpr with +and print_modexpr locals mexpr = match mexpr with | SEBident mp -> print_modpath locals mp | SEBfunctor (mbid,mty,mexpr) -> -(* let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env +(* let env' = Modops.add_module (MPbid mbid) (Modops.body_of_type mtb) env in *) let locals' = (mbid, get_new_id locals (id_of_mbid mbid))::locals in - hov 2 (str "Functor" ++ spc() ++ str"(" ++ pr_id(id_of_mbid mbid) ++ - str ":" ++ print_modtype locals mty.typ_expr ++ + hov 2 (str "Functor" ++ spc() ++ str"(" ++ pr_id(id_of_mbid mbid) ++ + str ":" ++ print_modtype locals mty.typ_expr ++ str ")" ++ spc () ++ print_modexpr locals' mexpr) - | SEBstruct (msid, struc) -> + | SEBstruct (msid, struc) -> hv 2 (str "Struct" ++ spc () ++ print_struct locals msid struc ++ brk (1,-2) ++ str "End") - | SEBapply (mexpr,marg,_) -> + | SEBapply (mexpr,marg,_) -> let lapp = flatten_app mexpr [marg] in hov 3 (str"(" ++ prlist_with_sep spc (print_modexpr locals) lapp ++ str")") | SEBwith (_,_)-> anomaly "Not avaible yet" -let rec printable_body dir = +let rec printable_body dir = let dir = pop_dirpath dir in - dir = empty_dirpath || - try + dir = empty_dirpath || + try match Nametab.locate_dir (qualid_of_dirpath dir) with DirOpenModtype _ -> false | DirModule _ | DirOpenModule _ -> printable_body dir | _ -> true - with + with Not_found -> true -let print_module with_body mp = +let print_module with_body mp = let name = print_modpath [] mp in print_module name [] with_body (Global.lookup_module mp) ++ fnl () -let print_modtype kn = +let print_modtype kn = let mtb = Global.lookup_modtype kn in let name = print_kn [] kn in - str "Module Type " ++ name ++ str " = " ++ + str "Module Type " ++ name ++ str " = " ++ print_modtype [] mtb.typ_expr ++ fnl () diff --git a/parsing/q_constr.ml4 b/parsing/q_constr.ml4 index a796cef822..093910b4d4 100644 --- a/parsing/q_constr.ml4 +++ b/parsing/q_constr.ml4 @@ -21,8 +21,8 @@ open Pcaml let loc = dummy_loc let dloc = <:expr< Util.dummy_loc >> -let apply_ref f l = - <:expr< +let apply_ref f l = + <:expr< Rawterm.RApp ($dloc$, Rawterm.RRef ($dloc$, Lazy.force $f$), $mlexpr_of_list (fun x -> x) l$) >> @@ -57,13 +57,13 @@ EXTEND (* fix todo *) ] | "100" RIGHTA - [ c1 = constr; ":"; c2 = SELF -> + [ c1 = constr; ":"; c2 = SELF -> <:expr< Rawterm.RCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ] | "90" RIGHTA - [ c1 = constr; "->"; c2 = SELF -> + [ c1 = constr; "->"; c2 = SELF -> <:expr< Rawterm.RProd ($dloc$,Anonymous,Rawterm.Explicit,$c1$,$c2$) >> ] | "75" RIGHTA - [ "~"; c = constr -> + [ "~"; c = constr -> apply_ref <:expr< coq_not_ref >> [c] ] | "70" RIGHTA [ c1 = constr; "="; c2 = NEXT; ":>"; t = NEXT -> @@ -85,26 +85,26 @@ EXTEND ; match_constr: [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type; - "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" -> + "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" -> let br = mlexpr_of_list (fun x -> x) br in - <:expr< Rawterm.RCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> + <:expr< Rawterm.RCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> ] ] ; match_type: - [ [ "as"; id = ident; "in"; ind = LIDENT; nal = LIST0 name; - "return"; ty = constr LEVEL "100" -> + [ [ "as"; id = ident; "in"; ind = LIDENT; nal = LIST0 name; + "return"; ty = constr LEVEL "100" -> let nal = mlexpr_of_list (fun x -> x) nal in - <:expr< Some $ty$ >>, - <:expr< (Name $id$, Some ($dloc$,$lid:ind$,$nal$)) >> + <:expr< Some $ty$ >>, + <:expr< (Name $id$, Some ($dloc$,$lid:ind$,$nal$)) >> | -> <:expr< None >>, <:expr< (Anonymous, None) >> ] ] ; eqn: - [ [ (lid,pl) = pattern; "=>"; rhs = constr -> + [ [ (lid,pl) = pattern; "=>"; rhs = constr -> let lid = mlexpr_of_list (fun x -> x) lid in - <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >> + <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >> ] ] ; - pattern: + pattern: [ [ "%"; e = string; lip = LIST0 patvar -> let lp = mlexpr_of_list (fun (_,x) -> x) lip in let lid = List.flatten (List.map fst lip) in @@ -113,13 +113,13 @@ EXTEND | "("; p = pattern; ")" -> p ] ] ; patvar: - [ [ "_" -> [], <:expr< Rawterm.PatVar ($dloc$,Anonymous) >> - | id = ident -> [id], <:expr< Rawterm.PatVar ($dloc$,Name $id$) >> + [ [ "_" -> [], <:expr< Rawterm.PatVar ($dloc$,Anonymous) >> + | id = ident -> [id], <:expr< Rawterm.PatVar ($dloc$,Name $id$) >> ] ] ; END;; -(* Example +(* Example open Coqlib let a = PATTERN [ match ?X with %path_of_S n => n | %path_of_O => ?X end ] *) diff --git a/parsing/q_coqast.ml4 b/parsing/q_coqast.ml4 index 91cb681a5d..cd3e7d2a83 100644 --- a/parsing/q_coqast.ml4 +++ b/parsing/q_coqast.ml4 @@ -28,11 +28,11 @@ IFDEF CAMLP5 THEN DEFINE NOP END let anti loc x = let e = let loc = - IFDEF NOP THEN + IFDEF NOP THEN loc - ELSE + ELSE (1, snd loc - fst loc) - END + END in <:expr< $lid:purge_str x$ >> in <:expr< $anti:e$ >> @@ -47,7 +47,7 @@ let mlexpr_of_ident id = let mlexpr_of_name = function | Names.Anonymous -> <:expr< Names.Anonymous >> - | Names.Name id -> + | Names.Name id -> <:expr< Names.Name (Names.id_of_string $str:Names.string_of_id id$) >> let mlexpr_of_dirpath dir = @@ -68,7 +68,7 @@ let mlexpr_of_loc loc = <:expr< $dloc$ >> let mlexpr_of_by_notation f = function | Genarg.AN x -> <:expr< Genarg.AN $f x$ >> - | Genarg.ByNotation (loc,s,sco) -> + | Genarg.ByNotation (loc,s,sco) -> <:expr< Genarg.ByNotation $dloc$ $str:s$ $mlexpr_of_option mlexpr_of_string sco$ >> let mlexpr_of_intro_pattern = function @@ -134,14 +134,14 @@ let mlexpr_of_red_flags { let mlexpr_of_explicitation = function | Topconstr.ExplByName id -> <:expr< Topconstr.ExplByName $mlexpr_of_ident id$ >> | Topconstr.ExplByPos (n,_id) -> <:expr< Topconstr.ExplByPos $mlexpr_of_int n$ >> - + let mlexpr_of_binding_kind = function | Rawterm.Implicit -> <:expr< Rawterm.Implicit >> | Rawterm.Explicit -> <:expr< Rawterm.Explicit >> let mlexpr_of_binder_kind = function | Topconstr.Default b -> <:expr< Topconstr.Default $mlexpr_of_binding_kind b$ >> - | Topconstr.Generalized (b,b',b'') -> + | Topconstr.Generalized (b,b',b'') -> <:expr< Topconstr.TypeClass $mlexpr_of_binding_kind b$ $mlexpr_of_binding_kind b'$ $mlexpr_of_bool b''$ >> @@ -153,7 +153,7 @@ let rec mlexpr_of_constr = function | Topconstr.CCoFix (loc,_,_) -> failwith "mlexpr_of_constr: TODO" | Topconstr.CArrow (loc,a,b) -> <:expr< Topconstr.CArrow $dloc$ $mlexpr_of_constr a$ $mlexpr_of_constr b$ >> - | Topconstr.CProdN (loc,l,a) -> <:expr< Topconstr.CProdN $dloc$ $mlexpr_of_list + | Topconstr.CProdN (loc,l,a) -> <:expr< Topconstr.CProdN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> | Topconstr.CLambdaN (loc,l,a) -> <:expr< Topconstr.CLambdaN $dloc$ $mlexpr_of_list (mlexpr_of_triple (mlexpr_of_list (mlexpr_of_pair (fun _ -> dloc) mlexpr_of_name)) mlexpr_of_binder_kind mlexpr_of_constr) l$ $mlexpr_of_constr a$ >> | Topconstr.CLetIn (loc,_,_,_) -> failwith "mlexpr_of_constr: TODO" @@ -164,10 +164,10 @@ let rec mlexpr_of_constr = function | Topconstr.CHole (loc, Some _) -> failwith "mlexpr_of_constr: TODO CHole (Some _)" | Topconstr.CNotation(_,ntn,subst) -> <:expr< Topconstr.CNotation $dloc$ $mlexpr_of_string ntn$ - $mlexpr_of_pair + $mlexpr_of_pair (mlexpr_of_list mlexpr_of_constr) (mlexpr_of_list (mlexpr_of_list mlexpr_of_constr)) subst$ >> - | Topconstr.CPatVar (loc,n) -> + | Topconstr.CPatVar (loc,n) -> <:expr< Topconstr.CPatVar $dloc$ $mlexpr_of_pair mlexpr_of_bool mlexpr_of_ident n$ >> | _ -> failwith "mlexpr_of_constr: TODO" @@ -216,7 +216,7 @@ let rec mlexpr_of_argtype loc = function | Genarg.List0ArgType t -> <:expr< Genarg.List0ArgType $mlexpr_of_argtype loc t$ >> | Genarg.List1ArgType t -> <:expr< Genarg.List1ArgType $mlexpr_of_argtype loc t$ >> | Genarg.OptArgType t -> <:expr< Genarg.OptArgType $mlexpr_of_argtype loc t$ >> - | Genarg.PairArgType (t1,t2) -> + | Genarg.PairArgType (t1,t2) -> let t1 = mlexpr_of_argtype loc t1 in let t2 = mlexpr_of_argtype loc t2 in <:expr< Genarg.PairArgType $t1$ $t2$ >> @@ -237,10 +237,10 @@ let mlexpr_of_binding_kind = function | Rawterm.ExplicitBindings l -> let l = mlexpr_of_list (mlexpr_of_triple mlexpr_of_loc mlexpr_of_quantified_hypothesis mlexpr_of_constr) l in <:expr< Rawterm.ExplicitBindings $l$ >> - | Rawterm.ImplicitBindings l -> + | Rawterm.ImplicitBindings l -> let l = mlexpr_of_list mlexpr_of_constr l in <:expr< Rawterm.ImplicitBindings $l$ >> - | Rawterm.NoBindings -> + | Rawterm.NoBindings -> <:expr< Rawterm.NoBindings >> let mlexpr_of_binding = mlexpr_of_pair mlexpr_of_binding_kind mlexpr_of_constr @@ -256,7 +256,7 @@ let mlexpr_of_move_location f = function let mlexpr_of_induction_arg = function | Tacexpr.ElimOnConstr c -> <:expr< Tacexpr.ElimOnConstr $mlexpr_of_constr_with_binding c$ >> - | Tacexpr.ElimOnIdent (_,id) -> + | Tacexpr.ElimOnIdent (_,id) -> <:expr< Tacexpr.ElimOnIdent $dloc$ $mlexpr_of_ident id$ >> | Tacexpr.ElimOnAnonHyp n -> <:expr< Tacexpr.ElimOnAnonHyp $mlexpr_of_int n$ >> @@ -347,11 +347,11 @@ let rec mlexpr_of_atomic_tactic = function <:expr< Tacexpr.TacCut $mlexpr_of_constr c$ >> | Tacexpr.TacAssert (t,ipat,c) -> let ipat = mlexpr_of_option (mlexpr_of_located mlexpr_of_intro_pattern) ipat in - <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ + <:expr< Tacexpr.TacAssert $mlexpr_of_option mlexpr_of_tactic t$ $ipat$ $mlexpr_of_constr c$ >> | Tacexpr.TacGeneralize cl -> <:expr< Tacexpr.TacGeneralize - $mlexpr_of_list + $mlexpr_of_list (mlexpr_of_pair mlexpr_of_occ_constr mlexpr_of_name) cl$ >> | Tacexpr.TacGeneralizeDep c -> <:expr< Tacexpr.TacGeneralizeDep $mlexpr_of_constr c$ >> @@ -366,8 +366,8 @@ let rec mlexpr_of_atomic_tactic = function <:expr< Tacexpr.TacSimpleInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_quantified_hypothesis h$ >> | Tacexpr.TacInductionDestruct (isrec,ev,l) -> - <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$ - $mlexpr_of_list (mlexpr_of_quadruple + <:expr< Tacexpr.TacInductionDestruct $mlexpr_of_bool isrec$ $mlexpr_of_bool ev$ + $mlexpr_of_list (mlexpr_of_quadruple (mlexpr_of_list mlexpr_of_induction_arg) (mlexpr_of_option mlexpr_of_constr_with_binding) (mlexpr_of_pair @@ -437,7 +437,7 @@ let rec mlexpr_of_atomic_tactic = function and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function | Tacexpr.TacAtom (loc,t) -> <:expr< Tacexpr.TacAtom $dloc$ $mlexpr_of_atomic_tactic t$ >> - | Tacexpr.TacThen (t1,[||],t2,[||]) -> + | Tacexpr.TacThen (t1,[||],t2,[||]) -> <:expr< Tacexpr.TacThen $mlexpr_of_tactic t1$ [||] $mlexpr_of_tactic t2$ [||]>> | Tacexpr.TacThens (t,tl) -> <:expr< Tacexpr.TacThens $mlexpr_of_tactic t$ $mlexpr_of_list mlexpr_of_tactic tl$>> @@ -455,7 +455,7 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function <:expr< Tacexpr.TacRepeat $mlexpr_of_tactic t$ >> | Tacexpr.TacProgress t -> <:expr< Tacexpr.TacProgress $mlexpr_of_tactic t$ >> - | Tacexpr.TacId l -> + | Tacexpr.TacId l -> <:expr< Tacexpr.TacId $mlexpr_of_list mlexpr_of_message_token l$ >> | Tacexpr.TacFail (n,l) -> <:expr< Tacexpr.TacFail $mlexpr_of_or_var mlexpr_of_int n$ $mlexpr_of_list mlexpr_of_message_token l$ >> @@ -477,7 +477,7 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function $mlexpr_of_tactic t$ $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> | Tacexpr.TacMatchGoal (lz,lr,l) -> - <:expr< Tacexpr.TacMatchGoal + <:expr< Tacexpr.TacMatchGoal $mlexpr_of_bool lz$ $mlexpr_of_bool lr$ $mlexpr_of_list (mlexpr_of_match_rule mlexpr_of_tactic) l$>> @@ -495,7 +495,7 @@ and mlexpr_of_tactic : (Tacexpr.raw_tactic_expr -> MLast.expr) = function and mlexpr_of_tactic_arg = function | Tacexpr.MetaIdArg (loc,true,id) -> anti loc id - | Tacexpr.MetaIdArg (loc,false,id) -> + | Tacexpr.MetaIdArg (loc,false,id) -> <:expr< Tacexpr.ConstrMayEval (Rawterm.ConstrTerm $anti loc id$) >> | Tacexpr.TacCall (loc,t,tl) -> <:expr< Tacexpr.TacCall $dloc$ $mlexpr_of_reference t$ $mlexpr_of_list mlexpr_of_tactic_arg tl$>> @@ -523,7 +523,7 @@ let ftac e = let ep s = patt_of_expr (ee s) in Quotation.ExAst (ee, ep) -let _ = +let _ = Quotation.add "constr" (fconstr Pcoq.Constr.constr_eoi); Quotation.add "tactic" (ftac Pcoq.Tactic.tactic_eoi); Quotation.default := "constr" diff --git a/parsing/q_util.ml4 b/parsing/q_util.ml4 index 4694497491..7b9037d92d 100644 --- a/parsing/q_util.ml4 +++ b/parsing/q_util.ml4 @@ -20,7 +20,7 @@ let not_impl name x = let desc = if Obj.is_block (Obj.repr x) then "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else + else "int_val = " ^ string_of_int (Obj.magic x) in failwith ("> in - let v = + let v = (* Special case for tactics which must be stored in algebraic form to avoid marshalling closures and to be reprinted *) if is_tactic_genarg t then @@ -95,7 +95,7 @@ let rec make_eval_tactic e = function let rec make_fun e = function | [] -> e - | GramNonTerminal(loc,_,_,Some p)::l -> + | GramNonTerminal(loc,_,_,Some p)::l -> let p = Names.string_of_id p in <:expr< fun $lid:p$ -> $make_fun e l$ >> | _::l -> make_fun e l @@ -138,7 +138,7 @@ let rec contains_epsilon = function | ExtraArgType("hintbases") -> true | _ -> false let is_atomic = function - | GramTerminal s :: l when + | GramTerminal s :: l when List.for_all (function GramTerminal _ -> false | GramNonTerminal(_,t,_,_) -> contains_epsilon t) l @@ -152,7 +152,7 @@ let declare_tactic loc s cl = let hide_tac (p,e) = (* reste a definir les fonctions cachees avec des noms frais *) let stac = "h_"^s in - let e = + let e = make_fun <:expr< Refiner.abstract_extended_tactic $mlexpr_of_string s$ $make_args p$ $make_eval_tactic e p$ @@ -194,7 +194,7 @@ EXTEND ; tacrule: [ [ "["; l = LIST1 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]" - -> + -> if match List.hd l with GramNonTerminal _ -> true | _ -> false then (* En attendant la syntaxe de tacticielles *) failwith "Tactic syntax must start with an identifier"; diff --git a/parsing/tactic_printer.ml b/parsing/tactic_printer.ml index 49cec626f4..c09b3431e5 100644 --- a/parsing/tactic_printer.ml +++ b/parsing/tactic_printer.ml @@ -23,30 +23,30 @@ let pr_tactic = function | TacArg (Tacexp t) -> (*top tactic from tacinterp*) Pptactic.pr_glob_tactic (Global.env()) t - | t -> + | t -> Pptactic.pr_tactic (Global.env()) t -let pr_proof_instr instr = +let pr_proof_instr instr = Ppdecl_proof.pr_proof_instr (Global.env()) instr let pr_rule = function | Prim r -> hov 0 (pr_prim_rule r) | Nested(cmpd,_) -> begin - match cmpd with + match cmpd with | Tactic (texp,_) -> hov 0 (pr_tactic texp) | Proof_instr (_,instr) -> hov 0 (pr_proof_instr instr) end | Daimon -> str "" - | Decl_proof _ -> str "proof" + | Decl_proof _ -> str "proof" let uses_default_tac = function | Nested(Tactic(_,dflt),_) -> dflt | _ -> false (* Does not print change of evars *) -let pr_rule_dot = function - | Prim Change_evars ->str "PC: ch_evars" ++ mt () +let pr_rule_dot = function + | Prim Change_evars ->str "PC: ch_evars" ++ mt () (* PC: this might be redundant *) | r -> pr_rule r ++ if uses_default_tac r then str "..." else str"." @@ -66,7 +66,7 @@ exception Different let thin_sign osign sign = Sign.fold_named_context (fun (id,c,ty as d) sign -> - try + try if Sign.lookup_named id osign = (id,c,ty) then sign else raise Different with Not_found | Different -> Environ.push_named_context_val d sign) @@ -76,17 +76,17 @@ let rec print_proof _sigma osign pf = let hyps = Environ.named_context_of_val pf.goal.evar_hyps in let hyps' = thin_sign osign hyps in match pf.ref with - | None -> + | None -> hov 0 (pr_goal {pf.goal with evar_hyps=hyps'}) | Some(r,spfl) -> - hov 0 + hov 0 (hov 0 (pr_goal {pf.goal with evar_hyps=hyps'}) ++ spc () ++ str" BY " ++ hov 0 (pr_rule r) ++ fnl () ++ str" " ++ hov 0 (prlist_with_sep pr_fnl (print_proof _sigma hyps) spfl)) - -let pr_change gl = + +let pr_change gl = str"change " ++ pr_lconstr_env (Global.env_of_context gl.evar_hyps) gl.evar_concl ++ str"." @@ -94,9 +94,9 @@ let print_decl_script tac_printer ?(nochange=true) sigma pf = let rec print_prf pf = match pf.ref with | None -> - (if nochange then + (if nochange then (str"") - else + else pr_change pf.goal) ++ fnl () | Some (Daimon,[]) -> str "(* Some proof has been skipped here *)" @@ -114,17 +114,17 @@ let print_decl_script tac_printer ?(nochange=true) sigma pf = (if opened then mt () else str "end claim." ++ fnl ()) ++ print_prf cont | Pfocus _,[body;cont] -> - hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ + hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ fnl () ++ (if opened then mt () else str "end focus." ++ fnl ()) ++ print_prf cont | (Psuppose _ |Pcase (_,_,_)),[body;cont] -> hov 2 (pr_rule_dot_fnl rule ++ print_prf body) ++ fnl () ++ - print_prf cont + print_prf cont | _,[next] -> pr_rule_dot_fnl rule ++ print_prf next | _,[] -> - pr_rule_dot rule + pr_rule_dot rule | _,_ -> anomaly "unknown branching instruction" end | _ -> anomaly "Not Applicable" in @@ -134,19 +134,19 @@ let print_script ?(nochange=true) sigma pf = let rec print_prf pf = match pf.ref with | None -> - (if nochange then - (str"") - else + (if nochange then + (str"") + else pr_change pf.goal) ++ fnl () | Some(Decl_proof opened,script) -> assert (List.length script = 1); begin - if nochange then (mt ()) else (pr_change pf.goal ++ fnl ()) + if nochange then (mt ()) else (pr_change pf.goal ++ fnl ()) end ++ begin - hov 0 (str "proof." ++ fnl () ++ - print_decl_script print_prf + hov 0 (str "proof." ++ fnl () ++ + print_decl_script print_prf ~nochange sigma (List.hd script)) end ++ fnl () ++ begin @@ -167,7 +167,7 @@ let print_treescript ?(nochange=true) sigma pf = let rec print_prf pf = match pf.ref with | None -> - if nochange then + if nochange then if pf.goal.evar_extra=None then str"" else str"" else pr_change pf.goal @@ -176,10 +176,10 @@ let print_treescript ?(nochange=true) sigma pf = begin if nochange then mt () else pr_change pf.goal ++ fnl () end ++ - hov 0 + hov 0 begin str "proof." ++ fnl () ++ - print_decl_script print_prf ~nochange sigma (List.hd script) - end ++ fnl () ++ + print_decl_script print_prf ~nochange sigma (List.hd script) + end ++ fnl () ++ begin if opened then mt () else (str "end proof." ++ fnl ()) end @@ -197,27 +197,27 @@ let rec print_info_script sigma osign pf = match pf.ref with | None -> (mt ()) | Some(r,spfl) -> - (pr_rule r ++ + (pr_rule r ++ match spfl with | [pf1] -> - if pf1.ref = None then + if pf1.ref = None then (str "." ++ fnl ()) - else + else (str";" ++ brk(1,3) ++ - print_info_script sigma + print_info_script sigma (Environ.named_context_of_val sign) pf1) | _ -> (str"." ++ fnl () ++ prlist_with_sep pr_fnl - (print_info_script sigma + (print_info_script sigma (Environ.named_context_of_val sign)) spfl)) -let format_print_info_script sigma osign pf = +let format_print_info_script sigma osign pf = hov 0 (print_info_script sigma osign pf) - -let print_subscript sigma sign pf = - if is_tactic_proof pf then + +let print_subscript sigma sign pf = + if is_tactic_proof pf then format_print_info_script sigma sign (subproof_of_proof pf) - else + else format_print_info_script sigma sign pf let _ = Refiner.set_info_printer print_subscript diff --git a/parsing/vernacextend.ml4 b/parsing/vernacextend.ml4 index dd05d5cd76..e8a3094b9a 100644 --- a/parsing/vernacextend.ml4 +++ b/parsing/vernacextend.ml4 @@ -75,7 +75,7 @@ EXTEND ; rule: [ [ "["; s = STRING; l = LIST0 args; "]"; "->"; "["; e = Pcaml.expr; "]" - -> + -> if s = "" then Util.user_err_loc (loc,"",Pp.str"Command name is empty."); (s,l,<:expr< fun () -> $e$ >>) ] ] diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 418980c54b..9cc6f9de93 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -22,45 +22,45 @@ open Proof_type let init_size=5 -let cc_verbose=ref false +let cc_verbose=ref false -let debug f x = +let debug f x = if !cc_verbose then f x let _= let gdopt= { optsync=true; optname="Congruence Verbose"; - optkey=["Congruence";"Verbose"]; - optread=(fun ()-> !cc_verbose); - optwrite=(fun b -> cc_verbose := b)} + optkey=["Congruence";"Verbose"]; + optread=(fun ()-> !cc_verbose); + optwrite=(fun b -> cc_verbose := b)} in declare_bool_option gdopt (* Signature table *) module ST=struct - + (* l: sign -> term r: term -> sign *) - + type t = {toterm:(int*int,int) Hashtbl.t; tosign:(int,int*int) Hashtbl.t} - + let empty ()= {toterm=Hashtbl.create init_size; tosign=Hashtbl.create init_size} - + let enter t sign st= - if Hashtbl.mem st.toterm sign then + if Hashtbl.mem st.toterm sign then anomaly "enter: signature already entered" - else + else Hashtbl.replace st.toterm sign t; Hashtbl.replace st.tosign t sign - + let query sign st=Hashtbl.find st.toterm sign let rev_query term st=Hashtbl.find st.tosign term - + let delete st t= try let sign=Hashtbl.find st.tosign t in Hashtbl.remove st.toterm sign; @@ -69,7 +69,7 @@ module ST=struct Not_found -> () let rec delete_set st s = Intset.iter (delete st) s - + end type pa_constructor= @@ -85,11 +85,11 @@ type pa_mark= Fmark of pa_fun | Cmark of pa_constructor -module PacMap=Map.Make(struct - type t=pa_constructor - let compare=Pervasives.compare end) +module PacMap=Map.Make(struct + type t=pa_constructor + let compare=Pervasives.compare end) -module PafMap=Map.Make(struct +module PafMap=Map.Make(struct type t=pa_fun let compare=Pervasives.compare end) @@ -107,11 +107,11 @@ type term= type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) - | PVar of int + | PVar of int type rule= Congruence - | Axiom of constr * bool + | Axiom of constr * bool | Injection of int * pa_constructor * int * pa_constructor * int type from= @@ -127,7 +127,7 @@ type equality = rule eq type disequality = from eq type patt_kind = - Normal + Normal | Trivial of types | Creates_variables @@ -146,7 +146,7 @@ let swap eq : equality = | Injection (i,pi,j,pj,k) -> Injection (j,pj,i,pi,k) | Axiom (id,reversed) -> Axiom (id,not reversed) in {lhs=eq.rhs;rhs=eq.lhs;rule=swap_rule} - + type inductive_status = Unknown | Partial of pa_constructor @@ -163,15 +163,15 @@ type representative= mutable constructors: int PacMap.t} (*pac -> term = app(constr,t) *) type cl = Rep of representative| Eqto of int*equality - -type vertex = Leaf| Node of (int*int) -type node = +type vertex = Leaf| Node of (int*int) + +type node = {mutable clas:cl; - mutable cpath: int; + mutable cpath: int; vertex:vertex; term:term} - + type forest= {mutable max_size:int; mutable size:int; @@ -180,11 +180,11 @@ type forest= mutable epsilons: pa_constructor list; syms:(term,int) Hashtbl.t} -type state = +type state = {uf: forest; sigtable:ST.t; - mutable terms: Intset.t; - combine: equality Queue.t; + mutable terms: Intset.t; + combine: equality Queue.t; marks: (int * pa_mark) Queue.t; mutable diseq: disequality list; mutable quant: quant_eq list; @@ -222,17 +222,17 @@ let empty depth gls:state = changed=false; gls=gls} -let forest state = state.uf - +let forest state = state.uf + let compress_path uf i j = uf.map.(j).cpath<-i - -let rec find_aux uf visited i= - let j = uf.map.(i).cpath in + +let rec find_aux uf visited i= + let j = uf.map.(i).cpath in if j<0 then let _ = List.iter (compress_path uf i) visited in i else find_aux uf (i::visited) j - + let find uf i= find_aux uf [] i - + let get_representative uf i= match uf.map.(i).clas with Rep r -> r @@ -245,7 +245,7 @@ let get_constructor_info uf i= match uf.map.(i).term with Constructor cinfo->cinfo | _ -> anomaly "get_constructor: not a constructor" - + let size uf i= (get_representative uf i).weight @@ -264,36 +264,36 @@ let add_rfather uf i t= r.weight<-r.weight+1; r.fathers <-Intset.add t r.fathers -exception Discriminable of int * pa_constructor * int * pa_constructor +exception Discriminable of int * pa_constructor * int * pa_constructor let append_pac t p = - {p with arity=pred p.arity;args=t::p.args} + {p with arity=pred p.arity;args=t::p.args} let tail_pac p= {p with arity=succ p.arity;args=List.tl p.args} let fsucc paf = {paf with fnargs=succ paf.fnargs} - + let add_pac rep pac t = if not (PacMap.mem pac rep.constructors) then rep.constructors<-PacMap.add pac t rep.constructors let add_paf rep paf t = - let already = + let already = try PafMap.find paf rep.functions with Not_found -> Intset.empty in rep.functions<- PafMap.add paf (Intset.add t already) rep.functions let term uf i=uf.map.(i).term - + let subterms uf i= match uf.map.(i).vertex with Node(j,k) -> (j,k) | _ -> anomaly "subterms: not a node" - + let signature uf i= let j,k=subterms uf i in (find uf j,find uf k) - + let next uf= let size=uf.size in let nsize= succ size in @@ -304,11 +304,11 @@ let next uf= uf.max_size<-newmax; Array.blit uf.map 0 newmap 0 size; uf.map<-newmap - end + end else (); - uf.size<-nsize; + uf.size<-nsize; size - + let new_representative typ = {weight=0; lfathers=Intset.empty; @@ -317,14 +317,14 @@ let new_representative typ = class_type=typ; functions=PafMap.empty; constructors=PacMap.empty} - + (* rebuild a constr from an applicative term *) - + let _A_ = Name (id_of_string "A") let _B_ = Name (id_of_string "A") let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) -let cc_product s1 s2 = +let cc_product s1 s2 = mkLambda(_A_,mkSort(Termops.new_sort_in_family s1), mkLambda(_B_,mkSort(Termops.new_sort_in_family s2),_body_)) @@ -332,27 +332,27 @@ let rec constr_of_term = function Symb s->s | Product(s1,s2) -> cc_product s1 s2 | Eps id -> mkVar id - | Constructor cinfo -> mkConstruct cinfo.ci_constr + | Constructor cinfo -> mkConstruct cinfo.ci_constr | Appli (s1,s2)-> make_app [(constr_of_term s2)] s1 and make_app l=function - Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 - | other -> applistc (constr_of_term other) l + Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1 + | other -> applistc (constr_of_term other) l (* rebuild a term from a pattern and a substitution *) let build_subst uf subst = - Array.map (fun i -> - try term uf i + Array.map (fun i -> + try term uf i with _ -> anomaly "incomplete matching") subst let rec inst_pattern subst = function - PVar i -> - subst.(pred i) - | PApp (t, args) -> + PVar i -> + subst.(pred i) + | PApp (t, args) -> List.fold_right (fun spat f -> Appli (f,inst_pattern subst spat)) - args t + args t let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++ Termops.print_constr (constr_of_term (term state.uf i)) ++ str "]" @@ -360,9 +360,9 @@ let pr_idx_term state i = str "[" ++ int i ++ str ":=" ++ let pr_term t = str "[" ++ Termops.print_constr (constr_of_term t) ++ str "]" -let rec add_term state t= +let rec add_term state t= let uf=state.uf in - try Hashtbl.find uf.syms t with + try Hashtbl.find uf.syms t with Not_found -> let b=next uf in let typ = pf_type_of state.gls (constr_of_term t) in @@ -377,12 +377,12 @@ let rec add_term state t= cpath= -1; vertex= Leaf; term= t} - | Eps id -> + | Eps id -> {clas= Rep (new_representative typ); cpath= -1; vertex= Leaf; term= t} - | Appli (t1,t2) -> + | Appli (t1,t2) -> let i1=add_term state t1 and i2=add_term state t2 in add_lfather uf (find uf i1) b; add_rfather uf (find uf i2) b; @@ -408,9 +408,9 @@ let rec add_term state t= in uf.map.(b)<-new_node; Hashtbl.add uf.syms t b; - Hashtbl.replace state.by_type typ - (Intset.add b - (try Hashtbl.find state.by_type typ with + Hashtbl.replace state.by_type typ + (Intset.add b + (try Hashtbl.find state.by_type typ with Not_found -> Intset.empty)); b @@ -436,22 +436,22 @@ let add_quant state id pol (nvars,valid1,patt1,valid2,patt2) = qe_rhs_valid=valid2}::state.quant let is_redundant state id args = - try + try let norm_args = Array.map (find state.uf) args in let prev_args = Hashtbl.find_all state.q_history id in - List.exists - (fun old_args -> - Util.array_for_all2 (fun i j -> i = find state.uf j) - norm_args old_args) + List.exists + (fun old_args -> + Util.array_for_all2 (fun i j -> i = find state.uf j) + norm_args old_args) prev_args with Not_found -> false -let add_inst state (inst,int_subst) = +let add_inst state (inst,int_subst) = check_for_interrupt (); if state.rew_depth > 0 then if is_redundant state inst.qe_hyp_id int_subst then debug msgnl (str "discarding redundant (dis)equality") - else + else begin Hashtbl.add state.q_history inst.qe_hyp_id int_subst; let subst = build_subst (forest state) int_subst in @@ -459,149 +459,149 @@ let add_inst state (inst,int_subst) = let args = Array.map constr_of_term subst in let _ = array_rev args in (* highest deBruijn index first *) let prf= mkApp(prfhead,args) in - let s = inst_pattern subst inst.qe_lhs + let s = inst_pattern subst inst.qe_lhs and t = inst_pattern subst inst.qe_rhs in state.changed<-true; state.rew_depth<-pred state.rew_depth; if inst.qe_pol then begin - debug (fun () -> - msgnl + debug (fun () -> + msgnl (str "Adding new equality, depth="++ int state.rew_depth); - msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ + msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ pr_term s ++ str " == " ++ pr_term t ++ str "]")) (); add_equality state prf s t end else begin - debug (fun () -> - msgnl + debug (fun () -> + msgnl (str "Adding new disequality, depth="++ int state.rew_depth); - msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ + msgnl (str " [" ++ Termops.print_constr prf ++ str " : " ++ pr_term s ++ str " <> " ++ pr_term t ++ str "]")) (); - add_disequality state (Hyp prf) s t + add_disequality state (Hyp prf) s t end end let link uf i j eq = (* links i -> j *) - let node=uf.map.(i) in + let node=uf.map.(i) in node.clas<-Eqto (j,eq); node.cpath<-j - + let rec down_path uf i l= match uf.map.(i).clas with Eqto(j,t)->down_path uf j (((i,j),t)::l) | Rep _ ->l - + let rec min_path=function ([],l2)->([],l2) | (l1,[])->(l1,[]) - | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) + | (((c1,t1)::q1),((c2,t2)::q2)) when c1=c2 -> min_path (q1,q2) | cpl -> cpl - + let join_path uf i j= assert (find uf i=find uf j); min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= - debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++ + debug (fun () -> msgnl (str "Linking " ++ pr_idx_term state i1 ++ str " and " ++ pr_idx_term state i2 ++ str ".")) (); - let r1= get_representative state.uf i1 + let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in link state.uf i1 i2 eq; - Hashtbl.replace state.by_type r1.class_type - (Intset.remove i1 - (try Hashtbl.find state.by_type r1.class_type with + Hashtbl.replace state.by_type r1.class_type + (Intset.remove i1 + (try Hashtbl.find state.by_type r1.class_type with Not_found -> Intset.empty)); let f= Intset.union r1.fathers r2.fathers in r2.weight<-Intset.cardinal f; r2.fathers<-f; r2.lfathers<-Intset.union r1.lfathers r2.lfathers; ST.delete_set state.sigtable r1.fathers; - state.terms<-Intset.union state.terms r1.fathers; - PacMap.iter - (fun pac b -> Queue.add (b,Cmark pac) state.marks) + state.terms<-Intset.union state.terms r1.fathers; + PacMap.iter + (fun pac b -> Queue.add (b,Cmark pac) state.marks) r1.constructors; - PafMap.iter - (fun paf -> Intset.iter - (fun b -> Queue.add (b,Fmark paf) state.marks)) + PafMap.iter + (fun paf -> Intset.iter + (fun b -> Queue.add (b,Fmark paf) state.marks)) r1.functions; - match r1.inductive_status,r2.inductive_status with + match r1.inductive_status,r2.inductive_status with Unknown,_ -> () - | Partial pac,Unknown -> + | Partial pac,Unknown -> r2.inductive_status<-Partial pac; state.pa_classes<-Intset.remove i1 state.pa_classes; state.pa_classes<-Intset.add i2 state.pa_classes - | Partial _ ,(Partial _ |Partial_applied) -> + | Partial _ ,(Partial _ |Partial_applied) -> state.pa_classes<-Intset.remove i1 state.pa_classes - | Partial_applied,Unknown -> - r2.inductive_status<-Partial_applied - | Partial_applied,Partial _ -> + | Partial_applied,Unknown -> + r2.inductive_status<-Partial_applied + | Partial_applied,Partial _ -> state.pa_classes<-Intset.remove i2 state.pa_classes; r2.inductive_status<-Partial_applied | Total cpl,Unknown -> r2.inductive_status<-Total cpl; - | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks - | _,_ -> () - + | Total (i,pac),Total _ -> Queue.add (i,Cmark pac) state.marks + | _,_ -> () + let merge eq state = (* merge and no-merge *) - debug (fun () -> msgnl - (str "Merging " ++ pr_idx_term state eq.lhs ++ + debug (fun () -> msgnl + (str "Merging " ++ pr_idx_term state eq.lhs ++ str " and " ++ pr_idx_term state eq.rhs ++ str ".")) (); let uf=state.uf in - let i=find uf eq.lhs + let i=find uf eq.lhs and j=find uf eq.rhs in - if i<>j then + if i<>j then if (size uf i)<(size uf j) then union state i j eq else union state j i (swap eq) let update t state = (* update 1 and 2 *) - debug (fun () -> msgnl + debug (fun () -> msgnl (str "Updating term " ++ pr_idx_term state t ++ str ".")) (); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in let rep = get_representative state.uf i in begin - match rep.inductive_status with + match rep.inductive_status with Partial _ -> rep.inductive_status <- Partial_applied; state.pa_classes <- Intset.remove i state.pa_classes | _ -> () end; - PacMap.iter - (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) - rep.constructors; - PafMap.iter - (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) - rep.functions; - try - let s = ST.query sign state.sigtable in + PacMap.iter + (fun pac _ -> Queue.add (t,Cmark (append_pac v pac)) state.marks) + rep.constructors; + PafMap.iter + (fun paf _ -> Queue.add (t,Fmark (fsucc paf)) state.marks) + rep.functions; + try + let s = ST.query sign state.sigtable in Queue.add {lhs=t;rhs=s;rule=Congruence} state.combine - with + with Not_found -> ST.enter t sign state.sigtable let process_function_mark t rep paf state = add_paf rep paf t; state.terms<-Intset.union rep.lfathers state.terms - + let process_constructor_mark t i rep pac state = match rep.inductive_status with Total (s,opac) -> - if pac.cnode <> opac.cnode then (* Conflict *) - raise (Discriminable (s,opac,t,pac)) + if pac.cnode <> opac.cnode then (* Conflict *) + raise (Discriminable (s,opac,t,pac)) else (* Match *) let cinfo = get_constructor_info state.uf pac.cnode in let rec f n oargs args= - if n > 0 then + if n > 0 then match (oargs,args) with s1::q1,s2::q2-> - Queue.add + Queue.add {lhs=s1;rhs=s2;rule=Injection(s,opac,t,pac,n)} state.combine; - f (n-1) q1 q2 - | _-> anomaly - "add_pacs : weird error in injection subterms merge" + f (n-1) q1 q2 + | _-> anomaly + "add_pacs : weird error in injection subterms merge" in f cinfo.ci_nhyps opac.args pac.args | Partial_applied | Partial _ -> add_pac rep pac t; @@ -617,8 +617,8 @@ let process_constructor_mark t i rep pac state = state.pa_classes<- Intset.add i state.pa_classes end -let process_mark t m state = - debug (fun () -> msgnl +let process_mark t m state = + debug (fun () -> msgnl (str "Processing mark for term " ++ pr_idx_term state t ++ str ".")) (); let i=find state.uf t in let rep=get_representative state.uf i in @@ -634,15 +634,15 @@ type explanation = let check_disequalities state = let uf=state.uf in let rec check_aux = function - dis::q -> - debug (fun () -> msg - (str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++ - pr_idx_term state dis.rhs ++ str " ... ")) (); - if find uf dis.lhs=find uf dis.rhs then - begin debug msgnl (str "Yes");Some dis end + dis::q -> + debug (fun () -> msg + (str "Checking if " ++ pr_idx_term state dis.lhs ++ str " = " ++ + pr_idx_term state dis.rhs ++ str " ... ")) (); + if find uf dis.lhs=find uf dis.rhs then + begin debug msgnl (str "Yes");Some dis end else begin debug msgnl (str "No");check_aux q end - | [] -> None + | [] -> None in check_aux state.diseq @@ -651,8 +651,8 @@ let one_step state = let eq = Queue.take state.combine in merge eq state; true - with Queue.Empty -> - try + with Queue.Empty -> + try let (t,m) = Queue.take state.marks in process_mark t m state; true @@ -664,40 +664,40 @@ let one_step state = true with Not_found -> false -let __eps__ = id_of_string "_eps_" +let __eps__ = id_of_string "_eps_" let new_state_var typ state = let id = pf_get_new_id __eps__ state.gls in state.gls<- {state.gls with it = - {state.gls.it with evar_hyps = - Environ.push_named_context_val (id,None,typ) + {state.gls.it with evar_hyps = + Environ.push_named_context_val (id,None,typ) state.gls.it.evar_hyps}}; id let complete_one_class state i= match (get_representative state.uf i).inductive_status with Partial pac -> - let rec app t typ n = + let rec app t typ n = if n<=0 then t else let _,etyp,rest= destProd typ in let id = new_state_var etyp state in app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in let _c = pf_type_of state.gls (constr_of_term (term state.uf pac.cnode)) in - let _args = - List.map (fun i -> constr_of_term (term state.uf i)) + let _args = + List.map (fun i -> constr_of_term (term state.uf i)) pac.args in - let typ = prod_applist _c (List.rev _args) in + let typ = prod_applist _c (List.rev _args) in let ct = app (term state.uf i) typ pac.arity in - state.uf.epsilons <- pac :: state.uf.epsilons; + state.uf.epsilons <- pac :: state.uf.epsilons; ignore (add_term state ct) - | _ -> anomaly "wrong incomplete class" + | _ -> anomaly "wrong incomplete class" let complete state = Intset.iter (complete_one_class state) state.pa_classes -type matching_problem = +type matching_problem = {mp_subst : int array; mp_inst : quant_eq; mp_stack : (ccpattern*int) list } @@ -705,31 +705,31 @@ type matching_problem = let make_fun_table state = let uf= state.uf in let funtab=ref PafMap.empty in - Array.iteri + Array.iteri (fun i inode -> if i < uf.size then match inode.clas with Rep rep -> - PafMap.iter - (fun paf _ -> - let elem = - try PafMap.find paf !funtab + PafMap.iter + (fun paf _ -> + let elem = + try PafMap.find paf !funtab with Not_found -> Intset.empty in - funtab:= PafMap.add paf (Intset.add i elem) !funtab) + funtab:= PafMap.add paf (Intset.add i elem) !funtab) rep.functions | _ -> ()) state.uf.map; !funtab - + let rec do_match state res pb_stack = let mp=Stack.pop pb_stack in match mp.mp_stack with - [] -> + [] -> res:= (mp.mp_inst,mp.mp_subst) :: !res | (patt,cl)::remains -> let uf=state.uf in match patt with - PVar i -> - if mp.mp_subst.(pred i)<0 then + PVar i -> + if mp.mp_subst.(pred i)<0 then begin mp.mp_subst.(pred i)<- cl; (* no aliasing problem here *) Stack.push {mp with mp_stack=remains} pb_stack @@ -746,18 +746,18 @@ let rec do_match state res pb_stack = with Not_found -> () end | PApp(f, ((last_arg::rem_args) as args)) -> - try - let j=Hashtbl.find uf.syms f in + try + let j=Hashtbl.find uf.syms f in let paf={fsym=j;fnargs=List.length args} in let rep=get_representative uf cl in let good_terms = PafMap.find paf rep.functions in - let aux i = + let aux i = let (s,t) = signature state.uf i in - Stack.push - {mp with + Stack.push + {mp with mp_subst=Array.copy mp.mp_subst; mp_stack= - (PApp(f,rem_args),s) :: + (PApp(f,rem_args),s) :: (last_arg,t) :: remains} pb_stack in Intset.iter aux good_terms with Not_found -> () @@ -768,7 +768,7 @@ let paf_of_patt syms = function {fsym=Hashtbl.find syms f; fnargs=List.length args} -let init_pb_stack state = +let init_pb_stack state = let syms= state.uf.syms in let pb_stack = Stack.create () in let funtab = make_fun_table state in @@ -778,51 +778,51 @@ let init_pb_stack state = match inst.qe_lhs_valid with Creates_variables -> Intset.empty | Normal -> - begin - try + begin + try let paf= paf_of_patt syms inst.qe_lhs in PafMap.find paf funtab with Not_found -> Intset.empty end - | Trivial typ -> - begin - try + | Trivial typ -> + begin + try Hashtbl.find state.by_type typ with Not_found -> Intset.empty end in - Intset.iter (fun i -> - Stack.push - {mp_subst = Array.make inst.qe_nvars (-1); + Intset.iter (fun i -> + Stack.push + {mp_subst = Array.make inst.qe_nvars (-1); mp_inst=inst; mp_stack=[inst.qe_lhs,i]} pb_stack) good_classes end; - begin + begin let good_classes = match inst.qe_rhs_valid with Creates_variables -> Intset.empty | Normal -> - begin - try + begin + try let paf= paf_of_patt syms inst.qe_rhs in PafMap.find paf funtab with Not_found -> Intset.empty end - | Trivial typ -> - begin - try + | Trivial typ -> + begin + try Hashtbl.find state.by_type typ with Not_found -> Intset.empty end in - Intset.iter (fun i -> - Stack.push - {mp_subst = Array.make inst.qe_nvars (-1); + Intset.iter (fun i -> + Stack.push + {mp_subst = Array.make inst.qe_nvars (-1); mp_inst=inst; mp_stack=[inst.qe_rhs,i]} pb_stack) good_classes end in List.iter aux state.quant; pb_stack -let find_instances state = +let find_instances state = let pb_stack= init_pb_stack state in let res =ref [] in let _ = @@ -830,7 +830,7 @@ let find_instances state = try while true do check_for_interrupt (); - do_match state res pb_stack + do_match state res pb_stack done; anomaly "get out of here !" with Stack.Empty -> () in @@ -839,34 +839,34 @@ let find_instances state = let rec execute first_run state = debug msgnl (str "Executing ... "); try - while + while check_for_interrupt (); one_step state do () done; match check_disequalities state with - None -> + None -> if not(Intset.is_empty state.pa_classes) then - begin + begin debug msgnl (str "First run was incomplete, completing ... "); complete state; execute false state end - else + else if state.rew_depth>0 then let l=find_instances state in List.iter (add_inst state) l; - if state.changed then + if state.changed then begin state.changed <- false; execute true state end else - begin + begin debug msgnl (str "Out of instances ... "); None end - else - begin + else + begin debug msgnl (str "Out of depth ... "); None end diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 3bd52b6e1d..5f56c7e69f 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -25,35 +25,35 @@ type term = | Constructor of cinfo (* constructor arity + nhyps *) type patt_kind = - Normal + Normal | Trivial of types | Creates_variables type ccpattern = PApp of term * ccpattern list - | PVar of int + | PVar of int type pa_constructor = { cnode : int; arity : int; args : int list} -module PacMap : Map.S with type key = pa_constructor +module PacMap : Map.S with type key = pa_constructor type forest -type state +type state type rule= Congruence - | Axiom of constr * bool + | Axiom of constr * bool | Injection of int * pa_constructor * int * pa_constructor * int type from= Goal | Hyp of constr | HeqG of constr - | HeqnH of constr*constr + | HeqnH of constr*constr type 'a eq = {lhs:int;rhs:int;rule:'a} @@ -84,7 +84,7 @@ val add_equality : state -> constr -> term -> term -> unit val add_disequality : state -> from -> term -> term -> unit -val add_quant : state -> identifier -> bool -> +val add_quant : state -> identifier -> bool -> int * patt_kind * ccpattern * patt_kind * ccpattern -> unit val tail_pac : pa_constructor -> pa_constructor @@ -99,7 +99,7 @@ val get_constructor_info : forest -> int -> cinfo val subterms : forest -> int -> int * int -val join_path : forest -> int -> int -> +val join_path : forest -> int -> int -> ((int * int) * equality) list * ((int * int) * equality) list type quant_eq= @@ -117,10 +117,10 @@ type pa_fun= fnargs:int} type matching_problem - + module PafMap: Map.S with type key = pa_fun -val make_fun_table : state -> Intset.t PafMap.t +val make_fun_table : state -> Intset.t PafMap.t val do_match : state -> (quant_eq * int array) list ref -> matching_problem Stack.t -> unit @@ -150,20 +150,20 @@ val execute : bool -> state -> explanation option module PacMap:Map.S with type key=pa_constructor -type term = - Symb of Term.constr +type term = + Symb of Term.constr | Eps - | Appli of term * term + | Appli of term * term | Constructor of Names.constructor*int*int -type rule = - Congruence +type rule = + Congruence | Axiom of Names.identifier | Injection of int*int*int*int type equality = - {lhs : int; - rhs : int; + {lhs : int; + rhs : int; rule : rule} module ST : @@ -175,47 +175,47 @@ sig val delete : int -> t -> unit val delete_list : int list -> t -> unit end - + module UF : sig - type t - exception Discriminable of int * int * int * int * t + type t + exception Discriminable of int * int * int * int * t val empty : unit -> t val find : t -> int -> int val size : t -> int -> int val get_constructor : t -> int -> Names.constructor val pac_arity : t -> int -> int * int -> int - val mem_node_pac : t -> int -> int * int -> int - val add_pacs : t -> int -> pa_constructor PacMap.t -> + val mem_node_pac : t -> int -> int * int -> int + val add_pacs : t -> int -> pa_constructor PacMap.t -> int list * equality list - val term : t -> int -> term + val term : t -> int -> term val subterms : t -> int -> int * int val add : t -> term -> int val union : t -> int -> int -> equality -> int list * equality list - val join_path : t -> int -> int -> + val join_path : t -> int -> int -> ((int*int)*equality) list* ((int*int)*equality) list end - + val combine_rec : UF.t -> int list -> equality list val process_rec : UF.t -> equality list -> int list val cc : UF.t -> unit - + val make_uf : (Names.identifier * (term * term)) list -> UF.t val add_one_diseq : UF.t -> (term * term) -> int * int -val add_disaxioms : - UF.t -> (Names.identifier * (term * term)) list -> +val add_disaxioms : + UF.t -> (Names.identifier * (term * term)) list -> (Names.identifier * (int * int)) list - + val check_equal : UF.t -> int * int -> bool -val find_contradiction : UF.t -> - (Names.identifier * (int * int)) list -> +val find_contradiction : UF.t -> + (Names.identifier * (int * int)) list -> (Names.identifier * (int * int)) *) diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 1e57aa6cb1..2a019ebfff 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -8,30 +8,30 @@ (* $Id$ *) -(* This file uses the (non-compressed) union-find structure to generate *) +(* This file uses the (non-compressed) union-find structure to generate *) (* proof-trees that will be transformed into proof-terms in cctac.ml4 *) open Util open Names open Term open Ccalgo - + type rule= Ax of constr | SymAx of constr | Refl of term | Trans of proof*proof | Congr of proof*proof - | Inject of proof*constructor*int*int -and proof = + | Inject of proof*constructor*int*int +and proof = {p_lhs:term;p_rhs:term;p_rule:rule} let prefl t = {p_lhs=t;p_rhs=t;p_rule=Refl t} -let pcongr p1 p2 = - match p1.p_rule,p2.p_rule with +let pcongr p1 p2 = + match p1.p_rule,p2.p_rule with Refl t1, Refl t2 -> prefl (Appli (t1,t2)) - | _, _ -> + | _, _ -> {p_lhs=Appli (p1.p_lhs,p2.p_lhs); p_rhs=Appli (p1.p_rhs,p2.p_rhs); p_rule=Congr (p1,p2)} @@ -44,25 +44,25 @@ let rec ptrans p1 p3= | Congr(p1,p2), Congr(p3,p4) ->pcongr (ptrans p1 p3) (ptrans p2 p4) | Congr(p1,p2), Trans({p_rule=Congr(p3,p4)},p5) -> ptrans (pcongr (ptrans p1 p3) (ptrans p2 p4)) p5 - | _, _ -> - if p1.p_rhs = p3.p_lhs then + | _, _ -> + if p1.p_rhs = p3.p_lhs then {p_lhs=p1.p_lhs; p_rhs=p3.p_rhs; p_rule=Trans (p1,p3)} else anomaly "invalid cc transitivity" - -let rec psym p = - match p.p_rule with - Refl _ -> p + +let rec psym p = + match p.p_rule with + Refl _ -> p | SymAx s -> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=Ax s} - | Ax s-> + | Ax s-> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=SymAx s} - | Inject (p0,c,n,a)-> + | Inject (p0,c,n,a)-> {p_lhs=p.p_rhs; p_rhs=p.p_lhs; p_rule=Inject (psym p0,c,n,a)} @@ -82,9 +82,9 @@ let psymax axioms s = p_rule=SymAx s} let rec nth_arg t n= - match t with - Appli (t1,t2)-> - if n>0 then + match t with + Appli (t1,t2)-> + if n>0 then nth_arg t1 (n-1) else t2 | _ -> anomaly "nth_arg: not enough args" @@ -99,23 +99,23 @@ let build_proof uf= let axioms = axioms uf in let rec equal_proof i j= - if i=j then prefl (term uf i) else + if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in ptrans (path_proof i li) (psym (path_proof j lj)) - + and edge_proof ((i,j),eq)= let pi=equal_proof i eq.lhs in let pj=psym (equal_proof j eq.rhs) in let pij= - match eq.rule with + match eq.rule with Axiom (s,reversed)-> - if reversed then psymax axioms s + if reversed then psymax axioms s else pax axioms s | Congruence ->congr_proof eq.lhs eq.rhs | Injection (ti,ipac,tj,jpac,k) -> let p=ind_proof ti ipac tj jpac in let cinfo= get_constructor_info uf ipac.cnode in - pinject p cinfo.ci_constr cinfo.ci_nhyps k + pinject p cinfo.ci_constr cinfo.ci_nhyps k in ptrans (ptrans pi pij) pj and constr_proof i t ipac= @@ -133,15 +133,15 @@ let build_proof uf= and path_proof i=function [] -> prefl (term uf i) | x::q->ptrans (path_proof (snd (fst x)) q) (edge_proof x) - + and congr_proof i j= let (i1,i2) = subterms uf i - and (j1,j2) = subterms uf j in + and (j1,j2) = subterms uf j in pcongr (equal_proof i1 j1) (equal_proof i2 j2) - + and ind_proof i ipac j jpac= - let p=equal_proof i j - and p1=constr_proof i i ipac + let p=equal_proof i j + and p1=constr_proof i i ipac and p2=constr_proof j j jpac in ptrans (psym p1) (ptrans p p2) in diff --git a/plugins/cc/ccproof.mli b/plugins/cc/ccproof.mli index 7fd28390f6..2a0ca688c6 100644 --- a/plugins/cc/ccproof.mli +++ b/plugins/cc/ccproof.mli @@ -18,12 +18,12 @@ type rule= | Refl of term | Trans of proof*proof | Congr of proof*proof - | Inject of proof*constructor*int*int -and proof = + | Inject of proof*constructor*int*int +and proof = private {p_lhs:term;p_rhs:term;p_rule:rule} -val build_proof : - forest -> +val build_proof : + forest -> [ `Discr of int * pa_constructor * int * pa_constructor | `Prove of int * int ] -> proof diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 515d4aa932..4e6ea8022e 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -80,18 +80,18 @@ let rec decompose_term env sigma t= ci_arity=nargs; ci_nhyps=nargs-oib.mind_nparams} | _ ->if closed0 t then (Symb t) else raise Not_found - + (* decompose equality in members and type *) - + let atom_of_constr env sigma term = let wh = (whd_delta env term) in - let kot = kind_of_term wh in + let kot = kind_of_term wh in match kot with App (f,args)-> - if eq_constr f (Lazy.force _eq) && (Array.length args)=3 + if eq_constr f (Lazy.force _eq) && (Array.length args)=3 then `Eq (args.(0), - decompose_term env sigma args.(1), - decompose_term env sigma args.(2)) + decompose_term env sigma args.(1), + decompose_term env sigma args.(2)) else `Other (decompose_term env sigma term) | _ -> `Other (decompose_term env sigma term) @@ -99,7 +99,7 @@ let rec pattern_of_constr env sigma c = match kind_of_term (whd env c) with App (f,args)-> let pf = decompose_term env sigma f in - let pargs,lrels = List.split + let pargs,lrels = List.split (array_map_to_list (pattern_of_constr env sigma) args) in PApp (pf,List.rev pargs), List.fold_left Intset.union Intset.empty lrels @@ -112,7 +112,7 @@ let rec pattern_of_constr env sigma c = PApp(Product (sort_a,sort_b), [pa;pb]),(Intset.union sa sb) | Rel i -> PVar i,Intset.singleton i - | _ -> + | _ -> let pf = decompose_term env sigma c in PApp (pf,[]),Intset.empty @@ -121,58 +121,58 @@ let non_trivial = function | _ -> true let patterns_of_constr env sigma nrels term= - let f,args= + let f,args= try destApp (whd_delta env term) with _ -> raise Not_found in - if eq_constr f (Lazy.force _eq) && (Array.length args)=3 - then + if eq_constr f (Lazy.force _eq) && (Array.length args)=3 + then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in - let valid1 = + let valid1 = if Intset.cardinal rels1 <> nrels then Creates_variables else if non_trivial patt1 then Normal - else Trivial args.(0) + else Trivial args.(0) and valid2 = if Intset.cardinal rels2 <> nrels then Creates_variables else if non_trivial patt2 then Normal else Trivial args.(0) in if valid1 <> Creates_variables - || valid2 <> Creates_variables then + || valid2 <> Creates_variables then nrels,valid1,patt1,valid2,patt2 else raise Not_found else raise Not_found let rec quantified_atom_of_constr env sigma nrels term = match kind_of_term (whd_delta env term) with - Prod (_,atom,ff) -> + Prod (_,atom,ff) -> if eq_constr ff (Lazy.force _False) then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts - else + else quantified_atom_of_constr env sigma (succ nrels) ff - | _ -> + | _ -> let patts=patterns_of_constr env sigma nrels term in - `Rule patts + `Rule patts let litteral_of_constr env sigma term= match kind_of_term (whd_delta env term) with - | Prod (_,atom,ff) -> + | Prod (_,atom,ff) -> if eq_constr ff (Lazy.force _False) then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) else begin - try - quantified_atom_of_constr env sigma 1 ff + try + quantified_atom_of_constr env sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end - | _ -> + | _ -> atom_of_constr env sigma term - + (* store all equalities from the context *) - + let rec make_prb gls depth additionnal_terms = let env=pf_env gls in let sigma=sig_sig gls in @@ -182,8 +182,8 @@ let rec make_prb gls depth additionnal_terms = List.iter (fun c -> let t = decompose_term env sigma c in - ignore (add_term state t)) additionnal_terms; - List.iter + ignore (add_term state t)) additionnal_terms; + List.iter (fun (id,_,e) -> begin let cid=mkVar id in @@ -191,15 +191,15 @@ let rec make_prb gls depth additionnal_terms = `Eq (t,a,b) -> add_equality state cid a b | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b | `Other ph -> - List.iter - (fun (cidn,nh) -> - add_disequality state (HeqnH (cid,cidn)) ph nh) + List.iter + (fun (cidn,nh) -> + add_disequality state (HeqnH (cid,cidn)) ph nh) !neg_hyps; pos_hyps:=(cid,ph):: !pos_hyps | `Nother nh -> - List.iter - (fun (cidp,ph) -> - add_disequality state (HeqnH (cidp,cid)) ph nh) + List.iter + (fun (cidp,ph) -> + add_disequality state (HeqnH (cidp,cid)) ph nh) !pos_hyps; neg_hyps:=(cid,nh):: !neg_hyps | `Rule patts -> add_quant state id true patts @@ -208,9 +208,9 @@ let rec make_prb gls depth additionnal_terms = begin match atom_of_constr env sigma gls.it.evar_concl with `Eq (t,a,b) -> add_disequality state Goal a b - | `Other g -> - List.iter - (fun (idp,ph) -> + | `Other g -> + List.iter + (fun (idp,ph) -> add_disequality state (HeqG idp) ph g) !pos_hyps end; state @@ -218,11 +218,11 @@ let rec make_prb gls depth additionnal_terms = (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) let build_projection intype outtype (cstr:constructor) special default gls= - let env=pf_env gls in - let (h,argv) = - try destApp intype with + let env=pf_env gls in + let (h,argv) = + try destApp intype with Invalid_argument _ -> (intype,[||]) in - let ind=destInd h in + let ind=destInd h in let types=Inductiveops.arities_of_constructors env ind in let lp=Array.length types in let ci=pred (snd cstr) in @@ -230,16 +230,16 @@ let build_projection intype outtype (cstr:constructor) special default gls= let ti=Term.prod_appvect types.(i) argv in let rc=fst (decompose_prod_assum ti) in let head= - if i=ci then special else default in + if i=ci then special else default in it_mkLambda_or_LetIn head rc in let branches=Array.init lp branch in let casee=mkRel 1 in let pred=mkLambda(Anonymous,intype,outtype) in let case_info=make_case_info (pf_env gls) ind RegularStyle in let body= mkCase(case_info, pred, casee, branches) in - let id=pf_get_new_id (id_of_string "t") gls in + let id=pf_get_new_id (id_of_string "t") gls in mkLambda(Name id,intype,body) - + (* generate an adhoc tactic following the proof tree *) let _M =mkMeta @@ -247,29 +247,29 @@ let _M =mkMeta let rec proof_tac p gls = match p.p_rule with Ax c -> exact_check c gls - | SymAx c -> - let l=constr_of_term p.p_lhs and + | SymAx c -> + let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in - let typ = refresh_universes (pf_type_of gls l) in + let typ = refresh_universes (pf_type_of gls l) in exact_check (mkApp(Lazy.force _sym_eq,[|typ;r;l;c|])) gls | Refl t -> let lr = constr_of_term t in - let typ = refresh_universes (pf_type_of gls lr) in + let typ = refresh_universes (pf_type_of gls lr) in exact_check (mkApp(Lazy.force _refl_equal,[|typ;constr_of_term t|])) gls | Trans (p1,p2)-> let t1 = constr_of_term p1.p_lhs and t2 = constr_of_term p1.p_rhs and t3 = constr_of_term p2.p_rhs in - let typ = refresh_universes (pf_type_of gls t2) in - let prf = + let typ = refresh_universes (pf_type_of gls t2) in + let prf = mkApp(Lazy.force _trans_eq,[|typ;t1;t2;t3;_M 1;_M 2|]) in tclTHENS (refine prf) [(proof_tac p1);(proof_tac p2)] gls | Congr (p1,p2)-> - let tf1=constr_of_term p1.p_lhs - and tx1=constr_of_term p2.p_lhs - and tf2=constr_of_term p1.p_rhs + let tf1=constr_of_term p1.p_lhs + and tx1=constr_of_term p2.p_lhs + and tf2=constr_of_term p1.p_rhs and tx2=constr_of_term p2.p_rhs in let typf = refresh_universes (pf_type_of gls tf1) in let typx = refresh_universes (pf_type_of gls tx1) in @@ -282,7 +282,7 @@ let rec proof_tac p gls = let lemma2= mkApp(Lazy.force _f_equal, [|typx;typfx;tf2;tx1;tx2;_M 1|]) in - let prf = + let prf = mkApp(Lazy.force _trans_eq, [|typfx; mkApp(tf1,[|tx1|]); @@ -294,8 +294,8 @@ let rec proof_tac p gls = [tclTHEN (refine lemma2) (proof_tac p2); reflexivity; fun gls -> - errorlabstrm "Congruence" - (Pp.str + errorlabstrm "Congruence" + (Pp.str "I don't know how to handle dependent equality")]] gls | Inject (prf,cstr,nargs,argind) -> let ti=constr_of_term prf.p_lhs in @@ -306,10 +306,10 @@ let rec proof_tac p gls = let special=mkRel (1+nargs-argind) in let proj=build_projection intype outtype cstr special default gls in let injt= - mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in + mkApp (Lazy.force _f_equal,[|intype;outtype;proj;ti;tj;_M 1|]) in tclTHEN (refine injt) (proof_tac prf) gls -let refute_tac c t1 t2 p gls = +let refute_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let intype=refresh_universes (pf_type_of gls tt1) in let neweq= @@ -323,13 +323,13 @@ let refute_tac c t1 t2 p gls = let convert_to_goal_tac c t1 t2 p gls = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let sort=refresh_universes (pf_type_of gls tt2) in - let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in + let neweq=mkApp(Lazy.force _eq,[|sort;tt1;tt2|]) in let e=pf_get_new_id (id_of_string "e") gls in let x=pf_get_new_id (id_of_string "X") gls in - let identity=mkLambda (Name x,sort,mkRel 1) in + let identity=mkLambda (Name x,sort,mkRel 1) in let endt=mkApp (Lazy.force _eq_rect, [|sort;tt1;identity;c;tt2;mkVar e|]) in - tclTHENS (assert_tac (Name e) neweq) + tclTHENS (assert_tac (Name e) neweq) [proof_tac p;exact_check endt] gls let convert_to_hyp_tac c1 t1 c2 t2 p gls = @@ -339,7 +339,7 @@ let convert_to_hyp_tac c1 t1 c2 t2 p gls = tclTHENS (assert_tac (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] gls - + let discriminate_tac cstr p gls = let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in let intype=refresh_universes (pf_type_of gls t1) in @@ -351,25 +351,25 @@ let discriminate_tac cstr p gls = let trivial=pf_type_of gls identity in let outtype=mkType (new_univ ()) in let pred=mkLambda(Name xid,outtype,mkRel 1) in - let hid=pf_get_new_id (id_of_string "Heq") gls in + let hid=pf_get_new_id (id_of_string "Heq") gls in let proj=build_projection intype outtype cstr trivial concl gls in let injt=mkApp (Lazy.force _f_equal, - [|intype;outtype;proj;t1;t2;mkVar hid|]) in + [|intype;outtype;proj;t1;t2;mkVar hid|]) in let endt=mkApp (Lazy.force _eq_rect, [|outtype;trivial;pred;identity;concl;injt|]) in let neweq=mkApp(Lazy.force _eq,[|intype;t1;t2|]) in - tclTHENS (assert_tac (Name hid) neweq) + tclTHENS (assert_tac (Name hid) neweq) [proof_tac p;exact_check endt] gls - + (* wrap everything *) - + let build_term_to_complete uf meta pac = let cinfo = get_constructor_info uf pac.cnode in let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in let dummy_args = List.rev (list_tabulate meta pac.arity) in let all_args = List.rev_append real_args dummy_args in applistc (mkConstruct cinfo.ci_constr) all_args - + let cc_tactic depth additionnal_terms gls= Coqlib.check_required_library ["Coq";"Init";"Logic"]; let _ = debug Pp.msgnl (Pp.str "Reading subgoal ...") in @@ -379,7 +379,7 @@ let cc_tactic depth additionnal_terms gls= let _ = debug Pp.msgnl (Pp.str "Computation completed.") in let uf=forest state in match sol with - None -> tclFAIL 0 (str "congruence failed") gls + None -> tclFAIL 0 (str "congruence failed") gls | Some reason -> debug Pp.msgnl (Pp.str "Goal solved, generating proof ..."); match reason with @@ -390,22 +390,22 @@ let cc_tactic depth additionnal_terms gls= | Incomplete -> let metacnt = ref 0 in let newmeta _ = incr metacnt; _M !metacnt in - let terms_to_complete = - List.map - (build_term_to_complete uf newmeta) - (epsilons uf) in + let terms_to_complete = + List.map + (build_term_to_complete uf newmeta) + (epsilons uf) in Pp.msgnl (Pp.str "Goal is solvable by congruence but \ some arguments are missing."); Pp.msgnl (Pp.str " Try " ++ hov 8 - begin - str "\"congruence with (" ++ - prlist_with_sep + begin + str "\"congruence with (" ++ + prlist_with_sep (fun () -> str ")" ++ pr_spc () ++ str "(") (print_constr_env (pf_env gls)) - terms_to_complete ++ + terms_to_complete ++ str ")\"," end); Pp.msgnl @@ -417,18 +417,18 @@ let cc_tactic depth additionnal_terms gls= match dis.rule with Goal -> proof_tac p gls | Hyp id -> refute_tac id ta tb p gls - | HeqG id -> + | HeqG id -> convert_to_goal_tac id ta tb p gls - | HeqnH (ida,idb) -> + | HeqnH (ida,idb) -> convert_to_hyp_tac ida ta idb tb p gls - + let cc_fail gls = - errorlabstrm "Congruence" (Pp.str "congruence failed.") + errorlabstrm "Congruence" (Pp.str "congruence failed.") -let congruence_tac depth l = - tclORELSE - (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) +let congruence_tac depth l = + tclORELSE + (tclTHEN (tclREPEAT introf) (cc_tactic depth l)) cc_fail (* Beware: reflexivity = constructor 1 = apply refl_equal @@ -441,22 +441,22 @@ let simple_reflexivity () = apply (Lazy.force _refl_equal) It mimics the use of lemmas [f_equal], [f_equal2], etc. This isn't particularly related with congruence, apart from - the fact that congruence is called internally. + the fact that congruence is called internally. *) -let f_equal gl = - let cut_eq c1 c2 = - let ty = refresh_universes (pf_type_of gl c1) in +let f_equal gl = + let cut_eq c1 c2 = + let ty = refresh_universes (pf_type_of gl c1) in tclTHENTRY (Tactics.cut (mkApp (Lazy.force _eq, [|ty; c1; c2|]))) (simple_reflexivity ()) - in - try match kind_of_term (pf_concl gl) with - | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> - begin match kind_of_term t, kind_of_term t' with + in + try match kind_of_term (pf_concl gl) with + | App (r,[|_;t;t'|]) when eq_constr r (Lazy.force _eq) -> + begin match kind_of_term t, kind_of_term t' with | App (f,v), App (f',v') when Array.length v = Array.length v' -> - let rec cuts i = - if i < 0 then tclTRY (congruence_tac 1000 []) + let rec cuts i = + if i < 0 then tclTRY (congruence_tac 1000 []) else tclTHENFIRST (cut_eq v.(i) v'.(i)) (cuts (i-1)) in cuts (Array.length v - 1) gl | _ -> tclIDTAC gl diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index 7cdd46ab4a..7ed077bda1 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -8,7 +8,7 @@ (* $Id$ *) -open Term +open Term open Proof_type val proof_tac: Ccproof.proof -> Proof_type.tactic diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index f23ed49b6e..d9db927a37 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -15,12 +15,12 @@ open Tactics open Tacticals (* Tactic registration *) - + TACTIC EXTEND cc [ "congruence" ] -> [ congruence_tac 1000 [] ] |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] - |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> + |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> [ congruence_tac n l ] END diff --git a/plugins/dp/Dp.v b/plugins/dp/Dp.v index 47d67725f2..bc7d73f62d 100644 --- a/plugins/dp/Dp.v +++ b/plugins/dp/Dp.v @@ -103,14 +103,14 @@ Definition zenon_notequal_s := fun T a b x y => zenon_notequal T a b y x. Set Implicit Arguments. Section congr. Variable t:Type. -Lemma ergo_eq_concat_1 : +Lemma ergo_eq_concat_1 : forall (P:t -> Prop) (x y:t), P x -> x = y -> P y. Proof. intros; subst; auto. Qed. -Lemma ergo_eq_concat_2 : +Lemma ergo_eq_concat_2 : forall (P:t -> t -> Prop) (x1 x2 y1 y2:t), P x1 x2 -> x1 = y1 -> x2 = y2 -> P y1 y2. Proof. diff --git a/plugins/dp/dp.ml b/plugins/dp/dp.ml index a7e1a82068..dc4698c5ea 100644 --- a/plugins/dp/dp.ml +++ b/plugins/dp/dp.ml @@ -1,7 +1,7 @@ (* Authors: Nicolas Ayache and Jean-Christophe Filliâtre *) (* Tactics to call decision procedures *) -(* Works in two steps: +(* Works in two steps: - first the Coq context and the current goal are translated in Polymorphic First-Order Logic (see fol.mli in this directory) @@ -36,27 +36,27 @@ let set_trace b = trace := b let timeout = ref 10 let set_timeout n = timeout := n -let (dp_timeout_obj,_) = - declare_object - {(default_object "Dp_timeout") with +let (dp_timeout_obj,_) = + declare_object + {(default_object "Dp_timeout") with cache_function = (fun (_,x) -> set_timeout x); load_function = (fun _ (_,x) -> set_timeout x); export_function = (fun x -> Some x)} let dp_timeout x = Lib.add_anonymous_leaf (dp_timeout_obj x) -let (dp_debug_obj,_) = - declare_object - {(default_object "Dp_debug") with +let (dp_debug_obj,_) = + declare_object + {(default_object "Dp_debug") with cache_function = (fun (_,x) -> set_debug x); load_function = (fun _ (_,x) -> set_debug x); export_function = (fun x -> Some x)} let dp_debug x = Lib.add_anonymous_leaf (dp_debug_obj x) -let (dp_trace_obj,_) = - declare_object - {(default_object "Dp_trace") with +let (dp_trace_obj,_) = + declare_object + {(default_object "Dp_trace") with cache_function = (fun (_,x) -> set_trace x); load_function = (fun _ (_,x) -> set_trace x); export_function = (fun x -> Some x)} @@ -67,7 +67,7 @@ let logic_dir = ["Coq";"Logic";"Decidable"] let coq_modules = init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules @ [["Coq"; "ZArith"; "BinInt"]; - ["Coq"; "Reals"; "Rdefinitions"]; + ["Coq"; "Reals"; "Rdefinitions"]; ["Coq"; "Reals"; "Raxioms";]; ["Coq"; "Reals"; "Rbasic_fun";]; ["Coq"; "Reals"; "R_sqrt";]; @@ -123,36 +123,36 @@ let global_names = Hashtbl.create 97 let used_names = Hashtbl.create 97 let rename_global r = - try + try Hashtbl.find global_names r with Not_found -> - let rec loop id = - if Hashtbl.mem used_names id then + let rec loop id = + if Hashtbl.mem used_names id then loop (lift_ident id) - else begin + else begin Hashtbl.add used_names id (); let s = string_of_id id in - Hashtbl.add global_names r s; + Hashtbl.add global_names r s; s end in loop (Nametab.basename_of_global r) let foralls = - List.fold_right + List.fold_right (fun (x,t) p -> Forall (x, t, p)) let fresh_var = function | Anonymous -> rename_global (VarRef (id_of_string "x")) | Name x -> rename_global (VarRef x) -(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of - env names, and returns the new variables together with the new +(* coq_rename_vars env [(x1,t1);...;(xn,tn)] renames the xi outside of + env names, and returns the new variables together with the new environment *) let coq_rename_vars env vars = let avoid = ref (ids_of_named_context (Environ.named_context env)) in List.fold_right - (fun (na,t) (newvars, newenv) -> + (fun (na,t) (newvars, newenv) -> let id = next_name_away na !avoid in avoid := id :: !avoid; id :: newvars, Environ.push_named (id, None, t) newenv) @@ -162,9 +162,9 @@ let coq_rename_vars env vars = type_quantifiers env (A1:Set)...(Ak:Set)t = A1...An, (env+Ai), t *) let decomp_type_quantifiers env t = let rec loop vars t = match kind_of_term t with - | Prod (n, a, t) when is_Set a || is_Type a -> + | Prod (n, a, t) when is_Set a || is_Type a -> loop ((n,a) :: vars) t - | _ -> + | _ -> let vars, env = coq_rename_vars env vars in let t = substl (List.map mkVar vars) t in List.rev vars, env, t @@ -174,21 +174,21 @@ let decomp_type_quantifiers env t = (* same thing with lambda binders (for axiomatize body) *) let decomp_type_lambdas env t = let rec loop vars t = match kind_of_term t with - | Lambda (n, a, t) when is_Set a || is_Type a -> + | Lambda (n, a, t) when is_Set a || is_Type a -> loop ((n,a) :: vars) t - | _ -> + | _ -> let vars, env = coq_rename_vars env vars in let t = substl (List.map mkVar vars) t in List.rev vars, env, t in loop [] t -let decompose_arrows = +let decompose_arrows = let rec arrows_rec l c = match kind_of_term c with | Prod (_,t,c) when not (dependent (mkRel 1) c) -> arrows_rec (t :: l) c | Cast (c,_,_) -> arrows_rec l c | _ -> List.rev l, c - in + in arrows_rec [] let rec eta_expanse t vars env i = @@ -203,7 +203,7 @@ let rec eta_expanse t vars env i = let env' = Environ.push_named (id, None, a) env in let t' = mkApp (t, [| mkVar id |]) in eta_expanse t' (id :: vars) env' (pred i) - | _ -> + | _ -> assert false let rec skip_k_args k cl = match k, cl with @@ -222,7 +222,7 @@ let globals_stack = ref [] let () = Summary.declare_summary "Dp globals" { Summary.freeze_function = (fun () -> !globals, !globals_stack); - Summary.unfreeze_function = + Summary.unfreeze_function = (fun (g,s) -> globals := g; globals_stack := s); Summary.init_function = (fun () -> ()) } @@ -238,7 +238,7 @@ let lookup_local r = match Hashtbl.find locals r with | Gnot_fo -> raise NotFO | Gfo d -> d -let iter_all_constructors i f = +let iter_all_constructors i f = let _, oib = Global.lookup_inductive i in Array.iteri (fun j tj -> f j (mkConstruct (i, j+1))) @@ -246,7 +246,7 @@ let iter_all_constructors i f = (* injection c [t1,...,tn] adds the injection axiom - forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. + forall x1:t1,...,xn:tn,y1:t1,...,yn:tn. c(x1,...,xn)=c(y1,...,yn) -> x1=y1 /\ ... /\ xn=yn *) let injection c l = @@ -255,8 +255,8 @@ let injection c l = let xl = List.map (fun t -> rename_global (VarRef (var "x")), t) l in i := 0; let yl = List.map (fun t -> rename_global (VarRef (var "y")), t) l in - let f = - List.fold_right2 + let f = + List.fold_right2 (fun (x,_) (y,_) p -> And (Fatom (Eq (App (x,[]),App (y,[]))), p)) xl yl True in @@ -267,14 +267,14 @@ let injection c l = let ax = Axiom ("injection_" ^ c, f) in globals_stack := ax :: !globals_stack -(* rec_names_for c [|n1;...;nk|] builds the list of constant names for +(* rec_names_for c [|n1;...;nk|] builds the list of constant names for identifiers n1...nk with the same path as c, if they exist; otherwise raises Not_found *) let rec_names_for c = let mp,dp,_ = Names.repr_con c in array_map_to_list - (function - | Name id -> + (function + | Name id -> let c' = Names.make_con mp dp (label_of_id id) in ignore (Global.lookup_constant c'); msgnl (Printer.pr_constr (mkConst c')); @@ -286,7 +286,7 @@ let rec_names_for c = let term_abstractions = Hashtbl.create 97 -let new_abstraction = +let new_abstraction = let r = ref 0 in fun () -> incr r; "abstraction_" ^ string_of_int !r (* Arithmetic constants *) @@ -345,14 +345,14 @@ let rec tr_arith_constant t = match kind_of_term t with tr_powerRZ a b | Term.Cast (t, _, _) -> tr_arith_constant t - | _ -> + | _ -> raise NotArithConstant (* translates a constant of the form (powerRZ 2 int_constant) *) and tr_powerRZ a b = (* checking first that a is (R1 + R1) *) match kind_of_term a with - | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus -> + | Term.App (f, [|c;d|]) when f = Lazy.force coq_Rplus -> begin match kind_of_term c,kind_of_term d with | Term.Const _, Term.Const _ @@ -371,9 +371,9 @@ and tr_powerRZ a b = tv = list of type variables *) and tr_type tv env t = let t = Reductionops.nf_betadeltaiota env Evd.empty t in - if t = Lazy.force coq_Z then + if t = Lazy.force coq_Z then Tid ("int", []) - else if t = Lazy.force coq_R then + else if t = Lazy.force coq_R then Tid ("real", []) else match kind_of_term t with | Var x when List.mem x tv -> @@ -383,15 +383,15 @@ and tr_type tv env t = begin try let r = global_of_constr f in match tr_global env r with - | DeclType (id, k) -> + | DeclType (id, k) -> assert (k = List.length cl); (* since t:Set *) Tid (id, List.map (tr_type tv env) cl) - | _ -> + | _ -> raise NotFO - with + with | Not_found -> raise NotFO - | NotFO -> + | NotFO -> (* we need to abstract some part of (f cl) *) (*TODO*) raise NotFO @@ -403,8 +403,8 @@ and make_term_abstraction tv env c = match tr_decl env id ty with | DeclFun (id,_,_,_) as _d -> raise NotFO - (* [CM 07/09/2009] deactivated because it generates - unbound identifiers 'abstraction_' + (* [CM 07/09/2009] deactivated because it generates + unbound identifiers 'abstraction_' begin try Hashtbl.find term_abstractions c with Not_found -> @@ -428,7 +428,7 @@ and tr_decl env id ty = DeclType (id, List.length tv) else if is_Prop t then DeclPred (id, List.length tv, []) - else + else let s = Typing.type_of env Evd.empty t in if is_Prop s then Axiom (id, tr_formula tv [] env t) @@ -437,11 +437,11 @@ and tr_decl env id ty = let l = List.map (tr_type tv env) l in if is_Prop t then DeclPred(id, List.length tv, l) - else + else let s = Typing.type_of env Evd.empty t in - if is_Set s || is_Type s then + if is_Set s || is_Type s then DeclFun (id, List.length tv, l, tr_type tv env t) - else + else raise NotFO (* tr_global(r) = tr_decl(id(r),typeof(r)) + a cache mechanism *) @@ -457,7 +457,7 @@ and tr_global env r = match r with let id = rename_global r in let d = tr_decl env id ty in (* r can be already declared if it is a constructor *) - if not (mem_global r) then begin + if not (mem_global r) then begin add_global r (Gfo d); globals_stack := d :: !globals_stack end; @@ -468,7 +468,7 @@ and tr_global env r = match r with raise NotFO and axiomatize_body env r id d = match r with - | VarRef _ -> + | VarRef _ -> assert false | ConstRef c -> begin match (Global.lookup_constant c).const_body with @@ -488,7 +488,7 @@ and axiomatize_body env r id d = match r with (*Format.eprintf "axiomatize_body %S@." id;*) let b = match kind_of_term b with (* a single recursive function *) - | Fix (_, (_,_,[|b|])) -> + | Fix (_, (_,_,[|b|])) -> subst1 (mkConst c) b (* mutually recursive functions *) | Fix ((_,i), (names,_,bodies)) -> @@ -499,7 +499,7 @@ and axiomatize_body env r id d = match r with with Not_found -> b end - | _ -> + | _ -> b in let tv, env, b = decomp_type_lambdas env b in @@ -521,9 +521,9 @@ and axiomatize_body env r id d = match r with begin match kind_of_term t with | Case (ci, _, e, br) -> equations_for_case env id vars tv bv ci e br - | _ -> + | _ -> let t = tr_term tv bv env t in - let ax = + let ax = add_proof (Fun_def (id, vars, ty, t)) in let p = Fatom (Eq (App (id, fol_vars), t)) in @@ -542,7 +542,7 @@ and axiomatize_body env r id d = match r with in let axioms = List.map (fun (id,ax) -> Axiom (id, ax)) axioms in globals_stack := axioms @ !globals_stack - | None -> + | None -> () (* Coq axiom *) end | IndRef i -> @@ -597,12 +597,12 @@ and equations_for_case env id vars tv bv ci e br = match kind_of_term e with | (y, t)::l' -> if y = string_of_id e then l' else (y, t)::(remove l' e) in let vars = remove vars x in - let p = - Fatom (Eq (App (id, fol_vars), + let p = + Fatom (Eq (App (id, fol_vars), tr_term tv bv env b)) in eqs := (id ^ "_" ^ idc, foralls vars p) :: !eqs - | _ -> + | _ -> assert false end with NotFO -> ()); @@ -611,30 +611,30 @@ and equations_for_case env id vars tv bv ci e br = match kind_of_term e with raise NotFO (* assumption: t:T:Set *) -and tr_term tv bv env t = +and tr_term tv bv env t = try tr_arith_constant t with NotArithConstant -> match kind_of_term t with (* binary operations on integers *) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zplus -> Plus (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zminus -> Moins (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zmult -> Mult (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Zdiv -> Div (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a|]) when f = Lazy.force coq_Zopp -> + | Term.App (f, [|a|]) when f = Lazy.force coq_Zopp -> Opp (tr_term tv bv env a) (* binary operations on reals *) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rplus -> Plus (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rminus -> Moins (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rmult -> Mult (tr_term tv bv env a, tr_term tv bv env b) - | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv -> + | Term.App (f, [|a;b|]) when f = Lazy.force coq_Rdiv -> Div (tr_term tv bv env a, tr_term tv bv env b) | Term.Var id when List.mem id bv -> App (string_of_id id, []) @@ -643,12 +643,12 @@ and tr_term tv bv env t = begin try let r = global_of_constr f in match tr_global env r with - | DeclFun (s, k, _, _) -> + | DeclFun (s, k, _, _) -> let cl = skip_k_args k cl in Fol.App (s, List.map (tr_term tv bv env) cl) - | _ -> + | _ -> raise NotFO - with + with | Not_found -> raise NotFO | NotFO -> (* we need to abstract some part of (f cl) *) @@ -663,7 +663,7 @@ and tr_term tv bv env t = abstract (applist (app, [x])) l end in - let app,l = match cl with + let app,l = match cl with | x :: l -> applist (f, [x]), l | [] -> raise NotFO in abstract app l @@ -681,14 +681,14 @@ and quantifiers n a b tv bv env = and tr_formula tv bv env f = let c, args = decompose_app f in match kind_of_term c, args with - | Var id, [] -> + | Var id, [] -> Fatom (Pred (rename_global (VarRef id), [])) | _, [t;a;b] when c = build_coq_eq () -> let ty = Typing.type_of env Evd.empty t in if is_Set ty || is_Type ty then let _ = tr_type tv env t in Fatom (Eq (tr_term tv bv env a, tr_term tv bv env b)) - else + else raise NotFO (* comparisons on integers *) | _, [a;b] when c = Lazy.force coq_Zle -> @@ -731,7 +731,7 @@ and tr_formula tv bv env f = | Lambda(n, a, b) -> let id, t, bv, env, b = quantifiers n a b tv bv env in Exists (string_of_id id, t, tr_formula tv bv env b) - | _ -> + | _ -> (* unusual case of the shape (ex p) *) raise NotFO (* TODO: we could eta-expanse *) end @@ -739,10 +739,10 @@ and tr_formula tv bv env f = begin try let r = global_of_constr c in match tr_global env r with - | DeclPred (s, k, _) -> + | DeclPred (s, k, _) -> let args = skip_k_args k args in Fatom (Pred (s, List.map (tr_term tv bv env) args)) - | _ -> + | _ -> raise NotFO with Not_found -> raise NotFO @@ -751,7 +751,7 @@ and tr_formula tv bv env f = let tr_goal gl = Hashtbl.clear locals; - let tr_one_hyp (id, ty) = + let tr_one_hyp (id, ty) = try let s = rename_global (VarRef id) in let d = tr_decl (pf_env gl) s ty in @@ -762,7 +762,7 @@ let tr_goal gl = raise NotFO in let hyps = - List.fold_right + List.fold_right (fun h acc -> try tr_one_hyp h :: acc with NotFO -> acc) (pf_hyps_types gl) [] in @@ -781,9 +781,9 @@ let file_contents f = let buf = Buffer.create 1024 in try let c = open_in f in - begin try - while true do - let s = input_line c in Buffer.add_string buf s; + begin try + while true do + let s = input_line c in Buffer.add_string buf s; Buffer.add_char buf '\n' done; assert false @@ -791,7 +791,7 @@ let file_contents f = close_in c; Buffer.contents buf end - with _ -> + with _ -> sprintf "(cannot open %s)" f let timeout_sys_command cmd = @@ -799,24 +799,24 @@ let timeout_sys_command cmd = let out = Filename.temp_file "out" "" in let cmd = sprintf "why-cpulimit %d %s > %s 2>&1" !timeout cmd out in let ret = Sys.command cmd in - if !debug then + if !debug then Format.eprintf "Output file %s:@.%s@." out (file_contents out); ret, out let timeout_or_failure c cmd out = - if c = 152 then - Timeout + if c = 152 then + Timeout else - Failure + Failure (sprintf "command %s failed with output:\n%s " cmd (file_contents out)) let prelude_files = ref ([] : string list) let set_prelude l = prelude_files := l -let (dp_prelude_obj,_) = - declare_object - {(default_object "Dp_prelude") with +let (dp_prelude_obj,_) = + declare_object + {(default_object "Dp_prelude") with cache_function = (fun (_,x) -> set_prelude x); load_function = (fun _ (_,x) -> set_prelude x); export_function = (fun x -> Some x)} @@ -826,18 +826,18 @@ let dp_prelude x = Lib.add_anonymous_leaf (dp_prelude_obj x) let why_files f = String.concat " " (!prelude_files @ [f]) let call_simplify fwhy = - let cmd = - sprintf "why --simplify %s" (why_files fwhy) + let cmd = + sprintf "why --simplify %s" (why_files fwhy) in if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); let fsx = Filename.chop_suffix fwhy ".why" ^ "_why.sx" in - let cmd = - sprintf "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out" + let cmd = + sprintf "why-cpulimit %d Simplify %s > out 2>&1 && grep -q -w Valid out" !timeout fsx in let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout in if not !debug then remove_files [fwhy; fsx]; r @@ -847,15 +847,15 @@ let call_ergo fwhy = if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); let fwhy = Filename.chop_suffix fwhy ".why" ^ "_why.why" in let ftrace = Filename.temp_file "ergo_trace" "" in - let cmd = + let cmd = if !trace then sprintf "alt-ergo -cctrace %s %s" ftrace fwhy else sprintf "alt-ergo %s" fwhy in let ret,out = timeout_sys_command cmd in - let r = - if ret <> 0 then + let r = + if ret <> 0 then timeout_or_failure ret cmd out else if Sys.command (sprintf "grep -q -w Valid %s" out) = 0 then Valid (if !trace then Some ftrace else None) @@ -871,18 +871,18 @@ let call_ergo fwhy = let call_zenon fwhy = - let cmd = + let cmd = sprintf "why --no-prelude --no-zenon-prelude --zenon %s" (why_files fwhy) in if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); let fznn = Filename.chop_suffix fwhy ".why" ^ "_why.znn" in let out = Filename.temp_file "dp_out" "" in - let cmd = - sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out + let cmd = + sprintf "timeout %d zenon -ocoqterm %s > %s 2>&1" !timeout fznn out in let c = Sys.command cmd in if not !debug then remove_files [fwhy; fznn]; - if c = 137 then + if c = 137 then Timeout else begin if c <> 0 then anomaly ("command failed: " ^ cmd); @@ -893,58 +893,58 @@ let call_zenon fwhy = end let call_yices fwhy = - let cmd = + let cmd = sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) in if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in - let cmd = - sprintf "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out" + let cmd = + sprintf "why-cpulimit %d yices -pc 0 -smt %s > out 2>&1 && grep -q -w unsat out" !timeout fsmt in let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout in if not !debug then remove_files [fwhy; fsmt]; r let call_cvc3 fwhy = - let cmd = + let cmd = sprintf "why -smtlib --encoding sstrat %s" (why_files fwhy) in if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); let fsmt = Filename.chop_suffix fwhy ".why" ^ "_why.smt" in - let cmd = - sprintf "why-cpulimit %d cvc3 -lang smt %s > out 2>&1 && grep -q -w unsat out" + let cmd = + sprintf "why-cpulimit %d cvc3 -lang smt %s > out 2>&1 && grep -q -w unsat out" !timeout fsmt in let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout in if not !debug then remove_files [fwhy; fsmt]; r let call_cvcl fwhy = - let cmd = + let cmd = sprintf "why --cvcl --encoding sstrat %s" (why_files fwhy) in if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); let fcvc = Filename.chop_suffix fwhy ".why" ^ "_why.cvc" in - let cmd = - sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out" + let cmd = + sprintf "timeout %d cvcl < %s > out 2>&1 && grep -q -w Valid out" !timeout fcvc in let out = Sys.command cmd in - let r = - if out = 0 then Valid None else if out = 1 then Invalid else Timeout + let r = + if out = 0 then Valid None else if out = 1 then Invalid else Timeout in if not !debug then remove_files [fwhy; fcvc]; r let call_harvey fwhy = - let cmd = + let cmd = sprintf "why --harvey --encoding strat %s" (why_files fwhy) in if Sys.command cmd <> 0 then error ("call to " ^ cmd ^ " failed"); @@ -953,15 +953,15 @@ let call_harvey fwhy = if out <> 0 then anomaly ("call to rvc -e -t " ^ frv ^ " failed"); let f = Filename.chop_suffix frv ".rv" ^ "-0.baf" in let outf = Filename.temp_file "rv" ".out" in - let out = - Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" - !timeout f outf) + let out = + Sys.command (sprintf "timeout %d rv -e\"-T 2000\" %s > %s 2>&1" + !timeout f outf) in let r = - if out <> 0 then + if out <> 0 then Timeout else - let cmd = + let cmd = sprintf "grep \"Proof obligation in\" %s | grep -q \"is valid\"" outf in if Sys.command cmd = 0 then Valid None else Invalid @@ -1000,12 +1000,12 @@ let call_prover prover q = | CVCLite -> call_cvcl fwhy | Harvey -> call_harvey fwhy | Gwhy -> call_gwhy fwhy - + let dp prover gl = Coqlib.check_required_library ["Coq";"ZArith";"ZArith"]; let concl_type = pf_type_of gl (pf_concl gl) in if not (is_Prop concl_type) then error "Conclusion is not a Prop"; - try + try let q = tr_goal gl in begin match call_prover prover q with | Valid (Some f) when prover = Zenon -> Dp_zenon.proof_from_file f gl @@ -1019,7 +1019,7 @@ let dp prover gl = end with NotFO -> error "Not a first order goal" - + let simplify = tclTHEN intros (dp Simplify) let ergo = tclTHEN intros (dp Ergo) @@ -1032,7 +1032,7 @@ let gwhy = tclTHEN intros (dp Gwhy) let dp_hint l = let env = Global.env () in - let one_hint (qid,r) = + let one_hint (qid,r) = if not (mem_global r) then begin let ty = Global.type_of_global r in let s = Typing.type_of env Evd.empty ty in @@ -1046,7 +1046,7 @@ let dp_hint l = with NotFO -> add_global r Gnot_fo; msg_warning - (pr_reference qid ++ + (pr_reference qid ++ str " ignored (not a first order proposition)") else begin add_global r Gnot_fo; @@ -1057,9 +1057,9 @@ let dp_hint l = in List.iter one_hint (List.map (fun qid -> qid, Nametab.global qid) l) -let (dp_hint_obj,_) = - declare_object - {(default_object "Dp_hint") with +let (dp_hint_obj,_) = + declare_object + {(default_object "Dp_hint") with cache_function = (fun (_,l) -> dp_hint l); load_function = (fun _ (_,l) -> dp_hint l); export_function = (fun x -> Some x)} @@ -1075,7 +1075,7 @@ let dp_predefined qid s = let d = match tr_decl env id ty with | DeclType (_, n) -> DeclType (s, n) | DeclFun (_, n, tyl, ty) -> DeclFun (s, n, tyl, ty) - | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl) + | DeclPred (_, n, tyl) -> DeclPred (s, n, tyl) | Axiom _ as d -> d in match d with @@ -1084,22 +1084,22 @@ let dp_predefined qid s = with NotFO -> msg_warning (str " ignored (not a first order declaration)") -let (dp_predefined_obj,_) = - declare_object - {(default_object "Dp_predefined") with +let (dp_predefined_obj,_) = + declare_object + {(default_object "Dp_predefined") with cache_function = (fun (_,(id,s)) -> dp_predefined id s); load_function = (fun _ (_,(id,s)) -> dp_predefined id s); export_function = (fun x -> Some x)} let dp_predefined id s = Lib.add_anonymous_leaf (dp_predefined_obj (id,s)) -let _ = declare_summary "Dp options" - { freeze_function = +let _ = declare_summary "Dp options" + { freeze_function = (fun () -> !debug, !trace, !timeout, !prelude_files); - unfreeze_function = - (fun (d,tr,tm,pr) -> + unfreeze_function = + (fun (d,tr,tm,pr) -> debug := d; trace := tr; timeout := tm; prelude_files := pr); - init_function = - (fun () -> - debug := false; trace := false; timeout := 10; - prelude_files := []) } + init_function = + (fun () -> + debug := false; trace := false; timeout := 10; + prelude_files := []) } diff --git a/plugins/dp/dp_why.ml b/plugins/dp/dp_why.ml index 94dc0ef484..4a1d70d411 100644 --- a/plugins/dp/dp_why.ml +++ b/plugins/dp/dp_why.ml @@ -4,12 +4,12 @@ open Format open Fol -type proof = +type proof = | Immediate of Term.constr | Fun_def of string * (string * typ) list * typ * term let proofs = Hashtbl.create 97 -let proof_name = +let proof_name = let r = ref 0 in fun () -> incr r; "dp_axiom__" ^ string_of_int !r let add_proof pr = let n = proof_name () in Hashtbl.add proofs n pr; n @@ -24,9 +24,9 @@ let rec print_list sep print fmt = function let space fmt () = fprintf fmt "@ " let comma fmt () = fprintf fmt ",@ " -let is_why_keyword = +let is_why_keyword = let h = Hashtbl.create 17 in - List.iter + List.iter (fun s -> Hashtbl.add h s ()) ["absurd"; "and"; "array"; "as"; "assert"; "axiom"; "begin"; "bool"; "do"; "done"; "else"; "end"; "exception"; "exists"; @@ -34,7 +34,7 @@ let is_why_keyword = "if"; "in"; "int"; "invariant"; "label"; "let"; "logic"; "not"; "of"; "or"; "parameter"; "predicate"; "prop"; "raise"; "raises"; "reads"; "real"; "rec"; "ref"; "returns"; "then"; "true"; "try"; - "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; + "type"; "unit"; "variant"; "void"; "while"; "with"; "writes" ]; Hashtbl.mem h let ident fmt s = @@ -49,9 +49,9 @@ let rec print_typ fmt = function | Tid (x,tl) -> fprintf fmt "(%a) %a" (print_list comma print_typ) tl ident x let rec print_term fmt = function - | Cst n -> + | Cst n -> fprintf fmt "%s" (Big_int.string_of_big_int n) - | RCst s -> + | RCst s -> fprintf fmt "%s.0" (Big_int.string_of_big_int s) | Power2 n -> fprintf fmt "0x1p%s" (Big_int.string_of_big_int n) @@ -64,17 +64,17 @@ let rec print_term fmt = function | Div (a, b) -> fprintf fmt "@[(%a /@ %a)@]" print_term a print_term b | Opp (a) -> - fprintf fmt "@[(-@ %a)@]" print_term a + fprintf fmt "@[(-@ %a)@]" print_term a | App (id, []) -> fprintf fmt "%a" ident id | App (id, tl) -> fprintf fmt "@[%a(%a)@]" ident id print_terms tl -and print_terms fmt tl = +and print_terms fmt tl = print_list comma print_term fmt tl -let rec print_predicate fmt p = - let pp = print_predicate in +let rec print_predicate fmt p = + let pp = print_predicate in match p with | True -> fprintf fmt "true" @@ -90,9 +90,9 @@ let rec print_predicate fmt p = fprintf fmt "@[(%a >=@ %a)@]" print_term a print_term b | Fatom (Gt (a, b)) -> fprintf fmt "@[(%a >@ %a)@]" print_term a print_term b - | Fatom (Pred (id, [])) -> + | Fatom (Pred (id, [])) -> fprintf fmt "%a" ident id - | Fatom (Pred (id, tl)) -> + | Fatom (Pred (id, tl)) -> fprintf fmt "@[%a(%a)@]" ident id print_terms tl | Imp (a, b) -> fprintf fmt "@[(%a ->@ %a)@]" pp a pp b @@ -104,9 +104,9 @@ let rec print_predicate fmt p = fprintf fmt "@[(%a or@ %a)@]" pp a pp b | Not a -> fprintf fmt "@[(not@ %a)@]" pp a - | Forall (id, t, p) -> + | Forall (id, t, p) -> fprintf fmt "@[(forall %a:%a.@ %a)@]" ident id print_typ t pp p - | Exists (id, t, p) -> + | Exists (id, t, p) -> fprintf fmt "@[(exists %a:%a.@ %a)@]" ident id print_typ t pp p let print_query fmt (decls,concl) = @@ -117,7 +117,7 @@ let print_query fmt (decls,concl) = fprintf fmt "@[type 'a %a@]@\n@\n" ident id | DeclType (id, n) -> fprintf fmt "@[type ("; - for i = 1 to n do + for i = 1 to n do fprintf fmt "'a%d" i; if i < n then fprintf fmt ", " done; fprintf fmt ") %a@]@\n@\n" ident id @@ -128,18 +128,18 @@ let print_query fmt (decls,concl) = | DeclFun (id, _, [], t) -> fprintf fmt "@[logic %a : -> %a@]@\n@\n" ident id print_typ t | DeclFun (id, _, l, t) -> - fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" + fprintf fmt "@[logic %a : %a -> %a@]@\n@\n" ident id (print_list comma print_typ) l print_typ t | DeclPred (id, _, []) -> fprintf fmt "@[logic %a : -> prop @]@\n@\n" ident id - | DeclPred (id, _, l) -> - fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" + | DeclPred (id, _, l) -> + fprintf fmt "@[logic %a : %a -> prop@]@\n@\n" ident id (print_list comma print_typ) l | DeclType _ | Axiom _ -> () in let print_assert = function - | Axiom (id, f) -> + | Axiom (id, f) -> fprintf fmt "@[axiom %a:@ %a@]@\n@\n" ident id print_predicate f | DeclType _ | DeclFun _ | DeclPred _ -> () diff --git a/plugins/dp/dp_why.mli b/plugins/dp/dp_why.mli index b38a3d3762..0efa24a238 100644 --- a/plugins/dp/dp_why.mli +++ b/plugins/dp/dp_why.mli @@ -7,7 +7,7 @@ val output_file : string -> query -> unit (* table to translate the proofs back to Coq (used in dp_zenon) *) -type proof = +type proof = | Immediate of Term.constr | Fun_def of string * (string * typ) list * typ * term diff --git a/plugins/dp/dp_zenon.mll b/plugins/dp/dp_zenon.mll index 658534151a..949e91e344 100644 --- a/plugins/dp/dp_zenon.mll +++ b/plugins/dp/dp_zenon.mll @@ -1,7 +1,7 @@ { - open Lexing + open Lexing open Pp open Util open Names @@ -12,9 +12,9 @@ let debug = ref false let set_debug b = debug := b - + let buf = Buffer.create 1024 - + let string_of_global env ref = Libnames.string_of_qualid (Nametab.shortest_qualid_of_global env ref) @@ -50,15 +50,15 @@ and scan = parse { anomaly "malformed Zenon proof term" } and read_coq_term = parse -| "." "\n" +| "." "\n" { let s = Buffer.contents buf in Buffer.clear buf; s } | "coq__" (ident as id) (* a Why keyword renamed *) { Buffer.add_string buf id; read_coq_term lexbuf } -| ("dp_axiom__" ['0'-'9']+) as id +| ("dp_axiom__" ['0'-'9']+) as id { axioms := id :: !axioms; Buffer.add_string buf id; read_coq_term lexbuf } -| _ as c +| _ as c { Buffer.add_char buf c; read_coq_term lexbuf } -| eof +| eof { anomaly "malformed Zenon proof term" } and read_lemma_proof = parse @@ -71,7 +71,7 @@ and read_lemma_proof = parse and read_main_proof = parse | ":=" "\n" { read_coq_term lexbuf } -| _ +| _ { read_main_proof lexbuf } | eof { anomaly "malformed Zenon proof term" } @@ -88,7 +88,7 @@ and read_main_proof = parse if not !debug then begin try Sys.remove f with _ -> () end; p - let constr_of_string gl s = + let constr_of_string gl s = let parse_constr = Pcoq.parse_string Pcoq.Constr.constr in Constrintern.interp_constr (project gl) (pf_env gl) (parse_constr s) @@ -102,7 +102,7 @@ and read_main_proof = parse | [] -> () | [x] -> print fmt x | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r - + let space fmt () = fprintf fmt "@ " let comma fmt () = fprintf fmt ",@ " @@ -110,14 +110,14 @@ and read_main_proof = parse | Tvar x -> fprintf fmt "%s" x | Tid ("int", []) -> fprintf fmt "Z" | Tid (x, []) -> fprintf fmt "%s" x - | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t - | Tid (x,tl) -> - fprintf fmt "(%s %a)" x (print_list comma print_typ) tl - + | Tid (x, [t]) -> fprintf fmt "(%s %a)" x print_typ t + | Tid (x,tl) -> + fprintf fmt "(%s %a)" x (print_list comma print_typ) tl + let rec print_term fmt = function - | Cst n -> + | Cst n -> fprintf fmt "%s" (Big_int.string_of_big_int n) - | RCst s -> + | RCst s -> fprintf fmt "%s" (Big_int.string_of_big_int s) | Power2 n -> fprintf fmt "@[(powerRZ 2 %s)@]" (Big_int.string_of_big_int n) @@ -132,13 +132,13 @@ and read_main_proof = parse | Div (a, b) -> fprintf fmt "@[(Zdiv %a %a)@]" print_term a print_term b | Opp (a) -> - fprintf fmt "@[(Zopp %a)@]" print_term a + fprintf fmt "@[(Zopp %a)@]" print_term a | App (id, []) -> fprintf fmt "%s" id | App (id, tl) -> fprintf fmt "@[(%s %a)@]" id print_terms tl - and print_terms fmt tl = + and print_terms fmt tl = print_list space print_term fmt tl (* builds the text for "forall vars, f vars = t" *) @@ -146,17 +146,17 @@ and read_main_proof = parse let binder fmt (x,t) = fprintf fmt "(%s: %a)" x print_typ t in fprintf str_formatter "@[(forall %a, %s %a = %a)@]@." - (print_list space binder) vars f + (print_list space binder) vars f (print_list space (fun fmt (x,_) -> pp_print_string fmt x)) vars print_term t; flush_str_formatter () - + end let prove_axiom id = match Dp_why.find_proof id with - | Immediate t -> + | Immediate t -> exact_check t - | Fun_def (f, vars, ty, t) -> + | Fun_def (f, vars, ty, t) -> tclTHENS (fun gl -> let s = Coq.fun_def_axiom f vars t in diff --git a/plugins/dp/fol.mli b/plugins/dp/fol.mli index 32637bb74d..4fb763a6d1 100644 --- a/plugins/dp/fol.mli +++ b/plugins/dp/fol.mli @@ -1,11 +1,11 @@ (* Polymorphic First-Order Logic (that is Why's input logic) *) -type typ = +type typ = | Tvar of string | Tid of string * typ list -type term = +type term = | Cst of Big_int.big_int | RCst of Big_int.big_int | Power2 of Big_int.big_int @@ -16,7 +16,7 @@ type term = | Opp of term | App of string * term list -and atom = +and atom = | Eq of term * term | Le of term * term | Lt of term * term @@ -24,7 +24,7 @@ and atom = | Gt of term * term | Pred of string * term list -and form = +and form = | Fatom of atom | Imp of form * form | Iff of form * form @@ -48,8 +48,8 @@ type query = decl list * form (* prover result *) -type prover_answer = - | Valid of string option +type prover_answer = + | Valid of string option | Invalid | DontKnow | Timeout diff --git a/plugins/dp/g_dp.ml4 b/plugins/dp/g_dp.ml4 index e027c882e6..505b07a143 100644 --- a/plugins/dp/g_dp.ml4 +++ b/plugins/dp/g_dp.ml4 @@ -49,7 +49,7 @@ TACTIC EXTEND admit [ "admit" ] -> [ Tactics.admit_as_an_axiom ] END -VERNAC COMMAND EXTEND Dp_hint +VERNAC COMMAND EXTEND Dp_hint [ "Dp_hint" ne_global_list(l) ] -> [ dp_hint l ] END diff --git a/plugins/dp/test2.v b/plugins/dp/test2.v index 3e4c0f6dd0..0940b13524 100644 --- a/plugins/dp/test2.v +++ b/plugins/dp/test2.v @@ -36,7 +36,7 @@ Goal fct O = O. Admitted. Fixpoint even (n:nat) : Prop := - match n with + match n with O => True | S O => False | S (S p) => even p @@ -64,9 +64,9 @@ BUG avec head prédéfini : manque eta-expansion sur A:Set Goal forall x, head _ (p _ _ 1 2) = Some x -> fst x = 1. -Print value. +Print value. Print Some. - + zenon. *) diff --git a/plugins/dp/tests.v b/plugins/dp/tests.v index 1a796094b8..dc85d2ee2b 100644 --- a/plugins/dp/tests.v +++ b/plugins/dp/tests.v @@ -50,8 +50,8 @@ Qed. Parameter nlist: list nat -> Prop. Lemma poly_1 : forall l, nlist l -> True. -intros. -simplify. +intros. +simplify. Qed. (* user lists *) @@ -66,8 +66,8 @@ match l with | cons a l1 => cons A a (app A l1 m) end. -Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. -intros; ergo. +Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True. +intros; ergo. Qed. (* polymorphism *) @@ -81,13 +81,13 @@ Parameter my_nlist: mylist nat -> Prop. Goal forall l, my_nlist l -> True. intros. - simplify. + simplify. Qed. (* First example with the 0 and the equality translated *) Goal 0 = 0. -simplify. +simplify. Qed. (* Examples in the Propositional Calculus @@ -102,7 +102,7 @@ Qed. Goal A -> (A \/ C). -simplify. +simplify. Qed. @@ -145,12 +145,12 @@ induction x0; ergo. Qed. -(* No decision procedure can solve this problem +(* No decision procedure can solve this problem Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a. *) -(* Functions definitions *) +(* Functions definitions *) Definition fst (x y : Z) : Z := x. @@ -205,7 +205,7 @@ Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2). Dp_hint add_0. Dp_hint add_S. -(* Simplify can't prove this goal before the timeout +(* Simplify can't prove this goal before the timeout unlike zenon *) Goal forall n : nat, add n 0 = n. @@ -258,7 +258,7 @@ Qed. (* sorts issues *) -Parameter foo : Set. +Parameter foo : Set. Parameter ff : nat -> foo -> foo -> nat. Parameter g : foo -> foo. Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O. diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index ffaefd5e38..3468e8a360 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -620,7 +620,7 @@ and extract_cst_app env mle mlt kn args = else mla with _ -> mla else mla - in + in (* Different situations depending of the number of arguments: *) if ls = 0 then put_magic_if magic2 head else if List.mem Keep s then diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index 2b561616b4..60a2e91a2f 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -28,7 +28,7 @@ open Table open Extract_env let pr_language = function - | Ocaml -> str "Ocaml" + | Ocaml -> str "Ocaml" | Haskell -> str "Haskell" | Scheme -> str "Scheme" diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 6403e7bbe9..9d45c08b7e 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -300,7 +300,7 @@ let pp_decl = function else let e = pp_global Term r in e ++ str " :: " ++ pp_type false [] t ++ fnl () ++ - if is_custom r then + if is_custom r then hov 0 (e ++ str " = " ++ str (find_custom r) ++ fnl2 ()) else hov 0 (pp_function (empty_env ()) e a ++ fnl2 ()) diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index 12ca9ad757..55231d766b 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -85,7 +85,7 @@ type equiv = type ml_ind = { ind_info : inductive_info; - ind_nparams : int; + ind_nparams : int; ind_packets : ml_ind_packet array; ind_equiv : equiv } diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 0394ea4b74..1b1a39770d 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -115,7 +115,7 @@ let decl_iter_references do_term do_cons do_type = | Dind (kn,ind) -> ind_iter_references do_term do_cons do_type kn ind | Dtype (r,_,t) -> do_type r; type_iter t | Dterm (r,a,t) -> do_term r; ast_iter a; type_iter t - | Dfix(rv,c,t) -> + | Dfix(rv,c,t) -> Array.iter do_term rv; Array.iter ast_iter c; Array.iter type_iter t let spec_iter_references do_term do_cons do_type = function diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index eaa47f5f92..50339d473d 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -98,7 +98,7 @@ let rec pp_expr env args = if i = Coinductive then paren (str "delay " ++ st) else st | MLcase ((i,_),t, pv) -> let e = - if i <> Coinductive then pp_expr env [] t + if i <> Coinductive then pp_expr env [] t else paren (str "force" ++ spc () ++ pp_expr env [] t) in apply (v 3 (paren (str "match " ++ e ++ fnl () ++ pp_pat env pv))) diff --git a/plugins/field/LegacyField_Compl.v b/plugins/field/LegacyField_Compl.v index 746e7c9976..d4a39296a0 100644 --- a/plugins/field/LegacyField_Compl.v +++ b/plugins/field/LegacyField_Compl.v @@ -13,7 +13,7 @@ Require Import List. Definition assoc_2nd := (fix assoc_2nd_rec (A:Type) (B:Set) (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2}) - (lst:list (prod A B)) {struct lst} : + (lst:list (prod A B)) {struct lst} : B -> A -> A := fun (key:B) (default:A) => match lst with @@ -26,7 +26,7 @@ Definition assoc_2nd := end). Definition mem := - (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) + (fix mem (A:Set) (eq_dec:forall e1 e2:A, {e1 = e2} + {e1 <> e2}) (a:A) (l:list A) {struct l} : bool := match l with | nil => false diff --git a/plugins/field/LegacyField_Tactic.v b/plugins/field/LegacyField_Tactic.v index 63d9bdda69..5c1f228ac6 100644 --- a/plugins/field/LegacyField_Tactic.v +++ b/plugins/field/LegacyField_Tactic.v @@ -29,17 +29,17 @@ Ltac mem_assoc var lvar := end end. -Ltac number lvar := +Ltac number lvar := let rec number_aux lvar cpt := match constr:lvar with | (@nil ?X1) => constr:(@nil (prod X1 nat)) | ?X2 :: ?X3 => let l2 := number_aux X3 (S cpt) in - constr:((X2,cpt) :: l2) + constr:((X2,cpt) :: l2) end in number_aux lvar 0. -Ltac build_varlist FT trm := +Ltac build_varlist FT trm := let rec seek_var lvar trm := let AT := get_component A FT with AzeroT := get_component Azero FT @@ -244,11 +244,11 @@ Ltac inverse_test FT := Ltac apply_simplif sfun := match goal with - | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => + | |- (interp_ExprA ?X1 ?X2 ?X3 = interp_ExprA _ _ _) => sfun X1 X2 X3 end; match goal with - | |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => + | |- (interp_ExprA _ _ _ = interp_ExprA ?X1 ?X2 ?X3) => sfun X1 X2 X3 end. diff --git a/plugins/field/LegacyField_Theory.v b/plugins/field/LegacyField_Theory.v index 131ba84b83..378efa0353 100644 --- a/plugins/field/LegacyField_Theory.v +++ b/plugins/field/LegacyField_Theory.v @@ -13,7 +13,7 @@ Require Import Peano_dec. Require Import LegacyRing. Require Import LegacyField_Compl. -Record Field_Theory : Type := +Record Field_Theory : Type := {A : Type; Aplus : A -> A -> A; Amult : A -> A -> A; @@ -59,7 +59,7 @@ Proof. right; red in |- *; intro; inversion H1; auto. elim (eq_nat_dec n n0); intro y. left; rewrite y; auto. - right; red in |- *; intro; inversion H; auto. + right; red in |- *; intro; inversion H; auto. Defined. Definition eq_nat_dec := Eval compute in eq_nat_dec. @@ -149,7 +149,7 @@ Proof. repeat rewrite AplusT_assoc; rewrite <- H; reflexivity. legacy ring. Qed. - + Lemma r_AmultT_mult : forall r r1 r2:AT, AmultT r r1 = AmultT r r2 -> r <> AzeroT -> r1 = r2. Proof. @@ -164,22 +164,22 @@ Lemma AmultT_Or : forall r:AT, AmultT r AzeroT = AzeroT. Proof. intro; legacy ring. Qed. - + Lemma AmultT_Ol : forall r:AT, AmultT AzeroT r = AzeroT. Proof. intro; legacy ring. Qed. - + Lemma AmultT_1r : forall r:AT, AmultT r AoneT = r. Proof. intro; legacy ring. Qed. - + Lemma AinvT_r : forall r:AT, r <> AzeroT -> AmultT r (AinvT r) = AoneT. Proof. intros; rewrite AmultT_comm; apply Th_inv_defT; auto. Qed. - + Lemma Rmult_neq_0_reg : forall r1 r2:AT, AmultT r1 r2 <> AzeroT -> r1 <> AzeroT /\ r2 <> AzeroT. Proof. @@ -298,7 +298,7 @@ Lemma assoc_mult_correct1 : Proof. simple induction e1; auto; intros. rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_mult_correct; - simpl in |- *; rewrite merge_mult_correct; simpl in |- *; + simpl in |- *; rewrite merge_mult_correct; simpl in |- *; auto. Qed. @@ -318,7 +318,7 @@ simpl in |- *; rewrite merge_mult_correct; simpl in |- *; rewrite <- assoc_mult_correct1 in H1; unfold interp_ExprA at 3 in H1; fold interp_ExprA in H1; rewrite (H0 lvar) in H1; rewrite (AmultT_comm (interp_ExprA lvar e3) (interp_ExprA lvar e1)); - rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; + rewrite <- AmultT_assoc; rewrite H1; rewrite AmultT_assoc; legacy ring. simpl in |- *; rewrite (H0 lvar); auto. simpl in |- *; rewrite (H0 lvar); auto. @@ -365,7 +365,7 @@ Lemma assoc_plus_correct : Proof. simple induction e1; auto; intros. rewrite <- (H e0 lvar); simpl in |- *; rewrite merge_plus_correct; - simpl in |- *; rewrite merge_plus_correct; simpl in |- *; + simpl in |- *; rewrite merge_plus_correct; simpl in |- *; auto. Qed. @@ -388,7 +388,7 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; (interp_ExprA lvar e1))); rewrite <- AplusT_assoc; rewrite (AplusT_comm (interp_ExprA lvar (assoc e1)) (interp_ExprA lvar (assoc e2))) - ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; + ; rewrite assoc_plus_correct; rewrite H1; simpl in |- *; rewrite (H0 lvar); rewrite <- (AplusT_assoc (AplusT (interp_ExprA lvar e2) (interp_ExprA lvar e1)) @@ -402,13 +402,13 @@ simpl in |- *; rewrite merge_plus_correct; simpl in |- *; (AplusT_assoc (interp_ExprA lvar e2) (interp_ExprA lvar e3) (interp_ExprA lvar e1)); apply AplusT_comm. unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; - fold interp_ExprA in |- *; rewrite assoc_mult_correct; + fold interp_ExprA in |- *; rewrite assoc_mult_correct; rewrite (H0 lvar); simpl in |- *; auto. simpl in |- *; rewrite (H0 lvar); auto. simpl in |- *; rewrite (H0 lvar); auto. simpl in |- *; rewrite (H0 lvar); auto. unfold assoc in |- *; fold assoc in |- *; unfold interp_ExprA in |- *; - fold interp_ExprA in |- *; rewrite assoc_mult_correct; + fold interp_ExprA in |- *; rewrite assoc_mult_correct; simpl in |- *; auto. Qed. @@ -466,7 +466,7 @@ Proof. simple induction e1; try intros; simpl in |- *. rewrite AmultT_Ol; rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_Or. -rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. +rewrite distrib_mult_right_correct; simpl in |- *; apply AmultT_comm. rewrite AmultT_comm; rewrite (AmultT_AplusT_distr (interp_ExprA lvar e2) (interp_ExprA lvar e) @@ -629,7 +629,7 @@ Lemma monom_simplif_correct : Proof. simple induction e; intros; auto. simpl in |- *; case (eqExprA a e0); intros. -rewrite <- e2; apply monom_simplif_rem_correct; auto. +rewrite <- e2; apply monom_simplif_rem_correct; auto. simpl in |- *; trivial. Qed. diff --git a/plugins/field/field.ml4 b/plugins/field/field.ml4 index 7401491e45..2b4651dfb9 100644 --- a/plugins/field/field.ml4 +++ b/plugins/field/field.ml4 @@ -44,12 +44,12 @@ let th_tab = ref (Gmap.empty : (constr,constr) Gmap.t) let lookup env typ = try Gmap.find typ !th_tab - with Not_found -> + with Not_found -> errorlabstrm "field" (str "No field is declared for type" ++ spc() ++ Printer.pr_lconstr_env env typ) -let _ = +let _ = let init () = th_tab := Gmap.empty in let freeze () = !th_tab in let unfreeze fs = th_tab := fs in @@ -116,7 +116,7 @@ END (* For the translator, otherwise the code above is OK *) open Ppconstr -let pp_minus_div_arg _prc _prlc _prt (omin,odiv) = +let pp_minus_div_arg _prc _prlc _prt (omin,odiv) = if omin=None && odiv=None then mt() else spc() ++ str "with" ++ pr_opt (fun c -> str "minus := " ++ _prc c) omin ++ @@ -128,7 +128,7 @@ let () = (globwit_minus_div_arg,pp_minus_div_arg) (wit_minus_div_arg,pp_minus_div_arg) *) -ARGUMENT EXTEND minus_div_arg +ARGUMENT EXTEND minus_div_arg TYPED AS constr_opt * constr_opt PRINTED BY pp_minus_div_arg | [ "with" minusarg(m) divarg_opt(d) ] -> [ Some m, d ] @@ -137,7 +137,7 @@ ARGUMENT EXTEND minus_div_arg END VERNAC COMMAND EXTEND Field - [ "Add" "Legacy" "Field" + [ "Add" "Legacy" "Field" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(ainv) constr(rth) constr(ainv_l) minus_div_arg(md) ] diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 0be3a4b399..45365cb2cd 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -41,20 +41,20 @@ let meta_succ m = m+1 let rec nb_prod_after n c= match kind_of_term c with - | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else + | Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else 1+(nb_prod_after 0 b) | _ -> 0 let construct_nhyps ind gls = let nparams = (fst (Global.lookup_inductive ind)).mind_nparams in - let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in - let hyp = nb_prod_after nparams in + let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in + let hyp = nb_prod_after nparams in Array.map hyp constr_types (* indhyps builds the array of arrays of constructor hyps for (ind largs)*) -let ind_hyps nevar ind largs gls= - let types= Inductiveops.arities_of_constructors (pf_env gls) ind in - let lp=Array.length types in +let ind_hyps nevar ind largs gls= + let types= Inductiveops.arities_of_constructors (pf_env gls) ind in + let lp=Array.length types in let myhyps i= let t1=Term.prod_applist types.(i) largs in let t2=snd (decompose_prod_n_assum nevar t1) in @@ -77,7 +77,7 @@ type kind_of_formula= | Exists of inductive*constr list | Forall of constr*constr | Atom of constr - + let rec kind_of_formula gl term = let normalize=special_nf gl in let cciterm=special_whd gl term in @@ -86,34 +86,34 @@ let rec kind_of_formula gl term = |_-> match match_with_forall_term cciterm with Some (_,a,b)-> Forall(a,b) - |_-> + |_-> match match_with_nodep_ind cciterm with Some (i,l,n)-> let ind=destInd i in let (mib,mip) = Global.lookup_inductive ind in let nconstr=Array.length mip.mind_consnames in - if nconstr=0 then + if nconstr=0 then False(ind,l) else let has_realargs=(n>0) in let is_trivial= let is_constant c = - nb_prod c = mib.mind_nparams in - array_exists is_constant mip.mind_nf_lc in + nb_prod c = mib.mind_nparams in + array_exists is_constant mip.mind_nf_lc in if Inductiveops.mis_is_recursive (ind,mib,mip) || (has_realargs && not is_trivial) then - Atom cciterm + Atom cciterm else if nconstr=1 then And(ind,l,is_trivial) - else - Or(ind,l,is_trivial) - | _ -> + else + Or(ind,l,is_trivial) + | _ -> match match_with_sigma_type cciterm with Some (i,l)-> Exists((destInd i),l) |_-> Atom (normalize cciterm) - + type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint @@ -126,7 +126,7 @@ let build_atoms gl metagen side cciterm = let trivial =ref false and positive=ref [] and negative=ref [] in - let normalize=special_nf gl in + let normalize=special_nf gl in let rec build_rec env polarity cciterm= match kind_of_formula gl cciterm with False(_,_)->if not polarity then trivial:=true @@ -134,12 +134,12 @@ let build_atoms gl metagen side cciterm = build_rec env (not polarity) a; build_rec env polarity b | And(i,l,b) | Or(i,l,b)-> - if b then + if b then begin let unsigned=normalize (substnl env 0 cciterm) in - if polarity then - positive:= unsigned :: !positive - else + if polarity then + positive:= unsigned :: !positive + else negative:= unsigned :: !negative end; let v = ind_hyps 0 i l gl in @@ -148,9 +148,9 @@ let build_atoms gl metagen side cciterm = let f l = list_fold_left_i g (1-(List.length l)) () l in if polarity && (* we have a constant constructor *) - array_exists (function []->true|_->false) v + array_exists (function []->true|_->false) v then trivial:=true; - Array.iter f v + Array.iter f v | Exists(i,l)-> let var=mkMeta (metagen true) in let v =(ind_hyps 1 i l gl).(0) in @@ -163,15 +163,15 @@ let build_atoms gl metagen side cciterm = | Atom t-> let unsigned=substnl env 0 t in if not (isMeta unsigned) then (* discarding wildcard atoms *) - if polarity then - positive:= unsigned :: !positive - else + if polarity then + positive:= unsigned :: !positive + else negative:= unsigned :: !negative in begin match side with Concl -> build_rec [] true cciterm | Hyp -> build_rec [] false cciterm - | Hint -> + | Hint -> let rels,head=decompose_prod cciterm in let env=List.rev (List.map (fun _->mkMeta (metagen true)) rels) in build_rec env false head;trivial:=false (* special for hints *) @@ -179,15 +179,15 @@ let build_atoms gl metagen side cciterm = (!trivial, {positive= !positive; negative= !negative}) - + type right_pattern = Rarrow | Rand - | Ror + | Ror | Rfalse | Rforall | Rexists of metavariable*constr*bool - + type left_arrow_pattern= LLatom | LLfalse of inductive*constr list @@ -198,9 +198,9 @@ type left_arrow_pattern= | LLarrow of constr*constr*constr type left_pattern= - Lfalse + Lfalse | Land of inductive - | Lor of inductive + | Lor of inductive | Lforall of metavariable*constr*bool | Lexists of inductive | LA of constr*left_arrow_pattern @@ -209,14 +209,14 @@ type t={id:global_reference; constr:constr; pat:(left_pattern,right_pattern) sum; atoms:atoms} - + let build_formula side nam typ gl metagen= let normalize = special_nf gl in - try + try let m=meta_succ(metagen false) in let trivial,atoms= - if !qflag then - build_atoms gl metagen side typ + if !qflag then + build_atoms gl metagen side typ else no_atoms in let pattern= match side with @@ -227,10 +227,10 @@ let build_formula side nam typ gl metagen= | Atom a -> raise (Is_atom a) | And(_,_,_) -> Rand | Or(_,_,_) -> Ror - | Exists (i,l) -> + | Exists (i,l) -> let (_,_,d)=list_last (ind_hyps 0 i l gl).(0) in Rexists(m,d,trivial) - | Forall (_,a) -> Rforall + | Forall (_,a) -> Rforall | Arrow (a,b) -> Rarrow in Right pat | _ -> @@ -238,7 +238,7 @@ let build_formula side nam typ gl metagen= match kind_of_formula gl typ with False(i,_) -> Lfalse | Atom a -> raise (Is_atom a) - | And(i,_,b) -> + | And(i,_,b) -> if b then let nftyp=normalize typ in raise (Is_atom nftyp) else Land i @@ -246,12 +246,12 @@ let build_formula side nam typ gl metagen= if b then let nftyp=normalize typ in raise (Is_atom nftyp) else Lor i - | Exists (ind,_) -> Lexists ind - | Forall (d,_) -> + | Exists (ind,_) -> Lexists ind + | Forall (d,_) -> Lforall(m,d,trivial) | Arrow (a,b) -> let nfa=normalize a in - LA (nfa, + LA (nfa, match kind_of_formula gl a with False(i,l)-> LLfalse(i,l) | Atom t-> LLatom diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 9e9d1e1220..2e89ddb061 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -16,10 +16,10 @@ val qflag : bool ref val red_flags: Closure.RedFlags.reds ref -val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) -> +val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) -> 'a -> 'a -> 'b -> 'b -> int - -val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> + +val (==?) : ('a -> 'a -> 'b ->'b -> int) -> ('c -> 'c -> int) -> 'a -> 'a -> 'b -> 'b -> 'c ->'c -> int type ('a,'b) sum = Left of 'a | Right of 'b @@ -28,7 +28,7 @@ type counter = bool -> metavariable val construct_nhyps : inductive -> Proof_type.goal Tacmach.sigma -> int array -val ind_hyps : int -> inductive -> constr list -> +val ind_hyps : int -> inductive -> constr list -> Proof_type.goal Tacmach.sigma -> rel_context array type atoms = {positive:constr list;negative:constr list} @@ -36,18 +36,18 @@ type atoms = {positive:constr list;negative:constr list} type side = Hyp | Concl | Hint val dummy_id: global_reference - -val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> + +val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> side -> constr -> bool * atoms type right_pattern = Rarrow | Rand - | Ror + | Ror | Rfalse | Rforall | Rexists of metavariable*constr*bool - + type left_arrow_pattern= LLatom | LLfalse of inductive*constr list @@ -58,20 +58,20 @@ type left_arrow_pattern= | LLarrow of constr*constr*constr type left_pattern= - Lfalse + Lfalse | Land of inductive - | Lor of inductive + | Lor of inductive | Lforall of metavariable*constr*bool | Lexists of inductive | LA of constr*left_arrow_pattern - + type t={id: global_reference; constr: constr; pat: (left_pattern,right_pattern) sum; atoms: atoms} - + (*exception Is_atom of constr*) -val build_formula : side -> global_reference -> types -> +val build_formula : side -> global_reference -> types -> Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 8302da5c1d..c986a30260 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -30,10 +30,10 @@ let _= let gdopt= { optsync=true; optname="Firstorder Depth"; - optkey=["Firstorder";"Depth"]; - optread=(fun ()->Some !ground_depth); + optkey=["Firstorder";"Depth"]; + optread=(fun ()->Some !ground_depth); optwrite= - (function + (function None->ground_depth:=3 | Some i->ground_depth:=(max i 0))} in @@ -45,10 +45,10 @@ let _= let gdopt= { optsync=true; optname="Congruence Depth"; - optkey=["Congruence";"Depth"]; - optread=(fun ()->Some !congruence_depth); + optkey=["Congruence";"Depth"]; + optread=(fun ()->Some !congruence_depth); optwrite= - (function + (function None->congruence_depth:=0 | Some i->congruence_depth:=(max i 0))} in @@ -57,23 +57,23 @@ let _= let default_solver=(Tacinterp.interp <:tactic>) let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") - + let gen_ground_tac flag taco ids bases gl= let backup= !qflag in try qflag:=flag; - let solver= - match taco with + let solver= + match taco with Some tac-> tac | None-> default_solver in let startseq gl= let seq=empty_seq !ground_depth in extend_with_auto_hints bases (extend_with_ref_list ids seq gl) gl in - let result=ground_tac solver startseq gl in + let result=ground_tac solver startseq gl in qflag:=backup;result with e ->qflag:=backup;raise e - -(* special for compatibility with Intuition + +(* special for compatibility with Intuition let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str @@ -83,10 +83,10 @@ let defined_connectives=lazy let normalize_evaluables= onAllHypsAndConcl - (function + (function None->unfold_in_concl (Lazy.force defined_connectives) - | Some id-> - unfold_in_hyp (Lazy.force defined_connectives) + | Some id-> + unfold_in_hyp (Lazy.force defined_connectives) (Tacexpr.InHypType id)) *) open Genarg @@ -116,12 +116,12 @@ END TACTIC EXTEND firstorder [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> [ gen_ground_tac true (Option.map eval_tactic t) l [] ] -| [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> +| [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> [ gen_ground_tac true (Option.map eval_tactic t) [] l ] -| [ "firstorder" tactic_opt(t) firstorder_using(l) - "with" ne_preident_list(l') ] -> +| [ "firstorder" tactic_opt(t) firstorder_using(l) + "with" ne_preident_list(l') ] -> [ gen_ground_tac true (Option.map eval_tactic t) l l' ] -| [ "firstorder" tactic_opt(t) ] -> +| [ "firstorder" tactic_opt(t) ] -> [ gen_ground_tac true (Option.map eval_tactic t) [] [] ] END @@ -131,11 +131,11 @@ TACTIC EXTEND gintuition END -let default_declarative_automation gls = +let default_declarative_automation gls = tclORELSE - (tclORELSE (Auto.h_trivial [] None) + (tclORELSE (Auto.h_trivial [] None) (Cctac.congruence_tac !congruence_depth [])) - (gen_ground_tac true + (gen_ground_tac true (Some (tclTHEN default_solver (Cctac.congruence_tac !congruence_depth []))) @@ -143,6 +143,6 @@ let default_declarative_automation gls = -let () = +let () = Decl_proof_instr.register_automation_tac default_declarative_automation diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index a8d5fc2ef3..8a0f02d27e 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -19,10 +19,10 @@ open Tacticals open Libnames (* -let old_search=ref !Auto.searchtable +let old_search=ref !Auto.searchtable -(* I use this solution as a means to know whether hints have changed, -but this prevents the GC from collecting the previous table, +(* I use this solution as a means to know whether hints have changed, +but this prevents the GC from collecting the previous table, resulting in some limited space wasting*) let update_flags ()= @@ -30,7 +30,7 @@ let update_flags ()= begin old_search:=!Auto.searchtable; let predref=ref Names.KNpred.empty in - let f p_a_t = + let f p_a_t = match p_a_t.Auto.code with Auto.Unfold_nth (ConstRef kn)-> predref:=Names.KNpred.add kn !predref @@ -39,7 +39,7 @@ let update_flags ()= let h _ hdb=Auto.Hint_db.iter g hdb in Util.Stringmap.iter h !Auto.searchtable; red_flags:= - Closure.RedFlags.red_add_transparent + Closure.RedFlags.red_add_transparent Closure.betaiotazeta (Names.Idpred.full,!predref) end *) @@ -53,8 +53,8 @@ let update_flags ()= with Invalid_argument "destConst"-> () in List.iter f (Classops.coercions ()); red_flags:= - Closure.RedFlags.red_add_transparent - Closure.betaiotazeta + Closure.RedFlags.red_add_transparent + Closure.betaiotazeta (Names.Idpred.full,Names.Cpred.complement !predref) let ground_tac solver startseq gl= @@ -64,10 +64,10 @@ let ground_tac solver startseq gl= then Pp.msgnl (Printer.pr_goal (sig_it gl)); tclORELSE (axiom_tac seq.gl seq) begin - try - let (hd,seq1)=take_formula seq + try + let (hd,seq1)=take_formula seq and re_add s=re_add_formula_list skipped s in - let continue=toptac [] + let continue=toptac [] and backtrack gl=toptac (hd::skipped) seq1 gl in match hd.pat with Right rpat-> @@ -77,7 +77,7 @@ let ground_tac solver startseq gl= and_tac backtrack continue (re_add seq1) | Rforall-> let backtrack1= - if !qflag then + if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack in @@ -86,12 +86,12 @@ let ground_tac solver startseq gl= arrow_tac backtrack continue (re_add seq1) | Ror-> or_tac backtrack continue (re_add seq1) - | Rfalse->backtrack + | Rfalse->backtrack | Rexists(i,dom,triv)-> let (lfp,seq2)=collect_quantified seq in let backtrack2=toptac (lfp@skipped) seq2 in - if !qflag && seq.depth>0 then - quantified_tac lfp backtrack2 + if !qflag && seq.depth>0 then + quantified_tac lfp backtrack2 continue (re_add seq) else backtrack2 (* need special backtracking *) @@ -102,21 +102,21 @@ let ground_tac solver startseq gl= Lfalse-> left_false_tac hd.id | Land ind-> - left_and_tac ind backtrack + left_and_tac ind backtrack hd.id continue (re_add seq1) | Lor ind-> - left_or_tac ind backtrack + left_or_tac ind backtrack hd.id continue (re_add seq1) | Lforall (_,_,_)-> let (lfp,seq2)=collect_quantified seq in let backtrack2=toptac (lfp@skipped) seq2 in - if !qflag && seq.depth>0 then - quantified_tac lfp backtrack2 + if !qflag && seq.depth>0 then + quantified_tac lfp backtrack2 continue (re_add seq) else backtrack2 (* need special backtracking *) | Lexists ind -> - if !qflag then + if !qflag then left_exists_tac ind backtrack hd.id continue (re_add seq1) else backtrack @@ -124,14 +124,14 @@ let ground_tac solver startseq gl= let la_tac= begin match lap with - LLatom -> backtrack - | LLand (ind,largs) | LLor(ind,largs) + LLatom -> backtrack + | LLand (ind,largs) | LLor(ind,largs) | LLfalse (ind,largs)-> - (ll_ind_tac ind largs backtrack - hd.id continue (re_add seq1)) - | LLforall p -> - if seq.depth>0 && !qflag then - (ll_forall_tac p backtrack + (ll_ind_tac ind largs backtrack + hd.id continue (re_add seq1)) + | LLforall p -> + if seq.depth>0 && !qflag then + (ll_forall_tac p backtrack hd.id continue (re_add seq1)) else backtrack | LLexists (ind,l) -> @@ -140,13 +140,13 @@ let ground_tac solver startseq gl= hd.id continue (re_add seq1) else backtrack - | LLarrow (a,b,c) -> + | LLarrow (a,b,c) -> (ll_arrow_tac a b c backtrack hd.id continue (re_add seq1)) - end in + end in ll_atom_tac typ la_tac hd.id continue (re_add seq1) end with Heap.EmptyHeap->solver end gl in wrap (List.length (pf_hyps gl)) true (toptac []) (startseq gl) gl - + diff --git a/plugins/firstorder/ground_plugin.mllib b/plugins/firstorder/ground_plugin.mllib index 1647e0f3d3..447a1fb513 100644 --- a/plugins/firstorder/ground_plugin.mllib +++ b/plugins/firstorder/ground_plugin.mllib @@ -3,6 +3,6 @@ Unify Sequent Rules Instances -Ground +Ground G_ground Ground_plugin_mod diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 3e087cd8b6..810262a699 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -37,8 +37,8 @@ let compare_instance inst1 inst2= let compare_gr id1 id2= if id1==id2 then 0 else - if id1==dummy_id then 1 - else if id2==dummy_id then -1 + if id1==dummy_id then 1 + else if id2==dummy_id then -1 else Pervasives.compare id1 id2 module OrderedInstance= @@ -48,7 +48,7 @@ struct (compare_instance =? compare_gr) inst2 inst1 id2 id1 (* we want a __decreasing__ total order *) end - + module IS=Set.Make(OrderedInstance) let make_simple_atoms seq= @@ -62,7 +62,7 @@ let do_sequent setref triv id seq i dom atoms= let flag=ref true in let phref=ref triv in let do_atoms a1 a2 = - let do_pair t1 t2 = + let do_pair t1 t2 = match unif_atoms i dom t1 t2 with None->() | Some (Phantom _) ->phref:=true @@ -71,27 +71,27 @@ let do_sequent setref triv id seq i dom atoms= List.iter (fun t->List.iter (do_pair t) a2.positive) a1.negative in HP.iter (fun lf->do_atoms atoms lf.atoms) seq.redexes; do_atoms atoms (make_simple_atoms seq); - !flag && !phref - + !flag && !phref + let match_one_quantified_hyp setref seq lf= - match lf.pat with + match lf.pat with Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> if do_sequent setref triv lf.id seq i dom lf.atoms then - setref:=IS.add ((Phantom dom),lf.id) !setref - | _ ->anomaly "can't happen" + setref:=IS.add ((Phantom dom),lf.id) !setref + | _ ->anomaly "can't happen" let give_instances lf seq= let setref=ref IS.empty in List.iter (match_one_quantified_hyp setref seq) lf; IS.elements !setref - + (* collector for the engine *) let rec collect_quantified seq= try let hd,seq1=take_formula seq in - (match hd.pat with - Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> + (match hd.pat with + Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> let (q,seq2)=collect_quantified seq1 in ((hd::q),seq2) | _->[],seq) @@ -109,10 +109,10 @@ let mk_open_instance id gl m t= let var_id= if id==dummy_id then dummy_bvid else let typ=pf_type_of gl (constr_of_global id) in - (* since we know we will get a product, + (* since we know we will get a product, reduction is not too expensive *) let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in - match nam with + match nam with Name id -> id | Anonymous -> dummy_bvid in let revt=substl (list_tabulate (fun i->mkRel (m-i)) m) t in @@ -123,15 +123,15 @@ let mk_open_instance id gl m t= let nt=it_mkLambda_or_LetIn revt (aux m []) in let rawt=Detyping.detype false [] [] nt in let rec raux n t= - if n=0 then t else + if n=0 then t else match t with RLambda(loc,name,k,_,t0)-> let t1=raux (n-1) t0 in RLambda(loc,name,k,RHole (dummy_loc,Evd.BinderType name),t1) | _-> anomaly "can't happen" in - let ntt=try + let ntt=try Pretyping.Default.understand evmap env (raux m rawt) - with _ -> + with _ -> error "Untypable instance, maybe higher-order non-prenex quantification" in decompose_lam_n_assum m ntt @@ -140,51 +140,51 @@ let mk_open_instance id gl m t= let left_instance_tac (inst,id) continue seq= match inst with Phantom dom-> - if lookup (id,None) seq then + if lookup (id,None) seq then tclFAIL 0 (Pp.str "already done") else - tclTHENS (cut dom) + tclTHENS (cut dom) [tclTHENLIST [introf; - (fun gls->generalize + (fun gls->generalize [mkApp(constr_of_global id, [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])] gls); introf; - tclSOLVE [wrap 1 false continue + tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; tclTRY assumption] | Real((m,t) as c,_)-> - if lookup (id,Some c) seq then + if lookup (id,Some c) seq then tclFAIL 0 (Pp.str "already done") - else + else let special_generalize= - if m>0 then - fun gl-> + if m>0 then + fun gl-> let (rc,ot)= mk_open_instance id gl m t in - let gt= - it_mkLambda_or_LetIn + let gt= + it_mkLambda_or_LetIn (mkApp(constr_of_global id,[|ot|])) rc in generalize [gt] gl else generalize [mkApp(constr_of_global id,[|t|])] in - tclTHENLIST + tclTHENLIST [special_generalize; - introf; - tclSOLVE + introf; + tclSOLVE [wrap 1 false continue (deepen (record (id,Some c) seq))]] - + let right_instance_tac inst continue seq= match inst with Phantom dom -> - tclTHENS (cut dom) + tclTHENS (cut dom) [tclTHENLIST [introf; (fun gls-> - split (Rawterm.ImplicitBindings + split (Rawterm.ImplicitBindings [mkVar (Tacmach.pf_nth_hyp_id gls 1)]) gls); tclSOLVE [wrap 0 true continue (deepen seq)]]; - tclTRY assumption] + tclTRY assumption] | Real ((0,t),_) -> (tclTHEN (split (Rawterm.ImplicitBindings [t])) (tclSOLVE [wrap 0 true continue (deepen seq)])) @@ -192,7 +192,7 @@ let right_instance_tac inst continue seq= tclFAIL 0 (Pp.str "not implemented ... yet") let instance_tac inst= - if (snd inst)==dummy_id then + if (snd inst)==dummy_id then right_instance_tac (fst inst) else left_instance_tac inst @@ -203,4 +203,4 @@ let quantified_tac lf backtrack continue seq gl= (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) backtrack gl - + diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index aed2ec83d1..95dd22ea89 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -13,10 +13,10 @@ open Tacmach open Names open Libnames open Rules - + val collect_quantified : Sequent.t -> Formula.t list * Sequent.t -val give_instances : Formula.t list -> Sequent.t -> +val give_instances : Formula.t list -> Sequent.t -> (Unify.instance * global_reference) list val quantified_tac : Formula.t list -> seqtac with_backtracking diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 75d69099ae..515efea701 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -31,17 +31,17 @@ let wrap n b continue seq gls= let nc=pf_hyps gls in let env=pf_env gls in let rec aux i nc ctx= - if i<=0 then seq else + if i<=0 then seq else match nc with []->anomaly "Not the expected number of hyps" - | ((id,_,typ) as nd)::q-> - if occur_var env id (pf_concl gls) || + | ((id,_,typ) as nd)::q-> + if occur_var env id (pf_concl gls) || List.exists (occur_var_in_decl env id) ctx then (aux (i-1) q (nd::ctx)) else add_formula Hyp (VarRef id) typ (aux (i-1) q (nd::ctx)) gls in let seq1=aux n nc [] in - let seq2=if b then + let seq2=if b then add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in continue seq2 gls @@ -52,24 +52,24 @@ let basename_of_global=function let clear_global=function VarRef id->clear [id] | _->tclIDTAC - + (* connection rules *) let axiom_tac t seq= - try exact_no_check (constr_of_global (find_left t seq)) + try exact_no_check (constr_of_global (find_left t seq)) with Not_found->tclFAIL 0 (Pp.str "No axiom link") -let ll_atom_tac a backtrack id continue seq= +let ll_atom_tac a backtrack id continue seq= tclIFTHENELSE - (try + (try tclTHENLIST [generalize [mkApp(constr_of_global id, [|constr_of_global (find_left a seq)|])]; clear_global id; intro] with Not_found->tclFAIL 0 (Pp.str "No link")) - (wrap 1 false continue seq) backtrack + (wrap 1 false continue seq) backtrack (* right connectives rules *) @@ -77,7 +77,7 @@ let and_tac backtrack continue seq= tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack let or_tac backtrack continue seq= - tclORELSE + tclORELSE (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq)))) backtrack @@ -89,17 +89,17 @@ let arrow_tac backtrack continue seq= (* left connectives rules *) let left_and_tac ind backtrack id continue seq gls= - let n=(construct_nhyps ind gls).(0) in + let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE - (tclTHENLIST + (tclTHENLIST [simplest_elim (constr_of_global id); - clear_global id; + clear_global id; tclDO n intro]) (wrap n false continue seq) backtrack gls let left_or_tac ind backtrack id continue seq gls= - let v=construct_nhyps ind gls in + let v=construct_nhyps ind gls in let f n= tclTHENLIST [clear_global id; @@ -117,10 +117,10 @@ let left_false_tac id= (* We use this function for false, and, or, exists *) -let ll_ind_tac ind largs backtrack id continue seq gl= +let ll_ind_tac ind largs backtrack id continue seq gl= let rcs=ind_hyps 0 ind largs gl in let vargs=Array.of_list largs in - (* construire le terme H->B, le generaliser etc *) + (* construire le terme H->B, le generaliser etc *) let myterm i= let rc=rcs.(i) in let p=List.length rc in @@ -132,7 +132,7 @@ let ll_ind_tac ind largs backtrack id continue seq gl= let lp=Array.length rcs in let newhyps=list_tabulate myterm lp in tclIFTHENELSE - (tclTHENLIST + (tclTHENLIST [generalize newhyps; clear_global id; tclDO lp intro]) @@ -149,9 +149,9 @@ let ll_arrow_tac a b c backtrack id continue seq= [introf; clear_global id; wrap 1 false continue seq]; - tclTHENS (cut cc) - [exact_no_check (constr_of_global id); - tclTHENLIST + tclTHENS (cut cc) + [exact_no_check (constr_of_global id); + tclTHENLIST [generalize [d]; clear_global id; introf; @@ -167,21 +167,21 @@ let forall_tac backtrack continue seq= (tclORELSE (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) backtrack)) - (if !qflag then + (if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack) let left_exists_tac ind backtrack id continue seq gls= - let n=(construct_nhyps ind gls).(0) in + let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE (simplest_elim (constr_of_global id)) (tclTHENLIST [clear_global id; tclDO n intro; - (wrap (n-1) false continue seq)]) - backtrack + (wrap (n-1) false continue seq)]) + backtrack gls - + let ll_forall_tac prod backtrack id continue seq= tclORELSE (tclTHENS (cut prod) @@ -190,7 +190,7 @@ let ll_forall_tac prod backtrack id continue seq= (fun gls-> let id0=pf_nth_hyp_id gls 1 in let term=mkApp((constr_of_global id),[|mkVar(id0)|]) in - tclTHEN (generalize [term]) (clear [id0]) gls); + tclTHEN (generalize [term]) (clear [id0]) gls); clear_global id; intro; tclCOMPLETE (wrap 1 false continue (deepen seq))]; @@ -209,7 +209,7 @@ let defined_connectives=lazy let normalize_evaluables= onAllHypsAndConcl - (function + (function None->unfold_in_concl (Lazy.force defined_connectives) - | Some id -> + | Some id -> unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index b804c93ae3..fc32621ca7 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -49,6 +49,6 @@ val forall_tac : seqtac with_backtracking val left_exists_tac : inductive -> lseqtac with_backtracking -val ll_forall_tac : types -> lseqtac with_backtracking +val ll_forall_tac : types -> lseqtac with_backtracking val normalize_evaluables : tactic diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 98b178bdee..685d44a84d 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -27,7 +27,7 @@ let priority = (* pure heuristics, <=0 for non reversible *) begin match rf with Rarrow -> 100 - | Rand -> 40 + | Rand -> 40 | Ror -> -15 | Rfalse -> -50 | Rforall -> 100 @@ -38,7 +38,7 @@ let priority = (* pure heuristics, <=0 for non reversible *) Lfalse -> 999 | Land _ -> 90 | Lor _ -> 40 - | Lforall (_,_,_) -> -30 + | Lforall (_,_,_) -> -30 | Lexists _ -> 60 | LA(_,lap) -> match lap with @@ -48,7 +48,7 @@ let priority = (* pure heuristics, <=0 for non reversible *) | LLor (_,_) -> 70 | LLforall _ -> -20 | LLexists (_,_) -> 50 - | LLarrow (_,_,_) -> -10 + | LLarrow (_,_,_) -> -10 let left_reversible lpat=(priority lpat)>0 @@ -71,15 +71,15 @@ let rec compare_list f l1 l2= | _,[] -> 1 | (h1::q1),(h2::q2) -> (f =? (compare_list f)) h1 h2 q1 q2 -let compare_array f v1 v2= +let compare_array f v1 v2= let l=Array.length v1 in let c=l - Array.length v2 in if c=0 then let rec comp_aux i= - if i<0 then 0 + if i<0 then 0 else let ci=f v1.(i) v2.(i) in - if ci=0 then + if ci=0 then comp_aux (i-1) else ci in comp_aux (l-1) @@ -93,16 +93,16 @@ let compare_constr_int f t1 t2 = | Sort s1, Sort s2 -> Pervasives.compare s1 s2 | Cast (c1,_,_), _ -> f c1 t2 | _, Cast (c2,_,_) -> f t1 c2 - | Prod (_,t1,c1), Prod (_,t2,c2) + | Prod (_,t1,c1), Prod (_,t2,c2) | Lambda (_,t1,c1), Lambda (_,t2,c2) -> - (f =? f) t1 t2 c1 c2 - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> + (f =? f) t1 t2 c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> ((f =? f) ==? f) b1 b2 t1 t2 c1 c2 | App (_,_), App (_,_) -> - let c1,l1=decompose_app t1 + let c1,l1=decompose_app t1 and c2,l2=decompose_app t2 in (f =? (compare_list f)) c1 c2 l1 l2 - | Evar (e1,l1), Evar (e2,l2) -> + | Evar (e1,l1), Evar (e2,l2) -> ((-) =? (compare_array f)) e1 e2 l1 l2 | Const c1, Const c2 -> Pervasives.compare c1 c2 | Ind c1, Ind c2 -> Pervasives.compare c1 c2 @@ -119,7 +119,7 @@ let compare_constr_int f t1 t2 = let rec compare_constr m n= compare_constr_int compare_constr m n - + module OrderedConstr= struct type t=constr @@ -129,13 +129,13 @@ end type h_item = global_reference * (int*constr) option module Hitem= -struct +struct type t = h_item let compare (id1,co1) (id2,co2)= - (Pervasives.compare + (Pervasives.compare =? (fun oc1 oc2 -> - match oc1,oc2 with - Some (m1,c1),Some (m2,c2) -> + match oc1,oc2 with + Some (m1,c1),Some (m2,c2) -> ((-) =? OrderedConstr.compare) m1 m2 c1 c2 | _,_->Pervasives.compare oc1 oc2)) id1 id2 co1 co2 end @@ -145,16 +145,16 @@ module CM=Map.Make(OrderedConstr) module History=Set.Make(Hitem) let cm_add typ nam cm= - try + try let l=CM.find typ cm in CM.add typ (nam::l) cm with Not_found->CM.add typ [nam] cm - + let cm_remove typ nam cm= try - let l=CM.find typ cm in + let l=CM.find typ cm in let l0=List.filter (fun id->id<>nam) l in - match l0 with + match l0 with []->CM.remove typ cm | _ ->CM.add typ l0 cm with Not_found ->cm @@ -172,7 +172,7 @@ type t= depth:int} let deepen seq={seq with depth=seq.depth-1} - + let record item seq={seq with history=History.add item seq.history} let lookup item seq= @@ -192,12 +192,12 @@ let rec add_formula side nam t seq gl= begin match side with Concl -> - {seq with + {seq with redexes=HP.add f seq.redexes; gl=f.constr; glatom=None} | _ -> - {seq with + {seq with redexes=HP.add f seq.redexes; context=cm_add f.constr nam seq.context} end @@ -206,15 +206,15 @@ let rec add_formula side nam t seq gl= Concl -> {seq with gl=t;glatom=Some t} | _ -> - {seq with + {seq with context=cm_add t nam seq.context; latoms=t::seq.latoms} - + let re_add_formula_list lf seq= let do_one f cm= if f.id == dummy_id then cm else cm_add f.constr f.id cm in - {seq with + {seq with redexes=List.fold_right HP.add lf seq.redexes; context=List.fold_right do_one lf seq.context} @@ -234,17 +234,17 @@ let rec take_formula seq= and hp=HP.remove seq.redexes in if hd.id == dummy_id then let nseq={seq with redexes=hp} in - if seq.gl==hd.constr then + if seq.gl==hd.constr then hd,nseq else take_formula nseq (* discarding deprecated goal *) else - hd,{seq with + hd,{seq with redexes=hp; context=cm_remove hd.constr hd.id seq.context} - + let empty_seq depth= - {redexes=HP.empty; + {redexes=HP.empty; context=CM.empty; latoms=[]; gl=(mkMeta 1); @@ -264,7 +264,7 @@ let expand_constructor_hints = let extend_with_ref_list l seq gl= let l = expand_constructor_hints l in let f gr seq= - let c=constr_of_global gr in + let c=constr_of_global gr in let typ=(pf_type_of gl c) in add_formula Hyp gr typ seq gl in List.fold_right f l seq @@ -277,8 +277,8 @@ let extend_with_auto_hints l seq gl= match p_a_t.code with Res_pf (c,_) | Give_exact c | Res_pf_THEN_trivial_fail (c,_) -> - (try - let gr=global_of_constr c in + (try + let gr=global_of_constr c in let typ=(pf_type_of gl c) in seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) @@ -288,7 +288,7 @@ let extend_with_auto_hints l seq gl= let hdb= try searchtable_map dbname - with Not_found-> + with Not_found-> error ("Firstorder: "^dbname^" : No such Hint database") in Hint_db.iter g hdb in List.iter h l; @@ -297,16 +297,16 @@ let extend_with_auto_hints l seq gl= let print_cmap map= let print_entry c l s= let xc=Constrextern.extern_constr false (Global.env ()) c in - str "| " ++ - Util.prlist Printer.pr_global l ++ + str "| " ++ + Util.prlist Printer.pr_global l ++ str " : " ++ - Ppconstr.pr_constr_expr xc ++ - cut () ++ + Ppconstr.pr_constr_expr xc ++ + cut () ++ s in - msgnl (v 0 - (str "-----" ++ + msgnl (v 0 + (str "-----" ++ cut () ++ CM.fold print_entry map (mt ()) ++ str "-----")) - + diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index 206de27ed7..ce0eddccc2 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -46,7 +46,7 @@ val record: h_item -> t -> t val lookup: h_item -> t -> bool -val add_formula : side -> global_reference -> constr -> t -> +val add_formula : side -> global_reference -> constr -> t -> Proof_type.goal sigma -> t val re_add_formula_list : Formula.t list -> t -> t @@ -60,7 +60,7 @@ val empty_seq : int -> t val extend_with_ref_list : global_reference list -> t -> Proof_type.goal sigma -> t -val extend_with_auto_hints : Auto.hint_db_name list -> +val extend_with_auto_hints : Auto.hint_db_name list -> t -> Proof_type.goal sigma -> t -val print_cmap: global_reference list CM.t -> unit +val print_cmap: global_reference list CM.t -> unit diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 782129e5c9..e3a4c6a559 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -9,7 +9,7 @@ (*i $Id$ i*) open Util -open Formula +open Formula open Tacmach open Term open Names @@ -18,73 +18,73 @@ open Reductionops exception UFAIL of constr*constr -(* - RIGID-only Martelli-Montanari style unification for CLOSED terms - I repeat : t1 and t2 must NOT have ANY free deBruijn - sigma is kept normal with respect to itself but is lazily applied - to the equation set. Raises UFAIL with a pair of terms +(* + RIGID-only Martelli-Montanari style unification for CLOSED terms + I repeat : t1 and t2 must NOT have ANY free deBruijn + sigma is kept normal with respect to itself but is lazily applied + to the equation set. Raises UFAIL with a pair of terms *) -let unif t1 t2= - let bige=Queue.create () +let unif t1 t2= + let bige=Queue.create () and sigma=ref [] in let bind i t= sigma:=(i,t):: (List.map (function (n,tn)->(n,subst_meta [i,t] tn)) !sigma) in - let rec head_reduce t= + let rec head_reduce t= (* forbids non-sigma-normal meta in head position*) match kind_of_term t with Meta i-> - (try - head_reduce (List.assoc i !sigma) + (try + head_reduce (List.assoc i !sigma) with Not_found->t) - | _->t in + | _->t in Queue.add (t1,t2) bige; try while true do let t1,t2=Queue.take bige in - let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) + let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in match (kind_of_term nt1),(kind_of_term nt2) with - Meta i,Meta j-> - if i<>j then + Meta i,Meta j-> + if i<>j then if i let t=subst_meta !sigma nt2 in - if Intset.is_empty (free_rels t) && + if Intset.is_empty (free_rels t) && not (occur_term (mkMeta i) t) then bind i t else raise (UFAIL(nt1,nt2)) - | _,Meta i -> + | _,Meta i -> let t=subst_meta !sigma nt1 in - if Intset.is_empty (free_rels t) && + if Intset.is_empty (free_rels t) && not (occur_term (mkMeta i) t) then bind i t else raise (UFAIL(nt1,nt2)) | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige - | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige + | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> Queue.add (pa,pb) bige; Queue.add (ca,cb) bige; let l=Array.length va in - if l<>(Array.length vb) then + if l<>(Array.length vb) then raise (UFAIL (nt1,nt2)) - else + else for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige - done + done | App(ha,va),App(hb,vb)-> Queue.add (ha,hb) bige; let l=Array.length va in - if l<>(Array.length vb) then + if l<>(Array.length vb) then raise (UFAIL (nt1,nt2)) - else + else for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige done | _->if not (eq_constr nt1 nt2) then raise (UFAIL (nt1,nt2)) done; - assert false + assert false (* this place is unreachable but needed for the sake of typing *) with Queue.Empty-> !sigma @@ -93,23 +93,23 @@ let value i t= if x<0 then y else if y<0 then x else x+y in let tref=mkMeta i in let rec vaux term= - if term=tref then 0 else + if term=tref then 0 else let f v t=add v (vaux t) in let vr=fold_constr f (-1) term in if vr<0 then -1 else vr+1 in vaux t - + type instance= - Real of (int*constr)*int - | Phantom of constr + Real of (int*constr)*int + | Phantom of constr let mk_rel_inst t= let new_rel=ref 1 in let rel_env=ref [] in let rec renum_rec d t= - match kind_of_term t with + match kind_of_term t with Meta n-> - (try + (try mkRel (d+(List.assoc n !rel_env)) with Not_found-> let m= !new_rel in @@ -117,18 +117,18 @@ let mk_rel_inst t= rel_env:=(n,m) :: !rel_env; mkRel (m+d)) | _ -> map_constr_with_binders succ renum_rec d t - in + in let nt=renum_rec 0 t in (!new_rel - 1,nt) let unif_atoms i dom t1 t2= - try - let t=List.assoc i (unif t1 t2) in + try + let t=List.assoc i (unif t1 t2) in if isMeta t then Some (Phantom dom) else Some (Real(mk_rel_inst t,value i t1)) with UFAIL(_,_) ->None | Not_found ->Some (Phantom dom) - + let renum_metas_from k n t= (* requires n = max (free_rels t) *) let l=list_tabulate (fun i->mkMeta (k+i)) n in substl l t @@ -136,7 +136,7 @@ let renum_metas_from k n t= (* requires n = max (free_rels t) *) let more_general (m1,t1) (m2,t2)= let mt1=renum_metas_from 0 m1 t1 and mt2=renum_metas_from m1 m2 t2 in - try + try let sigma=unif mt1 mt2 in let p (n,t)= n 0 < a -> a * x1 < a * y1. intros; apply Rmult_lt_compat_l; assumption. Qed. - + Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1. red in |- *. intros. case H; auto with real. Qed. - + Lemma Rfourier_lt_lt : forall x1 y1 x2 y2 a:R, x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. @@ -33,7 +33,7 @@ apply Rfourier_lt. try exact H0. try exact H1. Qed. - + Lemma Rfourier_lt_le : forall x1 y1 x2 y2 a:R, x1 < y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. @@ -48,7 +48,7 @@ rewrite (Rplus_comm x1 (a * y2)). apply Rplus_lt_compat_l. try exact H. Qed. - + Lemma Rfourier_le_lt : forall x1 y1 x2 y2 a:R, x1 <= y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2. @@ -59,7 +59,7 @@ rewrite H2. apply Rplus_lt_compat_l. apply Rfourier_lt; auto with real. Qed. - + Lemma Rfourier_le_le : forall x1 y1 x2 y2 a:R, x1 <= y1 -> x2 <= y2 -> 0 < a -> x1 + a * x2 <= y1 + a * y2. @@ -81,25 +81,25 @@ red in |- *. right; try assumption. auto with real. Qed. - + Lemma Rlt_zero_pos_plus1 : forall x:R, 0 < x -> 0 < 1 + x. intros x H; try assumption. rewrite Rplus_comm. apply Rle_lt_0_plus_1. red in |- *; auto with real. Qed. - + Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. intros x y H H0; try assumption. replace 0 with (x * 0). apply Rmult_lt_compat_l; auto with real. ring. Qed. - + Lemma Rlt_zero_1 : 0 < 1. exact Rlt_0_1. Qed. - + Lemma Rle_zero_pos_plus1 : forall x:R, 0 <= x -> 0 <= 1 + x. intros x H; try assumption. case H; intros. @@ -112,7 +112,7 @@ red in |- *; left. exact Rlt_zero_1. ring. Qed. - + Lemma Rle_mult_inv_pos : forall x y:R, 0 <= x -> 0 < y -> 0 <= x * / y. intros x y H H0; try assumption. case H; intros. @@ -121,12 +121,12 @@ apply Rlt_mult_inv_pos; auto with real. rewrite <- H1. red in |- *; right; ring. Qed. - + Lemma Rle_zero_1 : 0 <= 1. red in |- *; left. exact Rlt_zero_1. Qed. - + Lemma Rle_not_lt : forall n d:R, 0 <= n * / d -> ~ 0 < - n * / d. intros n d H; red in |- *; intros H0; try exact H0. generalize (Rgt_not_le 0 (n * / d)). @@ -144,14 +144,14 @@ ring. ring. ring. Qed. - + Lemma Rnot_lt0 : forall x:R, ~ 0 < 0 * x. intros x; try assumption. replace (0 * x) with 0. apply Rlt_irrefl. ring. Qed. - + Lemma Rlt_not_le_frac_opp : forall n d:R, 0 < n * / d -> ~ 0 <= - n * / d. intros n d H; try assumption. apply Rgt_not_le. @@ -162,7 +162,7 @@ try exact H. ring. ring. Qed. - + Lemma Rnot_lt_lt : forall x y:R, ~ 0 < y - x -> ~ x < y. unfold not in |- *; intros. apply H. @@ -173,7 +173,7 @@ try exact H0. ring. ring. Qed. - + Lemma Rnot_le_le : forall x y:R, ~ 0 <= y - x -> ~ x <= y. unfold not in |- *; intros. apply H. @@ -188,35 +188,35 @@ ring. right. rewrite H1; ring. Qed. - + Lemma Rfourier_gt_to_lt : forall x y:R, y > x -> x < y. unfold Rgt in |- *; intros; assumption. Qed. - + Lemma Rfourier_ge_to_le : forall x y:R, y >= x -> x <= y. intros x y; exact (Rge_le y x). Qed. - + Lemma Rfourier_eqLR_to_le : forall x y:R, x = y -> x <= y. exact Req_le. Qed. - + Lemma Rfourier_eqRL_to_le : forall x y:R, y = x -> x <= y. exact Req_le_sym. Qed. - + Lemma Rfourier_not_ge_lt : forall x y:R, (x >= y -> False) -> x < y. exact Rnot_ge_lt. Qed. - + Lemma Rfourier_not_gt_le : forall x y:R, (x > y -> False) -> x <= y. exact Rnot_gt_le. Qed. - + Lemma Rfourier_not_le_gt : forall x y:R, (x <= y -> False) -> x > y. exact Rnot_le_lt. Qed. - + Lemma Rfourier_not_lt_ge : forall x y:R, (x < y -> False) -> x >= y. exact Rnot_lt_ge. Qed. diff --git a/plugins/fourier/fourier.ml b/plugins/fourier/fourier.ml index dd54aea29a..73fb49295a 100644 --- a/plugins/fourier/fourier.ml +++ b/plugins/fourier/fourier.ml @@ -11,17 +11,17 @@ (* Méthode d'élimination de Fourier *) (* Référence: Auteur(s) : Fourier, Jean-Baptiste-Joseph - + Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,... - + Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890 - + Pages: 326-327 http://gallica.bnf.fr/ *) -(* Un peu de calcul sur les rationnels... +(* Un peu de calcul sur les rationnels... Les opérations rendent des rationnels normalisés, i.e. le numérateur et le dénominateur sont premiers entre eux. *) @@ -45,7 +45,7 @@ let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in else (let d=pgcd x.num x.den in let d= (if d<0 then -d else d) in {num=(x.num)/d;den=(x.den)/d});; - + let rop x = rnorm {num=(-x.num);den=x.den};; let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};; @@ -72,7 +72,7 @@ type ineq = {coef:rational list; let pop x l = l:=x::(!l);; -(* sépare la liste d'inéquations s selon que leur premier coefficient est +(* sépare la liste d'inéquations s selon que leur premier coefficient est négatif, nul ou positif. *) let partitionne s = let lpos=ref [] in @@ -98,7 +98,7 @@ let partitionne s = let add_hist le = let n = List.length le in let i=ref 0 in - List.map (fun (ie,s) -> + List.map (fun (ie,s) -> let h =ref [] in for k=1 to (n-(!i)-1) do pop r0 h; done; pop r1 h; @@ -107,7 +107,7 @@ let add_hist le = {coef=ie;hist=(!h);strict=s}) le ;; -(* additionne deux inéquations *) +(* additionne deux inéquations *) let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef; hist=List.map2 rplus ie1.hist ie2.hist; strict=ie1.strict || ie2.strict} @@ -142,7 +142,7 @@ let deduce_add lneg lpos = opération qu'on itère dans l'algorithme de Fourier. *) let deduce1 s = - match (partitionne s) with + match (partitionne s) with [lneg;lnul;lpos] -> let lnew = deduce_add lneg lpos in (List.map ie_tl lnul)@lnew @@ -172,7 +172,7 @@ let unsolvable lie = (try (List.iter (fun e -> match e with {coef=[c];hist=lc;strict=s} -> - if (rinf c r0 && (not s)) || (rinfeq c r0 && s) + if (rinf c r0 && (not s)) || (rinfeq c r0 && s) then (res := [c,s,lc]; raise (Failure "contradiction found")) |_->assert false) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 9082677008..3f490babd7 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -10,7 +10,7 @@ -(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients +(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients des inéquations et équations sont entiers. En attendant la tactique Field. *) @@ -26,9 +26,9 @@ open Contradiction (****************************************************************************** Opérations sur les combinaisons linéaires affines. -La partie homogène d'une combinaison linéaire est en fait une table de hash -qui donne le coefficient d'un terme du calcul des constructions, -qui est zéro si le terme n'y est pas. +La partie homogène d'une combinaison linéaire est en fait une table de hash +qui donne le coefficient d'un terme du calcul des constructions, +qui est zéro si le terme n'y est pas. *) type flin = {fhom:(constr , rational)Hashtbl.t; @@ -38,27 +38,27 @@ let flin_zero () = {fhom=Hashtbl.create 50;fcste=r0};; let flin_coef f x = try (Hashtbl.find f.fhom x) with _-> r0;; -let flin_add f x c = +let flin_add f x c = let cx = flin_coef f x in Hashtbl.remove f.fhom x; Hashtbl.add f.fhom x (rplus cx c); f ;; -let flin_add_cste f c = +let flin_add_cste f c = {fhom=f.fhom; fcste=rplus f.fcste c} ;; let flin_one () = flin_add_cste (flin_zero()) r1;; -let flin_plus f1 f2 = +let flin_plus f1 f2 = let f3 = flin_zero() in Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom; flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste; ;; -let flin_minus f1 f2 = +let flin_minus f1 f2 = let f3 = flin_zero() in Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom; Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom; @@ -69,17 +69,17 @@ let flin_emult a f = Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom; flin_add_cste f2 (rmult a f.fcste); ;; - + (*****************************************************************************) open Vernacexpr type ineq = Rlt | Rle | Rgt | Rge -let string_of_R_constant kn = +let string_of_R_constant kn = match Names.repr_con kn with - | MPfile dir, sec_dir, id when - sec_dir = empty_dirpath && - string_of_dirpath dir = "Coq.Reals.Rdefinitions" + | MPfile dir, sec_dir, id when + sec_dir = empty_dirpath && + string_of_dirpath dir = "Coq.Reals.Rdefinitions" -> string_of_label id | _ -> "constant_not_of_R" @@ -94,20 +94,20 @@ let rec rational_of_constr c = | Cast (c,_,_) -> (rational_of_constr c) | App (c,args) -> (match (string_of_R_constr c) with - | "Ropp" -> + | "Ropp" -> rop (rational_of_constr args.(0)) - | "Rinv" -> + | "Rinv" -> rinv (rational_of_constr args.(0)) - | "Rmult" -> + | "Rmult" -> rmult (rational_of_constr args.(0)) (rational_of_constr args.(1)) - | "Rdiv" -> + | "Rdiv" -> rdiv (rational_of_constr args.(0)) (rational_of_constr args.(1)) - | "Rplus" -> + | "Rplus" -> rplus (rational_of_constr args.(0)) (rational_of_constr args.(1)) - | "Rminus" -> + | "Rminus" -> rminus (rational_of_constr args.(0)) (rational_of_constr args.(1)) | _ -> failwith "not a rational") @@ -125,9 +125,9 @@ let rec flin_of_constr c = | Cast (c,_,_) -> (flin_of_constr c) | App (c,args) -> (match (string_of_R_constr c) with - "Ropp" -> + "Ropp" -> flin_emult (rop r1) (flin_of_constr args.(0)) - | "Rplus"-> + | "Rplus"-> flin_plus (flin_of_constr args.(0)) (flin_of_constr args.(1)) | "Rminus"-> @@ -138,10 +138,10 @@ let rec flin_of_constr c = try (let b = (rational_of_constr args.(1)) in (flin_add_cste (flin_zero()) (rmult a b))) with _-> (flin_add (flin_zero()) - args.(1) + args.(1) a)) with _-> (flin_add (flin_zero()) - args.(0) + args.(0) (rational_of_constr args.(1)))) | "Rinv"-> let a=(rational_of_constr args.(0)) in @@ -151,7 +151,7 @@ let rec flin_of_constr c = try (let a = (rational_of_constr args.(0)) in (flin_add_cste (flin_zero()) (rdiv a b))) with _-> (flin_add (flin_zero()) - args.(0) + args.(0) (rinv b))) |_->assert false) | Const c -> @@ -254,19 +254,19 @@ let ineq1_of_constr (h,t) = (* Applique la méthode de Fourier à une liste d'hypothèses (type hineq) *) -let fourier_lineq lineq1 = +let fourier_lineq lineq1 = let nvar=ref (-1) in let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *) List.iter (fun f -> Hashtbl.iter (fun x _ -> if not (Hashtbl.mem hvar x) then begin - nvar:=(!nvar)+1; + nvar:=(!nvar)+1; Hashtbl.add hvar x (!nvar) end) f.hflin.fhom) lineq1; let sys= List.map (fun h-> let v=Array.create ((!nvar)+1) r0 in - Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c) + Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x)<-c) h.hflin.fhom; ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict)) lineq1 in @@ -346,7 +346,7 @@ let is_int x = (x.den)=1 (* fraction = couple (num,den) *) let rec rational_to_fraction x= (x.num,x.den) ;; - + (* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1))) *) let int_to_real n = @@ -371,7 +371,7 @@ let rational_to_real x = let tac_zero_inf_pos gl (n,d) = let tacn=ref (apply (get coq_Rlt_zero_1)) in let tacd=ref (apply (get coq_Rlt_zero_1)) in - for i=1 to n-1 do + for i=1 to n-1 do tacn:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacn); done; for i=1 to d-1 do tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; @@ -381,18 +381,18 @@ let tac_zero_inf_pos gl (n,d) = (* preuve que 0<=n*1/d *) let tac_zero_infeq_pos gl (n,d)= - let tacn=ref (if n=0 + let tacn=ref (if n=0 then (apply (get coq_Rle_zero_zero)) else (apply (get coq_Rle_zero_1))) in let tacd=ref (apply (get coq_Rlt_zero_1)) in - for i=1 to n-1 do + for i=1 to n-1 do tacn:=(tclTHEN (apply (get coq_Rle_zero_pos_plus1)) !tacn); done; for i=1 to d-1 do tacd:=(tclTHEN (apply (get coq_Rlt_zero_pos_plus1)) !tacd); done; (tclTHENS (apply (get coq_Rle_mult_inv_pos)) [!tacn;!tacd]) ;; - -(* preuve que 0<(-n)*(1/d) => False + +(* preuve que 0<(-n)*(1/d) => False *) let tac_zero_inf_false gl (n,d) = if n=0 then (apply (get coq_Rnot_lt0)) @@ -401,7 +401,7 @@ let tac_zero_inf_false gl (n,d) = (tac_zero_infeq_pos gl (-n,d))) ;; -(* preuve que 0<=(-n)*(1/d) => False +(* preuve que 0<=(-n)*(1/d) => False *) let tac_zero_infeq_false gl (n,d) = (tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) @@ -409,7 +409,7 @@ let tac_zero_infeq_false gl (n,d) = ;; let create_meta () = mkMeta(Evarutil.new_meta());; - + let my_cut c gl= let concl = pf_concl gl in apply_type (mkProd(Anonymous,c,concl)) [create_meta()] gl @@ -467,22 +467,22 @@ let rec fourier gl= match (kind_of_term goal) with App (f,args) -> (match (string_of_R_constr f) with - "Rlt" -> + "Rlt" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_ge_lt)) (intro_using fhyp)) fourier) - |"Rle" -> + |"Rle" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_gt_le)) (intro_using fhyp)) fourier) - |"Rgt" -> + |"Rgt" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_le_gt)) (intro_using fhyp)) fourier) - |"Rge" -> + |"Rge" -> (tclTHEN (tclTHEN (apply (get coq_Rfourier_not_lt_ge)) (intro_using fhyp)) @@ -490,7 +490,7 @@ let rec fourier gl= |_->assert false) |_->assert false in tac gl) - with _ -> + with _ -> (* les hypothèses *) let hyps = List.map (fun (h,t)-> (mkVar h,t)) (list_of_sign (pf_hyps gl)) in @@ -511,12 +511,12 @@ let rec fourier gl= qui donnent 0 if c<>r0 then (lutil:=(h,c)::(!lutil)(*; print_rational(c);print_string " "*))) - (List.combine (!lineq) lc); + (List.combine (!lineq) lc); (* on construit la combinaison linéaire des inéquation *) (match (!lutil) with (h1,c1)::lutil -> @@ -545,7 +545,7 @@ let rec fourier gl= !t2 |] in let tc=rational_to_real cres in (* puis sa preuve *) - let tac1=ref (if h1.hstrict + let tac1=ref (if h1.hstrict then (tclTHENS (apply (get coq_Rfourier_lt)) [tac_use h1; tac_zero_inf_pos gl @@ -555,24 +555,24 @@ let rec fourier gl= tac_zero_inf_pos gl (rational_to_fraction c1)])) in s:=h1.hstrict; - List.iter (fun (h,c)-> + List.iter (fun (h,c)-> (if (!s) then (if h.hstrict then tac1:=(tclTHENS (apply (get coq_Rfourier_lt_lt)) - [!tac1;tac_use h; + [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]) else tac1:=(tclTHENS (apply (get coq_Rfourier_lt_le)) - [!tac1;tac_use h; + [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)])) else (if h.hstrict then tac1:=(tclTHENS (apply (get coq_Rfourier_le_lt)) - [!tac1;tac_use h; + [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]) else tac1:=(tclTHENS (apply (get coq_Rfourier_le_le)) - [!tac1;tac_use h; + [!tac1;tac_use h; tac_zero_inf_pos gl (rational_to_fraction c)]))); s:=(!s)||(h.hstrict)) @@ -581,7 +581,7 @@ let rec fourier gl= then tac_zero_inf_false gl (rational_to_fraction cres) else tac_zero_infeq_false gl (rational_to_fraction cres) in - tac:=(tclTHENS (my_cut ineq) + tac:=(tclTHENS (my_cut ineq) [tclTHEN (change_in_concl None (mkAppL [| get coq_not; ineq|] )) @@ -594,17 +594,17 @@ let rec fourier gl= [tac2; (tclTHENS (Equality.replace - (mkApp (get coq_Rinv, + (mkApp (get coq_Rinv, [|get coq_R1|])) (get coq_R1)) -(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) +(* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) [tclORELSE (Ring.polynom []) tclIDTAC; (tclTHEN (apply (get coq_sym_eqT)) (apply (get coq_Rinv_1)))] - + ) ])); !tac1]); @@ -614,7 +614,7 @@ let rec fourier gl= |_-> assert false) |_-> assert false ); (* ((tclTHEN !tac (tclFAIL 1 (* 1 au hasard... *))) gl) *) - (!tac gl) + (!tac gl) (* ((tclABSTRACT None !tac) gl) *) ;; diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v index 2d206220e4..00302a741d 100644 --- a/plugins/funind/Recdef.v +++ b/plugins/funind/Recdef.v @@ -20,21 +20,21 @@ Fixpoint iter (n : nat) : (A -> A) -> A -> A := End Iter. Theorem SSplus_lt : forall p p' : nat, p < S (S (p + p')). - intro p; intro p'; change (S p <= S (S (p + p'))); - apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); + intro p; intro p'; change (S p <= S (S (p + p'))); + apply le_S; apply Gt.gt_le_S; change (p < S (p + p')); apply Lt.le_lt_n_Sm; apply Plus.le_plus_l. Qed. - + Theorem Splus_lt : forall p p' : nat, p' < S (p + p'). - intro p; intro p'; change (S p' <= S (p + p')); + intro p; intro p'; change (S p' <= S (p + p')); apply Gt.gt_le_S; change (p' < S (p + p')); apply Lt.le_lt_n_Sm; apply Plus.le_plus_r. Qed. Theorem le_lt_SS : forall x y, x <= y -> x < S (S y). -intro x; intro y; intro H; change (S x <= S (S y)); - apply le_S; apply Gt.gt_le_S; change (x < S y); +intro x; intro y; intro H; change (S x <= S (S y)); + apply le_S; apply Gt.gt_le_S; change (x < S y); apply Lt.le_lt_n_Sm; exact H. Qed. diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 9087f51798..90eb499422 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,8 +1,8 @@ open Printer open Util open Term -open Termops -open Names +open Termops +open Names open Declarations open Pp open Entries @@ -16,7 +16,7 @@ open Indfun_common open Libnames let msgnl = Pp.msgnl - + let observe strm = if do_observe () @@ -35,11 +35,11 @@ let do_observe_tac s tac g = try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v with e -> let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in - msgnl (str "observation "++ s++str " raised exception " ++ - Cerrors.explain_exn e ++ str " on goal " ++ goal ); + msgnl (str "observation "++ s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); raise e;; -let observe_tac_stream s tac g = +let observe_tac_stream s tac g = if do_observe () then do_observe_tac s tac g else tac g @@ -52,54 +52,54 @@ let observe_tac s tac g = observe_tac_stream (str s) tac g (* else tac *) -let list_chop ?(msg="") n l = - try - list_chop n l - with Failure (msg') -> +let list_chop ?(msg="") n l = + try + list_chop n l + with Failure (msg') -> failwith (msg ^ msg') - + let make_refl_eq constructor type_of_t t = (* let refl_equal_term = Lazy.force refl_equal in *) mkApp(constructor,[|type_of_t;t|]) -type pte_info = - { +type pte_info = + { proving_tac : (identifier list -> Tacmach.tactic); is_valid : constr -> bool } type ptes_info = pte_info Idmap.t -type 'a dynamic_info = - { +type 'a dynamic_info = + { nb_rec_hyps : int; - rec_hyps : identifier list ; + rec_hyps : identifier list ; eq_hyps : identifier list; info : 'a } -type body_info = constr dynamic_info - +type body_info = constr dynamic_info + -let finish_proof dynamic_infos g = - observe_tac "finish" +let finish_proof dynamic_infos g = + observe_tac "finish" ( h_assumption) g - -let refine c = + +let refine c = Tacmach.refine_no_check c -let thin l = +let thin l = Tacmach.thin_no_check l - -let cut_replacing id t tac :tactic= + +let cut_replacing id t tac :tactic= tclTHENS (cut t) [ tclTHEN (thin_no_check [id]) (introduction_no_check id); - tac + tac ] let intro_erasing id = tclTHEN (thin [id]) (introduction id) @@ -108,54 +108,54 @@ let intro_erasing id = tclTHEN (thin [id]) (introduction id) let rec_hyp_id = id_of_string "rec_hyp" -let is_trivial_eq t = - let res = try +let is_trivial_eq t = + let res = try begin - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> + match kind_of_term t with + | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> eq_constr t1 t2 | App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ()) -> eq_constr t1 t2 && eq_constr a1 a2 - | _ -> false + | _ -> false end with _ -> false in (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res -let rec incompatible_constructor_terms t1 t2 = - let c1,arg1 = decompose_app t1 - and c2,arg2 = decompose_app t2 - in +let rec incompatible_constructor_terms t1 t2 = + let c1,arg1 = decompose_app t1 + and c2,arg2 = decompose_app t2 + in (not (eq_constr t1 t2)) && - isConstruct c1 && isConstruct c2 && + isConstruct c1 && isConstruct c2 && ( - not (eq_constr c1 c2) || + not (eq_constr c1 c2) || List.exists2 incompatible_constructor_terms arg1 arg2 ) -let is_incompatible_eq t = +let is_incompatible_eq t = let res = try - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> + match kind_of_term t with + | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> incompatible_constructor_terms t1 t2 - | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) -> + | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) -> (eq_constr u1 u2 && incompatible_constructor_terms t1 t2) - | _ -> false + | _ -> false with _ -> false - in + in if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); res -let change_hyp_with_using msg hyp_id t tac : tactic = - fun g -> - let prov_id = pf_get_new_id hyp_id g in +let change_hyp_with_using msg hyp_id t tac : tactic = + fun g -> + let prov_id = pf_get_new_id hyp_id g in tclTHENS ((* observe_tac msg *) (assert_by (Name prov_id) t (tclCOMPLETE tac))) - [tclTHENLIST - [ + [tclTHENLIST + [ (* observe_tac "change_hyp_with_using thin" *) (thin [hyp_id]); (* observe_tac "change_hyp_with_using rename " *) (h_rename [prov_id,hyp_id]) ]] g @@ -163,20 +163,20 @@ let change_hyp_with_using msg hyp_id t tac : tactic = exception TOREMOVE -let prove_trivial_eq h_id context (constructor,type_of_term,term) = - let nb_intros = List.length context in +let prove_trivial_eq h_id context (constructor,type_of_term,term) = + let nb_intros = List.length context in tclTHENLIST [ tclDO nb_intros intro; (* introducing context *) - (fun g -> - let context_hyps = - fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) + (fun g -> + let context_hyps = + fst (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) in - let context_hyps' = + let context_hyps' = (mkApp(constructor,[|type_of_term;term|])):: (List.map mkVar context_hyps) in - let to_refine = applist(mkVar h_id,List.rev context_hyps') in + let to_refine = applist(mkVar h_id,List.rev context_hyps') in refine to_refine g ) ] @@ -191,124 +191,124 @@ let find_rectype env c = | _ -> raise Not_found -let isAppConstruct ?(env=Global.env ()) t = - try - let t',l = find_rectype (Global.env ()) t in +let isAppConstruct ?(env=Global.env ()) t = + try + let t',l = find_rectype (Global.env ()) t in observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist (t',l))); true - with Not_found -> false + with Not_found -> false let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) let clos_norm_flags flgs env sigma t = Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty - -let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = - let nochange ?t' msg = - begin + +let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = + let nochange ?t' msg = + begin observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t ); - failwith "NoChange"; + failwith "NoChange"; end - in - let eq_constr = Reductionops.is_conv env sigma in + in + let eq_constr = Reductionops.is_conv env sigma in if not (noccurn 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp t) then nochange "not an equality"; let f_eq,args = destApp t in - let constructor,t1,t2,t1_typ = - try - if (eq_constr f_eq (Lazy.force eq)) - then + let constructor,t1,t2,t1_typ = + try + if (eq_constr f_eq (Lazy.force eq)) + then let t1 = (args.(1),args.(0)) - and t2 = (args.(2),args.(0)) + and t2 = (args.(2),args.(0)) and t1_typ = args.(0) in (Lazy.force refl_equal,t1,t2,t1_typ) else - if (eq_constr f_eq (jmeq ())) - then + if (eq_constr f_eq (jmeq ())) + then (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) else nochange "not an equality" with _ -> nochange "not an equality" - in - if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; - let rec compute_substitution sub t1 t2 = + in + if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; + let rec compute_substitution sub t1 t2 = (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) - if isRel t2 - then - let t2 = destRel t2 in - begin - try - let t1' = Intmap.find t2 sub in + if isRel t2 + then + let t2 = destRel t2 in + begin + try + let t1' = Intmap.find t2 sub in if not (eq_constr t1 t1') then nochange "twice bound variable"; sub - with Not_found -> + with Not_found -> assert (closed0 t1); Intmap.add t2 t1 sub end - else if isAppConstruct t1 && isAppConstruct t2 - then + else if isAppConstruct t1 && isAppConstruct t2 + then begin let c1,args1 = find_rectype env t1 and c2,args2 = find_rectype env t2 - in + in if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; List.fold_left2 compute_substitution sub args1 args2 end - else + else if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2) "cannot solve (diff)" in - let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in + let sub = compute_substitution Intmap.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) - let new_end_of_type = - (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 + let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) + let new_end_of_type = + (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 Can be safely replaced by the next comment for Ocaml >= 3.08.4 *) - let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in - let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in + let sub' = Intmap.fold (fun i t acc -> (i,t)::acc) sub [] in + let sub'' = List.sort (fun (x,_) (y,_) -> Pervasives.compare x y) sub' in List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type)) end_of_type_with_pop sub'' in let old_context_length = List.length context + 1 in - let witness_fun = + let witness_fun = mkLetIn(Anonymous,make_refl_eq constructor t1_typ (fst t1),t, mkApp(mkVar hyp_id,Array.init old_context_length (fun i -> mkRel (old_context_length - i))) ) in - let new_type_of_hyp,ctxt_size,witness_fun = - list_fold_left_i - (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> - try - let witness = Intmap.find i sub in + let new_type_of_hyp,ctxt_size,witness_fun = + list_fold_left_i + (fun i (end_of_type,ctxt_size,witness_fun) ((x',b',t') as decl) -> + try + let witness = Intmap.find i sub in if b' <> None then anomaly "can not redefine a rel!"; (pop end_of_type,ctxt_size,mkLetIn(x',witness,t',witness_fun)) - with Not_found -> + with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) - 1 + 1 (new_end_of_type,0,witness_fun) context in let new_type_of_hyp = - Reductionops.nf_betaiota Evd.empty new_type_of_hyp in - let new_ctxt,new_end_of_type = - decompose_prod_n_assum ctxt_size new_type_of_hyp - in - let prove_new_hyp : tactic = + Reductionops.nf_betaiota Evd.empty new_type_of_hyp in + let new_ctxt,new_end_of_type = + decompose_prod_n_assum ctxt_size new_type_of_hyp + in + let prove_new_hyp : tactic = tclTHEN (tclDO ctxt_size intro) (fun g -> - let all_ids = pf_ids_of_hyps g in - let new_ids,_ = list_chop ctxt_size all_ids in - let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in + let all_ids = pf_ids_of_hyps g in + let new_ids,_ = list_chop ctxt_size all_ids in + let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in refine to_refine g ) in - let simpl_eq_tac = + let simpl_eq_tac = change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp prove_new_hyp in (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) @@ -328,51 +328,51 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = new_ctxt,new_end_of_type,simpl_eq_tac -let is_property ptes_info t_x full_type_of_hyp = - if isApp t_x - then - let pte,args = destApp t_x in - if isVar pte && array_for_all closed0 args - then - try - let info = Idmap.find (destVar pte) ptes_info in - info.is_valid full_type_of_hyp - with Not_found -> false - else false - else false +let is_property ptes_info t_x full_type_of_hyp = + if isApp t_x + then + let pte,args = destApp t_x in + if isVar pte && array_for_all closed0 args + then + try + let info = Idmap.find (destVar pte) ptes_info in + info.is_valid full_type_of_hyp + with Not_found -> false + else false + else false -let isLetIn t = - match kind_of_term t with - | LetIn _ -> true - | _ -> false +let isLetIn t = + match kind_of_term t with + | LetIn _ -> true + | _ -> false -let h_reduce_with_zeta = - h_reduce +let h_reduce_with_zeta = + h_reduce (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; + {Rawterm.all_flags + with Rawterm.rDelta = false; }) - + let rewrite_until_var arg_num eq_ids : tactic = - (* tests if the declares recursive argument is neither a Constructor nor - an applied Constructor since such a form for the recursive argument - will break the Guard when trying to save the Lemma. + (* tests if the declares recursive argument is neither a Constructor nor + an applied Constructor since such a form for the recursive argument + will break the Guard when trying to save the Lemma. *) - let test_var g = - let _,args = destApp (pf_concl g) in + let test_var g = + let _,args = destApp (pf_concl g) in not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num)) in - let rec do_rewrite eq_ids g = - if test_var g + let rec do_rewrite eq_ids g = + if test_var g then tclIDTAC g else - match eq_ids with + match eq_ids with | [] -> anomaly "Cannot find a way to prove recursive property"; - | eq_id::eq_ids -> - tclTHEN + | eq_id::eq_ids -> + tclTHEN (tclTRY (Equality.rewriteRL (mkVar eq_id))) (do_rewrite eq_ids) g @@ -380,50 +380,50 @@ let rewrite_until_var arg_num eq_ids : tactic = do_rewrite eq_ids -let rec_pte_id = id_of_string "Hrec" -let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = Coqlib.build_coq_False () in - let coq_True = Coqlib.build_coq_True () in - let coq_I = Coqlib.build_coq_I () in - let rec scan_type context type_of_hyp : tactic = - if isLetIn type_of_hyp then +let rec_pte_id = id_of_string "Hrec" +let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = + let coq_False = Coqlib.build_coq_False () in + let coq_True = Coqlib.build_coq_True () in + let coq_I = Coqlib.build_coq_I () in + let rec scan_type context type_of_hyp : tactic = + if isLetIn type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn ~init:type_of_hyp context in - let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in + let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in (* length of context didn't change ? *) - let new_context,new_typ_of_hyp = + let new_context,new_typ_of_hyp = decompose_prod_n_assum (List.length context) reduced_type_of_hyp in - tclTHENLIST + tclTHENLIST [ h_reduce_with_zeta (Tacticals.onHyp hyp_id) ; - scan_type new_context new_typ_of_hyp - + scan_type new_context new_typ_of_hyp + ] - else if isProd type_of_hyp - then - begin - let (x,t_x,t') = destProd type_of_hyp in - let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in + else if isProd type_of_hyp + then + begin + let (x,t_x,t') = destProd type_of_hyp in + let actual_real_type_of_hyp = it_mkProd_or_LetIn ~init:t' context in if is_property ptes_infos t_x actual_real_type_of_hyp then begin - let pte,pte_args = (destApp t_x) in - let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in - let popped_t' = pop t' in - let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in - let prove_new_type_of_hyp = - let context_length = List.length context in + let pte,pte_args = (destApp t_x) in + let (* fix_info *) prove_rec_hyp = (Idmap.find (destVar pte) ptes_infos).proving_tac in + let popped_t' = pop t' in + let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in + let prove_new_type_of_hyp = + let context_length = List.length context in tclTHENLIST - [ - tclDO context_length intro; - (fun g -> - let context_hyps_ids = + [ + tclDO context_length intro; + (fun g -> + let context_hyps_ids = fst (list_chop ~msg:"rec hyp : context_hyps" context_length (pf_ids_of_hyps g)) in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = + let rec_pte_id = pf_get_new_id rec_pte_id g in + let to_refine = applist(mkVar hyp_id, List.rev_map mkVar (rec_pte_id::context_hyps_ids) ) @@ -440,39 +440,39 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ) ] in - tclTHENLIST + tclTHENLIST [ (* observe_tac "hyp rec" *) (change_hyp_with_using "rec_hyp_tac" hyp_id real_type_of_hyp prove_new_type_of_hyp); scan_type context popped_t' ] end - else if eq_constr t_x coq_False then + else if eq_constr t_x coq_False then begin (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) (* str " since it has False in its preconds " *) (* ); *) raise TOREMOVE; (* False -> .. useless *) end - else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) + else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) else if eq_constr t_x coq_True (* Trivial => we remove this precons *) - then + then (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) (* str " removing useless precond True" *) (* ); *) let popped_t' = pop t' in - let real_type_of_hyp = - it_mkProd_or_LetIn ~init:popped_t' context - in - let prove_trivial = - let nb_intro = List.length context in + let real_type_of_hyp = + it_mkProd_or_LetIn ~init:popped_t' context + in + let prove_trivial = + let nb_intro = List.length context in tclTHENLIST [ tclDO nb_intro intro; - (fun g -> - let context_hyps = + (fun g -> + let context_hyps = fst (list_chop ~msg:"removing True : context_hyps "nb_intro (pf_ids_of_hyps g)) in - let to_refine = + let to_refine = applist (mkVar hyp_id, List.rev (coq_I::List.map mkVar context_hyps) ) @@ -482,19 +482,19 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ] in tclTHENLIST[ - change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp + change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp ((* observe_tac "prove_trivial" *) prove_trivial); scan_type context popped_t' ] - else if is_trivial_eq t_x - then (* t_x := t = t => we remove this precond *) + else if is_trivial_eq t_x + then (* t_x := t = t => we remove this precond *) let popped_t' = pop t' in let real_type_of_hyp = it_mkProd_or_LetIn ~init:popped_t' context in let hd,args = destApp t_x in - let get_args hd args = - if eq_constr hd (Lazy.force eq) + let get_args hd args = + if eq_constr hd (Lazy.force eq) then (Lazy.force refl_equal,args.(0),args.(1)) else (jmeq_refl (),args.(0),args.(1)) in @@ -504,77 +504,77 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = "prove_trivial_eq" hyp_id real_type_of_hyp - ((* observe_tac "prove_trivial_eq" *) + ((* observe_tac "prove_trivial_eq" *) (prove_trivial_eq hyp_id context (get_args hd args))); scan_type context popped_t' - ] - else + ] + else begin - try - let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in + try + let new_context,new_t',tac = change_eq env sigma hyp_id context x t_x t' in tclTHEN - tac + tac (scan_type new_context new_t') - with Failure "NoChange" -> - (* Last thing todo : push the rel in the context and continue *) + with Failure "NoChange" -> + (* Last thing todo : push the rel in the context and continue *) scan_type ((x,None,t_x)::context) t' end end else tclIDTAC - in - try + in + try scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id] - with TOREMOVE -> + with TOREMOVE -> thin [hyp_id],[] -let clean_goal_with_heq ptes_infos continue_tac dyn_infos = - fun g -> - let env = pf_env g - and sigma = project g +let clean_goal_with_heq ptes_infos continue_tac dyn_infos = + fun g -> + let env = pf_env g + and sigma = project g in - let tac,new_hyps = - List.fold_left ( + let tac,new_hyps = + List.fold_left ( fun (hyps_tac,new_hyps) hyp_id -> - let hyp_tac,new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + let hyp_tac,new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma in (tclTHEN hyp_tac hyps_tac),new_hyp@new_hyps ) (tclIDTAC,[]) dyn_infos.rec_hyps in - let new_infos = - { dyn_infos with - rec_hyps = new_hyps; + let new_infos = + { dyn_infos with + rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps } in - tclTHENLIST + tclTHENLIST [ tac ; (* observe_tac "clean_hyp_with_heq continue" *) (continue_tac new_infos) ] - g + g let heq_id = id_of_string "Heq" -let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = - fun g -> - let heq_id = pf_get_new_id heq_id g in +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = + fun g -> + let heq_id = pf_get_new_id heq_id g in let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in tclTHENLIST - [ - (* We first introduce the variables *) + [ + (* We first introduce the variables *) tclDO nb_first_intro (intro_avoiding dyn_infos.rec_hyps); (* Then the equation itself *) introduction_no_check heq_id; - (* Then the new hypothesis *) + (* Then the new hypothesis *) tclMAP introduction_no_check dyn_infos.rec_hyps; - (* observe_tac "after_introduction" *)(fun g' -> + (* observe_tac "after_introduction" *)(fun g' -> (* We get infos on the equations introduced*) - let new_term_value_eq = pf_type_of g' (mkVar heq_id) in + let new_term_value_eq = pf_type_of g' (mkVar heq_id) in (* compute the new value of the body *) let new_term_value = match kind_of_term new_term_value_eq with @@ -592,31 +592,31 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = ) in let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with + let new_infos = + {dyn_infos with info = new_body; eq_hyps = heq_id::dyn_infos.eq_hyps } - in + in clean_goal_with_heq ptes_infos continue_tac new_infos g' ) ] g -let my_orelse tac1 tac2 g = - try - tac1 g - with e -> +let my_orelse tac1 tac2 g = + try + tac1 g + with e -> (* observe (str "using snd tac since : " ++ Cerrors.explain_exn e); *) - tac2 g + tac2 g -let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = - let args = Array.of_list (List.map mkVar args_id) in - let instanciate_one_hyp hid = +let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id = + let args = Array.of_list (List.map mkVar args_id) in + let instanciate_one_hyp hid = my_orelse ( (* we instanciate the hyp if possible *) - fun g -> + fun g -> let prov_hid = pf_get_new_id hid g in tclTHENLIST[ pose_proof (Name prov_hid) (mkApp(mkVar hid,args)); @@ -625,21 +625,21 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id ] g ) ( (* - if not then we are in a mutual function block + if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. - - We are not supposed to use it while proving this - principle so that we can trash it - + + We are not supposed to use it while proving this + principle so that we can trash it + *) - (fun g -> + (fun g -> (* observe (str "Instanciation: removing hyp " ++ Ppconstr.pr_id hid); *) thin [hid] g ) ) in - if args_id = [] - then + if args_id = [] + then tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; do_prove hyps @@ -649,32 +649,32 @@ let instanciate_hyps_with_args (do_prove:identifier list -> tactic) hyps args_id [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) hyps; tclMAP instanciate_one_hyp hyps; - (fun g -> - let all_g_hyps_id = + (fun g -> + let all_g_hyps_id = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty - in - let remaining_hyps = + in + let remaining_hyps = List.filter (fun id -> Idset.mem id all_g_hyps_id) hyps in do_prove remaining_hyps g ) ] -let build_proof +let build_proof (interactive_proof:bool) (fnames:constant list) ptes_infos dyn_infos : tactic = - let rec build_proof_aux do_finalize dyn_infos : tactic = - fun g -> + let rec build_proof_aux do_finalize dyn_infos : tactic = + fun g -> (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match kind_of_term dyn_infos.info with - | Case(ci,ct,t,cb) -> - let do_finalize_t dyn_info' = + match kind_of_term dyn_infos.info with + | Case(ci,ct,t,cb) -> + let do_finalize_t dyn_info' = fun g -> - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = + let t = dyn_info'.info in + let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in let g_nb_prod = nb_prod (pf_concl g) in let type_of_term = pf_type_of g t in @@ -686,21 +686,21 @@ let build_proof h_generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps)); thin dyn_infos.rec_hyps; pattern_option [(false,[1]),t] None; - (fun g -> observe_tac "toto" ( + (fun g -> observe_tac "toto" ( tclTHENSEQ [h_simplest_case t; - (fun g' -> - let g'_nb_prod = nb_prod (pf_concl g') in - let nb_instanciate_partial = g'_nb_prod - g_nb_prod in + (fun g' -> + let g'_nb_prod = nb_prod (pf_concl g') in + let nb_instanciate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" - (treat_new_case + (treat_new_case ptes_infos - nb_instanciate_partial - (build_proof do_finalize) - t + nb_instanciate_partial + (build_proof do_finalize) + t dyn_infos) g' ) - + ]) g ) ] @@ -715,25 +715,25 @@ let build_proof intro (fun g' -> let (id,_,_) = pf_last_hyp g' in - let new_term = - pf_nf_betaiota g' - (mkApp(dyn_infos.info,[|mkVar id|])) + let new_term = + pf_nf_betaiota g' + (mkApp(dyn_infos.info,[|mkVar id|])) in let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = - build_proof do_finalize + let do_prove new_hyps = + build_proof do_finalize {new_infos with - rec_hyps = new_hyps; + rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps } - in + in (* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' (* build_proof do_finalize new_infos g' *) ) g | _ -> - do_finalize dyn_infos g + do_finalize dyn_infos g end - | Cast(t,_,_) -> + | Cast(t,_,_) -> build_proof do_finalize {dyn_infos with info = t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> do_finalize dyn_infos g @@ -743,15 +743,15 @@ let build_proof match kind_of_term f with | App _ -> assert false (* we have collected all the app in decompose_app *) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> - let new_infos = - { dyn_infos with + let new_infos = + { dyn_infos with info = (f,args) } in build_proof_args do_finalize new_infos g | Const c when not (List.mem c fnames) -> - let new_infos = - { dyn_infos with + let new_infos = + { dyn_infos with info = (f,args) } in @@ -759,93 +759,93 @@ let build_proof build_proof_args do_finalize new_infos g | Const _ -> do_finalize dyn_infos g - | Lambda _ -> + | Lambda _ -> let new_term = - Reductionops.nf_beta Evd.empty dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} + Reductionops.nf_beta Evd.empty dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} g - | LetIn _ -> - let new_infos = - { dyn_infos with info = nf_betaiotazeta dyn_infos.info } - in - - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + | LetIn _ -> + let new_infos = + { dyn_infos with info = nf_betaiotazeta dyn_infos.info } + in + + tclTHENLIST + [tclMAP + (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Tacticals.onConcl; build_proof do_finalize new_infos - ] + ] g - | Cast(b,_,_) -> + | Cast(b,_,_) -> build_proof do_finalize {dyn_infos with info = b } g | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = - { dyn_infos with + let new_finalize dyn_infos = + let new_infos = + { dyn_infos with info = dyn_infos.info,args } - in - build_proof_args do_finalize new_infos - in + in + build_proof_args do_finalize new_infos + in build_proof new_finalize {dyn_infos with info = f } g end | Fix _ | CoFix _ -> error ( "Anonymous local (co)fixpoints are not handled yet") - | Prod _ -> error "Prod" - | LetIn _ -> - let new_infos = - { dyn_infos with - info = nf_betaiotazeta dyn_infos.info + | Prod _ -> error "Prod" + | LetIn _ -> + let new_infos = + { dyn_infos with + info = nf_betaiotazeta dyn_infos.info } - in + in - tclTHENLIST - [tclMAP - (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) + tclTHENLIST + [tclMAP + (fun hyp_id -> h_reduce_with_zeta (Tacticals.onHyp hyp_id)) dyn_infos.rec_hyps; h_reduce_with_zeta Tacticals.onConcl; build_proof do_finalize new_infos ] g - | Rel _ -> anomaly "Free var in goal conclusion !" + | Rel _ -> anomaly "Free var in goal conclusion !" and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) observe_tac "build_proof" (build_proof_aux do_finalize dyn_infos) g and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> - let (f_args',args) = dyn_infos.info in + let (f_args',args) = dyn_infos.info in let tac : tactic = - fun g -> + fun g -> match args with | [] -> - do_finalize {dyn_infos with info = f_args'} g + do_finalize {dyn_infos with info = f_args'} g | arg::args -> (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) (* fnl () ++ *) (* pr_goal (Tacmach.sig_it g) *) (* ); *) let do_finalize dyn_infos = - let new_arg = dyn_infos.info in + let new_arg = dyn_infos.info in (* tclTRYD *) (build_proof_args do_finalize {dyn_infos with info = (mkApp(f_args',[|new_arg|])), args} ) in - build_proof do_finalize + build_proof do_finalize {dyn_infos with info = arg } g in (* observe_tac "build_proof_args" *) (tac ) g in - let do_finish_proof dyn_infos = - (* tclTRYD *) (clean_goal_with_heq + let do_finish_proof dyn_infos = + (* tclTRYD *) (clean_goal_with_heq ptes_infos finish_proof dyn_infos) in (* observe_tac "build_proof" *) - (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) + (build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos) @@ -858,16 +858,16 @@ let build_proof -(* Proof of principles from structural functions *) +(* Proof of principles from structural functions *) let is_pte_type t = isSort ((strip_prod t)) - + let is_pte (_,_,t) = is_pte_type t -type static_fix_info = +type static_fix_info = { idx : int; name : identifier; @@ -875,18 +875,18 @@ type static_fix_info = offset : int; nb_realargs : int; body_with_param : constr; - num_in_block : int + num_in_block : int } -let prove_rec_hyp_for_struct fix_info = - (fun eq_hyps -> tclTHEN +let prove_rec_hyp_for_struct fix_info = + (fun eq_hyps -> tclTHEN (rewrite_until_var (fix_info.idx) eq_hyps) - (fun g -> - let _,pte_args = destApp (pf_concl g) in - let rec_hyp_proof = - mkApp(mkVar fix_info.name,array_get_start pte_args) + (fun g -> + let _,pte_args = destApp (pf_concl g) in + let rec_hyp_proof = + mkApp(mkVar fix_info.name,array_get_start pte_args) in refine rec_hyp_proof g )) @@ -894,38 +894,38 @@ let prove_rec_hyp_for_struct fix_info = let prove_rec_hyp fix_info = { proving_tac = prove_rec_hyp_for_struct fix_info ; - is_valid = fun _ -> true + is_valid = fun _ -> true } exception Not_Rec - -let generalize_non_dep hyp g = + +let generalize_non_dep hyp g = (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) - let hyps = [hyp] in - let env = Global.env () in - let hyp_typ = pf_type_of g (mkVar hyp) in - let to_revert,_ = + let hyps = [hyp] in + let env = Global.env () in + let hyp_typ = pf_type_of g (mkVar hyp) in + let to_revert,_ = Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> if List.mem hyp hyps or List.exists (occur_var_in_decl env hyp) keep or occur_var env hyp hyp_typ - or Termops.is_section_variable hyp (* should be dangerous *) + or Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (pf_env g) in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) - tclTHEN + tclTHEN ((* observe_tac "h_generalize" *) (h_generalize (List.map mkVar to_revert) )) ((* observe_tac "thin" *) (thin to_revert)) g - + let id_of_decl (na,_,_) = (Nameops.out_name na) let var_of_decl decl = mkVar (id_of_decl decl) -let revert idl = - tclTHEN - (generalize (List.map mkVar idl)) +let revert idl = + tclTHEN + (generalize (List.map mkVar idl)) (thin idl) let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = @@ -950,7 +950,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = (* observe (str "f_body_with_params_and_other_fun " ++ pr_lconstr f_body_with_params_and_other_fun); *) let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) - let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args) + let type_ctxt,type_of_f = decompose_prod_n_assum (nb_params + nb_args) (Typeops.type_of_constant_type (Global.env()) f_def.const_type) in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn ~init:eqn type_ctxt in @@ -971,7 +971,7 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = Command.start_proof (*i The next call to mk_equation_id is valid since we are constructing the lemma Ensures by: obvious - i*) + i*) (mk_equation_id f_id) (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) lemma_type @@ -981,72 +981,72 @@ let generate_equation_lemma fnames f fun_num nb_params nb_args rec_args_num = - + let do_replace params rec_arg_num rev_args_id f fun_num all_funs g = - let equation_lemma = - try - let finfos = find_Function_infos (destConst f) in + let equation_lemma = + try + let finfos = find_Function_infos (destConst f) in mkConst (Option.get finfos.equation_lemma) - with (Not_found | Option.IsNone as e) -> - let f_id = id_of_label (con_label (destConst f)) in + with (Not_found | Option.IsNone as e) -> + let f_id = id_of_label (con_label (destConst f)) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious - i*) - let equation_lemma_id = (mk_equation_id f_id) in + i*) + let equation_lemma_id = (mk_equation_id f_id) in generate_equation_lemma all_funs f fun_num (List.length params) (List.length rev_args_id) rec_arg_num; let _ = - match e with - | Option.IsNone -> - let finfos = find_Function_infos (destConst f) in - update_Function + match e with + | Option.IsNone -> + let finfos = find_Function_infos (destConst f) in + update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with ConstRef c -> c - | _ -> Util.anomaly "Not a constant" + | _ -> Util.anomaly "Not a constant" ) } - | _ -> () + | _ -> () - in + in Tacinterp.constr_of_id (pf_env g) equation_lemma_id in let nb_intro_to_do = nb_prod (pf_concl g) in tclTHEN (tclDO nb_intro_to_do intro) ( - fun g' -> - let just_introduced = nLastDecls nb_intro_to_do g' in - let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in + fun g' -> + let just_introduced = nLastDecls nb_intro_to_do g' in + let just_introduced_id = List.map (fun (id,_,_) -> id) just_introduced in tclTHEN (Equality.rewriteLR equation_lemma) (revert just_introduced_id) g' ) g let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tactic = - fun g -> - let princ_type = pf_concl g in - let princ_info = compute_elim_sig princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps g) in - (fun na -> - let new_id = - match na with - Name id -> fresh_id !avoid (string_of_id id) + fun g -> + let princ_type = pf_concl g in + let princ_info = compute_elim_sig princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps g) in + (fun na -> + let new_id = + match na with + Name id -> fresh_id !avoid (string_of_id id) | Anonymous -> fresh_id !avoid "H" in - avoid := new_id :: !avoid; + avoid := new_id :: !avoid; (Name new_id) ) in - let fresh_decl = - (fun (na,b,t) -> + let fresh_decl = + (fun (na,b,t) -> (fresh_id na,b,t) ) in - let princ_info : elim_scheme = - { princ_info with + let princ_info : elim_scheme = + { princ_info with params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; + predicates = List.map fresh_decl princ_info.predicates; + branches = List.map fresh_decl princ_info.branches; args = List.map fresh_decl princ_info.args } in @@ -1062,15 +1062,15 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : | None -> error ( "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in - let f_ctxt,f_body = decompose_lam fbody in - let f_ctxt_length = List.length f_ctxt in - let diff_params = princ_info.nparams - f_ctxt_length in - let full_params,princ_params,fbody_with_full_params = + let f_ctxt,f_body = decompose_lam fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params,princ_params,fbody_with_full_params = if diff_params > 0 - then - let princ_params,full_params = - list_chop diff_params princ_info.params - in + then + let princ_params,full_params = + list_chop diff_params princ_info.params + in (full_params, (* real params *) princ_params, (* the params of the principle which are not params of the function *) substl (* function instanciated with real params *) @@ -1078,9 +1078,9 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : f_body ) else - let f_ctxt_other,f_ctxt_params = - list_chop (- diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in + let f_ctxt_other,f_ctxt_params = + list_chop (- diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in (princ_info.params, (* real params *) [],(* all params are full params *) substl (* function instanciated with real params *) @@ -1099,32 +1099,32 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : (* observe (str "fbody_with_full_params := " ++ *) (* pr_lconstr fbody_with_full_params *) (* ); *) - let all_funs_with_full_params = + let all_funs_with_full_params = Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs in - let fix_offset = List.length princ_params in - let ptes_to_fix,infos = - match kind_of_term fbody_with_full_params with - | Fix((idxs,i),(names,typess,bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> + let fix_offset = List.length princ_params in + let ptes_to_fix,infos = + match kind_of_term fbody_with_full_params with + | Fix((idxs,i),(names,typess,bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> Reductionops.nf_betaiota Evd.empty (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, List.rev_map var_of_decl princ_params)) ) bodies in - let info_array = - Array.mapi - (fun i types -> + let info_array = + Array.mapi + (fun i types -> let types = prod_applist types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; name = Nameops.out_name (fresh_id names.(i)); - types = types; + types = types; offset = fix_offset; - nb_realargs = - List.length + nb_realargs = + List.length (fst (decompose_lam bodies.(i))) - fix_offset; body_with_param = bodies_with_all_params.(i); num_in_block = i @@ -1132,65 +1132,65 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : ) typess in - let pte_to_fix,rev_info = - list_fold_left_i - (fun i (acc_map,acc_info) (pte,_,_) -> - let infos = info_array.(i) in - let type_args,_ = decompose_prod infos.types in - let nargs = List.length type_args in + let pte_to_fix,rev_info = + list_fold_left_i + (fun i (acc_map,acc_info) (pte,_,_) -> + let infos = info_array.(i) in + let type_args,_ = decompose_prod infos.types in + let nargs = List.length type_args in let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in let app_f = mkApp(f,first_args) in - let pte_args = (Array.to_list first_args)@[app_f] in - let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in - let body_with_param,num = - let body = get_body fnames.(i) in - let body_with_full_params = + let pte_args = (Array.to_list first_args)@[app_f] in + let app_pte = applist(mkVar (Nameops.out_name pte),pte_args) in + let body_with_param,num = + let body = get_body fnames.(i) in + let body_with_full_params = Reductionops.nf_betaiota Evd.empty ( applist(body,List.rev_map var_of_decl full_params)) in - match kind_of_term body_with_full_params with - | Fix((_,num),(_,_,bs)) -> + match kind_of_term body_with_full_params with + | Fix((_,num),(_,_,bs)) -> Reductionops.nf_betaiota Evd.empty ( (applist - (substl - (List.rev - (Array.to_list all_funs_with_full_params)) + (substl + (List.rev + (Array.to_list all_funs_with_full_params)) bs.(num), List.rev_map var_of_decl princ_params)) ),num | _ -> error "Not a mutual block" in - let info = - {infos with + let info = + {infos with types = compose_prod type_args app_pte; body_with_param = body_with_param; num_in_block = num } - in + in (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.out_name pte) ++ *) (* str " to " ++ Ppconstr.pr_id info.name); *) (Idmap.add (Nameops.out_name pte) info acc_map,info::acc_info) ) - 0 - (Idmap.empty,[]) + 0 + (Idmap.empty,[]) (List.rev princ_info.predicates) in pte_to_fix,List.rev rev_info | _ -> Idmap.empty,[] in - let mk_fixes : tactic = - let pre_info,infos = list_chop fun_num infos in - match pre_info,infos with + let mk_fixes : tactic = + let pre_info,infos = list_chop fun_num infos in + match pre_info,infos with | [],[] -> tclIDTAC - | _, this_fix_info::others_infos -> + | _, this_fix_info::others_infos -> let other_fix_infos = List.map - (fun fi -> fi.name,fi.idx + 1 ,fi.types) + (fun fi -> fi.name,fi.idx + 1 ,fi.types) (pre_info@others_infos) - in - if other_fix_infos = [] + in + if other_fix_infos = [] then (* observe_tac ("h_fix") *) (h_fix (Some this_fix_info.name) (this_fix_info.idx +1)) else @@ -1199,34 +1199,34 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : | _ -> anomaly "Not a valid information" in let first_tac : tactic = (* every operations until fix creations *) - tclTHENSEQ - [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params)); - (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates)); - (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches)); + tclTHENSEQ + [ (* observe_tac "introducing params" *) (intros_using (List.rev_map id_of_decl princ_info.params)); + (* observe_tac "introducing predictes" *) (intros_using (List.rev_map id_of_decl princ_info.predicates)); + (* observe_tac "introducing branches" *) (intros_using (List.rev_map id_of_decl princ_info.branches)); (* observe_tac "building fixes" *) mk_fixes; ] in - let intros_after_fixes : tactic = - fun gl -> + let intros_after_fixes : tactic = + fun gl -> let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in let pte,pte_args = (decompose_app pte_app) in try - let pte = try destVar pte with _ -> anomaly "Property is not a variable" in + let pte = try destVar pte with _ -> anomaly "Property is not a variable" in let fix_info = Idmap.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in + let nb_args = fix_info.nb_realargs in tclTHENSEQ [ (* observe_tac ("introducing args") *) (tclDO nb_args intro); (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in + let args = nLastDecls nb_args g in let fix_body = fix_info.body_with_param in (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) let args_id = List.map (fun (id,_,_) -> id) args in - let dyn_infos = + let dyn_infos = { nb_rec_hyps = -100; rec_hyps = []; - info = + info = Reductionops.nf_betaiota Evd.empty (applist(fix_body,List.rev_map mkVar args_id)); eq_hyps = [] @@ -1235,42 +1235,42 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : tclTHENSEQ [ (* observe_tac "do_replace" *) - (do_replace - full_params - (fix_info.idx + List.length princ_params) + (do_replace + full_params + (fix_info.idx + List.length princ_params) (args_id@(List.map (fun (id,_,_) -> Nameops.out_name id ) princ_params)) - (all_funs.(fix_info.num_in_block)) - fix_info.num_in_block + (all_funs.(fix_info.num_in_block)) + fix_info.num_in_block all_funs ); (* observe_tac "do_replace" *) (* (do_replace princ_info.params fix_info.idx args_id *) (* (List.hd (List.rev pte_args)) fix_body); *) - let do_prove = - build_proof + let do_prove = + build_proof interactive_proof - (Array.to_list fnames) + (Array.to_list fnames) (Idmap.map prove_rec_hyp ptes_to_fix) in - let prove_tac branches = - let dyn_infos = - {dyn_infos with + let prove_tac branches = + let dyn_infos = + {dyn_infos with rec_hyps = branches; nb_rec_hyps = List.length branches } in observe_tac "cleaning" (clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) - do_prove + (Idmap.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos) in (* observe (str "branches := " ++ *) (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - + (* ); *) - (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) + (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) (List.rev args_id)) ] g @@ -1282,14 +1282,14 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : [ tclDO nb_args intro; (fun g -> (* replacement of the function by its body *) - let args = nLastDecls nb_args g in + let args = nLastDecls nb_args g in let args_id = List.map (fun (id,_,_) -> id) args in - let dyn_infos = + let dyn_infos = { nb_rec_hyps = -100; rec_hyps = []; - info = - Reductionops.nf_betaiota Evd.empty + info = + Reductionops.nf_betaiota Evd.empty (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) @@ -1300,44 +1300,44 @@ let prove_princ_for_struct interactive_proof fun_num fnames all_funs _nparams : let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in tclTHENSEQ [unfold_in_concl [(all_occurrences,Names.EvalConstRef fname)]; - let do_prove = - build_proof + let do_prove = + build_proof interactive_proof - (Array.to_list fnames) + (Array.to_list fnames) (Idmap.map prove_rec_hyp ptes_to_fix) in - let prove_tac branches = - let dyn_infos = - {dyn_infos with + let prove_tac branches = + let dyn_infos = + {dyn_infos with rec_hyps = branches; nb_rec_hyps = List.length branches } in clean_goal_with_heq - (Idmap.map prove_rec_hyp ptes_to_fix) - do_prove + (Idmap.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos in - instanciate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) + instanciate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) (List.rev args_id) ] g ) - ] + ] gl in - tclTHEN + tclTHEN first_tac intros_after_fixes g - -(* Proof of principles of general functions *) + +(* Proof of principles of general functions *) let h_id = Recdef.h_id and hrec_id = Recdef.hrec_id and acc_inv_id = Recdef.acc_inv_id @@ -1376,73 +1376,73 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = gls -let backtrack_eqs_until_hrec hrec eqs : tactic = - fun gls -> - let eqs = List.map mkVar eqs in - let rewrite = +let backtrack_eqs_until_hrec hrec eqs : tactic = + fun gls -> + let eqs = List.map mkVar eqs in + let rewrite = tclFIRST (List.map Equality.rewriteRL eqs ) - in - let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in - let f_app = array_last (snd (destApp hrec_concl)) in - let f = (fst (destApp f_app)) in - let rec backtrack : tactic = - fun g -> - let f_app = array_last (snd (destApp (pf_concl g))) in - match kind_of_term f_app with + in + let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in + let f_app = array_last (snd (destApp hrec_concl)) in + let f = (fst (destApp f_app)) in + let rec backtrack : tactic = + fun g -> + let f_app = array_last (snd (destApp (pf_concl g))) in + match kind_of_term f_app with | App(f',_) when eq_constr f' f -> tclIDTAC g | _ -> tclTHEN rewrite backtrack g in backtrack gls - - -let build_clause eqs = + + +let build_clause eqs = { - Tacexpr.onhyps = - Some (List.map + Tacexpr.onhyps = + Some (List.map (fun id -> (Rawterm.all_occurrences_expr,id),InHyp) eqs ); - Tacexpr.concl_occs = Rawterm.no_occurrences_expr + Tacexpr.concl_occs = Rawterm.no_occurrences_expr } -let rec rewrite_eqs_in_eqs eqs = - match eqs with +let rec rewrite_eqs_in_eqs eqs = + match eqs with | [] -> tclIDTAC - | eq::eqs -> - - tclTHEN - (tclMAP - (fun id gl -> - observe_tac - (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) + | eq::eqs -> + + tclTHEN + (tclMAP + (fun id gl -> + observe_tac + (Format.sprintf "rewrite %s in %s " (string_of_id eq) (string_of_id id)) (tclTRY (Equality.general_rewrite_in true all_occurrences id (mkVar eq) false)) gl - ) + ) eqs ) - (rewrite_eqs_in_eqs eqs) + (rewrite_eqs_in_eqs eqs) -let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = +let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = fun gls -> - (tclTHENSEQ + (tclTHENSEQ [ backtrack_eqs_until_hrec hrec eqs; (* observe_tac ("new_prove_with_tcc ( applying "^(string_of_id hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) (apply (mkVar hrec)) - [ tclTHENSEQ + [ tclTHENSEQ [ keep (tcc_hyps@eqs); apply (Lazy.force acc_inv); - (fun g -> - if is_mes - then - unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g + (fun g -> + if is_mes + then + unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))] g else tclIDTAC g ); observe_tac "rew_and_finish" - (tclTHENLIST + (tclTHENLIST [tclTRY(Recdef.list_rewrite false (List.map mkVar eqs)); observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs); (observe_tac "finishing using" @@ -1462,7 +1462,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = ]) ]) gls - + let is_valid_hypothesis predicates_name = let predicates_name = List.fold_right Idset.add predicates_name Idset.empty in @@ -1477,78 +1477,78 @@ let is_valid_hypothesis predicates_name = in let rec is_valid_hypothesis typ = is_pte typ || - match kind_of_term typ with + match kind_of_term typ with | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' - | _ -> false + | _ -> false in - is_valid_hypothesis + is_valid_hypothesis let prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes - rec_arg_num rec_arg_type relation gl = - let princ_type = pf_concl gl in - let princ_info = compute_elim_sig princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps gl) in - fun na -> - let new_id = - match na with - | Name id -> fresh_id !avoid (string_of_id id) - | Anonymous -> fresh_id !avoid "H" + rec_arg_num rec_arg_type relation gl = + let princ_type = pf_concl gl in + let princ_info = compute_elim_sig princ_type in + let fresh_id = + let avoid = ref (pf_ids_of_hyps gl) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (string_of_id id) + | Anonymous -> fresh_id !avoid "H" in avoid := new_id :: !avoid; Name new_id in let fresh_decl (na,b,t) = (fresh_id na,b,t) in - let princ_info : elim_scheme = - { princ_info with + let princ_info : elim_scheme = + { princ_info with params = List.map fresh_decl princ_info.params; - predicates = List.map fresh_decl princ_info.predicates; - branches = List.map fresh_decl princ_info.branches; + predicates = List.map fresh_decl princ_info.predicates; + branches = List.map fresh_decl princ_info.branches; args = List.map fresh_decl princ_info.args } in - let wf_tac = - if is_mes - then + let wf_tac = + if is_mes + then (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None) else fun _ -> prove_with_tcc tcc_lemma_ref [] in - let real_rec_arg_num = rec_arg_num - princ_info.nparams in - let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in + let real_rec_arg_num = rec_arg_num - princ_info.nparams in + let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in (* observe ( *) (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) - + (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) - let (post_rec_arg,pre_rec_arg) = + let (post_rec_arg,pre_rec_arg) = Util.list_chop npost_rec_arg princ_info.args in - let rec_arg_id = - match List.rev post_rec_arg with - | (Name id,_,_)::_ -> id - | _ -> assert false + let rec_arg_id = + match List.rev post_rec_arg with + | (Name id,_,_)::_ -> id + | _ -> assert false in (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in - let relation = substl subst_constrs relation in - let input_type = substl subst_constrs rec_arg_type in - let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in - let acc_rec_arg_id = + let subst_constrs = List.map (fun (na,_,_) -> mkVar (Nameops.out_name na)) (pre_rec_arg@princ_info.params) in + let relation = substl subst_constrs relation in + let input_type = substl subst_constrs rec_arg_type in + let wf_thm_id = Nameops.out_name (fresh_id (Name (id_of_string "wf_R"))) in + let acc_rec_arg_id = Nameops.out_name (fresh_id (Name (id_of_string ("Acc_"^(string_of_id rec_arg_id))))) - in - let revert l = - tclTHEN (h_generalize (List.map mkVar l)) (clear l) in - let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in - let prove_rec_arg_acc g = + let revert l = + tclTHEN (h_generalize (List.map mkVar l)) (clear l) + in + let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in + let prove_rec_arg_acc g = ((* observe_tac "prove_rec_arg_acc" *) (tclCOMPLETE (tclTHEN - (assert_by (Name wf_thm_id) + (assert_by (Name wf_thm_id) (mkApp (delayed_force well_founded,[|input_type;relation|])) (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)) ( @@ -1562,8 +1562,8 @@ let prove_principle_for_gen g in let args_ids = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.args in - let lemma = - match !tcc_lemma_ref with + let lemma = + match !tcc_lemma_ref with | None -> anomaly ( "No tcc proof !!") | Some lemma -> lemma in @@ -1578,11 +1578,11 @@ let prove_principle_for_gen (* f::(list_diff r check_list) *) (* in *) let tcc_list = ref [] in - let start_tac gls = - let hyps = pf_ids_of_hyps gls in - let hid = - next_global_ident_away true - (id_of_string "prov") + let start_tac gls = + let hyps = pf_ids_of_hyps gls in + let hid = + next_global_ident_away true + (id_of_string "prov") hyps in tclTHENSEQ @@ -1590,12 +1590,12 @@ let prove_principle_for_gen generalize [lemma]; h_intro hid; Elim.h_decompose_and (mkVar hid); - (fun g -> - let new_hyps = pf_ids_of_hyps g in + (fun g -> + let new_hyps = pf_ids_of_hyps g in tcc_list := List.rev (list_subtract new_hyps (hid::hyps)); if !tcc_list = [] - then - begin + then + begin tcc_list := [hid]; tclIDTAC g end @@ -1605,10 +1605,10 @@ let prove_principle_for_gen gls in tclTHENSEQ - [ + [ observe_tac "start_tac" start_tac; - h_intros - (List.rev_map (fun (na,_,_) -> Nameops.out_name na) + h_intros + (List.rev_map (fun (na,_,_) -> Nameops.out_name na) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); (* observe_tac "" *) (assert_by @@ -1619,24 +1619,24 @@ let prove_principle_for_gen (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) (* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) - (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1)); + (* observe_tac "h_fix " *) (h_fix (Some fix_id) (List.length args_ids + 1)); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); Equality.rewriteLR (mkConst eq_ref); - (* observe_tac "finish" *) (fun gl' -> - let body = - let _,args = destApp (pf_concl gl') in + (* observe_tac "finish" *) (fun gl' -> + let body = + let _,args = destApp (pf_concl gl') in array_last args in - let body_info rec_hyps = + let body_info rec_hyps = { nb_rec_hyps = List.length rec_hyps; rec_hyps = rec_hyps; eq_hyps = []; info = body } - in - let acc_inv = + in + let acc_inv = lazy ( mkApp ( delayed_force acc_inv_id, @@ -1645,12 +1645,12 @@ let prove_principle_for_gen ) in let acc_inv = lazy (mkApp(Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) in - let predicates_names = + let predicates_names = List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.predicates in - let pte_info = + let pte_info = { proving_tac = - (fun eqs -> + (fun eqs -> (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.args)); *) (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.out_name na)) princ_info.params)); *) @@ -1658,47 +1658,47 @@ let prove_principle_for_gen (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) (* observe_tac "new_prove_with_tcc" *) - (new_prove_with_tcc - is_mes acc_inv fix_id - - (!tcc_list@(List.map - (fun (na,_,_) -> (Nameops.out_name na)) + (new_prove_with_tcc + is_mes acc_inv fix_id + + (!tcc_list@(List.map + (fun (na,_,_) -> (Nameops.out_name na)) (princ_info.args@princ_info.params) )@ ([acc_rec_arg_id])) eqs ) - + ); is_valid = is_valid_hypothesis predicates_names } in - let ptes_info : pte_info Idmap.t = + let ptes_info : pte_info Idmap.t = List.fold_left - (fun map pte_id -> - Idmap.add pte_id - pte_info + (fun map pte_id -> + Idmap.add pte_id + pte_info map ) Idmap.empty predicates_names in - let make_proof rec_hyps = - build_proof - false + let make_proof rec_hyps = + build_proof + false [f_ref] ptes_info (body_info rec_hyps) in (* observe_tac "instanciate_hyps_with_args" *) - (instanciate_hyps_with_args + (instanciate_hyps_with_args make_proof (List.map (fun (na,_,_) -> Nameops.out_name na) princ_info.branches) (List.rev args_ids) ) gl' ) - + ] - gl + gl diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 62eb528e0d..ff98f2b97f 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -6,11 +6,11 @@ val prove_princ_for_struct : int -> constant array -> constr array -> int -> Tacmach.tactic -val prove_principle_for_gen : +val prove_principle_for_gen : constant*constant*constant -> (* name of the function, the fonctionnal and the fixpoint equation *) constr option ref -> (* a pointer to the obligation proofs lemma *) bool -> (* is that function uses measure *) - int -> (* the number of recursive argument *) + int -> (* the number of recursive argument *) types -> (* the type of the recursive argument *) constr -> (* the wf relation used to prove the function *) Tacmach.tactic diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 49d1a179b4..f6959d77e1 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,8 +1,8 @@ open Printer open Util open Term -open Termops -open Names +open Termops +open Names open Declarations open Pp open Entries @@ -19,102 +19,102 @@ exception Toberemoved_with_rel of int*constr exception Toberemoved -let pr_elim_scheme el = - let env = Global.env () in - let msg = str "params := " ++ Printer.pr_rel_context env el.params in - let env = Environ.push_rel_context el.params env in - let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in - let env = Environ.push_rel_context el.predicates env in - let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in - let env = Environ.push_rel_context el.branches env in - let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in - let env = Environ.push_rel_context el.args env in +let pr_elim_scheme el = + let env = Global.env () in + let msg = str "params := " ++ Printer.pr_rel_context env el.params in + let env = Environ.push_rel_context el.params env in + let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in + let env = Environ.push_rel_context el.predicates env in + let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in + let env = Environ.push_rel_context el.branches env in + let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in + let env = Environ.push_rel_context el.args env in msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl -let observe s = - if do_observe () - then Pp.msgnl s +let observe s = + if do_observe () + then Pp.msgnl s -let pr_elim_scheme el = - let env = Global.env () in - let msg = str "params := " ++ Printer.pr_rel_context env el.params in - let env = Environ.push_rel_context el.params env in - let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in - let env = Environ.push_rel_context el.predicates env in - let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in - let env = Environ.push_rel_context el.branches env in - let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in - let env = Environ.push_rel_context el.args env in +let pr_elim_scheme el = + let env = Global.env () in + let msg = str "params := " ++ Printer.pr_rel_context env el.params in + let env = Environ.push_rel_context el.params env in + let msg = msg ++ fnl () ++ str "predicates := "++ Printer.pr_rel_context env el.predicates in + let env = Environ.push_rel_context el.predicates env in + let msg = msg ++ fnl () ++ str "branches := " ++ Printer.pr_rel_context env el.branches in + let env = Environ.push_rel_context el.branches env in + let msg = msg ++ fnl () ++ str "args := " ++ Printer.pr_rel_context env el.args in + let env = Environ.push_rel_context el.args env in msg ++ fnl () ++ str "concl := " ++ pr_lconstr_env env el.concl -let observe s = - if do_observe () - then Pp.msgnl s +let observe s = + if do_observe () + then Pp.msgnl s -(* - Transform an inductive induction principle into +(* + Transform an inductive induction principle into a functional one -*) +*) let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = - let princ_type_info = compute_elim_sig princ_type in - let env = Global.env () in + let princ_type_info = compute_elim_sig princ_type in + let env = Global.env () in let env_with_params = Environ.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context = - match predicates with + let rec change_predicates_names (avoid:identifier list) (predicates:rel_context) : rel_context = + match predicates with | [] -> [] - |(Name x,v,t)::predicates -> - let id = Nameops.next_ident_away x avoid in + |(Name x,v,t)::predicates -> + let id = Nameops.next_ident_away x avoid in Hashtbl.add tbl id x; (Name id,v,t)::(change_predicates_names (id::avoid) predicates) | (Anonymous,_,_)::_ -> anomaly "Anonymous property binder " in let avoid = (Termops.ids_of_context env_with_params ) in - let princ_type_info = + let princ_type_info = { princ_type_info with predicates = change_predicates_names avoid princ_type_info.predicates } - in + in (* observe (str "starting princ_type := " ++ pr_lconstr_env env princ_type); *) (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) - let change_predicate_sort i (x,_,t) = + let change_predicate_sort i (x,_,t) = let new_sort = sorts.(i) in - let args,_ = decompose_prod t in - let real_args = - if princ_type_info.indarg_in_concl - then List.tl args + let args,_ = decompose_prod t in + let real_args = + if princ_type_info.indarg_in_concl + then List.tl args else args in - Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) + Nameops.out_name x,None,compose_prod real_args (mkSort new_sort) in - let new_predicates = + let new_predicates = list_map_i - change_predicate_sort + change_predicate_sort 0 princ_type_info.predicates in let env_with_params_and_predicates = List.fold_right Environ.push_named new_predicates env_with_params in - let rel_as_kn = + let rel_as_kn = fst (match princ_type_info.indref with - | Some (Libnames.IndRef ind) -> ind + | Some (Libnames.IndRef ind) -> ind | _ -> error "Not a valid predicate" ) in let ptes_vars = List.map (fun (id,_,_) -> id) new_predicates in - let is_pte = - let set = List.fold_right Idset.add ptes_vars Idset.empty in - fun t -> - match kind_of_term t with - | Var id -> Idset.mem id set - | _ -> false - in - let pre_princ = - it_mkProd_or_LetIn + let is_pte = + let set = List.fold_right Idset.add ptes_vars Idset.empty in + fun t -> + match kind_of_term t with + | Var id -> Idset.mem id set + | _ -> false + in + let pre_princ = + it_mkProd_or_LetIn ~init: - (it_mkProd_or_LetIn + (it_mkProd_or_LetIn ~init:(Option.fold_right mkProd_or_LetIn princ_type_info.indarg @@ -139,7 +139,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in let dummy_var = mkVar (id_of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in + let res = mkApp(rel_to_fun.(i),Array.map pop (array_get_start args)) in (* observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); *) res in @@ -168,10 +168,10 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let num = get_fun_num f in raise (Toberemoved_with_rel (var_to_be_removed,mk_replacement pre_princ num args)) | App(f,args) -> - let args = - if is_pte f && remove - then array_get_start args - else args + let args = + if is_pte f && remove + then array_get_start args + else args in let new_args,binders_to_remove = Array.fold_right (compute_new_princ_type_with_acc remove env) @@ -193,7 +193,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (* pr_lconstr_env env new_princ_type ++ fnl ()) *) (* | _ -> () in *) res - + and compute_new_princ_type_for_binder remove bind_fun env x t b = begin try @@ -240,7 +240,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) (List.map pop binders_to_remove_from_b) ) - + with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) @@ -257,54 +257,54 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = new_e::c_acc,list_union_eq eq_constr to_remove_from_e to_remove_acc in (* observe (str "Computing new principe from " ++ pr_lconstr_env env_with_params_and_predicates pre_princ); *) - let pre_res,_ = - compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ - in - let pre_res = - replace_vars + let pre_res,_ = + compute_new_princ_type princ_type_info.indarg_in_concl env_with_params_and_predicates pre_princ + in + let pre_res = + replace_vars (list_map_i (fun i id -> (id, mkRel i)) 1 ptes_vars) (lift (List.length ptes_vars) pre_res) in - it_mkProd_or_LetIn - ~init:(it_mkProd_or_LetIn - ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) + it_mkProd_or_LetIn + ~init:(it_mkProd_or_LetIn + ~init:pre_res (List.map (fun (id,t,b) -> Name(Hashtbl.find tbl id), t,b) new_predicates) ) princ_type_info.params - - -let change_property_sort toSort princ princName = - let princ_info = compute_elim_sig princ in - let change_sort_in_predicate (x,v,t) = + + +let change_property_sort toSort princ princName = + let princ_info = compute_elim_sig princ in + let change_sort_in_predicate (x,v,t) = (x,None, - let args,_ = decompose_prod t in + let args,_ = decompose_prod t in compose_prod args (mkSort toSort) ) - in - let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in - let init = - let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in + in + let princName_as_constr = Tacinterp.constr_of_id (Global.env ()) princName in + let init = + let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in mkApp(princName_as_constr, Array.init nargs (fun i -> mkRel (nargs - i ))) in it_mkLambda_or_LetIn - ~init: - (it_mkLambda_or_LetIn ~init + ~init: + (it_mkLambda_or_LetIn ~init (List.map change_sort_in_predicate princ_info.predicates) ) princ_info.params - -let pp_dur time time' = + +let pp_dur time time' = str (string_of_float (System.time_difference time time')) (* let qed () = save_named true *) -let defined () = - try - Command.save_named false - with +let defined () = + try + Command.save_named false + with | UserError("extract_proof",msg) -> Util.errorlabstrm "defined" @@ -318,7 +318,7 @@ let defined () = let build_functional_principle interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) - let mutr_nparams = (compute_elim_sig old_princ_type).nparams in + let mutr_nparams = (compute_elim_sig old_princ_type).nparams in (* let time1 = System.get_time () in *) let new_principle_type = compute_new_princ_type_from_rel @@ -346,7 +346,7 @@ let build_functional_principle interactive_proof old_princ_type sorts funs i pro (* let dur1 = System.time_difference tim1 tim2 in *) (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) (* end; *) - get_proof_clean true + get_proof_clean true end @@ -355,8 +355,8 @@ let generate_functional_principle interactive_proof old_princ_type sorts new_princ_name funs i proof_tac = - try - + try + let f = funs.(i) in let type_sort = Termops.new_sort_in_family InType in let new_sorts = @@ -395,8 +395,8 @@ let generate_functional_principle Decl_kinds.IsDefinition (Decl_kinds.Scheme) ) ); - Flags.if_verbose - (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) + Flags.if_verbose + (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) name; names := name :: !names in @@ -404,21 +404,21 @@ let generate_functional_principle register_with_sort InSet in let (id,(entry,g_kind,hook)) = - build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook + build_functional_principle interactive_proof old_princ_type new_sorts funs i proof_tac hook in (* Pr 1278 : Don't forget to close the goal if an error is raised !!!! - *) + *) save false new_princ_name entry g_kind hook - with e -> + with e -> begin - begin - try - let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in + begin + try + let id = Pfedit.get_current_proof_name () in + let s = string_of_id id in let n = String.length "___________princ_________" in - if String.length s >= n - then if String.sub s 0 n = "___________princ_________" + if String.length s >= n + then if String.sub s 0 n = "___________princ_________" then Pfedit.delete_current_proof () else () else () @@ -431,24 +431,24 @@ let generate_functional_principle exception Not_Rec -let get_funs_constant mp dp = - let rec get_funs_constant const e : (Names.constant*int) array = - match kind_of_term ((strip_lam e)) with - | Fix((_,(na,_,_))) -> - Array.mapi - (fun i na -> - match na with - | Name id -> - let const = make_con mp dp (label_of_id id) in +let get_funs_constant mp dp = + let rec get_funs_constant const e : (Names.constant*int) array = + match kind_of_term ((strip_lam e)) with + | Fix((_,(na,_,_))) -> + Array.mapi + (fun i na -> + match na with + | Name id -> + let const = make_con mp dp (label_of_id id) in const,i - | Anonymous -> - anomaly "Anonymous fix" + | Anonymous -> + anomaly "Anonymous fix" ) na | _ -> [|const,0|] in - function const -> - let find_constant_body const = + function const -> + let find_constant_body const = match (Global.lookup_constant const ).const_body with | Some b -> let body = force b in @@ -462,97 +462,97 @@ let get_funs_constant mp dp = | None -> error ( "Cannot define a principle over an axiom ") in let f = find_constant_body const in - let l_const = get_funs_constant const f in - (* - We need to check that all the functions found are in the same block + let l_const = get_funs_constant const f in + (* + We need to check that all the functions found are in the same block to prevent Reset stange thing - *) - let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in - (* all the paremeter must be equal*) - let _check_params = - let first_params = List.hd l_params in - List.iter - (fun params -> - if not ((=) first_params params) + *) + let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in + let l_params,l_fixes = List.split (List.map decompose_lam l_bodies) in + (* all the paremeter must be equal*) + let _check_params = + let first_params = List.hd l_params in + List.iter + (fun params -> + if not ((=) first_params params) then error "Not a mutal recursive block" ) l_params in - (* The bodies has to be very similar *) - let _check_bodies = - try - let extract_info is_first body = - match kind_of_term body with + (* The bodies has to be very similar *) + let _check_bodies = + try + let extract_info is_first body = + match kind_of_term body with | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && (List.length l_bodies = 1) + | _ -> + if is_first && (List.length l_bodies = 1) then raise Not_Rec else error "Not a mutal recursive block" in - let first_infos = extract_info true (List.hd l_bodies) in + let first_infos = extract_info true (List.hd l_bodies) in let check body = (* Hope this is correct *) - if not (first_infos = (extract_info false body)) + if not (first_infos = (extract_info false body)) then error "Not a mutal recursive block" - in + in List.iter check l_bodies with Not_Rec -> () in l_const -exception No_graph_found -exception Found_type of int +exception No_graph_found +exception Found_type of int -let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = - let env = Global.env () +let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_entry list = + let env = Global.env () and sigma = Evd.empty in - let funs = List.map fst fas in - let first_fun = List.hd funs in + let funs = List.map fst fas in + let first_fun = List.hd funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in - let first_fun_kn = - try - fst (find_Function_infos first_fun).graph_ind - with Not_found -> raise No_graph_found + let first_fun_kn = + try + fst (find_Function_infos first_fun).graph_ind + with Not_found -> raise No_graph_found in let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in - let this_block_funs = Array.map fst this_block_funs_indexes in + let this_block_funs = Array.map fst this_block_funs_indexes in let prop_sort = InProp in - let funs_indexes = - let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.map (function const -> List.assoc const this_block_funs_indexes) funs in - let ind_list = - List.map - (fun (idx) -> - let ind = first_fun_kn,idx in + let ind_list = + List.map + (fun (idx) -> + let ind = first_fun_kn,idx in let (mib,mip) = Global.lookup_inductive ind in ind,mib,mip,true,prop_sort ) funs_indexes in - let l_schemes = + let l_schemes = List.map - (Typing.type_of env sigma) + (Typing.type_of env sigma) (Indrec.build_mutual_indrec env sigma ind_list) - in + in let i = ref (-1) in - let sorts = - List.rev_map (fun (_,x) -> + let sorts = + List.rev_map (fun (_,x) -> Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) - ) - fas + ) + fas in (* We create the first priciple by tactic *) - let first_type,other_princ_types = - match l_schemes with + let first_type,other_princ_types = + match l_schemes with s::l_schemes -> s,l_schemes | _ -> anomaly "" in - let (_,(const,_,_)) = + let (_,(const,_,_)) = try build_functional_principle false first_type @@ -561,15 +561,15 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent 0 (prove_princ_for_struct false 0 (Array.of_list funs)) (fun _ _ _ -> ()) - with e -> + with e -> begin - begin - try - let id = Pfedit.get_current_proof_name () in - let s = string_of_id id in + begin + try + let id = Pfedit.get_current_proof_name () in + let s = string_of_id id in let n = String.length "___________princ_________" in - if String.length s >= n - then if String.sub s 0 n = "___________princ_________" + if String.length s >= n + then if String.sub s 0 n = "___________princ_________" then Pfedit.delete_current_proof () else () else () @@ -578,71 +578,71 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent raise (Defining_principle e) end - in + in incr i; - let opacity = - let finfos = find_Function_infos this_block_funs.(0) in - try - let equation = Option.get finfos.equation_lemma in - (Global.lookup_constant equation).Declarations.const_opaque - with Option.IsNone -> (* non recursive definition *) + let opacity = + let finfos = find_Function_infos this_block_funs.(0) in + try + let equation = Option.get finfos.equation_lemma in + (Global.lookup_constant equation).Declarations.const_opaque + with Option.IsNone -> (* non recursive definition *) false in - let const = {const with const_entry_opaque = opacity } in + let const = {const with const_entry_opaque = opacity } in (* The others are just deduced *) - if other_princ_types = [] + if other_princ_types = [] then [const] else - let other_fun_princ_types = - let funs = Array.map mkConst this_block_funs in - let sorts = Array.of_list sorts in + let other_fun_princ_types = + let funs = Array.map mkConst this_block_funs in + let sorts = Array.of_list sorts in List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types in - let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in + let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in let ctxt,fix = decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*) - let (idxs,_),(_,ta,_ as decl) = destFix fix in - let other_result = + let (idxs,_),(_,ta,_ as decl) = destFix fix in + let other_result = List.map (* we can now compute the other principles *) - (fun scheme_type -> + (fun scheme_type -> incr i; observe (Printer.pr_lconstr scheme_type); - let type_concl = (strip_prod_assum scheme_type) in - let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in + let type_concl = (strip_prod_assum scheme_type) in + let applied_f = List.hd (List.rev (snd (decompose_app type_concl))) in let f = fst (decompose_app applied_f) in try (* we search the number of the function in the fix block (name of the function) *) - Array.iteri - (fun j t -> - let t = (strip_prod_assum t) in - let applied_g = List.hd (List.rev (snd (decompose_app t))) in + Array.iteri + (fun j t -> + let t = (strip_prod_assum t) in + let applied_g = List.hd (List.rev (snd (decompose_app t))) in let g = fst (decompose_app applied_g) in if eq_constr f g - then raise (Found_type j); + then raise (Found_type j); observe (Printer.pr_lconstr f ++ str " <> " ++ Printer.pr_lconstr g) - + ) ta; - (* If we reach this point, the two principle are not mutually recursive - We fall back to the previous method + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method *) - let (_,(const,_,_)) = + let (_,(const,_,_)) = build_functional_principle - false + false (List.nth other_princ_types (!i - 1)) (Array.of_list sorts) this_block_funs !i (prove_princ_for_struct false !i (Array.of_list funs)) (fun _ _ _ -> ()) - in + in const - with Found_type i -> - let princ_body = + with Found_type i -> + let princ_body = Termops.it_mkLambda_or_LetIn ~init:(mkFix((idxs,i),decl)) ctxt - in - {const with - Entries.const_entry_body = princ_body; + in + {const with + Entries.const_entry_body = princ_body; Entries.const_entry_type = Some scheme_type } ) @@ -650,51 +650,51 @@ let make_scheme (fas : (constant*Rawterm.rawsort) list) : Entries.definition_ent in const::other_result -let build_scheme fas = +let build_scheme fas = Dumpglob.pause (); - let bodies_types = - make_scheme - (List.map - (fun (_,f,sort) -> + let bodies_types = + make_scheme + (List.map + (fun (_,f,sort) -> let f_as_constant = try - match Nametab.global f with - | Libnames.ConstRef c -> c + match Nametab.global f with + | Libnames.ConstRef c -> c | _ -> Util.error "Functional Scheme can only be used with functions" with Not_found -> Util.error ("Cannot find "^ Libnames.string_of_reference f) in (f_as_constant,sort) - ) + ) fas - ) - in - List.iter2 - (fun (princ_id,_,_) def_entry -> - ignore - (Declare.declare_constant - princ_id + ) + in + List.iter2 + (fun (princ_id,_,_) def_entry -> + ignore + (Declare.declare_constant + princ_id (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); - Flags.if_verbose + Flags.if_verbose (fun id -> Pp.msgnl (Ppconstr.pr_id id ++ str " is defined")) princ_id ) fas bodies_types; Dumpglob.continue () - -let build_case_scheme fa = - let env = Global.env () + +let build_case_scheme fa = + let env = Global.env () and sigma = Evd.empty in (* let id_to_constr id = *) (* Tacinterp.constr_of_id env id *) (* in *) - let funs = (fun (_,f,_) -> + let funs = (fun (_,f,_) -> try Libnames.constr_of_global (Nametab.global f) - with Not_found -> - Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in - let first_fun = destConst funs in + with Not_found -> + Util.error ("Cannot find "^ Libnames.string_of_reference f)) fa in + let first_fun = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in @@ -702,17 +702,17 @@ let build_case_scheme fa = let this_block_funs_indexes = get_funs_constant funs_mp funs_dp first_fun in - let this_block_funs = Array.map fst this_block_funs_indexes in + let this_block_funs = Array.map fst this_block_funs_indexes in let prop_sort = InProp in - let funs_indexes = - let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in List.assoc (destConst funs) this_block_funs_indexes in - let ind_fun = - let ind = first_fun_kn,funs_indexes in + let ind_fun = + let ind = first_fun_kn,funs_indexes in ind,prop_sort in - let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf) ind_fun) in + let scheme_type = (Typing.type_of env sigma ) ((fun (ind,sf) -> Indrec.make_case_gen env sigma ind sf) ind_fun) in let sorts = (fun (_,_,x) -> Termops.new_sort_in_family (Pretyping.interp_elimination_sort x) @@ -720,7 +720,7 @@ let build_case_scheme fa = fa in let princ_name = (fun (x,_,_) -> x) fa in - let _ = + let _ = (* Pp.msgnl (str "Generating " ++ Ppconstr.pr_id princ_name ++str " with " ++ pr_lconstr scheme_type ++ str " and " ++ (fun a -> prlist_with_sep spc (fun c -> pr_lconstr (mkConst c)) (Array.to_list a)) this_block_funs ); diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index cf28c6e6c2..fb04c6ec28 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -2,26 +2,26 @@ open Names open Term -val generate_functional_principle : +val generate_functional_principle : (* do we accept interactive proving *) bool -> - (* induction principle on rel *) + (* induction principle on rel *) types -> (* *) - sorts array option -> - (* Name of the new principle *) - (identifier) option -> + sorts array option -> + (* Name of the new principle *) + (identifier) option -> (* the compute functions to use *) - constant array -> + constant array -> (* We prove the nth- principle *) int -> (* The tactic to use to make the proof w.r the number of params *) - (constr array -> int -> Tacmach.tactic) -> + (constr array -> int -> Tacmach.tactic) -> unit -val compute_new_princ_type_from_rel : constr array -> sorts array -> +val compute_new_princ_type_from_rel : constr array -> sorts array -> types -> types diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 28fec2e981..0e51eb7e1b 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -11,7 +11,7 @@ open Term open Names open Pp open Topconstr -open Indfun_common +open Indfun_common open Indfun open Genarg open Pcoq @@ -26,14 +26,14 @@ let pr_bindings prc prlc = function brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc prc l | Rawterm.ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ + brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | Rawterm.NoBindings -> mt () let pr_with_bindings prc prlc (c,bl) = prc c ++ hv 0 (pr_bindings prc prlc bl) -let pr_fun_ind_using prc prlc _ opt_c = +let pr_fun_ind_using prc prlc _ opt_c = match opt_c with | None -> mt () | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings prc prlc (p,b)) @@ -45,10 +45,10 @@ let pr_fun_ind_using prc prlc _ opt_c = (prc,prlc)... *) let pr_with_bindings_typed prc prlc (c,bl) = - prc c ++ + prc c ++ hv 0 (pr_bindings (fun c -> prc (snd c)) (fun c -> prlc (snd c)) bl) -let pr_fun_ind_using_typed prc prlc _ opt_c = +let pr_fun_ind_using_typed prc prlc _ opt_c = match opt_c with | None -> mt () | Some (p,b) -> spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc (p,b)) @@ -67,46 +67,46 @@ END TACTIC EXTEND newfuninv - [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> + [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> [ Invfun.invfun hyp fname ] END -let pr_intro_as_pat prc _ _ pat = - match pat with +let pr_intro_as_pat prc _ _ pat = + match pat with | Some pat -> spc () ++ str "as" ++ spc () ++ pr_intro_pattern pat | None -> mt () ARGUMENT EXTEND with_names TYPED AS intro_pattern_opt PRINTED BY pr_intro_as_pat -| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] -| [] ->[ None ] +| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] +| [] ->[ None ] END TACTIC EXTEND newfunind - ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ - let c = match cl with + ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + [ + let c = match cl with | [] -> assert false - | [c] -> c + | [c] -> c | c::cl -> applist(c,cl) - in + in functional_induction true c princl pat ] END (***** debug only ***) TACTIC EXTEND snewfunind - ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ - let c = match cl with + ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + [ + let c = match cl with | [] -> assert false - | [c] -> c + | [c] -> c | c::cl -> applist(c,cl) - in + in functional_induction false c princl pat ] END @@ -130,8 +130,8 @@ ARGUMENT EXTEND auto_using' END let pr_rec_annotation2_aux s r id l = - str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ - Util.pr_opt Nameops.pr_id id ++ + str ("{"^s^" ") ++ Ppconstr.pr_constr_expr r ++ + Util.pr_opt Nameops.pr_id id ++ Pptactic.pr_auto_using Ppconstr.pr_constr_expr l ++ str "}" let pr_rec_annotation2 = function @@ -143,11 +143,11 @@ VERNAC ARGUMENT EXTEND rec_annotation2 PRINTED BY pr_rec_annotation2 [ "{" "struct" ident(id) "}"] -> [ Struct id ] | [ "{" "wf" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Wf(r,id,l) ] -| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] +| [ "{" "measure" constr(r) ident_opt(id) auto_using'(l) "}" ] -> [ Mes(r,id,l) ] END let pr_binder2 (idl,c) = - str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ + str "(" ++ Util.prlist_with_sep spc Nameops.pr_id idl ++ spc () ++ str ": " ++ Ppconstr.pr_lconstr_expr c ++ str ")" VERNAC ARGUMENT EXTEND binder2 @@ -159,9 +159,9 @@ let make_binder2 (idl,c) = LocalRawAssum (List.map (fun id -> (Util.dummy_loc,Name id)) idl,Topconstr.default_binder_kind,c) let pr_rec_definition2 (id,bl,annot,type_,def) = - Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ + Nameops.pr_id id ++ spc () ++ Util.prlist_with_sep spc pr_binder2 bl ++ Util.pr_opt pr_rec_annotation2 annot ++ spc () ++ str ":" ++ spc () ++ - Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ + Ppconstr.pr_lconstr_expr type_ ++ str " :=" ++ spc () ++ Ppconstr.pr_lconstr_expr def VERNAC ARGUMENT EXTEND rec_definition2 @@ -182,11 +182,11 @@ let make_rec_definitions2 (id,bl,annot,type_,def) = Pp.str "the recursive argument needs to be specified"); in let check_exists_args an = - try - let id = match an with - | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id - | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" - in + try + let id = match an with + | Struct id -> id | Wf(_,Some id,_) -> id | Mes(_,Some id,_) -> id + | Wf(_,None,_) | Mes(_,None,_) -> failwith "check_exists_args" + in (try ignore(Util.list_index0 (Name id) names); annot with Not_found -> Util.user_err_loc (Util.dummy_loc,"Function", @@ -206,33 +206,33 @@ let make_rec_definitions2 (id,bl,annot,type_,def) = VERNAC COMMAND EXTEND Function ["Function" ne_rec_definition2_list_sep(recsl,"with")] -> - [ - do_generate_principle false (List.map make_rec_definitions2 recsl); - + [ + do_generate_principle false (List.map make_rec_definitions2 recsl); + ] END -let pr_fun_scheme_arg (princ_name,fun_name,s) = - Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ - Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ +let pr_fun_scheme_arg (princ_name,fun_name,s) = + Nameops.pr_id princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ + Libnames.pr_reference fun_name ++ spc() ++ str "Sort " ++ Ppconstr.pr_rawsort s VERNAC ARGUMENT EXTEND fun_scheme_arg PRINTED BY pr_fun_scheme_arg -| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] -END +| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort(s) ] -> [ (princ_name,fun_name,s) ] +END -let warning_error names e = - match e with - | Building_graph e -> - Pp.msg_warning - (str "Cannot define graph(s) for " ++ +let warning_error names e = + match e with + | Building_graph e -> + Pp.msg_warning + (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt ()) - | Defining_principle e -> + | Defining_principle e -> Pp.msg_warning - (str "Cannot define principle(s) for "++ + (str "Cannot define principle(s) for "++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Libnames.pr_reference names) ++ if do_observe () then Cerrors.explain_exn e else mt ()) | _ -> anomaly "" @@ -242,29 +242,29 @@ VERNAC COMMAND EXTEND NewFunctionalScheme ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] -> [ begin - try + try Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> + with Functional_principles_types.No_graph_found -> begin - match fas with - | (_,fun_name,_)::_ -> + match fas with + | (_,fun_name,_)::_ -> begin begin make_graph (Nametab.global fun_name) end ; try Functional_principles_types.build_scheme fas - with Functional_principles_types.No_graph_found -> + with Functional_principles_types.No_graph_found -> Util.error ("Cannot generate induction principle(s)") - | e -> - let names = List.map (fun (_,na,_) -> na) fas in + | e -> + let names = List.map (fun (_,na,_) -> na) fas in warning_error names e - + end | _ -> assert false (* we can only have non empty list *) end - | e -> - let names = List.map (fun (_,na,_) -> na) fas in + | e -> + let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end @@ -280,7 +280,7 @@ VERNAC COMMAND EXTEND NewFunctionalCase END (***** debug only ***) -VERNAC COMMAND EXTEND GenerateGraph +VERNAC COMMAND EXTEND GenerateGraph ["Generate" "graph" "for" reference(c)] -> [ make_graph (Nametab.global c) ] END @@ -296,7 +296,7 @@ let msg x = () ;; let pr_lconstr c = str "" let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) -let prNamedConstr s c = +let prNamedConstr s c = begin msg(str ""); msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n"); @@ -318,8 +318,8 @@ type fapp_info = { (** [constr_head_match(a b c) a] returns true, false otherwise. *) let constr_head_match u t= - if isApp u - then + if isApp u + then let uhd,args= destApp u in uhd=t else false @@ -328,28 +328,28 @@ let constr_head_match u t= [inu]. DeBruijn are not pushed, so some of them may be unbound in the result. *) let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = - let subres = + let subres = match kind_of_term inu with - | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> + | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test | Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *) - Array.fold_left - (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) + Array.fold_left + (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) [] bl | _ -> (* Cofix will be wrong *) - fold_constr - (fun l cstr -> - l @ hdMatchSub cstr test) [] inu in + fold_constr + (fun l cstr -> + l @ hdMatchSub cstr test) [] inu in if not (test inu) then subres else let f,args = decompose_app inu in let freeset = Termops.free_rels inu in let max_rel = try Util.Intset.max_elt freeset with Not_found -> -1 in {fname = f; largs = args; free = Util.Intset.is_empty freeset; - max_rel = max_rel; onlyvars = List.for_all isVar args } + max_rel = max_rel; onlyvars = List.for_all isVar args } ::subres -let mkEq typ c1 c2 = +let mkEq typ c1 c2 = mkApp (Coqlib.build_coq_eq(),[| typ; c1; c2|]) @@ -357,11 +357,11 @@ let poseq_unsafe idunsafe cstr gl = let typ = Tacmach.pf_type_of gl cstr in tclTHEN (Tactics.letin_tac None (Name idunsafe) cstr None allHypsAndConcl) - (tclTHENFIRST - (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) + (tclTHENFIRST + (Tactics.assert_tac Anonymous (mkEq typ (mkVar idunsafe) cstr)) Tactics.reflexivity) gl - + let poseq id cstr gl = let x = Tactics.fresh_id [] id gl in @@ -374,11 +374,11 @@ let list_constr_largs = ref [] let rec poseq_list_ids_rec lcstr gl = match lcstr with | [] -> tclIDTAC gl - | c::lcstr' -> + | c::lcstr' -> match kind_of_term c with - | Var _ -> + | Var _ -> (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl) - | _ -> + | _ -> let _ = prstr "c = " in let _ = prconstr c in let _ = prstr "\n" in @@ -395,16 +395,16 @@ let rec poseq_list_ids_rec lcstr gl = (poseq_list_ids_rec lcstr') gl -let poseq_list_ids lcstr gl = +let poseq_list_ids lcstr gl = let _ = list_constr_largs := [] in poseq_list_ids_rec lcstr gl (** [find_fapp test g] returns the list of [app_info] of all calls to functions that satisfy [test] in the conclusion of goal g. Trivial repetition (not modulo conversion) are deleted. *) -let find_fapp (test:constr -> bool) g : fapp_info list = +let find_fapp (test:constr -> bool) g : fapp_info list = let pre_res = hdMatchSub (Tacmach.pf_concl g) test in - let res = + let res = List.fold_right (fun x acc -> if List.mem x acc then acc else x::acc) pre_res [] in (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res); res) @@ -418,24 +418,24 @@ let find_fapp (test:constr -> bool) g : fapp_info list = let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info list) (nexttac:Proof_type.tactic) g = let test = match oid with - | Some id -> + | Some id -> let idconstr = mkConst (const_of_id id) in (fun u -> constr_head_match u idconstr) (* select only id *) | None -> (fun u -> isApp u) in (* select calls to any function *) let info_list = find_fapp test g in let ordered_info_list = heuristic info_list in - prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); + prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); if List.length ordered_info_list = 0 then Util.error "function not found in goal\n"; - let taclist: Proof_type.tactic list = - List.map + let taclist: Proof_type.tactic list = + List.map (fun info -> (tclTHEN (tclTHEN (poseq_list_ids info.largs) ( - fun gl -> - (functional_induction - true (applist (info.fname, List.rev !list_constr_largs)) - None None) gl)) + fun gl -> + (functional_induction + true (applist (info.fname, List.rev !list_constr_largs)) + None None) gl)) nexttac)) ordered_info_list in (* we try each (f t u v) until one does not fail *) (* TODO: try also to mix functional schemes *) @@ -450,7 +450,7 @@ let finduction (oid:identifier option) (heuristic: fapp_info list -> fapp_info l let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = match oi with | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *) - | None -> + | None -> (* Default heuristic: put first occurrences where all arguments are *bound* (meaning already introduced) variables *) let ordering x y = @@ -464,11 +464,11 @@ let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = TACTIC EXTEND finduction - ["finduction" ident(id) natural_opt(oi)] -> - [ + ["finduction" ident(id) natural_opt(oi)] -> + [ match oi with | Some(n) when n<=0 -> Util.error "numerical argument must be > 0" - | _ -> + | _ -> let heuristic = chose_heuristic oi in finduction (Some id) heuristic tclIDTAC ] @@ -477,13 +477,13 @@ END TACTIC EXTEND fauto - [ "fauto" tactic(tac)] -> + [ "fauto" tactic(tac)] -> [ let heuristic = chose_heuristic None in finduction None heuristic (snd tac) ] | - [ "fauto" ] -> + [ "fauto" ] -> [ let heuristic = chose_heuristic None in finduction None heuristic tclIDTAC @@ -493,7 +493,7 @@ END TACTIC EXTEND poseq - [ "poseq" ident(x) constr(c) ] -> + [ "poseq" ident(x) constr(c) ] -> [ poseq x c ] END @@ -502,10 +502,10 @@ VERNAC COMMAND EXTEND Showindinfo END VERNAC COMMAND EXTEND MergeFunind - [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" - "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> - [ - let f1 = Constrintern.interp_constr Evd.empty (Global.env()) + [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" + "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> + [ + let f1 = Constrintern.interp_constr Evd.empty (Global.env()) (CRef (Libnames.Ident (Util.dummy_loc,id1))) in let f2 = Constrintern.interp_constr Evd.empty (Global.env()) (CRef (Libnames.Ident (Util.dummy_loc,id2))) in @@ -513,11 +513,11 @@ VERNAC COMMAND EXTEND MergeFunind let f2type = Typing.type_of (Global.env()) Evd.empty f2 in let ar1 = List.length (fst (decompose_prod f1type)) in let ar2 = List.length (fst (decompose_prod f2type)) in - let _ = - if ar1 <> List.length cl1 then + let _ = + if ar1 <> List.length cl1 then Util.error ("not the right number of arguments for " ^ string_of_id id1) in - let _ = - if ar2 <> List.length cl2 then + let _ = + if ar2 <> List.length cl2 then Util.error ("not the right number of arguments for " ^ string_of_id id2) in Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id ] diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 46da3a01d5..7cce53c7c3 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -7,13 +7,13 @@ open Libnames open Rawterm open Declarations -let is_rec_info scheme_info = - let test_branche min acc (_,_,br) = +let is_rec_info scheme_info = + let test_branche min acc (_,_,br) = acc || ( - let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in - let free_rels_in_br = Termops.free_rels new_branche in - let max = min + scheme_info.Tactics.npredicates in + let new_branche = + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum br)) in + let free_rels_in_br = Termops.free_rels new_branche in + let max = min + scheme_info.Tactics.npredicates in Util.Intset.exists (fun i -> i >= min && i< max) free_rels_in_br ) in @@ -28,38 +28,38 @@ let choose_dest_or_ind scheme_info = let functional_induction with_clean c princl pat = Dumpglob.pause (); - let res = let f,args = decompose_app c in - fun g -> - let princ,bindings, princ_type = - match princl with + let res = let f,args = decompose_app c in + fun g -> + let princ,bindings, princ_type = + match princl with | None -> (* No principle is given let's find the good one *) begin match kind_of_term f with | Const c' -> - let princ_option = + let princ_option = let finfo = (* we first try to find out a graph on f *) - try find_Function_infos c' - with Not_found -> + try find_Function_infos c' + with Not_found -> errorlabstrm "" (str "Cannot find induction information on "++ Printer.pr_lconstr (mkConst c') ) in - match Tacticals.elimination_sort_of_goal g with + match Tacticals.elimination_sort_of_goal g with | InProp -> finfo.prop_lemma | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma in let princ = (* then we get the principle *) try mkConst (Option.get princ_option ) - with Option.IsNone -> - (*i If there is not default lemma defined then, - we cross our finger and try to find a lemma named f_ind + with Option.IsNone -> + (*i If there is not default lemma defined then, + we cross our finger and try to find a lemma named f_ind (or f_rec, f_rect) i*) - let princ_name = + let princ_name = Indrec.make_elimination_ident (id_of_label (con_label c')) (Tacticals.elimination_sort_of_goal g) in - try + try mkConst(const_of_id princ_name ) with Not_found -> (* This one is neither defined ! *) errorlabstrm "" (str "Cannot find induction principle for " @@ -67,57 +67,57 @@ let functional_induction with_clean c princl pat = in (princ,Rawterm.NoBindings, Tacmach.pf_type_of g princ) | _ -> raise (UserError("",str "functional induction must be used with a function" )) - + end - | Some ((princ,binding)) -> + | Some ((princ,binding)) -> princ,binding,Tacmach.pf_type_of g princ in - let princ_infos = Tactics.compute_elim_sig princ_type in + let princ_infos = Tactics.compute_elim_sig princ_type in let args_as_induction_constr = - let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] + let c_list = + if princ_infos.Tactics.farg_in_concl + then [c] else [] in - List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) - in - let princ' = Some (princ,bindings) in - let princ_vars = - List.fold_right - (fun a acc -> + List.map (fun c -> Tacexpr.ElimOnConstr (c,NoBindings)) (args@c_list) + in + let princ' = Some (princ,bindings) in + let princ_vars = + List.fold_right + (fun a acc -> try Idset.add (destVar a) acc with _ -> acc ) args Idset.empty in - let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in - let old_idl = Idset.diff old_idl princ_vars in - let subst_and_reduce g = - if with_clean + let old_idl = List.fold_right Idset.add (Tacmach.pf_ids_of_hyps g) Idset.empty in + let old_idl = Idset.diff old_idl princ_vars in + let subst_and_reduce g = + if with_clean then - let idl = - map_succeed - (fun id -> + let idl = + map_succeed + (fun id -> if Idset.mem id old_idl then failwith "subst_and_reduce"; - id + id ) (Tacmach.pf_ids_of_hyps g) - in - let flag = + in + let flag = Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; + {Rawterm.all_flags + with Rawterm.rDelta = false; } in Tacticals.tclTHEN (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Equality.subst [id])) idl ) - (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl) + (Hiddentac.h_reduce flag Tacticals.allHypsAndConcl) g - else Tacticals.tclIDTAC g - + else Tacticals.tclIDTAC g + in Tacticals.tclTHEN - (choose_dest_or_ind + (choose_dest_or_ind princ_infos args_as_induction_constr princ' @@ -128,12 +128,12 @@ let functional_induction with_clean c princl pat = in Dumpglob.continue (); res - - -type annot = - Struct of identifier + + +type annot = + Struct of identifier | Wf of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list | Mes of Topconstr.constr_expr * identifier option * Topconstr.constr_expr list @@ -150,12 +150,12 @@ let rec abstract_rawconstr c = function let interp_casted_constr_with_implicits sigma env impls c = (* Constrintern.interp_rawconstr_with_implicits sigma env [] impls c *) - Constrintern.intern_gen false sigma env ~impls:([],impls) + Constrintern.intern_gen false sigma env ~impls:([],impls) ~allow_patvar:false ~ltacvars:([],[]) c -(* - Construct a fixpoint as a Rawterm +(* + Construct a fixpoint as a Rawterm and not as a constr *) let build_newrecursive @@ -192,7 +192,7 @@ let build_newrecursive States.unfreeze fs; def in recdef,rec_impls - + let compute_annot (name,annot,args,types,body) = let names = List.map snd (Topconstr.names_of_local_assums args) in @@ -207,124 +207,124 @@ let compute_annot (name,annot,args,types,body) = | Some r -> (name,r,args,types,body) -(* Checks whether or not the mutual bloc is recursive *) -let rec is_rec names = - let names = List.fold_right Idset.add names Idset.empty in - let check_id id names = Idset.mem id names in - let rec lookup names = function +(* Checks whether or not the mutual bloc is recursive *) +let rec is_rec names = + let names = List.fold_right Idset.add names Idset.empty in + let check_id id names = Idset.mem id names in + let rec lookup names = function | RVar(_,id) -> check_id id names | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ | RDynamic _ -> false | RCast(_,b,_) -> lookup names b | RRec _ -> error "RRec not handled" - | RIf(_,b,_,lhs,rhs) -> + | RIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) - | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b) -> + | RLetIn(_,na,t,b) | RLambda(_,na,_,t,b) | RProd(_,na,_,t,b) -> lookup names t || lookup (Nameops.name_fold Idset.remove na names) b - | RLetTuple(_,nal,_,t,b) -> lookup names t || - lookup - (List.fold_left + | RLetTuple(_,nal,_,t,b) -> lookup names t || + lookup + (List.fold_left (fun acc na -> Nameops.name_fold Idset.remove na acc) names nal ) b | RApp(_,f,args) -> List.exists (lookup names) (f::args) - | RCases(_,_,_,el,brl) -> + | RCases(_,_,_,el,brl) -> List.exists (fun (e,_) -> lookup names e) el || List.exists (lookup_br names) brl - and lookup_br names (_,idl,_,rt) = - let new_names = List.fold_right Idset.remove idl names in + and lookup_br names (_,idl,_,rt) = + let new_names = List.fold_right Idset.remove idl names in lookup new_names rt in lookup names -let prepare_body (name,annot,args,types,body) rt = - let n = (Topconstr.local_binders_length args) in +let prepare_body (name,annot,args,types,body) rt = + let n = (Topconstr.local_binders_length args) in (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_rawconstr rt); *) let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') let derive_inversion fix_names = - try + try (* we first transform the fix_names identifier into their corresponding constant *) - let fix_names_as_constant = - List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names - in - (* - Then we check that the graphs have been defined - If one of the graphs haven't been defined + let fix_names_as_constant = + List.map (fun id -> destConst (Tacinterp.constr_of_id (Global.env ()) id)) fix_names + in + (* + Then we check that the graphs have been defined + If one of the graphs haven't been defined we do nothing *) List.iter (fun c -> ignore (find_Function_infos c)) fix_names_as_constant ; try - Invfun.derive_correctness + Invfun.derive_correctness Functional_principles_types.make_scheme - functional_induction + functional_induction fix_names_as_constant - (*i The next call to mk_rel_id is valid since we have just construct the graph + (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : register_built - i*) + i*) (List.map (fun id -> destInd (Tacinterp.constr_of_id (Global.env ()) (mk_rel_id id))) fix_names ) - with e -> - msg_warning - (str "Cannot built inversion information" ++ + with e -> + msg_warning + (str "Cannot built inversion information" ++ if do_observe () then Cerrors.explain_exn e else mt ()) with _ -> () -let warning_error names e = - let e_explain e = - match e with +let warning_error names e = + let e_explain e = + match e with | ToShow e -> spc () ++ Cerrors.explain_exn e | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt () - in - match e with - | Building_graph e -> - Pp.msg_warning - (str "Cannot define graph(s) for " ++ + in + match e with + | Building_graph e -> + Pp.msg_warning + (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) - | Defining_principle e -> + | Defining_principle e -> Pp.msg_warning - (str "Cannot define principle(s) for "++ + (str "Cannot define principle(s) for "++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) | _ -> anomaly "" -let error_error names e = - let e_explain e = - match e with +let error_error names e = + let e_explain e = + match e with | ToShow e -> spc () ++ Cerrors.explain_exn e | _ -> if do_observe () then (spc () ++ Cerrors.explain_exn e) else mt () in - match e with - | Building_graph e -> - errorlabstrm "" - (str "Cannot define graph(s) for " ++ + match e with + | Building_graph e -> + errorlabstrm "" + (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) | _ -> anomaly "" let generate_principle on_error - is_general do_built fix_rec_l recdefs interactive_proof - (continue_proof : int -> Names.constant array -> Term.constr array -> int -> + is_general do_built fix_rec_l recdefs interactive_proof + (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = let names = List.map (function ((_, name),_,_,_,_) -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in let funs_types = List.map (function (_,_,_,types,_) -> types) fix_rec_l in - try + try (* We then register the Inductive graphs of the functions *) Rawterm_to_relation.build_inductive names funs_args funs_types recdefs; - if do_built + if do_built then begin - (*i The next call to mk_rel_id is valid since we have just construct the graph + (*i The next call to mk_rel_id is valid since we have just construct the graph Ensures by : do_built - i*) + i*) let f_R_mut = Ident (dummy_loc,mk_rel_id (List.nth names 0)) in let ind_kn = fst (locate_with_msg @@ -339,34 +339,34 @@ let generate_principle on_error locate_constant f_ref in - let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in - let _ = + let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in + let _ = list_map_i (fun i x -> - let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in + let princ = destConst (Indrec.lookup_eliminator (ind_kn,i) (InProp)) in let princ_type = Typeops.type_of_constant (Global.env()) princ in Functional_principles_types.generate_functional_principle - interactive_proof + interactive_proof princ_type None - None + None funs_kn i - (continue_proof 0 [|funs_kn.(i)|]) + (continue_proof 0 [|funs_kn.(i)|]) ) 0 fix_rec_l - in + in Array.iter (add_Function is_general) funs_kn; () end - with e -> - on_error names e + with e -> + on_error names e -let register_struct is_rec fixpoint_exprl = - match fixpoint_exprl with - | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> +let register_struct is_rec fixpoint_exprl = + match fixpoint_exprl with + | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> Command.declare_definition fname (Decl_kinds.Global,Flags.boxed_definitions (),Decl_kinds.Definition) @@ -375,65 +375,65 @@ let register_struct is_rec fixpoint_exprl = body (Some ret_type) (fun _ _ -> ()) - | _ -> + | _ -> Command.build_recursive fixpoint_exprl (Flags.boxed_definitions()) -let generate_correction_proof_wf f_ref tcc_lemma_ref +let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation - (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = + (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body - pre_hook - = - let type_of_f = Command.generalize_constr_expr ret_type args in - let rec_arg_num = - let names = + pre_hook + = + let type_of_f = Command.generalize_constr_expr ret_type args in + let rec_arg_num = + let names = List.map snd - (Topconstr.names_of_local_assums args) - in - match wf_arg with - | None -> + (Topconstr.names_of_local_assums args) + in + match wf_arg with + | None -> if List.length names = 1 then 1 else error "Recursive argument must be specified" - | Some wf_arg -> - list_index (Name wf_arg) names + | Some wf_arg -> + list_index (Name wf_arg) names in - let unbounded_eq = - let f_app_args = - Topconstr.CAppExpl - (dummy_loc, + let unbounded_eq = + let f_app_args = + Topconstr.CAppExpl + (dummy_loc, (None,(Ident (dummy_loc,fname))) , - (List.map + (List.map (function - | _,Anonymous -> assert false + | _,Anonymous -> assert false | _,Name e -> (Topconstr.mkIdentC e) - ) + ) (Topconstr.names_of_local_assums args) ) - ) + ) in Topconstr.CApp (dummy_loc,(None,Topconstr.mkRefC (Qualid (dummy_loc,(qualid_of_string "Logic.eq")))), [(f_app_args,None);(body,None)]) in - let eq = Command.generalize_constr_expr unbounded_eq args in + let eq = Command.generalize_constr_expr unbounded_eq args in let hook f_ref tcc_lemma_ref functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation = - try - pre_hook + try + pre_hook (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); derive_inversion [fname] - with e -> - (* No proof done *) + with e -> + (* No proof done *) () - in - Recdef.recursive_definition + in + Recdef.recursive_definition is_mes fname rec_impls type_of_f wf_rel_expr @@ -442,115 +442,115 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas hook using_lemmas - -let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = - let wf_arg_type,wf_arg = - match wf_arg with - | None -> + +let register_mes fname rec_impls wf_mes_expr wf_arg using_lemmas args ret_type body = + let wf_arg_type,wf_arg = + match wf_arg with + | None -> begin - match args with - | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x - | _ -> error "Recursive argument must be specified" + match args with + | [Topconstr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x + | _ -> error "Recursive argument must be specified" end - | Some wf_args -> - try - match - List.find - (function - | Topconstr.LocalRawAssum(l,k,t) -> - List.exists - (function (_,Name id) -> id = wf_args | _ -> false) - l + | Some wf_args -> + try + match + List.find + (function + | Topconstr.LocalRawAssum(l,k,t) -> + List.exists + (function (_,Name id) -> id = wf_args | _ -> false) + l | _ -> false ) - args - with + args + with | Topconstr.LocalRawAssum(_,k,t) -> t,wf_args - | _ -> assert false - with Not_found -> assert false + | _ -> assert false + with Not_found -> assert false in - let ltof = - let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in - Libnames.Qualid (dummy_loc,Libnames.qualid_of_path + let ltof = + let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) in + Libnames.Qualid (dummy_loc,Libnames.qualid_of_path (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (id_of_string "ltof"))) in - let fun_from_mes = - let applied_mes = + let fun_from_mes = + let applied_mes = Topconstr.mkAppC(wf_mes_expr,[Topconstr.mkIdentC wf_arg]) in - Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes) + Topconstr.mkLambdaC ([(dummy_loc,Name wf_arg)],Topconstr.default_binder_kind,wf_arg_type,applied_mes) in - let wf_rel_from_mes = + let wf_rel_from_mes = Topconstr.mkAppC(Topconstr.mkRefC ltof,[wf_arg_type;fun_from_mes]) in - register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) + register_wf ~is_mes:true fname rec_impls wf_rel_from_mes (Some wf_arg) using_lemmas args ret_type body - - -let do_generate_principle on_error register_built interactive_proof fixpoint_exprl = - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let _is_struct = - match fixpoint_exprl with - | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> - let pre_hook = - generate_principle + + +let do_generate_principle on_error register_built interactive_proof fixpoint_exprl = + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let _is_struct = + match fixpoint_exprl with + | [(((_,name),Some (Wf (wf_rel,wf_x,using_lemmas)),args,types,body))] -> + let pre_hook = + generate_principle on_error true register_built - fixpoint_exprl + fixpoint_exprl recdefs true - in - if register_built + in + if register_built then register_wf name rec_impls wf_rel wf_x using_lemmas args types body pre_hook; false - | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> - let pre_hook = - generate_principle + | [(((_,name),Some (Mes (wf_mes,wf_x,using_lemmas)),args,types,body))] -> + let pre_hook = + generate_principle on_error true register_built - fixpoint_exprl + fixpoint_exprl recdefs true - in - if register_built + in + if register_built then register_mes name rec_impls wf_mes wf_x using_lemmas args types body pre_hook; true - | _ -> - let fix_names = - List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl + | _ -> + let fix_names = + List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl in let is_one_rec = is_rec fix_names in - let old_fixpoint_exprl = + let old_fixpoint_exprl = List.map (function - | (name,Some (Struct id),args,types,body),_ -> - let annot = - try Some (dummy_loc, id), Topconstr.CStructRec - with Not_found -> - raise (UserError("",str "Cannot find argument " ++ - Ppconstr.pr_id id)) - in - (name,annot,args,types,body),(None:Vernacexpr.decl_notation) - | (name,None,args,types,body),recdef -> + | (name,Some (Struct id),args,types,body),_ -> + let annot = + try Some (dummy_loc, id), Topconstr.CStructRec + with Not_found -> + raise (UserError("",str "Cannot find argument " ++ + Ppconstr.pr_id id)) + in + (name,annot,args,types,body),(None:Vernacexpr.decl_notation) + | (name,None,args,types,body),recdef -> let names = (Topconstr.names_of_local_assums args) in if is_one_rec recdef && List.length names > 1 then user_err_loc (dummy_loc,"Function", Pp.str "the recursive argument needs to be specified in Function") - else + else let loc, na = List.hd names in (name,(Some (loc, Nameops.out_name na), Topconstr.CStructRec),args,types,body), (None:Vernacexpr.decl_notation) - | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> - error + | (_,Some (Wf _),_,_,_),_ | (_,Some (Mes _),_,_,_),_-> + error ("Cannot use mutual definition with well-founded recursion or measure") - ) + ) (List.combine fixpoint_exprl recdefs) in - (* ok all the expressions are structural *) - let fix_names = - List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl + (* ok all the expressions are structural *) + let fix_names = + List.map (function ((_,name),_,_,_,_) -> name) fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in if register_built then register_struct is_rec old_fixpoint_exprl; @@ -559,7 +559,7 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp false register_built fixpoint_exprl - recdefs + recdefs interactive_proof (Functional_principles_proofs.prove_princ_for_struct interactive_proof); if register_built then derive_inversion fix_names; @@ -568,52 +568,52 @@ let do_generate_principle on_error register_built interactive_proof fixpoint_exp () open Topconstr -let rec add_args id new_args b = - match b with - | CRef r -> - begin match r with - | Libnames.Ident(loc,fname) when fname = id -> +let rec add_args id new_args b = + match b with + | CRef r -> + begin match r with + | Libnames.Ident(loc,fname) when fname = id -> CAppExpl(dummy_loc,(None,r),new_args) | _ -> b end | CFix _ | CCoFix _ -> anomaly "add_args : todo" - | CArrow(loc,b1,b2) -> + | CArrow(loc,b1,b2) -> CArrow(loc,add_args id new_args b1, add_args id new_args b2) - | CProdN(loc,nal,b1) -> + | CProdN(loc,nal,b1) -> CProdN(loc, - List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, + List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) - | CLambdaN(loc,nal,b1) -> + | CLambdaN(loc,nal,b1) -> CLambdaN(loc, - List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, + List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) - | CLetIn(loc,na,b1,b2) -> + | CLetIn(loc,na,b1,b2) -> CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) - | CAppExpl(loc,(pf,r),exprl) -> - begin - match r with - | Libnames.Ident(loc,fname) when fname = id -> + | CAppExpl(loc,(pf,r),exprl) -> + begin + match r with + | Libnames.Ident(loc,fname) when fname = id -> CAppExpl(loc,(pf,r),new_args@(List.map (add_args id new_args) exprl)) | _ -> CAppExpl(loc,(pf,r),List.map (add_args id new_args) exprl) end - | CApp(loc,(pf,b),bl) -> - CApp(loc,(pf,add_args id new_args b), + | CApp(loc,(pf,b),bl) -> + CApp(loc,(pf,add_args id new_args b), List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(loc,sty,b_option,cel,cal) -> + | CCases(loc,sty,b_option,cel,cal) -> CCases(loc,sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,(na,b_option)) -> + List.map (fun (b,(na,b_option)) -> add_args id new_args b, - (na,Option.map (add_args id new_args) b_option)) cel, + (na,Option.map (add_args id new_args) b_option)) cel, List.map (fun (loc,cpl,e) -> (loc,cpl,add_args id new_args e)) cal ) - | CLetTuple(loc,nal,(na,b_option),b1,b2) -> + | CLetTuple(loc,nal,(na,b_option),b1,b2) -> CLetTuple(loc,nal,(na,Option.map (add_args id new_args) b_option), add_args id new_args b1, add_args id new_args b2 ) - - | CIf(loc,b1,(na,b_option),b2,b3) -> - CIf(loc,add_args id new_args b1, + + | CIf(loc,b1,(na,b_option),b2,b3) -> + CIf(loc,add_args id new_args b1, (na,Option.map (add_args id new_args) b_option), add_args id new_args b2, add_args id new_args b3 @@ -622,7 +622,7 @@ let rec add_args id new_args b = | CPatVar _ -> b | CEvar _ -> b | CSort _ -> b - | CCast(loc,b1,CastConv(ck,b2)) -> + | CCast(loc,b1,CastConv(ck,b2)) -> CCast(loc,add_args id new_args b1,CastConv(ck,add_args id new_args b2)) | CCast(loc,b1,CastCoerce) -> CCast(loc,add_args id new_args b1,CastCoerce) @@ -635,70 +635,70 @@ let rec add_args id new_args b = exception Stop of Topconstr.constr_expr -(* [chop_n_arrow n t] chops the [n] first arrows in [t] - Acts on Topconstr.constr_expr +(* [chop_n_arrow n t] chops the [n] first arrows in [t] + Acts on Topconstr.constr_expr *) -let rec chop_n_arrow n t = - if n <= 0 +let rec chop_n_arrow n t = + if n <= 0 then t (* If we have already removed all the arrows then return the type *) - else (* If not we check the form of [t] *) - match t with + else (* If not we check the form of [t] *) + match t with | Topconstr.CArrow(_,_,t) -> (* If we have an arrow, we discard it and recall [chop_n_arrow] *) chop_n_arrow (n-1) t - | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : + | Topconstr.CProdN(_,nal_ta',t') -> (* If we have a forall, to result are possible : either we need to discard more than the number of arrows contained in this product declaration then we just recall [chop_n_arrow] on - the remaining number of arrow to chop and [t'] we discard it and - recall [chop_n_arrow], either this product contains more arrows + the remaining number of arrow to chop and [t'] we discard it and + recall [chop_n_arrow], either this product contains more arrows than the number we need to chop and then we return the new type *) - begin - try + begin + try let new_n = - let rec aux (n:int) = function + let rec aux (n:int) = function [] -> n - | (nal,k,t'')::nal_ta' -> - let nal_l = List.length nal in + | (nal,k,t'')::nal_ta' -> + let nal_l = List.length nal in if n >= nal_l - then + then aux (n - nal_l) nal_ta' - else - let new_t' = + else + let new_t' = Topconstr.CProdN(dummy_loc, ((snd (list_chop n nal)),k,t'')::nal_ta',t') - in + in raise (Stop new_t') in aux n nal_ta' - in + in chop_n_arrow new_n t' with Stop t -> t end | _ -> anomaly "Not enough products" - -let rec get_args b t : Topconstr.local_binder list * - Topconstr.constr_expr * Topconstr.constr_expr = - match b with - | Topconstr.CLambdaN (loc, (nal_ta), b') -> + +let rec get_args b t : Topconstr.local_binder list * + Topconstr.constr_expr * Topconstr.constr_expr = + match b with + | Topconstr.CLambdaN (loc, (nal_ta), b') -> begin - let n = - (List.fold_left (fun n (nal,_,_) -> + let n = + (List.fold_left (fun n (nal,_,_) -> n+List.length nal) 0 nal_ta ) in - let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in - (List.map (fun (nal,k,ta) -> - (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' + let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in + (List.map (fun (nal,k,ta) -> + (Topconstr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' end | _ -> [],b,t let make_graph (f_ref:global_reference) = - let c,c_body = - match f_ref with - | ConstRef c -> - begin try c,Global.lookup_constant c - with Not_found -> + let c,c_body = + match f_ref with + | ConstRef c -> + begin try c,Global.lookup_constant c + with Not_found -> raise (UserError ("",str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) end | _ -> raise (UserError ("", str "Not a function reference") ) @@ -710,10 +710,10 @@ let make_graph (f_ref:global_reference) = | Some b -> let env = Global.env () in let body = (force b) in - let extern_body,extern_type = - with_full_print - (fun () -> - (Constrextern.extern_constr false env body, + let extern_body,extern_type = + with_full_print + (fun () -> + (Constrextern.extern_constr false env body, Constrextern.extern_type false env (Typeops.type_of_constant_type env c_body.const_type) ) @@ -721,48 +721,48 @@ let make_graph (f_ref:global_reference) = () in let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b with - | Topconstr.CFix(loc,l_id,fixexprl) -> - let l = + let expr_list = + match b with + | Topconstr.CFix(loc,l_id,fixexprl) -> + let l = List.map - (fun (id,(n,recexp),bl,t,b) -> + (fun (id,(n,recexp),bl,t,b) -> let loc, rec_id = Option.get n in - let new_args = - List.flatten - (List.map + let new_args = + List.flatten + (List.map (function | Topconstr.LocalRawDef (na,_)-> [] - | Topconstr.LocalRawAssum (nal,_,_) -> - List.map - (fun (loc,n) -> - CRef(Libnames.Ident(loc, Nameops.out_name n))) + | Topconstr.LocalRawAssum (nal,_,_) -> + List.map + (fun (loc,n) -> + CRef(Libnames.Ident(loc, Nameops.out_name n))) nal ) nal_tas ) in - let b' = add_args (snd id) new_args b in + let b' = add_args (snd id) new_args b in (id, Some (Struct rec_id),nal_tas@bl,t,b') ) fixexprl in l - | _ -> - let id = id_of_label (con_label c) in + | _ -> + let id = id_of_label (con_label c) in [((dummy_loc,id),None,nal_tas,t,b)] in do_generate_principle error_error false false expr_list; (* We register the infos *) - let mp,dp,_ = repr_con c in - List.iter - (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) + let mp,dp,_ = repr_con c in + List.iter + (fun ((_,id),_,_,_,_) -> add_Function false (make_con mp dp (label_of_id id))) expr_list); Dumpglob.continue () - + (* let make_graph _ = assert false *) - -let do_generate_principle = do_generate_principle warning_error true + +let do_generate_principle = do_generate_principle warning_error true diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 3583c84484..06f3291fe6 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -24,13 +24,13 @@ let get_name avoid ?(default="H") = function | Name n -> Name n let array_get_start a = - try + try Array.init (Array.length a - 1) (fun i -> a.(i)) - with Invalid_argument "index out of bounds" -> + with Invalid_argument "index out of bounds" -> invalid_argument "array_get_start" - + let id_of_name = function Name id -> id | _ -> raise Not_found @@ -78,7 +78,7 @@ let chop_rlambda_n = match rt with | Rawterm.RLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b | Rawterm.RLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b - | _ -> + | _ -> raise (Util.UserError("chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) in @@ -107,11 +107,11 @@ let list_union_eq eq_fun l1 l2 = let list_add_set_eq eq_fun x l = if List.exists (eq_fun x) l then l else x::l - + let const_of_id id = - let _,princ_ref = + let _,princ_ref = qualid_of_reference (Libnames.Ident (Util.dummy_loc,id)) in try Nametab.locate_constant princ_ref @@ -119,7 +119,7 @@ let const_of_id id = let def_of_const t = match (Term.kind_of_term t) with - Term.Const sp -> + Term.Const sp -> (try (match (Global.lookup_constant sp) with {Declarations.const_body=Some c} -> Declarations.force c |_ -> assert false) @@ -127,17 +127,17 @@ let def_of_const t = |_ -> assert false let coq_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" + Coqlib.gen_constant_in_modules "RecursiveDefinition" (Coqlib.init_modules @ Coqlib.arith_modules) s;; let constant sl s = constr_of_global - (Nametab.locate (make_qualid(Names.make_dirpath + (Nametab.locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; let find_reference sl s = - (Nametab.locate (make_qualid(Names.make_dirpath + (Nametab.locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; @@ -146,7 +146,7 @@ let refl_equal = lazy(coq_constant "refl_equal") (*****************************************************************) (* Copy of the standart save mechanism but without the much too *) -(* slow reduction function *) +(* slow reduction function *) (*****************************************************************) open Declarations open Entries @@ -183,7 +183,7 @@ let save with_clean id const (locality,kind) hook = let extract_pftreestate pts = let pfterm,subgoals = Refiner.extract_open_pftreestate pts in - let tpfsigma = Refiner.evc_of_pftreestate pts in + let tpfsigma = Refiner.evc_of_pftreestate pts in let exl = Evarutil.non_instantiated tpfsigma in if subgoals <> [] or exl <> [] then Util.errorlabstrm "extract_proof" @@ -198,19 +198,19 @@ let extract_pftreestate pts = let nf_betaiotazeta = let clos_norm_flags flgs env sigma t = Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiotazeta + clos_norm_flags Closure.betaiotazeta let nf_betaiota = let clos_norm_flags flgs env sigma t = Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiota + clos_norm_flags Closure.betaiota let cook_proof do_reduce = - let pfs = Pfedit.get_pftreestate () + let pfs = Pfedit.get_pftreestate () (* and ident = Pfedit.get_current_proof_name () *) and (ident,strength,concl,hook) = Pfedit.current_proof_statement () in let env,sigma,pfterm = extract_pftreestate pfs in - let pfterm = + let pfterm = if do_reduce then nf_betaiota env sigma pfterm else pfterm @@ -228,32 +228,32 @@ let new_save_named opacity = let const = { const with const_entry_opaque = opacity } in save true id const persistence hook -let get_proof_clean do_reduce = - let result = cook_proof do_reduce in +let get_proof_clean do_reduce = + let result = cook_proof do_reduce in Pfedit.delete_current_proof (); result -let with_full_print f a = +let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in - let old_rawprint = !Flags.raw_print in + let old_rawprint = !Flags.raw_print in Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; Impargs.make_contextual_implicit_args false; Impargs.make_contextual_implicit_args false; Dumpglob.pause (); - try - let res = f a in + try + let res = f a in Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; Dumpglob.continue (); res - with - | e -> + with + | e -> Impargs.make_implicit_args old_implicit_args; Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; @@ -268,19 +268,19 @@ let with_full_print f a = (**********************) -type function_info = - { +type function_info = + { function_constant : constant; graph_ind : inductive; equation_lemma : constant option; correctness_lemma : constant option; - completeness_lemma : constant option; + completeness_lemma : constant option; rect_lemma : constant option; rec_lemma : constant option; prop_lemma : constant option; is_general : bool; (* Has this function been defined using general recursive definition *) } - + (* type function_db = function_info list *) @@ -290,54 +290,54 @@ type function_info = let from_function = ref Cmap.empty let from_graph = ref Indmap.empty (* -let rec do_cache_info finfo = function - | [] -> raise Not_found - | (finfo'::finfos as l) -> - if finfo' == finfo then l - else if finfo'.function_constant = finfo.function_constant +let rec do_cache_info finfo = function + | [] -> raise Not_found + | (finfo'::finfos as l) -> + if finfo' == finfo then l + else if finfo'.function_constant = finfo.function_constant then finfo::finfos else - let res = do_cache_info finfo finfos in + let res = do_cache_info finfo finfos in if res == finfos then l else finfo'::l - -let cache_Function (_,(finfos)) = - let new_tbl = + +let cache_Function (_,(finfos)) = + let new_tbl = try do_cache_info finfos !function_table with Not_found -> finfos::!function_table - in - if new_tbl != !function_table + in + if new_tbl != !function_table then function_table := new_tbl *) -let cache_Function (_,finfos) = +let cache_Function (_,finfos) = from_function := Cmap.add finfos.function_constant finfos !from_function; from_graph := Indmap.add finfos.graph_ind finfos !from_graph let load_Function _ = cache_Function let open_Function _ = cache_Function -let subst_Function (_,subst,finfos) = +let subst_Function (_,subst,finfos) = let do_subst_con c = fst (Mod_subst.subst_con subst c) and do_subst_ind (kn,i) = (Mod_subst.subst_kn subst kn,i) in - let function_constant' = do_subst_con finfos.function_constant in - let graph_ind' = do_subst_ind finfos.graph_ind in - let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in - let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in - let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in + let function_constant' = do_subst_con finfos.function_constant in + let graph_ind' = do_subst_ind finfos.graph_ind in + let equation_lemma' = Option.smartmap do_subst_con finfos.equation_lemma in + let correctness_lemma' = Option.smartmap do_subst_con finfos.correctness_lemma in + let completeness_lemma' = Option.smartmap do_subst_con finfos.completeness_lemma in let rect_lemma' = Option.smartmap do_subst_con finfos.rect_lemma in - let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in - let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in - if function_constant' == finfos.function_constant && - graph_ind' == finfos.graph_ind && + let rec_lemma' = Option.smartmap do_subst_con finfos.rec_lemma in + let prop_lemma' = Option.smartmap do_subst_con finfos.prop_lemma in + if function_constant' == finfos.function_constant && + graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma - then finfos + correctness_lemma' == finfos.correctness_lemma && + completeness_lemma' == finfos.completeness_lemma && + rect_lemma' == finfos.rect_lemma && + rec_lemma' == finfos.rec_lemma && + prop_lemma' == finfos.prop_lemma + then finfos else { function_constant = function_constant'; graph_ind = graph_ind'; @@ -355,25 +355,25 @@ let classify_Function infos = Libobject.Substitute infos let export_Function infos = Some infos -let discharge_Function (_,finfos) = +let discharge_Function (_,finfos) = let function_constant' = Lib.discharge_con finfos.function_constant - and graph_ind' = Lib.discharge_inductive finfos.graph_ind - and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma - and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma - and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma - and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma + and graph_ind' = Lib.discharge_inductive finfos.graph_ind + and equation_lemma' = Option.smartmap Lib.discharge_con finfos.equation_lemma + and correctness_lemma' = Option.smartmap Lib.discharge_con finfos.correctness_lemma + and completeness_lemma' = Option.smartmap Lib.discharge_con finfos.completeness_lemma + and rect_lemma' = Option.smartmap Lib.discharge_con finfos.rect_lemma and rec_lemma' = Option.smartmap Lib.discharge_con finfos.rec_lemma and prop_lemma' = Option.smartmap Lib.discharge_con finfos.prop_lemma in - if function_constant' == finfos.function_constant && - graph_ind' == finfos.graph_ind && + if function_constant' == finfos.function_constant && + graph_ind' == finfos.graph_ind && equation_lemma' == finfos.equation_lemma && - correctness_lemma' == finfos.correctness_lemma && - completeness_lemma' == finfos.completeness_lemma && - rect_lemma' == finfos.rect_lemma && - rec_lemma' == finfos.rec_lemma && - prop_lemma' == finfos.prop_lemma - then Some finfos + correctness_lemma' == finfos.correctness_lemma && + completeness_lemma' == finfos.completeness_lemma && + rect_lemma' == finfos.rect_lemma && + rec_lemma' == finfos.rec_lemma && + prop_lemma' == finfos.prop_lemma + then Some finfos else Some { function_constant = function_constant' ; graph_ind = graph_ind' ; @@ -384,12 +384,12 @@ let discharge_Function (_,finfos) = rec_lemma = rec_lemma'; prop_lemma = prop_lemma' ; is_general = finfos.is_general - } + } open Term -let pr_info f_info = +let pr_info f_info = str "function_constant := " ++ Printer.pr_lconstr (mkConst f_info.function_constant)++ fnl () ++ - str "function_constant_type := " ++ + str "function_constant_type := " ++ (try Printer.pr_lconstr (Global.type_of_global (ConstRef f_info.function_constant)) with _ -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.equation_lemma (mt ()) ) ++ fnl () ++ str "completeness_lemma :=" ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.completeness_lemma (mt ()) ) ++ fnl () ++ @@ -397,15 +397,15 @@ let pr_info f_info = str "rect_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rect_lemma (mt ()) ) ++ fnl () ++ str "rec_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.rec_lemma (mt ()) ) ++ fnl () ++ str "prop_lemma := " ++ (Option.fold_right (fun v acc -> Printer.pr_lconstr (mkConst v)) f_info.prop_lemma (mt ()) ) ++ fnl () ++ - str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () + str "graph_ind := " ++ Printer.pr_lconstr (mkInd f_info.graph_ind) ++ fnl () -let pr_table tb = - let l = Cmap.fold (fun k v acc -> v::acc) tb [] in +let pr_table tb = + let l = Cmap.fold (fun k v acc -> v::acc) tb [] in Util.prlist_with_sep fnl pr_info l -let in_Function,out_Function = +let in_Function,out_Function = Libobject.declare_object - {(Libobject.default_object "FUNCTIONS_DB") with + {(Libobject.default_object "FUNCTIONS_DB") with Libobject.cache_function = cache_Function; Libobject.load_function = load_Function; Libobject.classify_function = classify_Function; @@ -418,57 +418,57 @@ let in_Function,out_Function = (* Synchronisation with reset *) -let freeze () = +let freeze () = !from_function,!from_graph -let unfreeze (functions,graphs) = +let unfreeze (functions,graphs) = (* Pp.msgnl (str "unfreezing function_table : " ++ pr_table l); *) from_function := functions; from_graph := graphs -let init () = +let init () = (* Pp.msgnl (str "reseting function_table"); *) from_function := Cmap.empty; from_graph := Indmap.empty -let _ = +let _ = Summary.declare_summary "functions_db_sum" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } -let find_or_none id = - try Some - (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" - ) +let find_or_none id = + try Some + (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Util.anomaly "Not a constant" + ) with Not_found -> None -let find_Function_infos f = +let find_Function_infos f = Cmap.find f !from_function -let find_Function_of_graph ind = +let find_Function_of_graph ind = Indmap.find ind !from_graph - -let update_Function finfo = + +let update_Function finfo = (* Pp.msgnl (pr_info finfo); *) Lib.add_anonymous_leaf (in_Function finfo) - - -let add_Function is_general f = - let f_id = id_of_label (con_label f) in + + +let add_Function is_general f = + let f_id = id_of_label (con_label f) in let equation_lemma = find_or_none (mk_equation_id f_id) - and correctness_lemma = find_or_none (mk_correct_id f_id) - and completeness_lemma = find_or_none (mk_complete_id f_id) + and correctness_lemma = find_or_none (mk_correct_id f_id) + and completeness_lemma = find_or_none (mk_complete_id f_id) and rect_lemma = find_or_none (Nameops.add_suffix f_id "_rect") and rec_lemma = find_or_none (Nameops.add_suffix f_id "_rec") and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") - and graph_ind = - match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) + and graph_ind = + match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) with | IndRef ind -> ind | _ -> Util.anomaly "Not an inductive" in - let finfos = + let finfos = { function_constant = f; equation_lemma = equation_lemma; completeness_lemma = completeness_lemma; @@ -478,7 +478,7 @@ let add_Function is_general f = prop_lemma = prop_lemma; graph_ind = graph_ind; is_general = is_general - + } in update_Function finfos @@ -486,7 +486,7 @@ let add_Function is_general f = let pr_table () = pr_table !from_function (*********************************) (* Debuging *) -let function_debug = ref false +let function_debug = ref false open Goptions let function_debug_sig = @@ -501,13 +501,13 @@ let function_debug_sig = let _ = declare_bool_option function_debug_sig -let do_observe () = +let do_observe () = !function_debug = true - - - + + + let strict_tcc = ref false -let is_strict_tcc () = !strict_tcc +let is_strict_tcc () = !strict_tcc let strict_tcc_sig = { optsync = false; @@ -520,29 +520,29 @@ let strict_tcc_sig = let _ = declare_bool_option strict_tcc_sig -exception Building_graph of exn +exception Building_graph of exn exception Defining_principle of exn exception ToShow of exn -let init_constant dir s = - try +let init_constant dir s = + try Coqlib.gen_constant "Function" dir s with e -> raise (ToShow e) -let jmeq () = - try - (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; +let jmeq () = + try + (Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq") with e -> raise (ToShow e) -let jmeq_rec () = +let jmeq_rec () = try - Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; + Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_rec" with e -> raise (ToShow e) -let jmeq_refl () = - try +let jmeq_refl () = + try Coqlib.check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_refl" with e -> raise (ToShow e) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index e9aa692b61..87d646ab89 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -1,10 +1,10 @@ open Names open Pp -(* - The mk_?_id function build different name w.r.t. a function - Each of their use is justified in the code -*) +(* + The mk_?_id function build different name w.r.t. a function + Each of their use is justified in the code +*) val mk_rel_id : identifier -> identifier val mk_correct_id : identifier -> identifier val mk_complete_id : identifier -> identifier @@ -16,8 +16,8 @@ val msgnl : std_ppcmds -> unit val invalid_argument : string -> 'a val fresh_id : identifier list -> string -> identifier -val fresh_name : identifier list -> string -> name -val get_name : identifier list -> ?default:string -> name -> name +val fresh_name : identifier list -> string -> name +val get_name : identifier list -> ?default:string -> name -> name val array_get_start : 'a array -> 'a array @@ -46,11 +46,11 @@ val eq : Term.constr Lazy.t val refl_equal : Term.constr Lazy.t val const_of_id: identifier -> constant val jmeq : unit -> Term.constr -val jmeq_refl : unit -> Term.constr +val jmeq_refl : unit -> Term.constr + +(* [save_named] is a copy of [Command.save_named] but uses + [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] -(* [save_named] is a copy of [Command.save_named] but uses - [nf_betaiotazeta] instead of [nf_betaiotaevar_preserving_vm_cast] - DON'T USE IT if you cannot ensure that there is no VMcast in the proof @@ -59,32 +59,32 @@ val jmeq_refl : unit -> Term.constr (* val nf_betaiotazeta : Reductionops.reduction_function *) -val new_save_named : bool -> unit +val new_save_named : bool -> unit -val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> - Tacexpr.declaration_hook -> unit +val save : bool -> identifier -> Entries.definition_entry -> Decl_kinds.goal_kind -> + Tacexpr.declaration_hook -> unit -(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and - abort the proof +(* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and + abort the proof *) -val get_proof_clean : bool -> +val get_proof_clean : bool -> Names.identifier * (Entries.definition_entry * Decl_kinds.goal_kind * Tacexpr.declaration_hook) - -(* [with_full_print f a] applies [f] to [a] in full printing environment - - This function preserves the print settings + +(* [with_full_print f a] applies [f] to [a] in full printing environment + + This function preserves the print settings *) val with_full_print : ('a -> 'b) -> 'a -> 'b (*****************) -type function_info = - { +type function_info = + { function_constant : constant; graph_ind : inductive; equation_lemma : constant option; @@ -101,10 +101,10 @@ val find_Function_of_graph : inductive -> function_info (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> constant -> unit -val update_Function : function_info -> unit +val update_Function : function_info -> unit -(** debugging *) +(** debugging *) val pr_info : function_info -> Pp.std_ppcmds val pr_table : unit -> Pp.std_ppcmds @@ -113,8 +113,8 @@ val pr_table : unit -> Pp.std_ppcmds val do_observe : unit -> bool (* To localize pb *) -exception Building_graph of exn +exception Building_graph of exn exception Defining_principle of exn -exception ToShow of exn +exception ToShow of exn val is_strict_tcc : unit -> bool diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 5f8587408b..116a3c9913 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -22,7 +22,7 @@ open Hiddentac (* Some pretty printing function for debugging purpose *) -let pr_binding prc = +let pr_binding prc = function | loc, Rawterm.NamedHyp id, (_,c) -> hov 1 (Ppconstr.pr_id id ++ str " := " ++ Pp.cut () ++ prc c) | loc, Rawterm.AnonHyp n, (_,c) -> hov 1 (int n ++ str " := " ++ Pp.cut () ++ prc c) @@ -32,7 +32,7 @@ let pr_bindings prc prlc = function brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc (fun (_,c) -> prc c) l | Rawterm.ExplicitBindings l -> - brk (1,1) ++ str "with" ++ brk (1,1) ++ + brk (1,1) ++ str "with" ++ brk (1,1) ++ Util.prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l | Rawterm.NoBindings -> mt () @@ -42,7 +42,7 @@ let pr_with_bindings prc prlc (c,bl) = -let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = +let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = pr_with_bindings prc prc (c,bl) (* The local debuging mechanism *) @@ -61,11 +61,11 @@ let observennl strm = let do_observe_tac s tac g = let goal = begin try (Printer.pr_goal (sig_it g)) with _ -> assert false end in - try + try let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v with e -> - msgnl (str "observation "++ s++str " raised exception " ++ - Cerrors.explain_exn e ++ str " on goal " ++ goal ); + msgnl (str "observation "++ s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); raise e;; @@ -75,117 +75,117 @@ let observe_tac s tac g = else tac g (* [nf_zeta] $\zeta$-normalization of a term *) -let nf_zeta = +let nf_zeta = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) Environ.empty_env Evd.empty (* [id_to_constr id] finds the term associated to [id] in the global environment *) -let id_to_constr id = +let id_to_constr id = try Tacinterp.constr_of_id (Global.env ()) id - with Not_found -> + with Not_found -> raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) -(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] - (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. +(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] + (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. - [generate_type true f i] returns - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, - graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion + [generate_type true f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion - [generate_type false f i] returns - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, - res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion + [generate_type false f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion *) -let generate_type g_to_f f graph i = +let generate_type g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) - let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in - let ctxt,_ = decompose_prod_assum graph_arity in - let fun_ctxt,res_type = - match ctxt with + let graph_arity = Inductive.type_of_inductive (Global.env()) (Global.lookup_inductive (destInd graph)) in + let ctxt,_ = decompose_prod_assum graph_arity in + let fun_ctxt,res_type = + match ctxt with | [] | [_] -> anomaly "Not a valid context" | (_,_,res_type)::fun_ctxt -> fun_ctxt,res_type in let nb_args = List.length fun_ctxt in - let args_from_decl i decl = - match decl with + let args_from_decl i decl = + match decl with | (_,Some _,_) -> incr i; failwith "args_from_decl" - | _ -> let j = !i in incr i;mkRel (nb_args - j + 1) + | _ -> let j = !i in incr i;mkRel (nb_args - j + 1) in (*i We need to name the vars [res] and [fv] i*) - let res_id = - Termops.next_global_ident_away + let res_id = + Termops.next_global_ident_away true (id_of_string "res") (map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "") fun_ctxt) in - let fv_id = - Termops.next_global_ident_away + let fv_id = + Termops.next_global_ident_away true (id_of_string "fv") (res_id::(map_succeed (function (Name id,_,_) -> id | (Anonymous,_,_) -> failwith "Anonymous!") fun_ctxt)) in (*i we can then type the argument to be applied to the function [f] i*) - let args_as_rels = + let args_as_rels = let i = ref 0 in - Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) + Array.of_list ((map_succeed (args_from_decl i) (List.rev fun_ctxt))) in let args_as_rels = Array.map Termops.pop args_as_rels in (*i - the hypothesis [res = fv] can then be computed - We will need to lift it by one in order to use it as a conclusion + the hypothesis [res = fv] can then be computed + We will need to lift it by one in order to use it as a conclusion i*) let res_eq_f_of_args = mkApp(Coqlib.build_coq_eq (),[|lift 2 res_type;mkRel 1;mkRel 2|]) - in - (*i - The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed - We will need to lift it by one in order to use it as a conclusion - i*) - let graph_applied = - let args_and_res_as_rels = + in + (*i + The hypothesis [graph\ x_1\ldots x_n\ res] can then be computed + We will need to lift it by one in order to use it as a conclusion + i*) + let graph_applied = + let args_and_res_as_rels = let i = ref 0 in Array.of_list ((map_succeed (args_from_decl i) (List.rev ((Name res_id,None,res_type)::fun_ctxt))) ) in - let args_and_res_as_rels = + let args_and_res_as_rels = Array.mapi (fun i c -> if i <> Array.length args_and_res_as_rels - 1 then lift 1 c else c) args_and_res_as_rels in - mkApp(graph,args_and_res_as_rels) - in - (*i The [pre_context] is the defined to be the context corresponding to + mkApp(graph,args_and_res_as_rels) + in + (*i The [pre_context] is the defined to be the context corresponding to \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) - let pre_ctxt = - (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt - in + let pre_ctxt = + (Name res_id,None,lift 1 res_type)::(Name fv_id,Some (mkApp(mkConst f,args_as_rels)),res_type)::fun_ctxt + in (*i and we can return the solution depending on which lemma type we are defining i*) - if g_to_f + if g_to_f then (Anonymous,None,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args) else (Anonymous,None,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied) -(* +(* [find_induction_principle f] searches and returns the [body] and the [type] of [f_rect] - + WARNING: while convertible, [type_of body] and [type] can be non equal *) -let find_induction_principle f = - let f_as_constant = match kind_of_term f with +let find_induction_principle f = + let f_as_constant = match kind_of_term f with | Const c' -> c' | _ -> error "Must be used with a function" in - let infos = find_Function_infos f_as_constant in - match infos.rect_lemma with - | None -> raise Not_found - | Some rect_lemma -> - let rect_lemma = mkConst rect_lemma in - let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in + let infos = find_Function_infos f_as_constant in + match infos.rect_lemma with + | None -> raise Not_found + | Some rect_lemma -> + let rect_lemma = mkConst rect_lemma in + let typ = Typing.type_of (Global.env ()) Evd.empty rect_lemma in rect_lemma,typ - - + + (* let fname = *) (* match kind_of_term f with *) @@ -205,41 +205,41 @@ let find_induction_principle f = (* c,Typing.type_of (Global.env ()) Evd.empty c *) -let rec generate_fresh_id x avoid i = - if i == 0 - then [] +let rec generate_fresh_id x avoid i = + if i == 0 + then [] else - let id = Termops.next_global_ident_away true x avoid in + let id = Termops.next_global_ident_away true x avoid in id::(generate_fresh_id x (id::avoid) (pred i)) -(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] - is the tactic used to prove correctness lemma. - +(* [prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i ] + is the tactic used to prove correctness lemma. + [functional_induction] is the tactic defined in [indfun] (dependency problem) [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions - (resp. graphs of the functions and principles and correctness lemma types) to prove correct. - + (resp. graphs of the functions and principles and correctness lemma types) to prove correct. + [i] is the indice of the function to prove correct - The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is it looks like~: - [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] - The sketch of the proof is the following one~: + The sketch of the proof is the following one~: \begin{enumerate} \item intros until $x_n$ \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) - \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the + \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the apply the corresponding constructor of the corresponding graph inductive. \end{enumerate} - + *) let prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos i : tactic = fun g -> - (* first of all we recreate the lemmas types to be used as predicates of the induction principle + (* first of all we recreate the lemmas types to be used as predicates of the induction principle that is~: \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) @@ -257,8 +257,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem in (* we the get the definition of the graphs block *) let graph_ind = destInd graphs_constr.(i) in - let kn = fst graph_ind in - let mib,_ = Global.lookup_inductive graph_ind in + let kn = fst graph_ind in + let mib,_ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in let princ_type = nf_zeta princ_type in @@ -267,9 +267,9 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let nb_fun_args = nb_prod (pf_concl g) - 2 in let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in - (* Since we cannot ensure that the funcitonnal principle is defined in the + (* Since we cannot ensure that the funcitonnal principle is defined in the environement and due to the bug #1174, we will need to pose the principle - using a name + using a name *) let principle_id = Termops.next_global_ident_away true (id_of_string "princ") ids in let ids = principle_id :: ids in @@ -290,8 +290,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let eq_ind = Coqlib.build_coq_eq () in let eq_construct = mkConstruct((destInd eq_ind),1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 - and min_constr_number = ref 0 in + let ind_number = ref 0 + and min_constr_number = ref 0 in (* The tactic to prove the ith branch of the principle *) let prove_branche i g = (* We get the identifiers of this branch *) @@ -317,18 +317,18 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (pre_args, tclTHEN (h_reduce (Rawterm.Unfold([Rawterm.all_occurrences_expr,EvalVarRef id])) allHyps) pre_tac ) - + else (pre_args,pre_tac) ) (pf_hyps g) ([],tclIDTAC) in - (* - We can then recompute the arguments of the constructor. - For each [hid] introduced by this branch, if [hid] has type + (* + We can then recompute the arguments of the constructor. + For each [hid] introduced by this branch, if [hid] has type $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are - [ fv (hid fv (refl_equal fv)) ]. - + [ fv (hid fv (refl_equal fv)) ]. + If [hid] has another type the corresponding argument of the constructor is [hid] *) let constructor_args = @@ -360,21 +360,21 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let params_id = fst (list_chop princ_infos.nparams args_names) in (List.map mkVar params_id)@(List.rev constructor_args) in - (* We then get the constructor corresponding to this branch and - modifies the references has needed i.e. - if the constructor is the last one of the current inductive then - add one the number of the inductive to take and add the number of constructor of the previous - graph to the minimal constructor number + (* We then get the constructor corresponding to this branch and + modifies the references has needed i.e. + if the constructor is the last one of the current inductive then + add one the number of the inductive to take and add the number of constructor of the previous + graph to the minimal constructor number *) - let constructor = - let constructor_num = i - !min_constr_number in - let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in + let constructor = + let constructor_num = i - !min_constr_number in + let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in if constructor_num <= length - then - begin + then + begin (kn,!ind_number),constructor_num end - else + else begin incr ind_number; min_constr_number := !min_constr_number + length ; @@ -418,8 +418,8 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let param_names = fst (list_chop princ_infos.nparams args_names) in let params = List.map mkVar param_names in let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in - (* The bindings of the principle - that is the params of the principle and the different lemma types + (* The bindings of the principle + that is the params of the principle and the different lemma types *) let bindings = let params_bindings,avoid = @@ -435,7 +435,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem let lemmas_bindings = List.rev (fst (List.fold_left2 (fun (bindings,avoid) (x,_,_) p -> - let id = Nameops.next_ident_away (Nameops.out_name x) avoid in + let id = Nameops.next_ident_away (Nameops.out_name x) avoid in (dummy_loc,Rawterm.NamedHyp id,inj_open (nf_zeta p))::bindings,id::avoid) ([],avoid) princ_infos.predicates @@ -451,7 +451,7 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem (h_exact f_principle)); tclTHEN_i (observe_tac "functional_induction" ( - fun g -> + fun g -> observe (pr_constr_with_binding (Printer.pr_lconstr_env (pf_env g)) (mkVar principle_id,bindings)); functional_induction false (applist(funs_constr.(i),List.map mkVar args_names)) @@ -462,13 +462,13 @@ let prove_fun_correct functional_induction funs_constr graphs_constr schemes lem ] g -(* [generalize_dependent_of x hyp g] - generalize every hypothesis which depends of [x] but [hyp] +(* [generalize_dependent_of x hyp g] + generalize every hypothesis which depends of [x] but [hyp] *) -let generalize_dependent_of x hyp g = - tclMAP - (function - | (id,None,t) when not (id = hyp) && +let generalize_dependent_of x hyp g = + tclMAP + (function + | (id,None,t) when not (id = hyp) && (Termops.occur_var (pf_env g) x t) -> tclTHEN (h_generalize [mkVar id]) (thin [id]) | _ -> tclIDTAC ) @@ -479,86 +479,86 @@ let generalize_dependent_of x hyp g = - (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis + (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis (unfolding, substituting, destructing cases \ldots) *) -let rec intros_with_rewrite g = +let rec intros_with_rewrite g = observe_tac "intros_with_rewrite" intros_with_rewrite_aux g -and intros_with_rewrite_aux : tactic = - fun g -> - let eq_ind = Coqlib.build_coq_eq () in - match kind_of_term (pf_concl g) with - | Prod(_,t,t') -> - begin - match kind_of_term t with - | App(eq,args) when (eq_constr eq eq_ind) -> +and intros_with_rewrite_aux : tactic = + fun g -> + let eq_ind = Coqlib.build_coq_eq () in + match kind_of_term (pf_concl g) with + | Prod(_,t,t') -> + begin + match kind_of_term t with + | App(eq,args) when (eq_constr eq eq_ind) -> if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ [ h_intro id; thin [id]; intros_with_rewrite ] g else if isVar args.(1) - then - let id = pf_get_new_id (id_of_string "y") g in + then + let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ [ h_intro id; - generalize_dependent_of (destVar args.(1)) id; + generalize_dependent_of (destVar args.(1)) id; tclTRY (Equality.rewriteLR (mkVar id)); intros_with_rewrite - ] + ] g else - begin - let id = pf_get_new_id (id_of_string "y") g in + begin + let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ[ h_intro id; tclTRY (Equality.rewriteLR (mkVar id)); intros_with_rewrite ] g end - | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> + | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> Tauto.tauto g - | Case(_,_,v,_) -> + | Case(_,_,v,_) -> tclTHENSEQ[ h_case false (v,Rawterm.NoBindings); intros_with_rewrite ] g - | LetIn _ -> + | LetIn _ -> tclTHENSEQ[ - h_reduce + h_reduce (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) onConcl ; intros_with_rewrite ] g - | _ -> - let id = pf_get_new_id (id_of_string "y") g in + | _ -> + let id = pf_get_new_id (id_of_string "y") g in tclTHENSEQ [ h_intro id;intros_with_rewrite] g end - | LetIn _ -> + | LetIn _ -> tclTHENSEQ[ - h_reduce + h_reduce (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) onConcl ; intros_with_rewrite ] g - | _ -> tclIDTAC g - -let rec reflexivity_with_destruct_cases g = - let destruct_case () = - try - match kind_of_term (snd (destApp (pf_concl g))).(2) with - | Case(_,_,v,_) -> + | _ -> tclIDTAC g + +let rec reflexivity_with_destruct_cases g = + let destruct_case () = + try + match kind_of_term (snd (destApp (pf_concl g))).(2) with + | Case(_,_,v,_) -> tclTHENSEQ[ h_case false (v,Rawterm.NoBindings); intros; - observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases + observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] | _ -> reflexivity with _ -> reflexivity @@ -566,13 +566,13 @@ let rec reflexivity_with_destruct_cases g = let eq_ind = Coqlib.build_coq_eq () in let discr_inject = Tacticals.onAllHypsAndConcl ( - fun sc g -> - match sc with + fun sc g -> + match sc with None -> tclIDTAC g - | Some id -> - match kind_of_term (pf_type_of g (mkVar id)) with - | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) t1 t2 + | Some id -> + match kind_of_term (pf_type_of g (mkVar id)) with + | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> + if Equality.discriminable (pf_env g) (project g) t1 t2 then Equality.discrHyp id g else if Equality.injectable (pf_env g) (project g) t1 t2 then tclTHENSEQ [Equality.injHyp id;thin [id];intros_with_rewrite] g @@ -583,10 +583,10 @@ let rec reflexivity_with_destruct_cases g = (tclFIRST [ reflexivity; tclTHEN (tclPROGRESS discr_inject) (destruct_case ()); - (* We reach this point ONLY if - the same value is matched (at least) two times + (* We reach this point ONLY if + the same value is matched (at least) two times along binding path. - In this case, either we have a discriminable hypothesis and we are done, + In this case, either we have a discriminable hypothesis and we are done, either at least an injectable one and we do the injection before continuing *) tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases @@ -594,95 +594,95 @@ let rec reflexivity_with_destruct_cases g = g -(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] - is the tactic used to prove completness lemma. - +(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] + is the tactic used to prove completness lemma. + [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions - (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. - + (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. + [i] is the indice of the function to prove complete - The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is it looks like~: - [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] - The sketch of the proof is the following one~: + The sketch of the proof is the following one~: \begin{enumerate} \item intros until $H:graph\ x_1\ldots x_n\ res$ \item $elim\ H$ using schemes.(i) - \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has - type [x=?] with [x] a variable, then subst [x], - if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else - if [h] is a match then destruct it, else do just introduce it, + \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has + type [x=?] with [x] a variable, then subst [x], + if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else + if [h] is a match then destruct it, else do just introduce it, after all intros, the conclusion should be a reflexive equality. \end{enumerate} - + *) -let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = - fun g -> - (* We compute the types of the different mutually recursive lemmas +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = + fun g -> + (* We compute the types of the different mutually recursive lemmas in $\zeta$ normal form *) - let lemmas = - Array.map - (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) + let lemmas = + Array.map + (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn ~init:concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = nf_zeta schemes.(i) in - let princ_type = pf_type_of g graph_principle in - let princ_infos = Tactics.compute_elim_sig princ_type in - (* Then we get the number of argument of the function + let graph_principle = nf_zeta schemes.(i) in + let princ_type = pf_type_of g graph_principle in + let princ_infos = Tactics.compute_elim_sig princ_type in + (* Then we get the number of argument of the function and compute a fresh name for each of them *) - let nb_fun_args = nb_prod (pf_concl g) - 2 in + let nb_fun_args = nb_prod (pf_concl g) - 2 in let args_names = generate_fresh_id (id_of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res,hres,graph_principle_id = - match generate_fresh_id (id_of_string "z") ids 3 with + let res,hres,graph_principle_id = + match generate_fresh_id (id_of_string "z") ids 3 with | [res;hres;graph_principle_id] -> res,hres,graph_principle_id - | _ -> assert false + | _ -> assert false in - let ids = res::hres::graph_principle_id::ids in + let ids = res::hres::graph_principle_id::ids in (* we also compute fresh names for each hyptohesis of each branche of the principle *) - let branches = List.rev princ_infos.branches in - let intro_pats = - List.map - (fun (_,_,br_type) -> - List.map - (fun id -> id) + let branches = List.rev princ_infos.branches in + let intro_pats = + List.map + (fun (_,_,br_type) -> + List.map + (fun id -> id) (generate_fresh_id (id_of_string "y") ids (nb_prod br_type)) ) branches in - (* We will need to change the function by its body - using [f_equation] if it is recursive (that is the graph is infinite - or unfold if the graph is finite + (* We will need to change the function by its body + using [f_equation] if it is recursive (that is the graph is infinite + or unfold if the graph is finite *) - let rewrite_tac j ids : tactic = - let graph_def = graphs.(j) in - let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in + let rewrite_tac j ids : tactic = + let graph_def = graphs.(j) in + let infos = try find_Function_infos (destConst funcs.(j)) with Not_found -> error "No graph found" in if infos.is_general || Rtree.is_infinite graph_def.mind_recargs - then - let eq_lemma = + then + let eq_lemma = try Option.get (infos).equation_lemma with Option.IsNone -> anomaly "Cannot find equation lemma" - in + in tclTHENSEQ[ tclMAP h_intro ids; Equality.rewriteLR (mkConst eq_lemma); (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) - h_reduce + h_reduce (Rawterm.Cbv - {Rawterm.all_flags - with Rawterm.rDelta = false; - }) + {Rawterm.all_flags + with Rawterm.rDelta = false; + }) onConcl ; h_generalize (List.map mkVar ids); @@ -691,16 +691,16 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = else unfold_in_concl [(all_occurrences,Names.EvalConstRef (destConst f))] in (* The proof of each branche itself *) - let ind_number = ref 0 in + let ind_number = ref 0 in let min_constr_number = ref 0 in - let prove_branche i g = + let prove_branche i g = (* we fist compute the inductive corresponding to the branch *) - let this_ind_number = - let constructor_num = i - !min_constr_number in - let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in + let this_ind_number = + let constructor_num = i - !min_constr_number in + let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in if constructor_num <= length then !ind_number - else + else begin incr ind_number; min_constr_number := !min_constr_number + length; @@ -719,13 +719,13 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = g in let params_names = fst (list_chop princ_infos.nparams args_names) in - let params = List.map mkVar params_names in - tclTHENSEQ + let params = List.map mkVar params_names in + tclTHENSEQ [ tclMAP h_intro (args_names@[res;hres]); - observe_tac "h_generalize" + observe_tac "h_generalize" (h_generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)]); h_intro graph_principle_id; - observe_tac "" (tclTHEN_i + observe_tac "" (tclTHEN_i (observe_tac "elim" ((elim false (mkVar hres,Rawterm.NoBindings) (Some (mkVar graph_principle_id,Rawterm.NoBindings))))) (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] @@ -737,94 +737,94 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let do_save () = Command.save_named false -(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness +(* [derive_correctness make_scheme functional_induction funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] - - [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and - [functional_induction] is Indfun.functional_induction (same pb) + + [make_scheme] is Functional_principle_types.make_scheme (dependency pb) and + [functional_induction] is Indfun.functional_induction (same pb) *) - -let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = + +let derive_correctness make_scheme functional_induction (funs: constant list) (graphs:inductive list) = let funs = Array.of_list funs and graphs = Array.of_list graphs in let funs_constr = Array.map mkConst funs in - try - let graphs_constr = Array.map mkInd graphs in - let lemmas_types_infos = - Util.array_map2_i - (fun i f_constr graph -> - let const_of_f = destConst f_constr in - let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = + try + let graphs_constr = Array.map mkInd graphs in + let lemmas_types_infos = + Util.array_map2_i + (fun i f_constr graph -> + let const_of_f = destConst f_constr in + let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type false const_of_f graph i - in - let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in + in + let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info ) funs_constr - graphs_constr + graphs_constr in - let schemes = - (* The functional induction schemes are computed and not saved if there is more that one function + let schemes = + (* The functional induction schemes are computed and not saved if there is more that one function if the block contains only one function we can safely reuse [f_rect] *) try if Array.length funs_constr <> 1 then raise Not_found; [| find_induction_principle funs_constr.(0) |] - with Not_found -> - Array.of_list - (List.map - (fun entry -> + with Not_found -> + Array.of_list + (List.map + (fun entry -> (entry.Entries.const_entry_body, Option.get entry.Entries.const_entry_type ) ) (make_scheme (array_map_to_list (fun const -> const,Rawterm.RType None) funs)) ) in - let proving_tac = + let proving_tac = prove_fun_correct functional_induction funs_constr graphs_constr schemes lemmas_types_infos in - Array.iteri - (fun i f_as_constant -> + Array.iteri + (fun i f_as_constant -> let f_id = id_of_label (con_label f_as_constant) in - Command.start_proof + Command.start_proof (*i The next call to mk_correct_id is valid since we are constructing the lemma Ensures by: obvious - i*) + i*) (mk_correct_id f_id) (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); Pfedit.by (observe_tac ("prove correctness ("^(string_of_id f_id)^")") (proving_tac i)); do_save (); - let finfo = find_Function_infos f_as_constant in + let finfo = find_Function_infos f_as_constant in update_Function - {finfo with + {finfo with correctness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_correct_id f_id))) } ) funs; - let lemmas_types_infos = - Util.array_map2_i - (fun i f_constr graph -> - let const_of_f = destConst f_constr in - let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = + let lemmas_types_infos = + Util.array_map2_i + (fun i f_constr graph -> + let const_of_f = destConst f_constr in + let (type_of_lemma_ctxt,type_of_lemma_concl) as type_info = generate_type true const_of_f graph i - in - let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in + in + let type_of_lemma = Termops.it_mkProd_or_LetIn ~init:type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info ) funs_constr - graphs_constr + graphs_constr in - let kn,_ as graph_ind = destInd graphs_constr.(0) in + let kn,_ as graph_ind = destInd graphs_constr.(0) in let mib,mip = Global.lookup_inductive graph_ind in - let schemes = - Array.of_list + let schemes = + Array.of_list (Indrec.build_mutual_indrec (Global.env ()) Evd.empty - (Array.to_list + (Array.to_list (Array.mapi (fun i mip -> (kn,i),mib,mip,true,InType) mib.Declarations.mind_packets @@ -832,25 +832,25 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g ) ) in - let proving_tac = + let proving_tac = prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos in - Array.iteri - (fun i f_as_constant -> + Array.iteri + (fun i f_as_constant -> let f_id = id_of_label (con_label f_as_constant) in - Command.start_proof + Command.start_proof (*i The next call to mk_complete_id is valid since we are constructing the lemma Ensures by: obvious - i*) + i*) (mk_complete_id f_id) (Decl_kinds.Global,(Decl_kinds.Proof Decl_kinds.Theorem)) (fst lemmas_types_infos.(i)) (fun _ _ -> ()); Pfedit.by (observe_tac ("prove completeness ("^(string_of_id f_id)^")") (proving_tac i)); do_save (); - let finfo = find_Function_infos f_as_constant in + let finfo = find_Function_infos f_as_constant in update_Function - {finfo with + {finfo with completeness_lemma = Some (destConst (Tacinterp.constr_of_id (Global.env ())(mk_complete_id f_id))) } ) @@ -859,16 +859,16 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g (* In case of problem, we reset all the lemmas *) (*i The next call to mk_correct_id is valid since we are erasing the lemmas Ensures by: obvious - i*) - let first_lemma_id = - let f_id = id_of_label (con_label funs.(0)) in - - mk_correct_id f_id + i*) + let first_lemma_id = + let f_id = id_of_label (con_label funs.(0)) in + + mk_correct_id f_id in ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,first_lemma_id) with _ -> ()); raise e - - + + @@ -876,73 +876,73 @@ let derive_correctness make_scheme functional_induction (funs: constant list) (g (* [revert_graph kn post_tac hid] transforme an hypothesis [hid] having type Ind(kn,num) t1 ... tn res when [kn] denotes a graph block into - f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result - + f_num t1... tn = res (by applying [f_complete] to the first type) before apply post_tac on the result + if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) let revert_graph kn post_tac hid g = - let typ = pf_type_of g (mkVar hid) in - match kind_of_term typ with - | App(i,args) when isInd i -> - let ((kn',num) as ind') = destInd i in - if kn = kn' + let typ = pf_type_of g (mkVar hid) in + match kind_of_term typ with + | App(i,args) when isInd i -> + let ((kn',num) as ind') = destInd i in + if kn = kn' then (* We have generated a graph hypothesis so that we must change it if we can *) - let info = + let info = try find_Function_of_graph ind' with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) anomaly "Cannot retrieve infos about a mutual block" - in - (* if we can find a completeness lemma for this function - then we can come back to the functional form. If not, we do nothing + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing *) - match info.completeness_lemma with + match info.completeness_lemma with | None -> tclIDTAC g - | Some f_complete -> + | Some f_complete -> let f_args,res = array_chop (Array.length args - 1) args in tclTHENSEQ [ h_generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]; thin [hid]; - h_intro hid; + h_intro hid; post_tac hid ] g - + else tclIDTAC g | _ -> tclIDTAC g -(* +(* [functional_inversion hid fconst f_correct ] is the functional version of [inversion] - + [hid] is the hypothesis to invert, [fconst] is the function to invert and [f_correct] is the correctness lemma for [fconst]. - The sketch is the follwing~: - \begin{enumerate} - \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ + The sketch is the follwing~: + \begin{enumerate} + \item Transforms the hypothesis [hid] such that its type is now $res\ =\ f\ t_1 \ldots t_n$ (fails if it is not possible) \item replace [hid] with $R\_f t_1 \ldots t_n res$ using [f_correct] \item apply [inversion] on [hid] - \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever + \item finally in each branch, replace each hypothesis [R\_f ..] by [f ...] using [f_complete] (whenever such a lemma exists) \end{enumerate} *) - -let functional_inversion kn hid fconst f_correct : tactic = - fun g -> - let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in - let type_of_h = pf_type_of g (mkVar hid) in - match kind_of_term type_of_h with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> - let pre_tac,f_args,res = - match kind_of_term args.(1),kind_of_term args.(2) with - | App(f,f_args),_ when eq_constr f fconst -> + +let functional_inversion kn hid fconst f_correct : tactic = + fun g -> + let old_ids = List.fold_right Idset.add (pf_ids_of_hyps g) Idset.empty in + let type_of_h = pf_type_of g (mkVar hid) in + match kind_of_term type_of_h with + | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + let pre_tac,f_args,res = + match kind_of_term args.(1),kind_of_term args.(2) with + | App(f,f_args),_ when eq_constr f fconst -> ((fun hid -> h_symmetry (onHyp hid)),f_args,args.(2)) - |_,App(f,f_args) when eq_constr f fconst -> - ((fun hid -> tclIDTAC),f_args,args.(1)) + |_,App(f,f_args) when eq_constr f fconst -> + ((fun hid -> tclIDTAC),f_args,args.(1)) | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) - in + in tclTHENSEQ[ pre_tac hid; h_generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]; @@ -950,7 +950,7 @@ let functional_inversion kn hid fconst f_correct : tactic = h_intro hid; Inv.inv FullInversion None (Rawterm.NamedHyp hid); (fun g -> - let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in + let new_ids = List.filter (fun id -> not (Idset.mem id old_ids)) (pf_ids_of_hyps g) in tclMAP (revert_graph kn pre_tac) (hid::new_ids) g ); ] g @@ -958,62 +958,62 @@ let functional_inversion kn hid fconst f_correct : tactic = -let invfun qhyp f = - let f = - match f with - | ConstRef f -> f +let invfun qhyp f = + let f = + match f with + | ConstRef f -> f | _ -> raise (Util.UserError("",str "Not a function")) in - try - let finfos = find_Function_infos f in - let f_correct = mkConst(Option.get finfos.correctness_lemma) + try + let finfos = find_Function_infos f in + let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in - Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp - with - | Not_found -> error "No graph found" + Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp + with + | Not_found -> error "No graph found" | Option.IsNone -> error "Cannot use equivalence with graph!" -let invfun qhyp f g = - match f with +let invfun qhyp f g = + match f with | Some f -> invfun qhyp f g - | None -> - Tactics.try_intros_until - (fun hid g -> - let hyp_typ = pf_type_of g (mkVar hid) in - match kind_of_term hyp_typ with - | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> + | None -> + Tactics.try_intros_until + (fun hid g -> + let hyp_typ = pf_type_of g (mkVar hid) in + match kind_of_term hyp_typ with + | App(eq,args) when eq_constr eq (Coqlib.build_coq_eq ()) -> begin - let f1,_ = decompose_app args.(1) in - try + let f1,_ = decompose_app args.(1) in + try if not (isConst f1) then failwith ""; - let finfos = find_Function_infos (destConst f1) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) + let finfos = find_Function_infos (destConst f1) in + let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f1 f_correct g - with | Failure "" | Option.IsNone | Not_found -> - try - let f2,_ = decompose_app args.(2) in + with | Failure "" | Option.IsNone | Not_found -> + try + let f2,_ = decompose_app args.(2) in if not (isConst f2) then failwith ""; - let finfos = find_Function_infos (destConst f2) in - let f_correct = mkConst(Option.get finfos.correctness_lemma) + let finfos = find_Function_infos (destConst f2) in + let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f2 f_correct g with - | Failure "" -> + | Failure "" -> errorlabstrm "" (str "Hypothesis" ++ Ppconstr.pr_id hid ++ str " must contain at leat one Function") - | Option.IsNone -> - if do_observe () + | Option.IsNone -> + if do_observe () then error "Cannot use equivalence with graph for any side of the equality" else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Not_found -> - if do_observe () + | Not_found -> + if do_observe () then - error "No graph found for any side of equality" + error "No graph found for any side of equality" else errorlabstrm "" (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) end | _ -> errorlabstrm "" (Ppconstr.pr_id hid ++ str " must be an equality ") diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 092830025b..3538f63426 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -18,7 +18,7 @@ open Vernacexpr open Pp open Names open Term -open Termops +open Termops open Declarations open Environ open Rawterm @@ -32,19 +32,19 @@ let rec popn i c = if i<=0 then c else pop (popn (i-1) c) (** Substitutions in constr *) let compare_constr_nosub t1 t2 = - if compare_constr (fun _ _ -> false) t1 t2 + if compare_constr (fun _ _ -> false) t1 t2 then true else false let rec compare_constr' t1 t2 = - if compare_constr_nosub t1 t2 + if compare_constr_nosub t1 t2 then true else (compare_constr (compare_constr') t1 t2) let rec substitterm prof t by_t in_u = if (compare_constr' (lift prof t) in_u) then (lift prof by_t) - else map_constr_with_binders succ + else map_constr_with_binders succ (fun i -> substitterm i t by_t) prof in_u let lift_ldecl n ldecl = List.map (fun (x,y) -> x,lift n y) ldecl @@ -59,23 +59,23 @@ let name_of_string str = Name (id_of_string str) let string_of_name nme = string_of_id (id_of_name nme) (** [isVarf f x] returns [true] if term [x] is of the form [(Var f)]. *) -let isVarf f x = +let isVarf f x = match x with - | RVar (_,x) -> Pervasives.compare x f = 0 + | RVar (_,x) -> Pervasives.compare x f = 0 | _ -> false (** [ident_global_exist id] returns true if identifier [id] is linked in global environment. *) -let ident_global_exist id = - try +let ident_global_exist id = + try let ans = CRef (Libnames.Ident (dummy_loc,id)) in let _ = ignore (Constrintern.intern_constr Evd.empty (Global.env()) ans) in true - with _ -> false + with _ -> false (** [next_ident_fresh id] returns a fresh identifier (ie not linked in global env) with base [id]. *) -let next_ident_fresh (id:identifier) = +let next_ident_fresh (id:identifier) = let res = ref id in while ident_global_exist !res do res := Nameops.lift_ident !res done; !res @@ -89,37 +89,37 @@ let prconstr c = msg (str" " ++ Printer.pr_lconstr c) let prconstrnl c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") let prlistconstr lc = List.iter prconstr lc let prstr s = msg(str s) -let prNamedConstr s c = +let prNamedConstr s c = begin msg(str ""); msg(str(s^" {§ ") ++ Printer.pr_lconstr c ++ str " §} "); msg(str ""); end -let prNamedRConstr s c = +let prNamedRConstr s c = begin msg(str ""); msg(str(s^" {§ ") ++ Printer.pr_rawconstr c ++ str " §} "); msg(str ""); end let prNamedLConstr_aux lc = List.iter (prNamedConstr "\n") lc -let prNamedLConstr s lc = +let prNamedLConstr s lc = begin prstr "[§§§ "; prstr s; prNamedLConstr_aux lc; prstr " §§§]\n"; end -let prNamedLDecl s lc = +let prNamedLDecl s lc = begin prstr s; prstr "\n"; List.iter (fun (nm,_,tp) -> prNamedConstr (string_of_name nm) tp) lc; prstr "\n"; end -let prNamedRLDecl s lc = +let prNamedRLDecl s lc = begin prstr s; prstr "\n"; prstr "{§§ "; - List.iter - (fun x -> + List.iter + (fun x -> match x with | (nm,None,Some tp) -> prNamedRConstr (string_of_name nm) tp | (nm,Some bdy,None) -> prNamedRConstr ("(letin) "^string_of_name nm) bdy @@ -133,16 +133,16 @@ let showind (id:identifier) = let cstrid = Tacinterp.constr_of_id (Global.env()) id in let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in - List.iter (fun (nm, optcstr, tp) -> + List.iter (fun (nm, optcstr, tp) -> print_string (string_of_name nm^":"); - prconstr tp; print_string "\n") + prconstr tp; print_string "\n") ib1.mind_arity_ctxt; (match ib1.mind_arity with | Monomorphic x -> Printf.printf "arity :"; prconstr x.mind_user_arity - | Polymorphic x -> + | Polymorphic x -> Printf.printf "arity : universe?"); - Array.iteri + Array.iteri (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) ib1.mind_user_lc @@ -151,7 +151,7 @@ let showind (id:identifier) = exception Found of int (* Array scanning *) -let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option = +let array_find (arr: 'a array) (pred: int -> 'a -> bool): int option = try for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done; None @@ -163,10 +163,10 @@ let array_prfx (arr: 'a array) (pred: int -> 'a -> bool): int = Array.length arr (* all elt are positive *) with Found i -> i -let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = - let i = ref 0 in - Array.fold_left - (fun acc x -> +let array_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b array): 'a = + let i = ref 0 in + Array.fold_left + (fun acc x -> let res = f !i acc x in i := !i + 1; res) acc arr @@ -176,25 +176,25 @@ let list_chop_end i l = if size_prefix < 0 then failwith "list_chop_end" else list_chop size_prefix l -let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = - let i = ref 0 in - List.fold_left - (fun acc x -> +let list_fold_lefti (f: int -> 'a -> 'b -> 'a) (acc:'a) (arr:'b list): 'a = + let i = ref 0 in + List.fold_left + (fun acc x -> let res = f !i acc x in i := !i + 1; res) acc arr -let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = - let i = ref 0 in +let list_filteri (f: int -> 'a -> bool) (l:'a list):'a list = + let i = ref 0 in List.filter (fun x -> let res = f !i x in i := !i + 1; res) l (** Iteration module *) -module For = +module For = struct let rec map i j (f: int -> 'a) = if i>j then [] else f i :: (map (i+1) j f) - let rec foldup i j (f: 'a -> int -> 'a) acc = + let rec foldup i j (f: 'a -> int -> 'a) acc = if i>j then acc else let newacc = f acc i in foldup (i+1) j f newacc - let rec folddown i j (f: 'a -> int -> 'a) acc = + let rec folddown i j (f: 'a -> int -> 'a) acc = if i>j then acc else let newacc = f acc j in folddown i (j-1) f newacc let fold i j = if i Printf.sprintf "Unlinked" | Funres -> Printf.sprintf "Funres" -let linkmonad f lnkvar = +let linkmonad f lnkvar = match lnkvar with | Linked i -> Linked (f i) | Unlinked -> Unlinked @@ -242,7 +242,7 @@ let linklift lnkvar i = linkmonad (fun x -> x+i) lnkvar (* This map is used to deal with debruijn linked indices. *) module Link = Map.Make (struct type t = int let compare = Pervasives.compare end) -let pr_links l = +let pr_links l = Printf.printf "links:\n"; Link.iter (fun k e -> Printf.printf "%d : %s\n" k (prlinked e)) l; Printf.printf "_____________\n" @@ -255,16 +255,16 @@ type 'a merged_arg = | Arg_linked of 'a | Arg_funres -(** Information about graph merging of two inductives. +(** Information about graph merging of two inductives. All rel_decl list are IN REVERSE ORDER (ie well suited for compose) *) type merge_infos = { ident:identifier; (** new inductive name *) mib1: mutual_inductive_body; - oib1: one_inductive_body; + oib1: one_inductive_body; mib2: mutual_inductive_body; - oib2: one_inductive_body; + oib2: one_inductive_body; (** Array of links of the first inductive (should be all stable) *) lnk1: int merged_arg array; @@ -275,24 +275,24 @@ type merge_infos = (** rec params which remain rec param (ie not linked) *) recprms1: rel_declaration list; recprms2: rel_declaration list; - nrecprms1: int; + nrecprms1: int; nrecprms2: int; (** rec parms which became non parm (either linked to something or because after a rec parm that became non parm) *) - otherprms1: rel_declaration list; - otherprms2: rel_declaration list; - notherprms1:int; + otherprms1: rel_declaration list; + otherprms2: rel_declaration list; + notherprms1:int; notherprms2:int; (** args which remain args in merge *) - args1:rel_declaration list; + args1:rel_declaration list; args2:rel_declaration list; nargs1:int; nargs2:int; (** functional result args *) - funresprms1: rel_declaration list; + funresprms1: rel_declaration list; funresprms2: rel_declaration list; nfunresprms1:int; nfunresprms2:int; @@ -301,7 +301,7 @@ type merge_infos = let pr_merginfo x = let i,s= - match x with + match x with | Prm_linked i -> Some i,"Prm_linked" | Arg_linked i -> Some i,"Arg_linked" | Prm_stable i -> Some i,"Prm_stable" @@ -317,7 +317,7 @@ let isPrm_stable x = match x with Prm_stable _ -> true | _ -> false (* ?? prm_linked?? *) let isArg_stable x = match x with Arg_stable _ | Prm_arg _ -> true | _ -> false -let is_stable x = +let is_stable x = match x with Arg_stable _ | Prm_stable _ | Prm_arg _ -> true | _ -> false let isArg_funres x = match x with Arg_funres -> true | _ -> false @@ -332,22 +332,22 @@ let filter_shift_stable (lnk:int merged_arg array) (l:'a list): 'a list = of int as several vars may be linked to the same var. *) let revlinked lnk = For.fold 0 (Array.length lnk - 1) - (fun acc k -> - match lnk.(k) with - | Unlinked | Funres -> acc - | Linked i -> + (fun acc k -> + match lnk.(k) with + | Unlinked | Funres -> acc + | Linked i -> let old = try Link.find i acc with Not_found -> [] in Link.add i (k::old) acc) Link.empty -let array_switch arr i j = +let array_switch arr i j = let aux = arr.(j) in arr.(j) <- arr.(i); arr.(i) <- aux let filter_shift_stable_right (lnk:int merged_arg array) (l:'a list): 'a list = let larr = Array.of_list l in let _ = Array.iteri - (fun j x -> + (fun j x -> match x with | Prm_linked i -> array_switch larr i j | Arg_linked i -> array_switch larr i j @@ -392,7 +392,7 @@ let build_raw_params prms_decl avoid = let ids_of_rawlist avoid rawl = List.fold_left Idset.union avoid (List.map ids_of_rawterm rawl) - + (** {1 Merging function graphs} *) @@ -402,7 +402,7 @@ let ids_of_rawlist avoid rawl = remain uniform when linked by [lnk]. All parameters are considered, ie we take parameters of the first inductive body of [mib1] and [mib2]. - + Explanation: The two inductives have parameters, some of the first are recursively uniform, some of the last are functional result of the functional graph. @@ -418,14 +418,14 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array let linked_targets = revlinked lnk2 in let is_param_of_mib1 x = x < mib1.mind_nparams_rec in let is_param_of_mib2 x = x < mib2.mind_nparams_rec in - let is_targetted_by_non_recparam_lnk1 i = - try - let targets = Link.find i linked_targets in + let is_targetted_by_non_recparam_lnk1 i = + try + let targets = Link.find i linked_targets in List.exists (fun x -> not (is_param_of_mib2 x)) targets with Not_found -> false in - let mlnk1 = + let mlnk1 = Array.mapi - (fun i lkv -> + (fun i lkv -> let isprm = is_param_of_mib1 i in let prmlost = is_targetted_by_non_recparam_lnk1 i in match isprm , prmlost, lnk1.(i) with @@ -435,13 +435,13 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array | _ , _ , Funres -> assert false (* fun res cannot be a rec param or lost *) | false , _ , _ -> Arg_stable i) (* Args of lnk1 are not linked *) lnk1 in - let mlnk2 = + let mlnk2 = Array.mapi - (fun i lkv -> + (fun i lkv -> (* Is this correct if some param of ind2 is lost? *) let isprm = is_param_of_mib2 i in match isprm , lnk2.(i) with - | true , Linked j when not (is_param_of_mib1 j) -> + | true , Linked j when not (is_param_of_mib1 j) -> Prm_arg j (* recparam becoming ordinary *) | true , Linked j -> Prm_linked j (*recparam linked to recparam*) | true , Unlinked -> Prm_stable i (* recparam remains recparam*) @@ -456,9 +456,9 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array (* count params remaining params *) let n_params1 = array_prfx mlnk1 (fun i x -> not (isPrm_stable x)) in let n_params2 = array_prfx mlnk2 (fun i x -> not (isPrm_stable x)) in - let bldprms arity_ctxt mlnk = + let bldprms arity_ctxt mlnk = list_fold_lefti - (fun i (acc1,acc2,acc3,acc4) x -> + (fun i (acc1,acc2,acc3,acc4) x -> prstr (pr_merginfo mlnk.(i));prstr "\n"; match mlnk.(i) with | Prm_stable _ -> x::acc1 , acc2 , acc3, acc4 @@ -467,19 +467,19 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array | Arg_funres -> acc1 , acc2 , acc3, x::acc4 | _ -> acc1 , acc2 , acc3, acc4) ([],[],[],[]) arity_ctxt in -(* let arity_ctxt2 = - build_raw_params oib2.mind_arity_ctxt +(* let arity_ctxt2 = + build_raw_params oib2.mind_arity_ctxt (Idset.elements (ids_of_rawterm oib1.mind_arity_ctxt)) in*) let recprms1,otherprms1,args1,funresprms1 = bldprms (List.rev oib1.mind_arity_ctxt) mlnk1 in let _ = prstr "\n\n\n" in let recprms2,otherprms2,args2,funresprms2 = bldprms (List.rev oib2.mind_arity_ctxt) mlnk2 in let _ = prstr "\notherprms1:\n" in - let _ = - List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") + let _ = + List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") otherprms1 in let _ = prstr "\notherprms2:\n" in - let _ = - List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") + let _ = + List.iter (fun (x,_,y) -> prstr (string_of_name x^" : ");prconstr y;prstr "\n") otherprms2 in { ident=id; @@ -514,38 +514,38 @@ let shift_linked_params mib1 mib2 (lnk1:linked_var array) (lnk2:linked_var array exception NoMerge -let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = +let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with - | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> + | RApp(_,f1, arr1), RApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> let _ = prstr "\nICI1!\n";Pp.flush_all() in let args = filter_shift_stable lnk (arr1 @ arr2) in RApp (dummy_loc,RVar (dummy_loc,shift.ident) , args) | RApp(_,f1, arr1), RApp(_,f2,arr2) -> raise NoMerge - | RLetIn(_,nme,bdy,trm) , _ -> - let _ = prstr "\nICI2!\n";Pp.flush_all() in + | RLetIn(_,nme,bdy,trm) , _ -> + let _ = prstr "\nICI2!\n";Pp.flush_all() in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in RLetIn(dummy_loc,nme,bdy,newtrm) - | _, RLetIn(_,nme,bdy,trm) -> - let _ = prstr "\nICI3!\n";Pp.flush_all() in + | _, RLetIn(_,nme,bdy,trm) -> + let _ = prstr "\nICI3!\n";Pp.flush_all() in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in RLetIn(dummy_loc,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in raise NoMerge -let rec merge_app_unsafe c1 c2 shift filter_shift_stable = +let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with - | RApp(_,f1, arr1), RApp(_,f2,arr2) -> + | RApp(_,f1, arr1), RApp(_,f2,arr2) -> let args = filter_shift_stable lnk (arr1 @ arr2) in RApp (dummy_loc,RVar(dummy_loc,shift.ident) , args) (* FIXME: what if the function appears in the body of the let? *) - | RLetIn(_,nme,bdy,trm) , _ -> - let _ = prstr "\nICI2 '!\n";Pp.flush_all() in + | RLetIn(_,nme,bdy,trm) , _ -> + let _ = prstr "\nICI2 '!\n";Pp.flush_all() in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in RLetIn(dummy_loc,nme,bdy,newtrm) - | _, RLetIn(_,nme,bdy,trm) -> - let _ = prstr "\nICI3 '!\n";Pp.flush_all() in + | _, RLetIn(_,nme,bdy,trm) -> + let _ = prstr "\nICI3 '!\n";Pp.flush_all() in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in RLetIn(dummy_loc,nme,bdy,newtrm) | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge @@ -555,33 +555,33 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = (* Heuristic when merging two lists of hypothesis: merge every rec calls of branch 1 with all rec calls of branch 2. *) (* TODO: reecrire cette heuristique (jusqu'a merge_types) *) -let rec merge_rec_hyps shift accrec - (ltyp:(Names.name * rawconstr option * rawconstr option) list) +let rec merge_rec_hyps shift accrec + (ltyp:(Names.name * rawconstr option * rawconstr option) list) filter_shift_stable : (Names.name * rawconstr option * rawconstr option) list = - let mergeonehyp t reldecl = + let mergeonehyp t reldecl = match reldecl with - | (nme,x,Some (RApp(_,i,args) as ind)) + | (nme,x,Some (RApp(_,i,args) as ind)) -> nme,x, Some (merge_app_unsafe ind t shift filter_shift_stable) | (nme,Some _,None) -> error "letins with recursive calls not treated yet" - | (nme,None,Some _) -> assert false + | (nme,None,Some _) -> assert false | (nme,None,None) | (nme,Some _,Some _) -> assert false in match ltyp with | [] -> [] - | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> + | (nme,None,Some (RApp(_,f, largs) as t)) :: lt when isVarf ind2name f -> let rechyps = List.map (mergeonehyp t) accrec in rechyps @ merge_rec_hyps shift accrec lt filter_shift_stable | e::lt -> e :: merge_rec_hyps shift accrec lt filter_shift_stable -let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = +let rec build_suppl_reccall (accrec:(name * rawconstr) list) concl2 shift = List.map (fun (nm,tp) -> (nm,merge_app_unsafe tp concl2 shift)) accrec -let find_app (nme:identifier) ltyp = +let find_app (nme:identifier) ltyp = try ignore (List.map - (fun x -> + (fun x -> match x with | _,None,Some (RApp(_,f,_)) when isVarf nme f -> raise (Found 0) | _ -> ()) @@ -589,17 +589,17 @@ let find_app (nme:identifier) ltyp = false with Found _ -> true -let prnt_prod_or_letin nm letbdy typ = +let prnt_prod_or_letin nm letbdy typ = match letbdy , typ with | Some lbdy , None -> prNamedRConstr ("(letin) " ^ string_of_name nm) lbdy | None , Some tp -> prNamedRConstr (string_of_name nm) tp | _ , _ -> assert false - -let rec merge_types shift accrec1 + +let rec merge_types shift accrec1 (ltyp1:(name * rawconstr option * rawconstr option) list) (concl1:rawconstr) (ltyp2:(name * rawconstr option * rawconstr option) list) concl2 - : (name * rawconstr option * rawconstr option) list * rawconstr = + : (name * rawconstr option * rawconstr option) list * rawconstr = let _ = prstr "MERGE_TYPES\n" in let _ = prstr "ltyp 1 : " in let _ = List.iter (fun (nm,lbdy,tp) -> prnt_prod_or_letin nm lbdy tp) ltyp1 in @@ -608,20 +608,20 @@ let rec merge_types shift accrec1 let _ = prstr "\n" in let res = match ltyp1 with - | [] -> + | [] -> let isrec1 = (accrec1<>[]) in let isrec2 = find_app ind2name ltyp2 in let rechyps = - if isrec1 && isrec2 + if isrec1 && isrec2 then (* merge_rec_hyps shift accrec1 ltyp2 filter_shift_stable *) - merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 + merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 filter_shift_stable_right @ merge_rec_hyps shift accrec1 [name_of_string "concl2",None, Some concl2] filter_shift_stable - else if isrec1 + else if isrec1 (* if rec calls in accrec1 and not in ltyp2, add one to ltyp2 *) - then - merge_rec_hyps shift accrec1 + then + merge_rec_hyps shift accrec1 (ltyp2@[name_of_string "concl2",None,Some concl2]) filter_shift_stable else if isrec2 then merge_rec_hyps shift [name_of_string "concl1",None,Some concl1] ltyp2 @@ -634,22 +634,22 @@ let rec merge_types shift accrec1 let _ = prstr " with " in let _ = prNamedRConstr "concl2" concl2 in let _ = prstr "\n" in - let concl = + let concl = merge_app concl1 concl2 ind1name ind2name shift filter_shift_stable in let _ = prstr "FIN " in let _ = prNamedRConstr "concl" concl in let _ = prstr "\n" in rechyps , concl - | (nme,None, Some t1)as e ::lt1 -> + | (nme,None, Some t1)as e ::lt1 -> (match t1 with - | RApp(_,f,carr) when isVarf ind1name f -> - merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 - | _ -> + | RApp(_,f,carr) when isVarf ind1name f -> + merge_types shift (e::accrec1) lt1 concl1 ltyp2 concl2 + | _ -> let recres, recconcl2 = merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in - ((nme,None,Some t1) :: recres) , recconcl2) - | (nme,Some bd, None) ::lt1 -> + ((nme,None,Some t1) :: recres) , recconcl2) + | (nme,Some bd, None) ::lt1 -> (* FIXME: what if ind1name appears in bd? *) let recres, recconcl2 = merge_types shift accrec1 lt1 concl1 ltyp2 concl2 in @@ -666,10 +666,10 @@ let rec merge_types shift accrec1 let build_link_map_aux (allargs1:identifier array) (allargs2:identifier array) (lnk:int merged_arg array) = array_fold_lefti - (fun i acc e -> + (fun i acc e -> if i = Array.length lnk - 1 then acc (* functional arg, not in allargs *) - else - match e with + else + match e with | Prm_linked j | Arg_linked j -> Idmap.add allargs2.(i) allargs1.(j) acc | _ -> acc) Idmap.empty lnk @@ -696,10 +696,10 @@ let build_link_map allargs1 allargs2 lnk = forall recparams1 (recparams2 without linked params), forall ordparams1 (ordparams2 without linked params), - H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... + H1a' -> H2a' -> ... -> H2a' -> H2b'(shifted) -> ... -> (newI x1 ... z1 x2 y2 ...z2 without linked params) - where Hix' have been adapted, ie: + where Hix' have been adapted, ie: - linked vars have been changed, - rec calls to I1 and I2 have been replaced by rec calls to newI. More precisely calls to I1 and I2 have been merge by an @@ -715,26 +715,26 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr) (* FIXME: les noms des parametres corerspondent en principe au parametres du niveau mib, mais il faudrait s'en assurer *) (* shift.nfunresprmsx last args are functional result *) - let nargs1 = + let nargs1 = shift.mib1.mind_nparams + shift.oib1.mind_nrealargs - shift.nfunresprms1 in let nargs2 = shift.mib2.mind_nparams + shift.oib2.mind_nrealargs - shift.nfunresprms2 in let allargs1,rest1 = raw_decompose_prod_or_letin_n nargs1 typcstr1 in - let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in + let allargs2,rest2 = raw_decompose_prod_or_letin_n nargs2 typcstr2 in (* Build map of linked args of [typcstr2], and apply it to [typcstr2]. *) let linked_map = build_link_map allargs1 allargs2 shift.lnk2 in let rest2 = change_vars linked_map rest2 in let hyps1,concl1 = raw_decompose_prod_or_letin rest1 in let hyps2,concl2' = raw_decompose_prod_or_letin rest2 in - let ltyp,concl2 = + let ltyp,concl2 = merge_types shift [] (List.rev hyps1) concl1 (List.rev hyps2) concl2' in let _ = prNamedRLDecl "ltyp result:" ltyp in let typ = raw_compose_prod_or_letin concl2 (List.rev ltyp) in - let revargs1 = + let revargs1 = list_filteri (fun i _ -> isArg_stable shift.lnk1.(i)) (List.rev allargs1) in let _ = prNamedRLDecl "ltyp allargs1" allargs1 in let _ = prNamedRLDecl "ltyp revargs1" revargs1 in - let revargs2 = + let revargs2 = list_filteri (fun i _ -> isArg_stable shift.lnk2.(i)) (List.rev allargs2) in let _ = prNamedRLDecl "ltyp allargs2" allargs2 in let _ = prNamedRLDecl "ltyp revargs2" revargs2 in @@ -746,7 +746,7 @@ let merge_one_constructor (shift:merge_infos) (typcstr1:rawconstr) (** constructor numbering *) let fresh_cstror_suffix , cstror_suffix_init = let cstror_num = ref 0 in - (fun () -> + (fun () -> let res = string_of_int !cstror_num in cstror_num := !cstror_num + 1; res) , @@ -755,7 +755,7 @@ let fresh_cstror_suffix , cstror_suffix_init = (** [merge_constructor_id id1 id2 shift] returns the identifier of the new constructor from the id of the two merged constructor and the merging info. *) -let merge_constructor_id id1 id2 shift:identifier = +let merge_constructor_id id1 id2 shift:identifier = let id = string_of_id shift.ident ^ "_" ^ fresh_cstror_suffix () in next_ident_fresh (id_of_string id) @@ -765,43 +765,43 @@ let merge_constructor_id id1 id2 shift:identifier = constructor [(name*type)]. These are translated to rawterms first, each of them having distinct var names. *) let rec merge_constructors (shift:merge_infos) (avoid:Idset.t) - (typcstr1:(identifier * rawconstr) list) + (typcstr1:(identifier * rawconstr) list) (typcstr2:(identifier * rawconstr) list) : (identifier * rawconstr) list = - List.flatten + List.flatten (List.map - (fun (id1,rawtyp1) -> + (fun (id1,rawtyp1) -> List.map - (fun (id2,rawtyp2) -> + (fun (id2,rawtyp2) -> let typ = merge_one_constructor shift rawtyp1 rawtyp2 in let newcstror_id = merge_constructor_id id1 id2 shift in let _ = prstr "\n**************\n" in newcstror_id , typ) typcstr2) typcstr1) - + (** [merge_inductive_body lnk shift avoid oib1 oib2] merges two inductive bodies [oib1] and [oib2], linking with [lnk], params info in [shift], avoiding identifiers in [avoid]. *) let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) (oib2:one_inductive_body) = (* building rawconstr type of constructors *) - let mkrawcor nme avoid typ = + let mkrawcor nme avoid typ = (* first replace rel 1 by a varname *) let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in Detyping.detype false (Idset.elements avoid) [] substindtyp in - let lcstr1: rawconstr list = + let lcstr1: rawconstr list = Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in (* add to avoid all indentifiers of lcstr1 *) let avoid2 = Idset.union avoid (ids_of_rawlist avoid lcstr1) in - let lcstr2 = + let lcstr2 = Array.to_list (Array.map (mkrawcor ind2name avoid2) oib2.mind_user_lc) in let avoid3 = Idset.union avoid (ids_of_rawlist avoid lcstr2) in - let params1 = - try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) + let params1 = + try fst (raw_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) with _ -> [] in - let params2 = - try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) + let params2 = + try fst (raw_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) with _ -> [] in let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in @@ -819,17 +819,17 @@ let rec merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) let rec merge_mutual_inductive_body (mib1:mutual_inductive_body) (mib2:mutual_inductive_body) (shift:merge_infos) = (* Mutual not treated, we take first ind body of each. *) - merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) + merge_inductive_body shift Idset.empty mib1.mind_packets.(0) mib2.mind_packets.(0) + - let rawterm_to_constr_expr x = (* build a constr_expr from a rawconstr *) Flags.with_option Flags.raw_print (Constrextern.extern_rawtype Idset.empty) x -let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = +let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let params = prms2 @ prms1 in let resparams = List.fold_left - (fun acc (nme,tp) -> + (fun acc (nme,tp) -> let _ = prstr "param :" in let _ = prNamedRConstr (string_of_name nme) tp in let _ = prstr " ; " in @@ -837,18 +837,18 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = LocalRawAssum ([(dummy_loc,nme)], Topconstr.default_binder_kind, typ) :: acc) [] params in let concl = Constrextern.extern_constr false (Global.env()) concl in - let arity,_ = - List.fold_left - (fun (acc,env) (nm,_,c) -> + let arity,_ = + List.fold_left + (fun (acc,env) (nm,_,c) -> let typ = Constrextern.extern_constr false env c in let newenv = Environ.push_rel (nm,None,c) env in CProdN (dummy_loc, [[(dummy_loc,nm)],Topconstr.default_binder_kind,typ] , acc) , newenv) (concl,Global.env()) - (shift.funresprms2 @ shift.funresprms1 - @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in + (shift.funresprms2 @ shift.funresprms1 + @ shift.args2 @ shift.args1 @ shift.otherprms2 @ shift.otherprms1) in resparams,arity - + (** [rawterm_list_to_inductive_expr ident rawlist] returns the induct_expr corresponding to the the list of constructor types @@ -859,17 +859,17 @@ let rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift let lident = dummy_loc, shift.ident in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in - let lcstor_expr : (bool * (lident * constr_expr)) list = + let lcstor_expr : (bool * (lident * constr_expr)) list = List.map (* zeta_normalize t ? *) (fun (id,t) -> false, ((dummy_loc,id),rawterm_to_constr_expr t)) - rawlist in + rawlist in lident , bindlist , Some cstr_expr , lcstor_expr let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = match rdecl with - | (nme,None,t) -> + | (nme,None,t) -> let traw = Detyping.detype false [] [] t in RProd (dummy_loc,nme,Explicit,traw,t2) | (_,Some _,_) -> assert false @@ -879,7 +879,7 @@ let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = match rdecl with - | (nme,None,t) -> + | (nme,None,t) -> let traw = Detyping.detype false [] [] t in RProd (dummy_loc,nme,Explicit,traw,t2) | (_,Some _,_) -> assert false @@ -888,7 +888,7 @@ let mkProd_reldecl (rdecl:rel_declaration) (t2:rawconstr) = (** [merge_inductive ind1 ind2 lnk] merges two graphs, linking variables specified in [lnk]. Graphs are not supposed to be mutual inductives for the moment. *) -let merge_inductive (ind1: inductive) (ind2: inductive) +let merge_inductive (ind1: inductive) (ind2: inductive) (lnk1: linked_var array) (lnk2: linked_var array) id = let env = Global.env() in let mib1,_ = Inductive.lookup_mind_specif env ind1 in @@ -898,14 +898,14 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let shift_prm = shift_linked_params mib1 mib2 lnk1 lnk2 id in let prms1,prms2, rawlist = merge_mutual_inductive_body mib1 mib2 shift_prm in let _ = prstr "\nrawlist : " in - let _ = + let _ = List.iter (fun (nm,tp) -> prNamedRConstr (string_of_id nm) tp;prstr "\n") rawlist in let _ = prstr "\nend rawlist\n" in (* FIX: retransformer en constr ici - let shift_prm = + let shift_prm = { shift_prm with recprms1=prms1; - recprms1=prms1; + recprms1=prms1; } in *) let indexpr = rawterm_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) @@ -927,28 +927,28 @@ let find_Function_infos_safe (id:identifier): Indfun_common.function_info = [ind1] and [ind2]. identifiers occuring in both arrays [args1] and [args2] are considered linked (i.e. are the same variable) in the new graph. - + Warning: For the moment, repetitions of an id in [args1] or [args2] are not supported. *) -let merge (id1:identifier) (id2:identifier) (args1:identifier array) +let merge (id1:identifier) (id2:identifier) (args1:identifier array) (args2:identifier array) id : unit = let finfo1 = find_Function_infos_safe id1 in let finfo2 = find_Function_infos_safe id2 in (* FIXME? args1 are supposed unlinked. mergescheme (G x x) ?? *) (* We add one arg (functional arg of the graph) *) let lnk1 = Array.make (Array.length args1 + 1) Unlinked in - let lnk2' = (* args2 may be linked to args1 members. FIXME: same + let lnk2' = (* args2 may be linked to args1 members. FIXME: same as above: vars may be linked inside args2?? *) Array.mapi - (fun i c -> + (fun i c -> match array_find args1 (fun i x -> x=c) with | Some j -> Linked j - | None -> Unlinked) + | None -> Unlinked) args2 in (* We add one arg (functional arg of the graph) *) let lnk2 = Array.append lnk2' (Array.make 1 Unlinked) in (* setting functional results *) - let _ = lnk1.(Array.length lnk1 - 1) <- Funres in + let _ = lnk1.(Array.length lnk1 - 1) <- Funres in let _ = lnk2.(Array.length lnk2 - 1) <- Funres in merge_inductive finfo1.graph_ind finfo2.graph_ind lnk1 lnk2 id @@ -968,12 +968,12 @@ let remove_last_n_arg n c = (* [funify_branches relinfo nfuns branch] returns the branch [branch] of the relinfo [relinfo] modified to fit in a functional principle. - Things to do: + Things to do: - remove indargs from rel applications - replace *variables only* corresponding to function (recursive) results by the actual function application. *) -let funify_branches relinfo nfuns branch = - let mut_induct, induct = +let funify_branches relinfo nfuns branch = + let mut_induct, induct = match relinfo.indref with | None -> assert false | Some (IndRef ((mutual_ind,i) as ind)) -> mutual_ind,ind @@ -987,13 +987,13 @@ let funify_branches relinfo nfuns branch = match kind_of_term c with | Ind((u,i)) | Construct((u,_),i) -> i | _ -> assert false in - let _is_pred c shift = + let _is_pred c shift = match kind_of_term c with | Rel i -> let reali = i-shift in (reali>=0 && reali false in (* FIXME: *) (Anonymous,Some mkProp,mkProp) - + let relprinctype_to_funprinctype relprinctype nfuns = let relinfo = compute_elim_sig relprinctype in @@ -1010,7 +1010,7 @@ let relprinctype_to_funprinctype relprinctype nfuns = args = remove_n_fst_list nfuns relinfo_noindarg.args; concl = popn nfuns relinfo_noindarg.concl } in - let new_branches = + let new_branches = List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in let relinfo_branches = { relinfo_argsok with branches = new_branches } in relinfo_branches @@ -1026,7 +1026,7 @@ let relprinctype_to_funprinctype relprinctype nfuns = url = "citeseer.ist.psu.edu/bundy93rippling.html" } *) -(* +(* *** Local Variables: *** *** compile-command: "make -C ../.. plugins/funind/merge.cmo" *** *** indent-tabs-mode: nil *** diff --git a/plugins/funind/rawterm_to_relation.ml b/plugins/funind/rawterm_to_relation.ml index 7e9ba3f8ea..4bd0385caa 100644 --- a/plugins/funind/rawterm_to_relation.ml +++ b/plugins/funind/rawterm_to_relation.ml @@ -1,6 +1,6 @@ open Printer open Pp -open Names +open Names open Term open Rawterm open Libnames @@ -8,76 +8,76 @@ open Indfun_common open Util open Rawtermops -let observe strm = +let observe strm = if do_observe () - then Pp.msgnl strm + then Pp.msgnl strm else () -let observennl strm = +let observennl strm = if do_observe () - then Pp.msg strm + then Pp.msg strm else () type binder_type = - | Lambda of name - | Prod of name + | Lambda of name + | Prod of name | LetIn of name type raw_context = (binder_type*rawconstr) list -(* - compose_raw_context [(bt_1,n_1,t_1);......] rt returns - b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the +(* + compose_raw_context [(bt_1,n_1,t_1);......] rt returns + b_1(n_1,t_1,.....,bn(n_k,t_k,rt)) where the b_i's are the binders corresponding to the bt_i's *) -let compose_raw_context = +let compose_raw_context = let compose_binder (bt,t) acc = - match bt with + match bt with | Lambda n -> mkRLambda(n,t,acc) | Prod n -> mkRProd(n,t,acc) | LetIn n -> mkRLetIn(n,t,acc) in List.fold_right compose_binder - -(* + +(* The main part deals with building a list of raw constructor expressions - from the rhs of a fixpoint equation. + from the rhs of a fixpoint equation. *) -type 'a build_entry_pre_return = +type 'a build_entry_pre_return = { context : raw_context; (* the binding context of the result *) value : 'a; (* The value *) } -type 'a build_entry_return = +type 'a build_entry_return = { - result : 'a build_entry_pre_return list; + result : 'a build_entry_pre_return list; to_avoid : identifier list } (* - [combine_results combine_fun res1 res2] combine two results [res1] and [res2] + [combine_results combine_fun res1 res2] combine two results [res1] and [res2] w.r.t. [combine_fun]. - Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...] - and [res2_1,....] and we need to produce + Informally, both [res1] and [res2] are lists of "constructors" [res1_1;...] + and [res2_1,....] and we need to produce [combine_fun res1_1 res2_1;combine_fun res1_1 res2_2;........] *) -let combine_results - (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> +let combine_results + (combine_fun : 'a build_entry_pre_return -> 'b build_entry_pre_return -> 'c build_entry_pre_return - ) - (res1: 'a build_entry_return) - (res2 : 'b build_entry_return) - : 'c build_entry_return - = - let pre_result = List.map + ) + (res1: 'a build_entry_return) + (res2 : 'b build_entry_return) + : 'c build_entry_return + = + let pre_result = List.map ( fun res1 -> (* for each result in arg_res *) - List.map (* we add it in each args_res *) - (fun res2 -> + List.map (* we add it in each args_res *) + (fun res2 -> combine_fun res1 res2 ) res2.result @@ -85,107 +85,107 @@ let combine_results res1.result in (* and then we flatten the map *) { - result = List.concat pre_result; + result = List.concat pre_result; to_avoid = list_union res1.to_avoid res2.to_avoid } - -(* - The combination function for an argument with a list of argument + +(* + The combination function for an argument with a list of argument *) -let combine_args arg args = +let combine_args arg args = { - context = arg.context@args.context; - (* Note that the binding context of [arg] MUST be placed before the one of - [args] in order to preserve possible type dependencies + context = arg.context@args.context; + (* Note that the binding context of [arg] MUST be placed before the one of + [args] in order to preserve possible type dependencies *) value = arg.value::args.value; } -let ids_of_binder = function +let ids_of_binder = function | LetIn Anonymous | Prod Anonymous | Lambda Anonymous -> [] | LetIn (Name id) | Prod (Name id) | Lambda (Name id) -> [id] -let rec change_vars_in_binder mapping = function +let rec change_vars_in_binder mapping = function [] -> [] | (bt,t)::l -> - let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in + let new_mapping = List.fold_right Idmap.remove (ids_of_binder bt) mapping in (bt,change_vars mapping t):: (if idmap_is_empty new_mapping - then l + then l else change_vars_in_binder new_mapping l ) let rec replace_var_by_term_in_binder x_id term = function | [] -> [] - | (bt,t)::l -> + | (bt,t)::l -> (bt,replace_var_by_term x_id term t):: - if List.mem x_id (ids_of_binder bt) + if List.mem x_id (ids_of_binder bt) then l else replace_var_by_term_in_binder x_id term l let add_bt_names bt = List.append (ids_of_binder bt) -let apply_args ctxt body args = - let need_convert_id avoid id = - List.exists (is_free_in id) args || List.mem id avoid - in - let need_convert avoid bt = +let apply_args ctxt body args = + let need_convert_id avoid id = + List.exists (is_free_in id) args || List.mem id avoid + in + let need_convert avoid bt = List.exists (need_convert_id avoid) (ids_of_binder bt) in - let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = - match na with - | Name id when List.mem id avoid -> - let new_id = Nameops.next_ident_away id avoid in + let next_name_away (na:name) (mapping: identifier Idmap.t) (avoid: identifier list) = + match na with + | Name id when List.mem id avoid -> + let new_id = Nameops.next_ident_away id avoid in Name new_id,Idmap.add id new_id mapping,new_id::avoid | _ -> na,mapping,avoid in - let next_bt_away bt (avoid:identifier list) = - match bt with - | LetIn na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + let next_bt_away bt (avoid:identifier list) = + match bt with + | LetIn na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in LetIn new_na,mapping,new_avoid - | Prod na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + | Prod na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in Prod new_na,mapping,new_avoid - | Lambda na -> - let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in + | Lambda na -> + let new_na,mapping,new_avoid = next_name_away na Idmap.empty avoid in Lambda new_na,mapping,new_avoid in - let rec do_apply avoid ctxt body args = - match ctxt,args with + let rec do_apply avoid ctxt body args = + match ctxt,args with | _,[] -> (* No more args *) (ctxt,body) | [],_ -> (* no more fun *) let f,args' = raw_decompose_app body in (ctxt,mkRApp(f,args'@args)) - | (Lambda Anonymous,t)::ctxt',arg::args' -> + | (Lambda Anonymous,t)::ctxt',arg::args' -> do_apply avoid ctxt' body args' - | (Lambda (Name id),t)::ctxt',arg::args' -> - let new_avoid,new_ctxt',new_body,new_id = - if need_convert_id avoid id - then - let new_avoid = id::avoid in - let new_id = Nameops.next_ident_away id new_avoid in - let new_avoid' = new_id :: new_avoid in - let mapping = Idmap.add id new_id Idmap.empty in - let new_ctxt' = change_vars_in_binder mapping ctxt' in - let new_body = change_vars mapping body in + | (Lambda (Name id),t)::ctxt',arg::args' -> + let new_avoid,new_ctxt',new_body,new_id = + if need_convert_id avoid id + then + let new_avoid = id::avoid in + let new_id = Nameops.next_ident_away id new_avoid in + let new_avoid' = new_id :: new_avoid in + let mapping = Idmap.add id new_id Idmap.empty in + let new_ctxt' = change_vars_in_binder mapping ctxt' in + let new_body = change_vars mapping body in new_avoid',new_ctxt',new_body,new_id - else - id::avoid,ctxt',body,id + else + id::avoid,ctxt',body,id in let new_body = replace_var_by_term new_id arg new_body in let new_ctxt' = replace_var_by_term_in_binder new_id arg new_ctxt' in do_apply avoid new_ctxt' new_body args' - | (bt,t)::ctxt',_ -> - let new_avoid,new_ctxt',new_body,new_bt = - let new_avoid = add_bt_names bt avoid in - if need_convert avoid bt - then - let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in + | (bt,t)::ctxt',_ -> + let new_avoid,new_ctxt',new_body,new_bt = + let new_avoid = add_bt_names bt avoid in + if need_convert avoid bt + then + let new_bt,mapping,new_avoid = next_bt_away bt new_avoid in ( new_avoid, change_vars_in_binder mapping ctxt', @@ -194,93 +194,93 @@ let apply_args ctxt body args = ) else new_avoid,ctxt',body,bt in - let new_ctxt',new_body = - do_apply new_avoid new_ctxt' new_body args + let new_ctxt',new_body = + do_apply new_avoid new_ctxt' new_body args in (new_bt,t)::new_ctxt',new_body - in + in do_apply [] ctxt body args -let combine_app f args = - let new_ctxt,new_value = apply_args f.context f.value args.value in - { - (* Note that the binding context of [args] MUST be placed before the one of - the applied value in order to preserve possible type dependencies +let combine_app f args = + let new_ctxt,new_value = apply_args f.context f.value args.value in + { + (* Note that the binding context of [args] MUST be placed before the one of + the applied value in order to preserve possible type dependencies *) context = args.context@new_ctxt; value = new_value; } -let combine_lam n t b = +let combine_lam n t b = { - context = []; - value = mkRLambda(n, compose_raw_context t.context t.value, + context = []; + value = mkRLambda(n, compose_raw_context t.context t.value, compose_raw_context b.context b.value ) } -let combine_prod n t b = +let combine_prod n t b = { context = t.context@((Prod n,t.value)::b.context); value = b.value} -let combine_letin n t b = +let combine_letin n t b = { context = t.context@((LetIn n,t.value)::b.context); value = b.value} -let mk_result ctxt value avoid = - { - result = +let mk_result ctxt value avoid = + { + result = [{context = ctxt; value = value}] ; to_avoid = avoid } (************************************************* - Some functions to deal with overlapping patterns + Some functions to deal with overlapping patterns **************************************************) -let coq_True_ref = +let coq_True_ref = lazy (Coqlib.gen_reference "" ["Init";"Logic"] "True") -let coq_False_ref = +let coq_False_ref = lazy (Coqlib.gen_reference "" ["Init";"Logic"] "False") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with (the list of expresions on which we will do the matching) - *) -let make_discr_match_el = + *) +let make_discr_match_el = List.map (fun e -> (e,(Anonymous,None))) (* - [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. - that is. + [make_discr_match_brl i \[pat_1,...,pat_n\]] constructs a discrimination pattern matching on the ith expression. + that is. match ?????? with \\ | pat_1 => False \\ | pat_{i-1} => False \\ | pat_i => True \\ | pat_{i+1} => False \\ - \vdots + \vdots | pat_n => False end *) -let make_discr_match_brl i = - list_map_i - (fun j (_,idl,patl,_) -> +let make_discr_match_brl i = + list_map_i + (fun j (_,idl,patl,_) -> if j=i then (dummy_loc,idl,patl, mkRRef (Lazy.force coq_True_ref)) else (dummy_loc,idl,patl, mkRRef (Lazy.force coq_False_ref)) ) - 0 -(* - [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff - brl_{i} is the first branch matched by [el] + 0 +(* + [make_discr_match brl el i] generates an hypothesis such that it reduce to true iff + brl_{i} is the first branch matched by [el] Used when we want to simulate the coq pattern matching algorithm *) -let make_discr_match brl = - fun el i -> +let make_discr_match brl = + fun el i -> mkRCases(None, make_discr_match_el el, make_discr_match_brl i brl) @@ -291,32 +291,32 @@ let pr_name = function (**********************************************************************) (* functions used to build case expression from lettuple and if ones *) -(**********************************************************************) +(**********************************************************************) -(* [build_constructors_of_type] construct the array of pattern of its inductive argument*) -let build_constructors_of_type ind' argl = +(* [build_constructors_of_type] construct the array of pattern of its inductive argument*) +let build_constructors_of_type ind' argl = let (mib,ind) = Inductive.lookup_mind_specif (Global.env()) ind' in let npar = mib.Declarations.mind_nparams in Array.mapi (fun i _ -> - let construct = ind',i+1 in - let constructref = ConstructRef(construct) in + let construct = ind',i+1 in + let constructref = ConstructRef(construct) in let _implicit_positions_of_cst = Impargs.implicits_of_global constructref in - let cst_narg = + let cst_narg = Inductiveops.mis_constructor_nargs_env (Global.env ()) construct - in - let argl = - if argl = [] + in + let argl = + if argl = [] then - Array.to_list + Array.to_list (Array.init (cst_narg - npar) (fun _ -> mkRHole ()) ) else argl in - let pat_as_term = + let pat_as_term = mkRApp(mkRRef (ConstructRef(ind',i+1)),argl) in cases_pattern_of_rawconstr Anonymous pat_as_term @@ -324,36 +324,36 @@ let build_constructors_of_type ind' argl = ind.Declarations.mind_consnames (* [find_type_of] very naive attempts to discover the type of an if or a letin *) -let rec find_type_of nb b = - let f,_ = raw_decompose_app b in - match f with - | RRef(_,ref) -> - begin - let ind_type = - match ref with - | VarRef _ | ConstRef _ -> - let constr_of_ref = constr_of_global ref in - let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in - let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in - let ret_type,_ = decompose_app ret_type in - if not (isInd ret_type) then +let rec find_type_of nb b = + let f,_ = raw_decompose_app b in + match f with + | RRef(_,ref) -> + begin + let ind_type = + match ref with + | VarRef _ | ConstRef _ -> + let constr_of_ref = constr_of_global ref in + let type_of_ref = Typing.type_of (Global.env ()) Evd.empty constr_of_ref in + let (_,ret_type) = Reduction.dest_prod (Global.env ()) type_of_ref in + let ret_type,_ = decompose_app ret_type in + if not (isInd ret_type) then begin (* Pp.msgnl (str "not an inductive" ++ pr_lconstr ret_type); *) raise (Invalid_argument "not an inductive") end; destInd ret_type | IndRef ind -> ind - | ConstructRef c -> fst c + | ConstructRef c -> fst c in - let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in + let _,ind_type_info = Inductive.lookup_mind_specif (Global.env()) ind_type in if not (Array.length ind_type_info.Declarations.mind_consnames = nb ) then raise (Invalid_argument "find_type_of : not a valid inductive"); - ind_type + ind_type end - | RCast(_,b,_) -> find_type_of nb b + | RCast(_,b,_) -> find_type_of nb b | RApp _ -> assert false (* we have decomposed any application via raw_decompose_app *) | _ -> raise (Invalid_argument "not a ref") - + @@ -363,32 +363,32 @@ let rec find_type_of nb b = -let raw_push_named (na,raw_value,raw_typ) env = - match na with - | Anonymous -> env - | Name id -> - let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in - let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in +let raw_push_named (na,raw_value,raw_typ) env = + match na with + | Anonymous -> env + | Name id -> + let value = Option.map (Pretyping.Default.understand Evd.empty env) raw_value in + let typ = Pretyping.Default.understand_type Evd.empty env raw_typ in Environ.push_named (id,value,typ) env -let add_pat_variables pat typ env : Environ.env = - let rec add_pat_variables env pat typ : Environ.env = +let add_pat_variables pat typ env : Environ.env = + let rec add_pat_variables env pat typ : Environ.env = observe (str "new rel env := " ++ Printer.pr_rel_context_of env); - match pat with - | PatVar(_,na) -> Environ.push_rel (na,None,typ) env - | PatCstr(_,c,patl,na) -> - let Inductiveops.IndType(indf,indargs) = + match pat with + | PatVar(_,na) -> Environ.push_rel (na,None,typ) env + | PatCstr(_,c,patl,na) -> + let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env Evd.empty typ - with Not_found -> assert false + with Not_found -> assert false in - let constructors = Inductiveops.get_constructors env indf in - let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in - List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) + let constructors = Inductiveops.get_constructors env indf in + let constructor : Inductiveops.constructor_summary = List.find (fun cs -> cs.Inductiveops.cs_cstr = c) (Array.to_list constructors) in + let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + List.fold_left2 add_pat_variables env patl (List.rev cs_args_types) in - let new_env = add_pat_variables env pat typ in + let new_env = add_pat_variables env pat typ in let res = fst ( Sign.fold_rel_context @@ -426,15 +426,15 @@ let rec pattern_to_term_and_type env typ = function (Global.env ()) constr in - let Inductiveops.IndType(indf,indargs) = + let Inductiveops.IndType(indf,indargs) = try Inductiveops.find_rectype env Evd.empty typ - with Not_found -> assert false + with Not_found -> assert false in - let constructors = Inductiveops.get_constructors env indf in - let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in - let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in - let _,cstl = Inductiveops.dest_ind_family indf in - let csta = Array.of_list cstl in + let constructors = Inductiveops.get_constructors env indf in + let constructor = List.find (fun cs -> cs.Inductiveops.cs_cstr = constr) (Array.to_list constructors) in + let cs_args_types :types list = List.map (fun (_,_,t) -> t) constructor.Inductiveops.cs_args in + let _,cstl = Inductiveops.dest_ind_family indf in + let csta = Array.of_list cstl in let implicit_args = Array.to_list (Array.init @@ -449,44 +449,44 @@ let rec pattern_to_term_and_type env typ = function implicit_args@patl_as_term ) -(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) - of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the - corresponding graphs. +(* [build_entry_lc funnames avoid rt] construct the list (in fact a build_entry_return) + of constructors corresponding to [rt] when replacing calls to [funnames] by calls to the + corresponding graphs. The idea to transform a term [t] into a list of constructors [lc] is the following: - \begin{itemize} - \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding + \begin{itemize} + \item if the term is a binder (bind x, body) then first compute [lc'] the list corresponding to [body] and add (bind x. _) to each elements of [lc] - \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) - then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], - then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], + \item if the term has the form (g t1 ... ... tn) where g does not appears in (fnames) + then compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], + then combine those lists and [g] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn], [g c1 ... cn] is an element of [lc] - \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then - compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], + \item if the term has the form (f t1 .... tn) where [f] appears in [fnames] then + compute [lc1] ... [lcn] the lists of constructors corresponding to [t1] ... [tn], then compute those lists and [f] as follows~: for each element [c1,...,cn] of [lc1\times...\times lcn] create a new variable [res] and [forall res, R_f c1 ... cn res] is in [lc] \item if the term is a cast just treat its body part - \item - if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case + \item + if the term is a match, an if or a lettuple then compute the lists corresponding to each branch of the case and concatenate them (informally, each branch of a match produces a new constructor) \end{itemize} - - WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. - We must wait to have complete all the current calculi to set the recursive calls. - At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by - a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. - We in fact not create a constructor list since then end of each constructor has not the expected form - but only the value of the function + + WARNING: The terms constructed here are only USING the rawconstr syntax but are highly bad formed. + We must wait to have complete all the current calculi to set the recursive calls. + At this point, each term [f t1 ... tn] (where f appears in [funnames]) is replaced by + a pseudo term [forall res, res t1 ... tn, res]. A reconstruction phase is done later. + We in fact not create a constructor list since then end of each constructor has not the expected form + but only the value of the function *) -let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = +let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = observe (str " Entering : " ++ Printer.pr_rawconstr rt); - match rt with - | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> + match rt with + | RRef _ | RVar _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> (* do nothing (except changing type of course) *) - mk_result [] rt avoid + mk_result [] rt avoid | RApp(_,_,_) -> let f,args = raw_decompose_app rt in let args_res : (rawconstr list) build_entry_return = @@ -502,108 +502,108 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = match f with | RVar(_,id) when Idset.mem id funnames -> (* if we have [f t1 ... tn] with [f]$\in$[fnames] - then we create a fresh variable [res], - add [res] and its "value" (i.e. [res v1 ... vn]) to each - pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and - a pseudo value "v1 ... vn". + then we create a fresh variable [res], + add [res] and its "value" (i.e. [res v1 ... vn]) to each + pseudo constructor build for the arguments (i.e. a pseudo context [ctxt] and + a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) - let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in - let rt_typ = Typing.type_of env Evd.empty rt_as_constr in + let rt_as_constr = Pretyping.Default.understand Evd.empty env rt in + let rt_typ = Typing.type_of env Evd.empty rt_as_constr in let res_raw_type = Detyping.detype false [] (Termops.names_of_rel_context env) rt_typ in let res = fresh_id args_res.to_avoid "res" in let new_avoid = res::args_res.to_avoid in - let res_rt = mkRVar res in - let new_result = - List.map - (fun arg_res -> - let new_hyps = + let res_rt = mkRVar res in + let new_result = + List.map + (fun arg_res -> + let new_hyps = [Prod (Name res),res_raw_type; Prod Anonymous,mkRApp(res_rt,(mkRVar id)::arg_res.value)] in - {context = arg_res.context@new_hyps; value = res_rt } + {context = arg_res.context@new_hyps; value = res_rt } ) args_res.result - in + in { result = new_result; to_avoid = new_avoid } - | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> - (* if have [g t1 ... tn] with [g] not appearing in [funnames] - then - foreach [ctxt,v1 ... vn] in [args_res] we return + | RVar _ | REvar _ | RPatVar _ | RHole _ | RSort _ | RRef _ -> + (* if have [g t1 ... tn] with [g] not appearing in [funnames] + then + foreach [ctxt,v1 ... vn] in [args_res] we return [ctxt, g v1 .... vn] *) { - args_res with - result = - List.map - (fun args_res -> + args_res with + result = + List.map + (fun args_res -> {args_res with value = mkRApp(f,args_res.value)}) args_res.result } | RApp _ -> assert false (* we have collected all the app in [raw_decompose_app] *) - | RLetIn(_,n,t,b) -> - (* if we have [(let x := v in b) t1 ... tn] , - we discard our work and compute the list of constructor for - [let x = v in (b t1 ... tn)] up to alpha conversion + | RLetIn(_,n,t,b) -> + (* if we have [(let x := v in b) t1 ... tn] , + we discard our work and compute the list of constructor for + [let x = v in (b t1 ... tn)] up to alpha conversion *) - let new_n,new_b,new_avoid = - match n with - | Name id when List.exists (is_free_in id) args -> + let new_n,new_b,new_avoid = + match n with + | Name id when List.exists (is_free_in id) args -> (* need to alpha-convert the name *) - let new_id = Nameops.next_ident_away id avoid in + let new_id = Nameops.next_ident_away id avoid in let new_avoid = id:: avoid in - let new_b = + let new_b = replace_var_by_term id - (RVar(dummy_loc,id)) + (RVar(dummy_loc,id)) b - in + in (Name new_id,new_b,new_avoid) | _ -> n,b,avoid in - build_entry_lc + build_entry_lc env - funnames + funnames avoid (mkRLetIn(new_n,t,mkRApp(new_b,args))) - | RCases _ | RLambda _ | RIf _ | RLetTuple _ -> + | RCases _ | RLambda _ | RIf _ | RLetTuple _ -> (* we have [(match e1, ...., en with ..... end) t1 tn] - we first compute the result from the case and + we first compute the result from the case and then combine each of them with each of args one *) let f_res = build_entry_lc env funnames args_res.to_avoid f in combine_results combine_app f_res args_res - | RDynamic _ ->error "Not handled RDynamic" - | RCast(_,b,_) -> - (* for an applied cast we just trash the cast part - and restart the work. + | RDynamic _ ->error "Not handled RDynamic" + | RCast(_,b,_) -> + (* for an applied cast we just trash the cast part + and restart the work. WARNING: We need to restart since [b] itself should be an application term *) build_entry_lc env funnames avoid (mkRApp(b,args)) | RRec _ -> error "Not handled RRec" | RProd _ -> error "Cannot apply a type" - end (* end of the application treatement *) + end (* end of the application treatement *) | RLambda(_,n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type and combine the two result *) let t_res = build_entry_lc env funnames avoid t in - let new_n = - match n with - | Name _ -> n + let new_n = + match n with + | Name _ -> n | Anonymous -> Name (Indfun_common.fresh_id [] "_x") in let new_env = raw_push_named (new_n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_lam new_n) t_res b_res | RProd(_,n,_,t,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the type + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the type and combine the two result *) let t_res = build_entry_lc env funnames avoid t in @@ -611,38 +611,38 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_prod n) t_res b_res | RLetIn(_,n,v,b) -> - (* we first compute the list of constructor - corresponding to the body of the function, - then the one corresponding to the value [t] + (* we first compute the list of constructor + corresponding to the body of the function, + then the one corresponding to the value [t] and combine the two result *) let v_res = build_entry_lc env funnames avoid v in - let v_as_constr = Pretyping.Default.understand Evd.empty env v in - let v_type = Typing.type_of env Evd.empty v_as_constr in - let new_env = + let v_as_constr = Pretyping.Default.understand Evd.empty env v in + let v_type = Typing.type_of env Evd.empty v_as_constr in + let new_env = match n with Anonymous -> env - | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env + | Name id -> Environ.push_named (id,Some v_as_constr,v_type) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_letin n) v_res b_res - | RCases(_,_,_,el,brl) -> - (* we create the discrimination function - and treat the case itself + | RCases(_,_,_,el,brl) -> + (* we create the discrimination function + and treat the case itself *) - let make_discr = make_discr_match brl in + let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid - | RIf(_,b,(na,e_option),lhs,rhs) -> + | RIf(_,b,(na,e_option),lhs,rhs) -> let b_as_constr = Pretyping.Default.understand Evd.empty env b in - let b_typ = Typing.type_of env Evd.empty b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ - with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ + let b_typ = Typing.type_of env Evd.empty b_as_constr in + let (ind,_) = + try Inductiveops.find_inductive env Evd.empty b_typ + with Not_found -> + errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_rawconstr b ++ str " in " ++ Printer.pr_rawconstr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind [] in + let case_pats = build_constructors_of_type ind [] in assert (Array.length case_pats = 2); let brl = list_map_i @@ -655,7 +655,7 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = in (* Pp.msgnl (str "new case := " ++ Printer.pr_rawconstr match_expr); *) build_entry_lc env funnames avoid match_expr - | RLetTuple(_,nal,_,b,e) -> + | RLetTuple(_,nal,_,b,e) -> begin let nal_as_rawconstr = List.map @@ -666,15 +666,15 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = nal in let b_as_constr = Pretyping.Default.understand Evd.empty env b in - let b_typ = Typing.type_of env Evd.empty b_as_constr in - let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ - with Not_found -> - errorlabstrm "" (str "Cannot find the inductive associated to " ++ + let b_typ = Typing.type_of env Evd.empty b_as_constr in + let (ind,_) = + try Inductiveops.find_inductive env Evd.empty b_typ + with Not_found -> + errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_rawconstr b ++ str " in " ++ Printer.pr_rawconstr rt ++ str ". try again with a cast") in - let case_pats = build_constructors_of_type ind nal_as_rawconstr in + let case_pats = build_constructors_of_type ind nal_as_rawconstr in assert (Array.length case_pats = 1); let br = (dummy_loc,[],[case_pats.(0)],e) @@ -684,25 +684,25 @@ let rec build_entry_lc env funnames avoid rt : rawconstr build_entry_return = end | RRec _ -> error "Not handled RRec" - | RCast(_,b,_) -> + | RCast(_,b,_) -> build_entry_lc env funnames avoid b | RDynamic _ -> error "Not handled RDynamic" and build_entry_lc_from_case env funname make_discr (el:tomatch_tuples) - (brl:Rawterm.cases_clauses) avoid : - rawconstr build_entry_return = - match el with - | [] -> assert false (* this case correspond to match with .... !*) - | el -> - (* this case correspond to + (brl:Rawterm.cases_clauses) avoid : + rawconstr build_entry_return = + match el with + | [] -> assert false (* this case correspond to match with .... !*) + | el -> + (* this case correspond to match el with brl end - we first compute the list of lists corresponding to [el] and - combine them . - Then for each elemeent of the combinations, - we compute the result we compute one list per branch in [brl] and - finally we just concatenate those list + we first compute the list of lists corresponding to [el] and + combine them . + Then for each elemeent of the combinations, + we compute the result we compute one list per branch in [brl] and + finally we just concatenate those list *) - let case_resl = + let case_resl = List.fold_right (fun (case_arg,_) ctxt_argsl -> let arg_res = build_entry_lc env funname avoid case_arg in @@ -711,32 +711,32 @@ and build_entry_lc_from_case env funname make_discr el (mk_result [] [] avoid) in - let types = - List.map (fun (case_arg,_) -> - let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in + let types = + List.map (fun (case_arg,_) -> + let case_arg_as_constr = Pretyping.Default.understand Evd.empty env case_arg in Typing.type_of env Evd.empty case_arg_as_constr ) el in (****** The next works only if the match is not dependent ****) let results = - List.map - (fun ca -> + List.map + (fun ca -> let res = build_entry_lc_from_case_term env types funname (make_discr) - [] brl + [] brl case_resl.to_avoid ca - in + in res - ) - case_resl.result - in - { + ) + case_resl.result + in + { result = List.concat (List.map (fun r -> r.result) results); - to_avoid = + to_avoid = List.fold_left (fun acc r -> list_union acc r.to_avoid) [] results - } + } and build_entry_lc_from_case_term env types funname make_discr patterns_to_prevent brl avoid matched_expr = @@ -746,24 +746,24 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (* alpha convertion to prevent name clashes *) let _,idl,patl,return = alpha_br avoid br in let new_avoid = idl@avoid in (* for now we can no more use idl as an indentifier *) - (* building a list of precondition stating that we are not in this branch + (* building a list of precondition stating that we are not in this branch (will be used in the following recursive calls) *) - let new_env = List.fold_right2 add_pat_variables patl types env in - let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = + let new_env = List.fold_right2 add_pat_variables patl types env in + let not_those_patterns : (identifier list -> rawconstr -> rawconstr) list = List.map2 - (fun pat typ -> - fun avoid pat'_as_term -> + (fun pat typ -> + fun avoid pat'_as_term -> let renamed_pat,_,_ = alpha_pat avoid pat in - let pat_ids = get_pattern_id renamed_pat in - let env_with_pat_ids = add_pat_variables pat typ new_env in - List.fold_right - (fun id acc -> - let typ_of_id = - Typing.type_of env_with_pat_ids Evd.empty (mkVar id) - in - let raw_typ_of_id = - Detyping.detype false [] + let pat_ids = get_pattern_id renamed_pat in + let env_with_pat_ids = add_pat_variables pat typ new_env in + List.fold_right + (fun id acc -> + let typ_of_id = + Typing.type_of env_with_pat_ids Evd.empty (mkVar id) + in + let raw_typ_of_id = + Detyping.detype false [] (Termops.names_of_rel_context env_with_pat_ids) typ_of_id in mkRProd (Name id,raw_typ_of_id,acc)) @@ -773,21 +773,21 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve patl types in - (* Checking if we can be in this branch + (* Checking if we can be in this branch (will be used in the following recursive calls) - *) + *) let unify_with_those_patterns : (cases_pattern -> bool*bool) list = - List.map - (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') + List.map + (fun pat pat' -> are_unifiable pat pat',eq_cases_pattern pat pat') patl in - (* - we first compute the other branch result (in ordrer to keep the order of the matching + (* + we first compute the other branch result (in ordrer to keep the order of the matching as much as possible) *) let brl'_res = build_entry_lc_from_case_term - env + env types funname make_discr @@ -797,9 +797,9 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve matched_expr in (* We now create the precondition of this branch i.e. - 1- the list of variable appearing in the different patterns of this branch and + 1- the list of variable appearing in the different patterns of this branch and the list of equation stating than el = patl (List.flatten ...) - 2- If there exists a previous branch which pattern unify with the one of this branch + 2- If there exists a previous branch which pattern unify with the one of this branch then a discrimination precond stating that we are not in a previous branch (if List.exists ...) *) let those_pattern_preconds = @@ -807,15 +807,15 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve ( list_map3 (fun pat e typ_as_constr -> - let this_pat_ids = ids_of_pat pat in + let this_pat_ids = ids_of_pat pat in let typ = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_as_constr in let pat_as_term = pattern_to_term pat in - List.fold_right - (fun id acc -> - if Idset.mem id this_pat_ids + List.fold_right + (fun id acc -> + if Idset.mem id this_pat_ids then (Prod (Name id), - let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in - let raw_typ_of_id = + let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in + let raw_typ_of_id = Detyping.detype false [] (Termops.names_of_rel_context new_env) typ_of_id in raw_typ_of_id @@ -832,15 +832,15 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve ) @ (if List.exists (function (unifl,_) -> - let (unif,_) = + let (unif,_) = List.split (List.map2 (fun x y -> x y) unifl patl) in List.for_all (fun x -> x) unif) patterns_to_prevent - then - let i = List.length patterns_to_prevent in + then + let i = List.length patterns_to_prevent in let pats_as_constr = List.map2 (pattern_to_term_and_type new_env) types patl in [(Prod Anonymous,make_discr pats_as_constr i )] - else + else [] ) in @@ -856,183 +856,183 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve return_res.result in { brl'_res with result = this_branch_res@brl'_res.result } - - -let is_res id = + + +let is_res id = try String.sub (string_of_id id) 0 3 = "res" - with Invalid_argument _ -> false + with Invalid_argument _ -> false exception Continue -(* - The second phase which reconstruct the real type of the constructor. - rebuild the raw constructors expression. +(* + The second phase which reconstruct the real type of the constructor. + rebuild the raw constructors expression. eliminates some meaningless equalities, applies some rewrites...... *) -let rec rebuild_cons env nb_args relname args crossed_types depth rt = +let rec rebuild_cons env nb_args relname args crossed_types depth rt = observe (str "rebuilding : " ++ pr_rawconstr rt); - match rt with - | RProd(_,n,k,t,b) -> - let not_free_in_t id = not (is_free_in id t) in - let new_crossed_types = t::crossed_types in + match rt with + | RProd(_,n,k,t,b) -> + let not_free_in_t id = not (is_free_in id t) in + let new_crossed_types = t::crossed_types in begin - match t with + match t with | RApp(_,(RVar(_,res_id) as res_rt),args') when is_res res_id -> begin - match args' with - | (RVar(_,this_relname))::args' -> - (*i The next call to mk_rel_id is + match args' with + | (RVar(_,this_relname))::args' -> + (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious - i*) - - let new_t = - mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) - in - let t' = Pretyping.Default.understand Evd.empty env new_t in - let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = + i*) + + let new_t = + mkRApp(mkRVar(mk_rel_id this_relname),args'@[res_rt]) + in + let t' = Pretyping.Default.understand Evd.empty env new_t in + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) b - in + in mkRProd(n,new_t,new_b), Idset.filter not_free_in_t id_to_exclude | _ -> (* the first args is the name of the function! *) - assert false + assert false end - | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt]) + | RApp(loc1,RRef(loc2,eq_as_ref),[ty;RVar(loc3,id);rt]) when eq_as_ref = Lazy.force Coqlib.coq_eq_ref && n = Anonymous - -> + -> begin - try + try observe (str "computing new type for eq : " ++ pr_rawconstr rt); - let t' = + let t' = try Pretyping.Default.understand Evd.empty env t with _ -> raise Continue in let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = List.map (replace_var_by_term id rt) args in - let subst_b = - if is_in_b then b else replace_var_by_term id rt b - in + let _keep_eq = + not (List.exists (is_free_in id) args) || is_in_b || + List.exists (is_free_in id) crossed_types + in + let new_args = List.map (replace_var_by_term id rt) args in + let subst_b = + if is_in_b then b else replace_var_by_term id rt b + in let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = - rebuild_cons + let new_b,id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types (depth + 1) subst_b - in + in mkRProd(n,t,new_b),id_to_exclude - with Continue -> - let jmeq = Libnames.IndRef (destInd (jmeq ())) in - let ty' = Pretyping.Default.understand Evd.empty env ty in - let ind,args' = Inductive.find_inductive env ty' in - let mib,_ = Global.lookup_inductive ind in - let nparam = mib.Declarations.mind_nparams in - let params,arg' = + with Continue -> + let jmeq = Libnames.IndRef (destInd (jmeq ())) in + let ty' = Pretyping.Default.understand Evd.empty env ty in + let ind,args' = Inductive.find_inductive env ty' in + let mib,_ = Global.lookup_inductive ind in + let nparam = mib.Declarations.mind_nparams in + let params,arg' = ((Util.list_chop nparam args')) in - let rt_typ = + let rt_typ = RApp(Util.dummy_loc, - RRef (Util.dummy_loc,Libnames.IndRef ind), - (List.map - (fun p -> Detyping.detype false [] + RRef (Util.dummy_loc,Libnames.IndRef ind), + (List.map + (fun p -> Detyping.detype false [] (Termops.names_of_rel_context env) - p) params)@(Array.to_list - (Array.make - (List.length args' - nparam) + p) params)@(Array.to_list + (Array.make + (List.length args' - nparam) (mkRHole ())))) in - let eq' = + let eq' = RApp(loc1,RRef(loc2,jmeq),[ty;RVar(loc3,id);rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_rawconstr eq'); let eq'_as_constr = Pretyping.Default.understand Evd.empty env eq' in observe (str " computing new type for jmeq : done") ; - let new_args = - match kind_of_term eq'_as_constr with - | App(_,[|_;_;ty;_|]) -> - let ty = Array.to_list (snd (destApp ty)) in - let ty' = snd (Util.list_chop nparam ty) in - List.fold_left2 - (fun acc var_as_constr arg -> - if isRel var_as_constr - then - let (na,_,_) = + let new_args = + match kind_of_term eq'_as_constr with + | App(_,[|_;_;ty;_|]) -> + let ty = Array.to_list (snd (destApp ty)) in + let ty' = snd (Util.list_chop nparam ty) in + List.fold_left2 + (fun acc var_as_constr arg -> + if isRel var_as_constr + then + let (na,_,_) = Environ.lookup_rel (destRel var_as_constr) env - in - match na with - | Anonymous -> acc - | Name id' -> - (id',Detyping.detype false [] + in + match na with + | Anonymous -> acc + | Name id' -> + (id',Detyping.detype false [] (Termops.names_of_rel_context env) arg)::acc - else if isVar var_as_constr - then (destVar var_as_constr,Detyping.detype false [] + else if isVar var_as_constr + then (destVar var_as_constr,Detyping.detype false [] (Termops.names_of_rel_context env) arg)::acc else acc ) [] arg' - ty' + ty' | _ -> assert false in let is_in_b = is_free_in id b in - let _keep_eq = - not (List.exists (is_free_in id) args) || is_in_b || - List.exists (is_free_in id) crossed_types - in - let new_args = - List.fold_left + let _keep_eq = + not (List.exists (is_free_in id) args) || is_in_b || + List.exists (is_free_in id) crossed_types + in + let new_args = + List.fold_left (fun args (id,rt) -> List.map (replace_var_by_term id rt) args ) - args + args ((id,rt)::new_args) - in - let subst_b = + in + let subst_b = if is_in_b then b else replace_var_by_term id rt b - in - let new_env = - let t' = Pretyping.Default.understand Evd.empty env eq' in + in + let new_env = + let t' = Pretyping.Default.understand Evd.empty env eq' in Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = - rebuild_cons + let new_b,id_to_exclude = + rebuild_cons new_env nb_args relname new_args new_crossed_types (depth + 1) subst_b - in + in mkRProd(n,eq',new_b),id_to_exclude end - (* J.F:. keep this comment it explain how to remove some meaningless equalities + (* J.F:. keep this comment it explain how to remove some meaningless equalities if keep_eq then mkRProd(n,t,new_b),id_to_exclude else new_b, Idset.add id id_to_exclude *) - | _ -> + | _ -> observe (str "computing new type for prod : " ++ pr_rawconstr rt); - let t' = Pretyping.Default.understand Evd.empty env t in - let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = + let t' = Pretyping.Default.understand Evd.empty env t in + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname args new_crossed_types (depth + 1) b - in + in match n with | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> - new_b,Idset.remove id + new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) | _ -> mkRProd(n,t,new_b),Idset.filter not_free_in_t id_to_exclude end @@ -1041,60 +1041,60 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in observe (str "computing new type for lambda : " ++ pr_rawconstr rt); - let t' = Pretyping.Default.understand Evd.empty env t in + let t' = Pretyping.Default.understand Evd.empty env t in match n with | Name id -> - let new_env = Environ.push_rel (n,None,t') env in - let new_b,id_to_exclude = + let new_env = Environ.push_rel (n,None,t') env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname (args@[mkRVar id])new_crossed_types - (depth + 1 ) b + (depth + 1 ) b in if Idset.mem id id_to_exclude && depth >= nb_args - then + then new_b, Idset.remove id (Idset.filter not_free_in_t id_to_exclude) else RProd(dummy_loc,n,k,t,new_b),Idset.filter not_free_in_t id_to_exclude - | _ -> anomaly "Should not have an anonymous function here" + | _ -> anomaly "Should not have an anonymous function here" (* We have renamed all the anonymous functions during alpha_renaming phase *) - + end - | RLetIn(_,n,t,b) -> + | RLetIn(_,n,t,b) -> begin - let not_free_in_t id = not (is_free_in id t) in - let t' = Pretyping.Default.understand Evd.empty env t in - let type_t' = Typing.type_of env Evd.empty t' in + let not_free_in_t id = not (is_free_in id t) in + let t' = Pretyping.Default.understand Evd.empty env t in + let type_t' = Typing.type_of env Evd.empty t' in let new_env = Environ.push_rel (n,Some t',type_t') env in - let new_b,id_to_exclude = - rebuild_cons new_env + let new_b,id_to_exclude = + rebuild_cons new_env nb_args relname args (t::crossed_types) (depth + 1 ) b in - match n with - | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> + match n with + | Name id when Idset.mem id id_to_exclude && depth >= nb_args -> new_b,Idset.remove id (Idset.filter not_free_in_t id_to_exclude) | _ -> RLetIn(dummy_loc,n,t,new_b), Idset.filter not_free_in_t id_to_exclude end - | RLetTuple(_,nal,(na,rto),t,b) -> + | RLetTuple(_,nal,(na,rto),t,b) -> assert (rto=None); begin - let not_free_in_t id = not (is_free_in id t) in - let new_t,id_to_exclude' = + let not_free_in_t id = not (is_free_in id t) in + let new_t,id_to_exclude' = rebuild_cons env nb_args - relname - args (crossed_types) - depth t + relname + args (crossed_types) + depth t in - let t' = Pretyping.Default.understand Evd.empty env new_t in - let new_env = Environ.push_rel (na,None,t') env in - let new_b,id_to_exclude = + let t' = Pretyping.Default.understand Evd.empty env new_t in + let new_env = Environ.push_rel (na,None,t') env in + let new_b,id_to_exclude = rebuild_cons new_env nb_args relname - args (t::crossed_types) - (depth + 1) b + args (t::crossed_types) + (depth + 1) b in (* match n with *) (* | Name id when Idset.mem id id_to_exclude -> *) @@ -1109,125 +1109,125 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* debuging wrapper *) -let rebuild_cons env nb_args relname args crossed_types rt = +let rebuild_cons env nb_args relname args crossed_types rt = (* observennl (str "rebuild_cons : rt := "++ pr_rawconstr rt ++ *) (* str "nb_args := " ++ str (string_of_int nb_args)); *) - let res = - rebuild_cons env nb_args relname args crossed_types 0 rt + let res = + rebuild_cons env nb_args relname args crossed_types 0 rt in (* observe (str " leads to "++ pr_rawconstr (fst res)); *) res -(* naive implementation of parameter detection. +(* naive implementation of parameter detection. - A parameter is an argument which is only preceded by parameters and whose - calls are all syntaxically equal. + A parameter is an argument which is only preceded by parameters and whose + calls are all syntaxically equal. - TODO: Find a valid way to deal with implicit arguments here! + TODO: Find a valid way to deal with implicit arguments here! *) -let rec compute_cst_params relnames params = function +let rec compute_cst_params relnames params = function | RRef _ | RVar _ | REvar _ | RPatVar _ -> params | RApp(_,RVar(_,relname'),rtl) when Idset.mem relname' relnames -> compute_cst_params_from_app [] (params,rtl) - | RApp(_,f,args) -> + | RApp(_,f,args) -> List.fold_left (compute_cst_params relnames) params (f::args) - | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> - let t_params = compute_cst_params relnames params t in + | RLambda(_,_,_,t,b) | RProd(_,_,_,t,b) | RLetIn(_,_,t,b) | RLetTuple(_,_,_,t,b) -> + let t_params = compute_cst_params relnames params t in compute_cst_params relnames t_params b | RCases _ -> - params (* If there is still cases at this point they can only be + params (* If there is still cases at this point they can only be discriminitation ones *) | RSort _ -> params | RHole _ -> params | RIf _ | RRec _ | RCast _ | RDynamic _ -> raise (UserError("compute_cst_params", str "Not handled case")) -and compute_cst_params_from_app acc (params,rtl) = - match params,rtl with +and compute_cst_params_from_app acc (params,rtl) = + match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' - when id_ord id id' == 0 && not is_defined -> + | ((Name id,_,is_defined) as param)::params',(RVar(_,id'))::rtl' + when id_ord id id' == 0 && not is_defined -> compute_cst_params_from_app (param::acc) (params',rtl') - | _ -> List.rev acc - -let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts = - let rels_params = - Array.mapi - (fun i args -> - List.fold_left - (fun params (_,cst) -> compute_cst_params relnames params cst) + | _ -> List.rev acc + +let compute_params_name relnames (args : (Names.name * Rawterm.rawconstr * bool) list array) csts = + let rels_params = + Array.mapi + (fun i args -> + List.fold_left + (fun params (_,cst) -> compute_cst_params relnames params cst) args csts.(i) ) args - in - let l = ref [] in - let _ = - try + in + let l = ref [] in + let _ = + try list_iter_i - (fun i ((n,nt,is_defined) as param) -> - if array_for_all - (fun l -> - let (n',nt',is_defined') = List.nth l i in + (fun i ((n,nt,is_defined) as param) -> + if array_for_all + (fun l -> + let (n',nt',is_defined') = List.nth l i in n = n' && Topconstr.eq_rawconstr nt nt' && is_defined = is_defined') rels_params - then + then l := param::!l - ) + ) rels_params.(0) - with _ -> + with _ -> () - in + in List.rev !l -let rec rebuild_return_type rt = - match rt with - | Topconstr.CProdN(loc,n,t') -> - Topconstr.CProdN(loc,n,rebuild_return_type t') - | Topconstr.CArrow(loc,t,t') -> +let rec rebuild_return_type rt = + match rt with + | Topconstr.CProdN(loc,n,t') -> + Topconstr.CProdN(loc,n,rebuild_return_type t') + | Topconstr.CArrow(loc,t,t') -> Topconstr.CArrow(loc,t,rebuild_return_type t') - | Topconstr.CLetIn(loc,na,t,t') -> - Topconstr.CLetIn(loc,na,t,rebuild_return_type t') + | Topconstr.CLetIn(loc,na,t,t') -> + Topconstr.CLetIn(loc,na,t,rebuild_return_type t') | _ -> Topconstr.CArrow(dummy_loc,rt,Topconstr.CSort(dummy_loc,RType None)) -let do_build_inductive - funnames (funsargs: (Names.name * rawconstr * bool) list list) - returned_types +let do_build_inductive + funnames (funsargs: (Names.name * rawconstr * bool) list list) + returned_types (rtl:rawconstr list) = let _time1 = System.get_time () in (* Pp.msgnl (prlist_with_sep fnl Printer.pr_rawconstr rtl); *) let funnames_as_set = List.fold_right Idset.add funnames Idset.empty in - let funnames = Array.of_list funnames in - let funsargs = Array.of_list funsargs in + let funnames = Array.of_list funnames in + let funsargs = Array.of_list funsargs in let returned_types = Array.of_list returned_types in (* alpha_renaming of the body to prevent variable capture during manipulation *) let rtl_alpha = List.map (function rt -> expand_as (alpha_rt [] rt)) rtl in let rta = Array.of_list rtl_alpha in (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious - i*) + i*) let relnames = Array.map mk_rel_id funnames in - let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in + let relnames_as_set = Array.fold_right Idset.add relnames Idset.empty in (* Construction of the pseudo constructors *) - let env = - Array.fold_right - (fun id env -> + let env = + Array.fold_right + (fun id env -> Environ.push_named (id,None,Typing.type_of env Evd.empty (Tacinterp.constr_of_id env id)) env ) - funnames + funnames (Global.env ()) - in - let resa = Array.map (build_entry_lc env funnames_as_set []) rta in - let env_with_graphs = + in + let resa = Array.map (build_entry_lc env funnames_as_set []) rta in + let env_with_graphs = let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = + let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = funargs - in + in List.fold_right - (fun (n,t,is_defined) acc -> + (fun (n,t,is_defined) acc -> if is_defined - then + then Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t, acc) else @@ -1240,40 +1240,40 @@ let do_build_inductive rel_first_args (rebuild_return_type returned_types.(i)) in - (* We need to lift back our work topconstr but only with all information - We mimick a Set Printing All. - Then save the graphs and reset Printing options to their primitive values + (* We need to lift back our work topconstr but only with all information + We mimick a Set Printing All. + Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in - Util.array_fold_left2 (fun env rel_name rel_ar -> + Util.array_fold_left2 (fun env rel_name rel_ar -> Environ.push_named (rel_name,None, Constrintern.interp_constr Evd.empty env rel_ar) env) env relnames rel_arities in (* and of the real constructors*) - let constr i res = - List.map - (function result (* (args',concl') *) -> - let rt = compose_raw_context result.context result.value in - let nb_args = List.length funsargs.(i) in + let constr i res = + List.map + (function result (* (args',concl') *) -> + let rt = compose_raw_context result.context result.value in + let nb_args = List.length funsargs.(i) in (* with_full_print (fun rt -> Pp.msgnl (str "raw constr " ++ pr_rawconstr rt)) rt; *) fst ( rebuild_cons env_with_graphs nb_args relnames.(i) [] [] - rt + rt ) - ) - res.result - in + ) + res.result + in (* adding names to constructors *) - let next_constructor_id = ref (-1) in - let mk_constructor_id i = + let next_constructor_id = ref (-1) in + let mk_constructor_id i = incr next_constructor_id; (*i The next call to mk_rel_id is valid since we are constructing the graph Ensures by: obvious - i*) + i*) id_of_string ((string_of_id (mk_rel_id funnames.(i)))^"_"^(string_of_int !next_constructor_id)) in - let rel_constructors i rt : (identifier*rawconstr) list = + let rel_constructors i rt : (identifier*rawconstr) list = next_constructor_id := (-1); List.map (fun constr -> (mk_constructor_id i),constr) (constr i rt) in @@ -1282,18 +1282,18 @@ let do_build_inductive let rels_params = compute_params_name relnames_as_set funsargs rel_constructors in let nrel_params = List.length rels_params in let rel_constructors = (* Taking into account the parameters in constructors *) - Array.map (List.map + Array.map (List.map (fun (id,rt) -> (id,snd (chop_rprod_n nrel_params rt)))) rel_constructors in let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = + let rel_first_args :(Names.name * Rawterm.rawconstr * bool ) list = (snd (list_chop nrel_params funargs)) - in + in List.fold_right - (fun (n,t,is_defined) acc -> + (fun (n,t,is_defined) acc -> if is_defined - then + then Topconstr.CLetIn(dummy_loc,(dummy_loc, n),Constrextern.extern_rawconstr Idset.empty t, acc) else @@ -1306,26 +1306,26 @@ let do_build_inductive rel_first_args (rebuild_return_type returned_types.(i)) in - (* We need to lift back our work topconstr but only with all information - We mimick a Set Printing All. - Then save the graphs and reset Printing options to their primitive values + (* We need to lift back our work topconstr but only with all information + We mimick a Set Printing All. + Then save the graphs and reset Printing options to their primitive values *) let rel_arities = Array.mapi rel_arity funsargs in - let rel_params = - List.map - (fun (n,t,is_defined) -> - if is_defined + let rel_params = + List.map + (fun (n,t,is_defined) -> + if is_defined then Topconstr.LocalRawDef((dummy_loc,n), Constrextern.extern_rawconstr Idset.empty t) else - Topconstr.LocalRawAssum + Topconstr.LocalRawAssum ([(dummy_loc,n)], Topconstr.default_binder_kind, Constrextern.extern_rawconstr Idset.empty t) ) rels_params - in - let ext_rels_constructors = - Array.map (List.map - (fun (id,t) -> + in + let ext_rels_constructors = + Array.map (List.map + (fun (id,t) -> false,((dummy_loc,id), Flags.with_option Flags.raw_print @@ -1334,14 +1334,14 @@ let do_build_inductive )) (rel_constructors) in - let rel_ind i ext_rel_constructors = + let rel_ind i ext_rel_constructors = ((dummy_loc,relnames.(i)), rel_params, Some rel_arities.(i), ext_rel_constructors),None in - let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in - let rel_inds = Array.to_list ext_rel_constructors in + let ext_rel_constructors = (Array.mapi rel_ind ext_rels_constructors) in + let rel_inds = Array.to_list ext_rel_constructors in (* let _ = *) (* Pp.msgnl (\* observe *\) ( *) (* str "Inductive" ++ spc () ++ *) @@ -1362,18 +1362,18 @@ let do_build_inductive (* rel_inds *) (* ) *) (* in *) - let _time2 = System.get_time () in - try + let _time2 = System.get_time () in + try with_full_print (Flags.silently (Command.build_mutual rel_inds)) true - with + with | UserError(s,msg) as e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = + let repacked_rel_inds = List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in - let msg = + let msg = str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ @@ -1381,16 +1381,16 @@ let do_build_inductive in observe (msg); raise e - | e -> + | e -> let _time3 = System.get_time () in (* Pp.msgnl (str "error : "++ str (string_of_float (System.time_difference time2 time3))); *) - let repacked_rel_inds = + let repacked_rel_inds = List.map (fun ((a , b , c , l),ntn) -> ((false,a) , b, c , Vernacexpr.Inductive_kw, Vernacexpr.Constructors l),ntn ) rel_inds in - let msg = + let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(Decl_kinds.Finite,false,repacked_rel_inds)) ++ fnl () ++ Cerrors.explain_exn e in @@ -1399,9 +1399,9 @@ let do_build_inductive -let build_inductive funnames funsargs returned_types rtl = - try +let build_inductive funnames funsargs returned_types rtl = + try do_build_inductive funnames funsargs returned_types rtl with e -> raise (Building_graph e) - + diff --git a/plugins/funind/rawterm_to_relation.mli b/plugins/funind/rawterm_to_relation.mli index 0075fb0a07..a314050f73 100644 --- a/plugins/funind/rawterm_to_relation.mli +++ b/plugins/funind/rawterm_to_relation.mli @@ -2,8 +2,8 @@ (* - [build_inductive parametrize funnames funargs returned_types bodies] - constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments + [build_inductive parametrize funnames funargs returned_types bodies] + constructs and saves the graphs of the functions [funnames] taking [funargs] as arguments and returning [returned_types] using bodies [bodies] *) diff --git a/plugins/funind/rawtermops.ml b/plugins/funind/rawtermops.ml index 92396af590..502960a144 100644 --- a/plugins/funind/rawtermops.ml +++ b/plugins/funind/rawtermops.ml @@ -1,11 +1,11 @@ -open Pp +open Pp open Rawterm open Util open Names (* Ocaml 3.06 Map.S does not handle is_empty *) let idmap_is_empty m = m = Idmap.empty -(* +(* Some basic functions to rebuild rawconstr In each of them the location is Util.dummy_loc *) @@ -24,152 +24,152 @@ let mkRCast(b,t) = RCast(dummy_loc,b,CastConv (Term.DEFAULTcast,t)) Some basic functions to decompose rawconstrs These are analogous to the ones constrs *) -let raw_decompose_prod = - let rec raw_decompose_prod args = function - | RProd(_,n,k,t,b) -> - raw_decompose_prod ((n,t)::args) b +let raw_decompose_prod = + let rec raw_decompose_prod args = function + | RProd(_,n,k,t,b) -> + raw_decompose_prod ((n,t)::args) b | rt -> args,rt in raw_decompose_prod [] -let raw_decompose_prod_or_letin = - let rec raw_decompose_prod args = function - | RProd(_,n,k,t,b) -> - raw_decompose_prod ((n,None,Some t)::args) b - | RLetIn(_,n,t,b) -> - raw_decompose_prod ((n,Some t,None)::args) b +let raw_decompose_prod_or_letin = + let rec raw_decompose_prod args = function + | RProd(_,n,k,t,b) -> + raw_decompose_prod ((n,None,Some t)::args) b + | RLetIn(_,n,t,b) -> + raw_decompose_prod ((n,Some t,None)::args) b | rt -> args,rt in raw_decompose_prod [] -let raw_compose_prod = +let raw_compose_prod = List.fold_left (fun b (n,t) -> mkRProd(n,t,b)) -let raw_compose_prod_or_letin = +let raw_compose_prod_or_letin = List.fold_left ( - fun concl decl -> - match decl with + fun concl decl -> + match decl with | (n,None,Some t) -> mkRProd(n,t,concl) | (n,Some bdy,None) -> mkRLetIn(n,bdy,concl) | _ -> assert false) -let raw_decompose_prod_n n = - let rec raw_decompose_prod i args c = +let raw_decompose_prod_n n = + let rec raw_decompose_prod i args c = if i<=0 then args,c else match c with - | RProd(_,n,_,t,b) -> - raw_decompose_prod (i-1) ((n,t)::args) b + | RProd(_,n,_,t,b) -> + raw_decompose_prod (i-1) ((n,t)::args) b | rt -> args,rt in raw_decompose_prod n [] -let raw_decompose_prod_or_letin_n n = - let rec raw_decompose_prod i args c = +let raw_decompose_prod_or_letin_n n = + let rec raw_decompose_prod i args c = if i<=0 then args,c else match c with - | RProd(_,n,_,t,b) -> - raw_decompose_prod (i-1) ((n,None,Some t)::args) b - | RLetIn(_,n,t,b) -> - raw_decompose_prod (i-1) ((n,Some t,None)::args) b + | RProd(_,n,_,t,b) -> + raw_decompose_prod (i-1) ((n,None,Some t)::args) b + | RLetIn(_,n,t,b) -> + raw_decompose_prod (i-1) ((n,Some t,None)::args) b | rt -> args,rt in raw_decompose_prod n [] -let raw_decompose_app = +let raw_decompose_app = let rec decompose_rapp acc rt = (* msgnl (str "raw_decompose_app on : "++ Printer.pr_rawconstr rt); *) - match rt with - | RApp(_,rt,rtl) -> + match rt with + | RApp(_,rt,rtl) -> decompose_rapp (List.fold_left (fun y x -> x::y) acc rtl) rt | rt -> rt,List.rev acc in - decompose_rapp [] + decompose_rapp [] -(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) -let raw_make_eq ?(typ= mkRHole ()) t1 t2 = +(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) +let raw_make_eq ?(typ= mkRHole ()) t1 t2 = mkRApp(mkRRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) -(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) -let raw_make_neq t1 t2 = +(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) +let raw_make_neq t1 t2 = mkRApp(mkRRef (Lazy.force Coqlib.coq_not_ref),[raw_make_eq t1 t2]) -(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) +(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) let raw_make_or t1 t2 = mkRApp (mkRRef(Lazy.force Coqlib.coq_or_ref),[t1;t2]) -(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding - to [P1 \/ ( .... \/ Pn)] -*) -let rec raw_make_or_list = function +(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding + to [P1 \/ ( .... \/ Pn)] +*) +let rec raw_make_or_list = function | [] -> raise (Invalid_argument "mk_or") | [e] -> e | e::l -> raw_make_or e (raw_make_or_list l) - -let remove_name_from_mapping mapping na = - match na with - | Anonymous -> mapping + +let remove_name_from_mapping mapping na = + match na with + | Anonymous -> mapping | Name id -> Idmap.remove id mapping -let change_vars = - let rec change_vars mapping rt = - match rt with - | RRef _ -> rt - | RVar(loc,id) -> - let new_id = - try - Idmap.find id mapping - with Not_found -> id +let change_vars = + let rec change_vars mapping rt = + match rt with + | RRef _ -> rt + | RVar(loc,id) -> + let new_id = + try + Idmap.find id mapping + with Not_found -> id in RVar(loc,new_id) - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> + | REvar _ -> rt + | RPatVar _ -> rt + | RApp(loc,rt',rtl) -> RApp(loc, change_vars mapping rt', List.map (change_vars mapping) rtl ) - | RLambda(loc,name,k,t,b) -> + | RLambda(loc,name,k,t,b) -> RLambda(loc, name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) - | RProd(loc,name,k,t,b) -> + | RProd(loc,name,k,t,b) -> RProd(loc, name, k, change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) - | RLetIn(loc,name,def,b) -> + | RLetIn(loc,name,def,b) -> RLetIn(loc, name, change_vars mapping def, change_vars (remove_name_from_mapping mapping name) b ) - | RLetTuple(loc,nal,(na,rto),b,e) -> - let new_mapping = List.fold_left remove_name_from_mapping mapping nal in + | RLetTuple(loc,nal,(na,rto),b,e) -> + let new_mapping = List.fold_left remove_name_from_mapping mapping nal in RLetTuple(loc, nal, - (na, Option.map (change_vars mapping) rto), - change_vars mapping b, + (na, Option.map (change_vars mapping) rto), + change_vars mapping b, change_vars new_mapping e ) - | RCases(loc,sty,infos,el,brl) -> + | RCases(loc,sty,infos,el,brl) -> RCases(loc,sty, infos, - List.map (fun (e,x) -> (change_vars mapping e,x)) el, + List.map (fun (e,x) -> (change_vars mapping e,x)) el, List.map (change_vars_br mapping) brl ) - | RIf(loc,b,(na,e_option),lhs,rhs) -> + | RIf(loc,b,(na,e_option),lhs,rhs) -> RIf(loc, change_vars mapping b, (na,Option.map (change_vars mapping) e_option), @@ -177,211 +177,211 @@ let change_vars = change_vars mapping rhs ) | RRec _ -> error "Local (co)fixes are not supported" - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv (k,t)) -> + | RSort _ -> rt + | RHole _ -> rt + | RCast(loc,b,CastConv (k,t)) -> RCast(loc,change_vars mapping b, CastConv (k,change_vars mapping t)) - | RCast(loc,b,CastCoerce) -> + | RCast(loc,b,CastCoerce) -> RCast(loc,change_vars mapping b,CastCoerce) | RDynamic _ -> error "Not handled RDynamic" - and change_vars_br mapping ((loc,idl,patl,res) as br) = - let new_mapping = List.fold_right Idmap.remove idl mapping in - if idmap_is_empty new_mapping - then br + and change_vars_br mapping ((loc,idl,patl,res) as br) = + let new_mapping = List.fold_right Idmap.remove idl mapping in + if idmap_is_empty new_mapping + then br else (loc,idl,patl,change_vars new_mapping res) in - change_vars + change_vars -let rec alpha_pat excluded pat = - match pat with - | PatVar(loc,Anonymous) -> - let new_id = Indfun_common.fresh_id excluded "_x" in +let rec alpha_pat excluded pat = + match pat with + | PatVar(loc,Anonymous) -> + let new_id = Indfun_common.fresh_id excluded "_x" in PatVar(loc,Name new_id),(new_id::excluded),Idmap.empty - | PatVar(loc,Name id) -> - if List.mem id excluded - then - let new_id = Nameops.next_ident_away id excluded in + | PatVar(loc,Name id) -> + if List.mem id excluded + then + let new_id = Nameops.next_ident_away id excluded in PatVar(loc,Name new_id),(new_id::excluded), (Idmap.add id new_id Idmap.empty) else pat,excluded,Idmap.empty - | PatCstr(loc,constr,patl,na) -> - let new_na,new_excluded,map = - match na with - | Name id when List.mem id excluded -> - let new_id = Nameops.next_ident_away id excluded in + | PatCstr(loc,constr,patl,na) -> + let new_na,new_excluded,map = + match na with + | Name id when List.mem id excluded -> + let new_id = Nameops.next_ident_away id excluded in Name new_id,new_id::excluded, Idmap.add id new_id Idmap.empty | _ -> na,excluded,Idmap.empty - in - let new_patl,new_excluded,new_map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in + in + let new_patl,new_excluded,new_map = + List.fold_left + (fun (patl,excluded,map) pat -> + let new_pat,new_excluded,new_map = alpha_pat excluded pat in (new_pat::patl,new_excluded,Idmap.fold Idmap.add new_map map) ) ([],new_excluded,map) patl - in + in PatCstr(loc,constr,List.rev new_patl,new_na),new_excluded,new_map -let alpha_patl excluded patl = - let patl,new_excluded,map = - List.fold_left - (fun (patl,excluded,map) pat -> - let new_pat,new_excluded,new_map = alpha_pat excluded pat in +let alpha_patl excluded patl = + let patl,new_excluded,map = + List.fold_left + (fun (patl,excluded,map) pat -> + let new_pat,new_excluded,new_map = alpha_pat excluded pat in new_pat::patl,new_excluded,(Idmap.fold Idmap.add new_map map) ) ([],excluded,Idmap.empty) patl - in + in (List.rev patl,new_excluded,map) - -let raw_get_pattern_id pat acc = - let rec get_pattern_id pat = - match pat with + +let raw_get_pattern_id pat acc = + let rec get_pattern_id pat = + match pat with | PatVar(loc,Anonymous) -> assert false - | PatVar(loc,Name id) -> + | PatVar(loc,Name id) -> [id] - | PatCstr(loc,constr,patternl,_) -> - List.fold_right - (fun pat idl -> - let idl' = get_pattern_id pat in + | PatCstr(loc,constr,patternl,_) -> + List.fold_right + (fun pat idl -> + let idl' = get_pattern_id pat in idl'@idl ) - patternl + patternl [] in (get_pattern_id pat)@acc let get_pattern_id pat = raw_get_pattern_id pat [] - -let rec alpha_rt excluded rt = - let new_rt = - match rt with + +let rec alpha_rt excluded rt = + let new_rt = + match rt with | RRef _ | RVar _ | REvar _ | RPatVar _ -> rt - | RLambda(loc,Anonymous,k,t,b) -> - let new_id = Nameops.next_ident_away (id_of_string "_x") excluded in - let new_excluded = new_id :: excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in + | RLambda(loc,Anonymous,k,t,b) -> + let new_id = Nameops.next_ident_away (id_of_string "_x") excluded in + let new_excluded = new_id :: excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in RLambda(loc,Name new_id,k,new_t,new_b) - | RProd(loc,Anonymous,k,t,b) -> - let new_t = alpha_rt excluded t in - let new_b = alpha_rt excluded b in + | RProd(loc,Anonymous,k,t,b) -> + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in RProd(loc,Anonymous,k,new_t,new_b) - | RLetIn(loc,Anonymous,t,b) -> - let new_t = alpha_rt excluded t in - let new_b = alpha_rt excluded b in + | RLetIn(loc,Anonymous,t,b) -> + let new_t = alpha_rt excluded t in + let new_b = alpha_rt excluded b in RLetIn(loc,Anonymous,new_t,new_b) - | RLambda(loc,Name id,k,t,b) -> - let new_id = Nameops.next_ident_away id excluded in - let t,b = - if new_id = id + | RLambda(loc,Name id,k,t,b) -> + let new_id = Nameops.next_ident_away id excluded in + let t,b = + if new_id = id then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in (t,replace b) in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in + let new_excluded = new_id::excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in RLambda(loc,Name new_id,k,new_t,new_b) - | RProd(loc,Name id,k,t,b) -> - let new_id = Nameops.next_ident_away id excluded in - let new_excluded = new_id::excluded in - let t,b = - if new_id = id + | RProd(loc,Name id,k,t,b) -> + let new_id = Nameops.next_ident_away id excluded in + let new_excluded = new_id::excluded in + let t,b = + if new_id = id then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in (t,replace b) in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in RProd(loc,Name new_id,k,new_t,new_b) - | RLetIn(loc,Name id,t,b) -> - let new_id = Nameops.next_ident_away id excluded in - let t,b = - if new_id = id + | RLetIn(loc,Name id,t,b) -> + let new_id = Nameops.next_ident_away id excluded in + let t,b = + if new_id = id then t,b - else - let replace = change_vars (Idmap.add id new_id Idmap.empty) in + else + let replace = change_vars (Idmap.add id new_id Idmap.empty) in (t,replace b) in - let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in - let new_b = alpha_rt new_excluded b in + let new_excluded = new_id::excluded in + let new_t = alpha_rt new_excluded t in + let new_b = alpha_rt new_excluded b in RLetIn(loc,Name new_id,new_t,new_b) - | RLetTuple(loc,nal,(na,rto),t,b) -> - let rev_new_nal,new_excluded,mapping = - List.fold_left - (fun (nal,excluded,mapping) na -> - match na with + | RLetTuple(loc,nal,(na,rto),t,b) -> + let rev_new_nal,new_excluded,mapping = + List.fold_left + (fun (nal,excluded,mapping) na -> + match na with | Anonymous -> (na::nal,excluded,mapping) - | Name id -> - let new_id = Nameops.next_ident_away id excluded in - if new_id = id - then - na::nal,id::excluded,mapping - else + | Name id -> + let new_id = Nameops.next_ident_away id excluded in + if new_id = id + then + na::nal,id::excluded,mapping + else (Name new_id)::nal,id::excluded,(Idmap.add id new_id mapping) ) ([],excluded,Idmap.empty) nal in - let new_nal = List.rev rev_new_nal in - let new_rto,new_t,new_b = + let new_nal = List.rev rev_new_nal in + let new_rto,new_t,new_b = if idmap_is_empty mapping then rto,t,b - else let replace = change_vars mapping in + else let replace = change_vars mapping in (Option.map replace rto, t,replace b) in - let new_t = alpha_rt new_excluded new_t in - let new_b = alpha_rt new_excluded new_b in + let new_t = alpha_rt new_excluded new_t in + let new_b = alpha_rt new_excluded new_b in let new_rto = Option.map (alpha_rt new_excluded) new_rto in RLetTuple(loc,new_nal,(na,new_rto),new_t,new_b) - | RCases(loc,sty,infos,el,brl) -> - let new_el = - List.map (function (rt,i) -> alpha_rt excluded rt, i) el - in - RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) - | RIf(loc,b,(na,e_o),lhs,rhs) -> + | RCases(loc,sty,infos,el,brl) -> + let new_el = + List.map (function (rt,i) -> alpha_rt excluded rt, i) el + in + RCases(loc,sty,infos,new_el,List.map (alpha_br excluded) brl) + | RIf(loc,b,(na,e_o),lhs,rhs) -> RIf(loc,alpha_rt excluded b, (na,Option.map (alpha_rt excluded) e_o), alpha_rt excluded lhs, alpha_rt excluded rhs ) | RRec _ -> error "Not handled RRec" - | RSort _ -> rt - | RHole _ -> rt - | RCast (loc,b,CastConv (k,t)) -> + | RSort _ -> rt + | RHole _ -> rt + | RCast (loc,b,CastConv (k,t)) -> RCast(loc,alpha_rt excluded b,CastConv(k,alpha_rt excluded t)) - | RCast (loc,b,CastCoerce) -> + | RCast (loc,b,CastCoerce) -> RCast(loc,alpha_rt excluded b,CastCoerce) | RDynamic _ -> error "Not handled RDynamic" - | RApp(loc,f,args) -> + | RApp(loc,f,args) -> RApp(loc, alpha_rt excluded f, List.map (alpha_rt excluded) args ) - in + in new_rt -and alpha_br excluded (loc,ids,patl,res) = - let new_patl,new_excluded,mapping = alpha_patl excluded patl in - let new_ids = List.fold_right raw_get_pattern_id new_patl [] in - let new_excluded = new_ids@excluded in - let renamed_res = change_vars mapping res in - let new_res = alpha_rt new_excluded renamed_res in +and alpha_br excluded (loc,ids,patl,res) = + let new_patl,new_excluded,mapping = alpha_patl excluded patl in + let new_ids = List.fold_right raw_get_pattern_id new_patl [] in + let new_excluded = new_ids@excluded in + let renamed_res = change_vars mapping res in + let new_res = alpha_rt new_excluded renamed_res in (loc,new_ids,new_patl,new_res) - -(* + +(* [is_free_in id rt] checks if [id] is a free variable in [rt] *) let is_free_in id = @@ -401,12 +401,12 @@ let is_free_in id = | RCases(_,_,_,el,brl) -> (List.exists (fun (e,_) -> is_free_in e) el) || List.exists is_free_in_br brl - | RLetTuple(_,nal,_,b,t) -> - let check_in_nal = - not (List.exists (function Name id' -> id'= id | _ -> false) nal) - in + | RLetTuple(_,nal,_,b,t) -> + let check_in_nal = + not (List.exists (function Name id' -> id'= id | _ -> false) nal) + in is_free_in t || (check_in_nal && is_free_in b) - + | RIf(_,cond,_,br1,br2) -> is_free_in cond || is_free_in br1 || is_free_in br2 | RRec _ -> raise (UserError("",str "Not handled RRec")) @@ -419,7 +419,7 @@ let is_free_in id = (not (List.mem id ids)) && is_free_in rt in is_free_in - + let rec pattern_to_term = function @@ -446,23 +446,23 @@ let rec pattern_to_term = function implicit_args@patl_as_term ) - -let replace_var_by_term x_id term = - let rec replace_var_by_pattern rt = - match rt with - | RRef _ -> rt + +let replace_var_by_term x_id term = + let rec replace_var_by_pattern rt = + match rt with + | RRef _ -> rt | RVar(_,id) when id_ord id x_id == 0 -> term - | RVar _ -> rt - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> + | RVar _ -> rt + | REvar _ -> rt + | RPatVar _ -> rt + | RApp(loc,rt',rtl) -> RApp(loc, replace_var_by_pattern rt', List.map replace_var_by_pattern rtl ) | RLambda(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt - | RLambda(loc,name,k,t,b) -> + | RLambda(loc,name,k,t,b) -> RLambda(loc, name, k, @@ -470,7 +470,7 @@ let replace_var_by_term x_id term = replace_var_by_pattern b ) | RProd(_,Name id,_,_,_) when id_ord id x_id == 0 -> rt - | RProd(loc,name,k,t,b) -> + | RProd(loc,name,k,t,b) -> RProd(loc, name, k, @@ -478,94 +478,94 @@ let replace_var_by_term x_id term = replace_var_by_pattern b ) | RLetIn(_,Name id,_,_) when id_ord id x_id == 0 -> rt - | RLetIn(loc,name,def,b) -> + | RLetIn(loc,name,def,b) -> RLetIn(loc, name, replace_var_by_pattern def, replace_var_by_pattern b ) - | RLetTuple(_,nal,_,_,_) - when List.exists (function Name id -> id = x_id | _ -> false) nal -> + | RLetTuple(_,nal,_,_,_) + when List.exists (function Name id -> id = x_id | _ -> false) nal -> rt - | RLetTuple(loc,nal,(na,rto),def,b) -> + | RLetTuple(loc,nal,(na,rto),def,b) -> RLetTuple(loc, nal, (na,Option.map replace_var_by_pattern rto), replace_var_by_pattern def, replace_var_by_pattern b ) - | RCases(loc,sty,infos,el,brl) -> + | RCases(loc,sty,infos,el,brl) -> RCases(loc,sty, infos, - List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, + List.map (fun (e,x) -> (replace_var_by_pattern e,x)) el, List.map replace_var_by_pattern_br brl ) - | RIf(loc,b,(na,e_option),lhs,rhs) -> + | RIf(loc,b,(na,e_option),lhs,rhs) -> RIf(loc, replace_var_by_pattern b, (na,Option.map replace_var_by_pattern e_option), replace_var_by_pattern lhs, replace_var_by_pattern rhs ) | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv(k,t)) -> + | RSort _ -> rt + | RHole _ -> rt + | RCast(loc,b,CastConv(k,t)) -> RCast(loc,replace_var_by_pattern b,CastConv(k,replace_var_by_pattern t)) - | RCast(loc,b,CastCoerce) -> + | RCast(loc,b,CastCoerce) -> RCast(loc,replace_var_by_pattern b,CastCoerce) | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) - and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = - if List.exists (fun id -> id_ord id x_id == 0) idl - then br + and replace_var_by_pattern_br ((loc,idl,patl,res) as br) = + if List.exists (fun id -> id_ord id x_id == 0) idl + then br else (loc,idl,patl,replace_var_by_pattern res) in - replace_var_by_pattern + replace_var_by_pattern -(* checking unifiability of patterns *) -exception NotUnifiable +(* checking unifiability of patterns *) +exception NotUnifiable -let rec are_unifiable_aux = function - | [] -> () - | eq::eqs -> - match eq with - | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 +let rec are_unifiable_aux = function + | [] -> () + | eq::eqs -> + match eq with + | PatVar _,_ | _,PatVar _ -> are_unifiable_aux eqs + | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + if constructor2 <> constructor1 then raise NotUnifiable - else - let eqs' = + else + let eqs' = try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "are_unifiable_aux" + with _ -> anomaly "are_unifiable_aux" in are_unifiable_aux eqs' - -let are_unifiable pat1 pat2 = - try + +let are_unifiable pat1 pat2 = + try are_unifiable_aux [pat1,pat2]; true with NotUnifiable -> false -let rec eq_cases_pattern_aux = function - | [] -> () - | eq::eqs -> - match eq with - | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs - | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> - if constructor2 <> constructor1 +let rec eq_cases_pattern_aux = function + | [] -> () + | eq::eqs -> + match eq with + | PatVar _,PatVar _ -> eq_cases_pattern_aux eqs + | PatCstr(_,constructor1,cpl1,_),PatCstr(_,constructor2,cpl2,_) -> + if constructor2 <> constructor1 then raise NotUnifiable - else - let eqs' = + else + let eqs' = try ((List.combine cpl1 cpl2)@eqs) - with _ -> anomaly "eq_cases_pattern_aux" + with _ -> anomaly "eq_cases_pattern_aux" in eq_cases_pattern_aux eqs' | _ -> raise NotUnifiable -let eq_cases_pattern pat1 pat2 = +let eq_cases_pattern pat1 pat2 = try eq_cases_pattern_aux [pat1,pat2]; true @@ -573,25 +573,25 @@ let eq_cases_pattern pat1 pat2 = -let ids_of_pat = - let rec ids_of_pat ids = function - | PatVar(_,Anonymous) -> ids - | PatVar(_,Name id) -> Idset.add id ids +let ids_of_pat = + let rec ids_of_pat ids = function + | PatVar(_,Anonymous) -> ids + | PatVar(_,Name id) -> Idset.add id ids | PatCstr(_,_,patl,_) -> List.fold_left ids_of_pat ids patl in - ids_of_pat Idset.empty - -let id_of_name = function - | Names.Anonymous -> id_of_string "x" + ids_of_pat Idset.empty + +let id_of_name = function + | Names.Anonymous -> id_of_string "x" | Names.Name x -> x (* TODO: finish Rec caes *) -let ids_of_rawterm c = - let rec ids_of_rawterm acc c = +let ids_of_rawterm c = + let rec ids_of_rawterm acc c = let idof = id_of_name in match c with | RVar (_,id) -> id::acc - | RApp (loc,g,args) -> + | RApp (loc,g,args) -> ids_of_rawterm [] g @ List.flatten (List.map (ids_of_rawterm []) args) @ acc | RLambda (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc | RProd (loc,na,k,ty,c) -> idof na :: ids_of_rawterm [] ty @ ids_of_rawterm [] c @ acc @@ -599,101 +599,101 @@ let ids_of_rawterm c = | RCast (loc,c,CastConv(k,t)) -> ids_of_rawterm [] c @ ids_of_rawterm [] t @ acc | RCast (loc,c,CastCoerce) -> ids_of_rawterm [] c @ acc | RIf (loc,c,(na,po),b1,b2) -> ids_of_rawterm [] c @ ids_of_rawterm [] b1 @ ids_of_rawterm [] b2 @ acc - | RLetTuple (_,nal,(na,po),b,c) -> + | RLetTuple (_,nal,(na,po),b,c) -> List.map idof nal @ ids_of_rawterm [] b @ ids_of_rawterm [] c @ acc - | RCases (loc,sty,rtntypopt,tml,brchl) -> + | RCases (loc,sty,rtntypopt,tml,brchl) -> List.flatten (List.map (fun (_,idl,patl,c) -> idl @ ids_of_rawterm [] c) brchl) | RRec _ -> failwith "Fix inside a constructor branch" | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> [] in (* build the set *) List.fold_left (fun acc x -> Idset.add x acc) Idset.empty (ids_of_rawterm [] c) - -let zeta_normalize = - let rec zeta_normalize_term rt = - match rt with - | RRef _ -> rt - | RVar _ -> rt - | REvar _ -> rt - | RPatVar _ -> rt - | RApp(loc,rt',rtl) -> + +let zeta_normalize = + let rec zeta_normalize_term rt = + match rt with + | RRef _ -> rt + | RVar _ -> rt + | REvar _ -> rt + | RPatVar _ -> rt + | RApp(loc,rt',rtl) -> RApp(loc, zeta_normalize_term rt', List.map zeta_normalize_term rtl ) - | RLambda(loc,name,k,t,b) -> + | RLambda(loc,name,k,t,b) -> RLambda(loc, name, k, zeta_normalize_term t, zeta_normalize_term b ) - | RProd(loc,name,k,t,b) -> + | RProd(loc,name,k,t,b) -> RProd(loc, - name, + name, k, zeta_normalize_term t, zeta_normalize_term b ) - | RLetIn(_,Name id,def,b) -> + | RLetIn(_,Name id,def,b) -> zeta_normalize_term (replace_var_by_term id def b) | RLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b - | RLetTuple(loc,nal,(na,rto),def,b) -> + | RLetTuple(loc,nal,(na,rto),def,b) -> RLetTuple(loc, nal, (na,Option.map zeta_normalize_term rto), zeta_normalize_term def, zeta_normalize_term b ) - | RCases(loc,sty,infos,el,brl) -> + | RCases(loc,sty,infos,el,brl) -> RCases(loc,sty, infos, - List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, + List.map (fun (e,x) -> (zeta_normalize_term e,x)) el, List.map zeta_normalize_br brl ) - | RIf(loc,b,(na,e_option),lhs,rhs) -> + | RIf(loc,b,(na,e_option),lhs,rhs) -> RIf(loc, zeta_normalize_term b, (na,Option.map zeta_normalize_term e_option), zeta_normalize_term lhs, zeta_normalize_term rhs ) | RRec _ -> raise (UserError("",str "Not handled RRec")) - | RSort _ -> rt - | RHole _ -> rt - | RCast(loc,b,CastConv(k,t)) -> + | RSort _ -> rt + | RHole _ -> rt + | RCast(loc,b,CastConv(k,t)) -> RCast(loc,zeta_normalize_term b,CastConv(k,zeta_normalize_term t)) - | RCast(loc,b,CastCoerce) -> + | RCast(loc,b,CastCoerce) -> RCast(loc,zeta_normalize_term b,CastCoerce) | RDynamic _ -> raise (UserError("",str "Not handled RDynamic")) - and zeta_normalize_br (loc,idl,patl,res) = + and zeta_normalize_br (loc,idl,patl,res) = (loc,idl,patl,zeta_normalize_term res) in - zeta_normalize_term + zeta_normalize_term -let expand_as = - - let rec add_as map pat = - match pat with - | PatVar _ -> map - | PatCstr(_,_,patl,Name id) -> +let expand_as = + + let rec add_as map pat = + match pat with + | PatVar _ -> map + | PatCstr(_,_,patl,Name id) -> Idmap.add id (pattern_to_term pat) (List.fold_left add_as map patl) | PatCstr(_,_,patl,_) -> List.fold_left add_as map patl - in - let rec expand_as map rt = - match rt with - | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt - | RVar(_,id) -> + in + let rec expand_as map rt = + match rt with + | RRef _ | REvar _ | RPatVar _ | RSort _ | RHole _ -> rt + | RVar(_,id) -> begin - try + try Idmap.find id map - with Not_found -> rt + with Not_found -> rt end | RApp(loc,f,args) -> RApp(loc,expand_as map f,List.map (expand_as map) args) | RLambda(loc,na,k,t,b) -> RLambda(loc,na,k,expand_as map t, expand_as map b) @@ -712,7 +712,7 @@ let expand_as = | RCases(loc,sty,po,el,brl) -> RCases(loc, sty, Option.map (expand_as map) po, List.map (fun (rt,t) -> expand_as map rt,t) el, List.map (expand_as_br map) brl) - and expand_as_br map (loc,idl,cpl,rt) = + and expand_as_br map (loc,idl,cpl,rt) = (loc,idl,cpl, expand_as (List.fold_left add_as map cpl) rt) in - expand_as Idmap.empty + expand_as Idmap.empty diff --git a/plugins/funind/rawtermops.mli b/plugins/funind/rawtermops.mli index 358c6ba6c7..455e7c89b2 100644 --- a/plugins/funind/rawtermops.mli +++ b/plugins/funind/rawtermops.mli @@ -7,12 +7,12 @@ val idmap_is_empty : 'a Names.Idmap.t -> bool (* [get_pattern_id pat] returns a list of all the variable appearing in [pat] *) val get_pattern_id : cases_pattern -> Names.identifier list -(* [pattern_to_term pat] returns a rawconstr corresponding to [pat]. - [pat] must not contain occurences of anonymous pattern +(* [pattern_to_term pat] returns a rawconstr corresponding to [pat]. + [pat] must not contain occurences of anonymous pattern *) -val pattern_to_term : cases_pattern -> rawconstr +val pattern_to_term : cases_pattern -> rawconstr -(* +(* Some basic functions to rebuild rawconstr In each of them the location is Util.dummy_loc *) @@ -23,35 +23,35 @@ val mkRLambda : Names.name*rawconstr*rawconstr -> rawconstr val mkRProd : Names.name*rawconstr*rawconstr -> rawconstr val mkRLetIn : Names.name*rawconstr*rawconstr -> rawconstr val mkRCases : rawconstr option * tomatch_tuples * cases_clauses -> rawconstr -val mkRSort : rawsort -> rawconstr +val mkRSort : rawsort -> rawconstr val mkRHole : unit -> rawconstr (* we only build Evd.BinderType Anonymous holes *) -val mkRCast : rawconstr* rawconstr -> rawconstr +val mkRCast : rawconstr* rawconstr -> rawconstr (* Some basic functions to decompose rawconstrs These are analogous to the ones constrs *) val raw_decompose_prod : rawconstr -> (Names.name*rawconstr) list * rawconstr -val raw_decompose_prod_or_letin : +val raw_decompose_prod_or_letin : rawconstr -> (Names.name*rawconstr option*rawconstr option) list * rawconstr val raw_decompose_prod_n : int -> rawconstr -> (Names.name*rawconstr) list * rawconstr -val raw_decompose_prod_or_letin_n : int -> rawconstr -> +val raw_decompose_prod_or_letin_n : int -> rawconstr -> (Names.name*rawconstr option*rawconstr option) list * rawconstr -val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list -> rawconstr -val raw_compose_prod_or_letin: rawconstr -> +val raw_compose_prod : rawconstr -> (Names.name*rawconstr) list -> rawconstr +val raw_compose_prod_or_letin: rawconstr -> (Names.name*rawconstr option*rawconstr option) list -> rawconstr val raw_decompose_app : rawconstr -> rawconstr*(rawconstr list) -(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) +(* [raw_make_eq t1 t2] build the rawconstr corresponding to [t2 = t1] *) val raw_make_eq : ?typ:rawconstr -> rawconstr -> rawconstr -> rawconstr -(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) +(* [raw_make_neq t1 t2] build the rawconstr corresponding to [t1 <> t2] *) val raw_make_neq : rawconstr -> rawconstr -> rawconstr -(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) +(* [raw_make_or P1 P2] build the rawconstr corresponding to [P1 \/ P2] *) val raw_make_or : rawconstr -> rawconstr -> rawconstr -(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding - to [P1 \/ ( .... \/ Pn)] -*) +(* [raw_make_or_list [P1;...;Pn]] build the rawconstr corresponding + to [P1 \/ ( .... \/ Pn)] +*) val raw_make_or_list : rawconstr list -> rawconstr @@ -64,8 +64,8 @@ val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr -(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. - the result does not share variables with [avoid]. This function create +(* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. + the result does not share variables with [avoid]. This function create a fresh variable for each occurence of the anonymous pattern. Also returns a mapping from old variables to new ones and the concatenation of @@ -77,8 +77,8 @@ val change_vars : Names.identifier Names.Idmap.t -> rawconstr -> rawconstr Rawterm.cases_pattern * Names.Idmap.key list * Names.identifier Names.Idmap.t -(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt - conventions and does not share bound variables with avoid +(* [alpha_rt avoid rt] alpha convert [rt] s.t. the result repects barendregt + conventions and does not share bound variables with avoid *) val alpha_rt : Names.identifier list -> rawconstr -> rawconstr @@ -90,35 +90,35 @@ val alpha_br : Names.identifier list -> Rawterm.rawconstr -(* Reduction function *) -val replace_var_by_term : +(* Reduction function *) +val replace_var_by_term : Names.identifier -> Rawterm.rawconstr -> Rawterm.rawconstr -> Rawterm.rawconstr -(* +(* [is_free_in id rt] checks if [id] is a free variable in [rt] *) val is_free_in : Names.identifier -> rawconstr -> bool -val are_unifiable : cases_pattern -> cases_pattern -> bool +val are_unifiable : cases_pattern -> cases_pattern -> bool val eq_cases_pattern : cases_pattern -> cases_pattern -> bool -(* - ids_of_pat : cases_pattern -> Idset.t - returns the set of variables appearing in a pattern +(* + ids_of_pat : cases_pattern -> Idset.t + returns the set of variables appearing in a pattern *) -val ids_of_pat : cases_pattern -> Names.Idset.t +val ids_of_pat : cases_pattern -> Names.Idset.t (* TODO: finish this function (Fix not treated) *) val ids_of_rawterm: rawconstr -> Names.Idset.t -(* - removing let_in construction in a rawterm +(* + removing let_in construction in a rawterm *) val zeta_normalize : Rawterm.rawconstr -> Rawterm.rawconstr diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 876f3de4bf..92438db399 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -49,23 +49,23 @@ open Eauto open Genarg -let compute_renamed_type gls c = +let compute_renamed_type gls c = rename_bound_var (pf_env gls) [] (pf_type_of gls c) -let qed () = Command.save_named true +let qed () = Command.save_named true let defined () = Command.save_named false -let pf_get_new_ids idl g = - let ids = pf_ids_of_hyps g in +let pf_get_new_ids idl g = + let ids = pf_ids_of_hyps g in List.fold_right (fun id acc -> next_global_ident_away false id (acc@ids)::acc) - idl + idl [] -let pf_get_new_id id g = +let pf_get_new_id id g = List.hd (pf_get_new_ids [id] g) -let h_intros l = +let h_intros l = tclMAP h_intro l let do_observe_tac s tac g = @@ -73,12 +73,12 @@ let do_observe_tac s tac g = try let v = tac g in msgnl (goal ++ fnl () ++ (str "recdef ") ++ (str s)++(str " ")++(str "finished")); v with e -> - msgnl (str "observation "++str s++str " raised exception " ++ - Cerrors.explain_exn e ++ str " on goal " ++ goal ); + msgnl (str "observation "++str s++str " raised exception " ++ + Cerrors.explain_exn e ++ str " on goal " ++ goal ); raise e;; -let observe_tac s tac g = +let observe_tac s tac g = if Tacinterp.get_debug () <> Tactic_debug.DebugOff then do_observe_tac s tac g else tac g @@ -114,11 +114,11 @@ let message s = if Flags.is_verbose () then msgnl(str s);; let def_of_const t = match (kind_of_term t) with - Const sp -> + Const sp -> (try (match (Global.lookup_constant sp) with {const_body=Some c} -> Declarations.force c |_ -> assert false) - with _ -> + with _ -> anomaly ("Cannot find definition of constant "^ (string_of_id (id_of_label (con_label sp)))) ) @@ -135,14 +135,14 @@ let arg_type t = | _ -> assert false;; let evaluable_of_global_reference r = - match r with + match r with ConstRef sp -> EvalConstRef sp | VarRef id -> EvalVarRef id | _ -> assert false;; -let rank_for_arg_list h = - let predicate a b = +let rank_for_arg_list h = + let predicate a b = try List.for_all2 eq_constr a b with Invalid_argument _ -> false in let rec rank_aux i = function @@ -150,11 +150,11 @@ let rank_for_arg_list h = | x::tl -> if predicate h x then Some i else rank_aux (i+1) tl in rank_aux 0;; -let rec (find_call_occs : int -> constr -> constr -> +let rec (find_call_occs : int -> constr -> constr -> (constr list -> constr) * constr list list) = fun nb_lam f expr -> match (kind_of_term expr) with - App (g, args) when g = f -> + App (g, args) when g = f -> (fun l -> List.hd l), [Array.to_list args] | App (g, args) -> let (largs: constr list) = Array.to_list args in @@ -162,17 +162,17 @@ let rec (find_call_occs : int -> constr -> constr -> [] -> (fun x -> []), [] | a::upper_tl -> (match find_aux upper_tl with - (cf, ((arg1::args) as args_for_upper_tl)) -> + (cf, ((arg1::args) as args_for_upper_tl)) -> (match find_call_occs nb_lam f a with cf2, (_ :: _ as other_args) -> let rec avoid_duplicates args = match args with | [] -> (fun _ -> []), [] - | h::tl -> + | h::tl -> let recomb_tl, args_for_tl = avoid_duplicates tl in match rank_for_arg_list h args_for_upper_tl with - | None -> + | None -> (fun l -> List.hd l::recomb_tl(List.tl l)), h::args_for_tl | Some i -> @@ -182,7 +182,7 @@ let rec (find_call_occs : int -> constr -> constr -> in let recombine, other_args' = avoid_duplicates other_args in - let len1 = List.length other_args' in + let len1 = List.length other_args' in (fun l -> cf2 (recombine l)::cf(nthtl(l,len1))), other_args'@args_for_upper_tl | _, [] -> (fun x -> a::cf x), args_for_upper_tl) @@ -203,22 +203,22 @@ let rec (find_call_occs : int -> constr -> constr -> | Sort(_) -> (fun l -> expr), [] | Cast(b,_,_) -> find_call_occs nb_lam f b | Prod(_,_,_) -> error "find_call_occs : Prod" - | Lambda(na,t,b) -> + | Lambda(na,t,b) -> begin - match find_call_occs (succ nb_lam) f b with - | _, [] -> (* Lambda are authorized as long as they do not contain + match find_call_occs (succ nb_lam) f b with + | _, [] -> (* Lambda are authorized as long as they do not contain recursives calls *) (fun l -> expr),[] | _ -> error "find_call_occs : Lambda" end - | LetIn(na,v,t,b) -> + | LetIn(na,v,t,b) -> begin - match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with - | (_,[]),(_,[]) -> + match find_call_occs nb_lam f v, find_call_occs (succ nb_lam) f b with + | (_,[]),(_,[]) -> ((fun l -> expr), []) - | (_,[]),(cf,(_::_ as l)) -> + | (_,[]),(cf,(_::_ as l)) -> ((fun l -> mkLetIn(na,v,t,cf l)),l) - | (cf,(_::_ as l)),(_,[]) -> + | (cf,(_::_ as l)),(_,[]) -> ((fun l -> mkLetIn(na,cf l,t,b)), l) | _ -> error "find_call_occs : LetIn" end @@ -233,17 +233,17 @@ let rec (find_call_occs : int -> constr -> constr -> | CoFix(_) -> error "find_call_occs : CoFix";; let coq_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" + Coqlib.gen_constant_in_modules "RecursiveDefinition" (Coqlib.init_modules @ Coqlib.arith_modules) s;; let constant sl s = constr_of_global - (locate (make_qualid(Names.make_dirpath + (locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; let find_reference sl s = - (locate (make_qualid(Names.make_dirpath + (locate (make_qualid(Names.make_dirpath (List.map id_of_string (List.rev sl))) (id_of_string s)));; @@ -295,7 +295,7 @@ let mkCaseEq a : tactic = tclTHENLIST [h_generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; (fun g2 -> - change_in_concl None + change_in_concl None (pattern_occs [((false,[1]), a)] (pf_env g2) Evd.empty (pf_concl g2)) g2); simplest_case a] g);; @@ -308,21 +308,21 @@ let mkCaseEq a : tactic = let mkDestructEq : identifier list -> constr -> goal sigma -> tactic * identifier list = fun not_on_hyp expr g -> - let hyps = pf_hyps g in - let to_revert = - Util.map_succeed - (fun (id,_,t) -> + let hyps = pf_hyps g in + let to_revert = + Util.map_succeed + (fun (id,_,t) -> if List.mem id not_on_hyp || not (Termops.occur_term expr t) then failwith "is_expr_context"; id) hyps in - let to_revert_constr = List.rev_map mkVar to_revert in + let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_type_of g expr in let new_hyps = mkApp(delayed_force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in tclTHENLIST [h_generalize new_hyps; (fun g2 -> - change_in_concl None + change_in_concl None (pattern_occs [((false,[1]), expr)] (pf_env g2) Evd.empty (pf_concl g2)) g2); simplest_case expr], to_revert @@ -334,15 +334,15 @@ let rec mk_intros_and_continue thin_intros (extra_eqn:bool) [ h_intro teq; thin thin_intros; h_intros thin_intros; - - tclMAP - (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences teq eq false)) + + tclMAP + (fun eq -> tclTRY (Equality.general_rewrite_in true all_occurrences teq eq false)) (List.rev eqs); - (fun g1 -> - let ty_teq = pf_type_of g1 (mkVar teq) in - let teq_lhs,teq_rhs = - let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in - args.(1),args.(2) + (fun g1 -> + let ty_teq = pf_type_of g1 (mkVar teq) in + let teq_lhs,teq_rhs = + let _,args = try destApp ty_teq with _ -> Pp.msgnl (Printer.pr_goal (sig_it g1) ++ fnl () ++ pr_id teq ++ str ":" ++ Printer.pr_lconstr ty_teq); assert false in + args.(1),args.(2) in cont_function (mkVar teq::eqs) (replace_term teq_lhs teq_rhs expr) g1 ) @@ -352,32 +352,32 @@ let rec mk_intros_and_continue thin_intros (extra_eqn:bool) tclTHENSEQ[ thin thin_intros; h_intros thin_intros; - cont_function eqs expr + cont_function eqs expr ] g in - if nb_lam = 0 - then finalize () + if nb_lam = 0 + then finalize () else match kind_of_term expr with - | Lambda (n, _, b) -> - let n1 = + | Lambda (n, _, b) -> + let n1 = match n with Name x -> x | Anonymous -> ano_id in let new_n = pf_get_new_id n1 g in tclTHEN (h_intro new_n) - (mk_intros_and_continue thin_intros extra_eqn cont_function eqs + (mk_intros_and_continue thin_intros extra_eqn cont_function eqs (pred nb_lam) (subst1 (mkVar new_n) b)) g - | _ -> - assert false + | _ -> + assert false (* finalize () *) let const_of_ref = function ConstRef kn -> kn | _ -> anomaly "ConstRef expected" let simpl_iter clause = - reduce + reduce (Lazy {rBeta=true;rIota=true;rZeta= true; rDelta=false; rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) @@ -386,16 +386,16 @@ let simpl_iter clause = (* The boolean value is_mes expresses that the termination is expressed using a measure function instead of a well-founded relation. *) -let tclUSER tac is_mes l g = - let clear_tac = - match l with +let tclUSER tac is_mes l g = + let clear_tac = + match l with | None -> h_clear true [] | Some l -> tclMAP (fun id -> tclTRY (h_clear false [id])) (List.rev l) in - tclTHENSEQ + tclTHENSEQ [ clear_tac; - if is_mes + if is_mes then tclTHEN (unfold_in_concl [(all_occurrences, evaluable_of_global_reference (delayed_force ltof_ref))]) @@ -403,8 +403,8 @@ let tclUSER tac is_mes l g = else tac ] g - - + + let list_rewrite (rev:bool) (eqs: constr list) = tclREPEAT (List.fold_right @@ -414,8 +414,8 @@ let list_rewrite (rev:bool) (eqs: constr list) = let base_leaf_terminate (func:global_reference) eqs expr = (* let _ = msgnl (str "entering base_leaf") in *) (fun g -> - let k',h = - match pf_get_new_ids [k_id;h_id] g with + let k',h = + match pf_get_new_ids [k_id;h_id] g with [k';h] -> k',h | _ -> assert false in @@ -424,9 +424,9 @@ let base_leaf_terminate (func:global_reference) eqs expr = observe_tac "second split" (split (ImplicitBindings [delayed_force coq_O])); observe_tac "intro k" (h_intro k'); - observe_tac "case on k" + observe_tac "case on k" (tclTHENS (simplest_case (mkVar k')) - [(tclTHEN (h_intro h) + [(tclTHEN (h_intro h) (tclTHEN (simplest_elim (mkApp (delayed_force gt_antirefl, [| delayed_force coq_O |]))) default_auto)); tclIDTAC ]); @@ -436,63 +436,63 @@ let base_leaf_terminate (func:global_reference) eqs expr = list_rewrite true eqs; default_auto] g);; -(* La fonction est donnee en premier argument a la +(* La fonction est donnee en premier argument a la fonctionnelle suivie d'autres Lambdas et de Case ... - Pour recuperer la fonction f a partir de la + Pour recuperer la fonction f a partir de la fonctionnelle *) -let get_f foncl = +let get_f foncl = match (kind_of_term (def_of_const foncl)) with - Lambda (Name f, _, _) -> f + Lambda (Name f, _, _) -> f |_ -> error "la fonctionnelle est mal definie";; let rec compute_le_proofs = function [] -> assumption | a::tl -> - tclORELSE assumption + tclORELSE assumption (tclTHENS - (fun g -> - let le_trans = delayed_force le_trans in - let t_le_trans = compute_renamed_type g le_trans in - let m_id = - let _,_,t = destProd t_le_trans in - let na,_,_ = destProd t in + (fun g -> + let le_trans = delayed_force le_trans in + let t_le_trans = compute_renamed_type g le_trans in + let m_id = + let _,_,t = destProd t_le_trans in + let na,_,_ = destProd t in Nameops.out_name na in apply_with_bindings (le_trans, ExplicitBindings[dummy_loc,NamedHyp m_id,a]) g) - [compute_le_proofs tl; + [compute_le_proofs tl; tclORELSE (apply (delayed_force le_n)) assumption]) let make_lt_proof pmax le_proof = tclTHENS - (fun g -> - let le_lt_trans = delayed_force le_lt_trans in - let t_le_lt_trans = compute_renamed_type g le_lt_trans in - let m_id = - let _,_,t = destProd t_le_lt_trans in - let na,_,_ = destProd t in + (fun g -> + let le_lt_trans = delayed_force le_lt_trans in + let t_le_lt_trans = compute_renamed_type g le_lt_trans in + let m_id = + let _,_,t = destProd t_le_lt_trans in + let na,_,_ = destProd t in Nameops.out_name na in apply_with_bindings (le_lt_trans, ExplicitBindings[dummy_loc,NamedHyp m_id, pmax]) g) - [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); + [observe_tac "compute_le_proofs" (compute_le_proofs le_proof); tclTHENLIST[observe_tac "lt_S_n" (apply (delayed_force lt_S_n)); default_full_auto]];; let rec list_cond_rewrite k def pmax cond_eqs le_proofs = match cond_eqs with [] -> tclIDTAC | eq::eqs -> - (fun g -> - let t_eq = compute_renamed_type g (mkVar eq) in - let k_id,def_id = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in + (fun g -> + let t_eq = compute_renamed_type g (mkVar eq) in + let k_id,def_id = + let k_na,_,t = destProd t_eq in + let _,_,t = destProd t in + let def_na,_,_ = destProd t in Nameops.out_name k_na,Nameops.out_name def_na in tclTHENS @@ -502,12 +502,12 @@ let rec list_cond_rewrite k def pmax cond_eqs le_proofs = dummy_loc, NamedHyp def_id, mkVar def]) false) [list_cond_rewrite k def pmax eqs le_proofs; observe_tac "make_lt_proof" (make_lt_proof pmax le_proofs)] g - ) + ) -let rec introduce_all_equalities func eqs values specs bound le_proofs +let rec introduce_all_equalities func eqs values specs bound le_proofs cond_eqs = match specs with - [] -> + [] -> fun g -> let ids = pf_ids_of_hyps g in let s_max = mkApp(delayed_force coq_S, [|bound|]) in @@ -530,9 +530,9 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs observe_tac "clearing k " (clear [k]); observe_tac "intros k h' def" (h_intros [k;h';def]); observe_tac "simple_iter" (simpl_iter onConcl); - observe_tac "unfold functional" + observe_tac "unfold functional" (unfold_in_concl[((true,[1]),evaluable_of_global_reference func)]); - observe_tac "rewriting equations" + observe_tac "rewriting equations" (list_rewrite true eqs); observe_tac ("cond rewrite "^(string_of_id k)) (list_cond_rewrite k def bound cond_eqs le_proofs); observe_tac "refl equal" (apply (delayed_force refl_equal))] g @@ -554,29 +554,29 @@ let rec introduce_all_equalities func eqs values specs bound le_proofs h_intros [p; heq]; simplest_elim (mkApp(delayed_force max_constr, [| bound; mkVar p|])); h_intros [pmax; hle1; hle2]; - introduce_all_equalities func eqs values specs + introduce_all_equalities func eqs values specs (mkVar pmax) ((mkVar pmax)::le_proofs) (heq::cond_eqs)] g;; - + let string_match s = if String.length s < 3 then failwith "string_match"; - try + try for i = 0 to 3 do if String.get s i <> String.get "Acc_" i then failwith "string_match" done; with Invalid_argument _ -> failwith "string_match" - -let retrieve_acc_var g = - (* Julien: I don't like this version .... *) - let hyps = pf_ids_of_hyps g in - map_succeed + +let retrieve_acc_var g = + (* Julien: I don't like this version .... *) + let hyps = pf_ids_of_hyps g in + map_succeed (fun id -> string_match (string_of_id id);id) - hyps + hyps let rec introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args values specs = (match args with - [] -> + [] -> tclTHENLIST [observe_tac "split" (split(ImplicitBindings [context_fn (List.map mkVar (List.rev values))])); @@ -588,17 +588,17 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn let rec_res = next_global_ident_away true rec_res_id ids in let ids = rec_res::ids in let hspec = next_global_ident_away true hspec_id ids in - let tac = + let tac = observe_tac "introduce_all_values" ( introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args (rec_res::values)(hspec::specs)) in (tclTHENS - (observe_tac "elim h_rec" + (observe_tac "elim h_rec" (simplest_elim (mkApp(mkVar hrec, Array.of_list arg))) ) [tclTHENLIST [h_intros [rec_res; hspec]; - tac]; + tac]; (tclTHENS (observe_tac "acc_inv" (apply (Lazy.force acc_inv))) [(* tclTHEN (tclTRY(list_rewrite true eqs)) *) @@ -607,126 +607,126 @@ let rec introduce_all_values concl_tac is_mes acc_inv func context_fn tclTHENLIST [ tclTRY(list_rewrite true eqs); - observe_tac "user proof" - (fun g -> + observe_tac "user proof" + (fun g -> tclUSER concl_tac is_mes (Some (hrec::hspec::(retrieve_acc_var g)@specs)) g - ) + ) ] ] ) ]) g) - + ) - - + + let rec_leaf_terminate f_constr concl_tac is_mes acc_inv hrec (func:global_reference) eqs expr = match find_call_occs 0 f_constr expr with | context_fn, args -> - observe_tac "introduce_all_values" + observe_tac "introduce_all_values" (introduce_all_values concl_tac is_mes acc_inv func context_fn eqs hrec args [] []) -let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier) - (f_constr:constr) (func:global_reference) base_leaf rec_leaf = +let proveterminate rec_arg_id is_mes acc_inv (hrec:identifier) + (f_constr:constr) (func:global_reference) base_leaf rec_leaf = let rec proveterminate (eqs:constr list) (expr:constr) = try (* let _ = msgnl (str "entering proveterminate") in *) let v = match (kind_of_term expr) with - Case (ci, t, a, l) -> + Case (ci, t, a, l) -> (match find_call_occs 0 f_constr a with _,[] -> - (fun g -> + (fun g -> let destruct_tac, rev_to_thin_intro = - mkDestructEq rec_arg_id a g in + mkDestructEq rec_arg_id a g in tclTHENS destruct_tac - (list_map_i - (fun i -> mk_intros_and_continue - (List.rev rev_to_thin_intro) - true - proveterminate + (list_map_i + (fun i -> mk_intros_and_continue + (List.rev rev_to_thin_intro) + true + proveterminate eqs ci.ci_cstr_nargs.(i)) 0 (Array.to_list l)) g) - | _, _::_ -> + | _, _::_ -> (match find_call_occs 0 f_constr expr with _,[] -> observe_tac "base_leaf" (base_leaf func eqs expr) - | _, _:: _ -> - observe_tac "rec_leaf" + | _, _:: _ -> + observe_tac "rec_leaf" (rec_leaf is_mes acc_inv hrec func eqs expr))) | _ -> (match find_call_occs 0 f_constr expr with - _,[] -> + _,[] -> (try observe_tac "base_leaf" (base_leaf func eqs expr) with e -> (msgerrnl (str "failure in base case");raise e )) - | _, _::_ -> + | _, _::_ -> observe_tac "rec_leaf" (rec_leaf is_mes acc_inv hrec func eqs expr)) in v with e -> begin msgerrnl(str "failure in proveterminate"); raise e end - in - proveterminate - -let hyp_terminates nb_args func = - let a_arrow_b = arg_type (constr_of_global func) in - let rev_args,b = decompose_prod_n nb_args a_arrow_b in - let left = - mkApp(delayed_force iter, - Array.of_list + in + proveterminate + +let hyp_terminates nb_args func = + let a_arrow_b = arg_type (constr_of_global func) in + let rev_args,b = decompose_prod_n nb_args a_arrow_b in + let left = + mkApp(delayed_force iter, + Array.of_list (lift 5 a_arrow_b:: mkRel 3:: constr_of_global func::mkRel 1:: List.rev (list_map_i (fun i _ -> mkRel (6+i)) 0 rev_args) ) ) in - let right = mkRel 5 in + let right = mkRel 5 in let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in let nb_iter = mkApp(delayed_force ex, [|delayed_force nat; - (mkLambda + (mkLambda (Name p_id, - delayed_force nat, - (mkProd (Name k_id, delayed_force nat, + delayed_force nat, + (mkProd (Name k_id, delayed_force nat, mkArrow cond result))))|])in - let value = mkApp(delayed_force coq_sig, + let value = mkApp(delayed_force coq_sig, [|b; (mkLambda (Name v_id, b, nb_iter))|]) in compose_prod rev_args value - -let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = - if is_mes + +let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = + if is_mes then tclCOMPLETE (h_simplest_apply (delayed_force well_founded_ltof)) else tclUSER concl_tac is_mes names_to_suppress let termination_proof_header is_mes input_type ids args_id relation - rec_arg_num rec_arg_id tac wf_tac : tactic = - begin - fun g -> + rec_arg_num rec_arg_id tac wf_tac : tactic = + begin + fun g -> let nargs = List.length args_id in - let pre_rec_args = + let pre_rec_args = List.rev_map - mkVar (fst (list_chop (rec_arg_num - 1) args_id)) - in - let relation = substl pre_rec_args relation in - let input_type = substl pre_rec_args input_type in - let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in - let wf_rec_arg = - next_global_ident_away true + mkVar (fst (list_chop (rec_arg_num - 1) args_id)) + in + let relation = substl pre_rec_args relation in + let input_type = substl pre_rec_args input_type in + let wf_thm = next_global_ident_away true (id_of_string ("wf_R")) ids in + let wf_rec_arg = + next_global_ident_away true (id_of_string ("Acc_"^(string_of_id rec_arg_id))) - (wf_thm::ids) - in + (wf_thm::ids) + in let hrec = next_global_ident_away true hrec_id - (wf_rec_arg::wf_thm::ids) in - let acc_inv = + (wf_rec_arg::wf_thm::ids) in + let acc_inv = lazy ( mkApp ( delayed_force acc_inv_id, @@ -737,40 +737,40 @@ let termination_proof_header is_mes input_type ids args_id relation tclTHEN (h_intros args_id) (tclTHENS - (observe_tac - "first assert" - (assert_tac - (Name wf_rec_arg) + (observe_tac + "first assert" + (assert_tac + (Name wf_rec_arg) (mkApp (delayed_force acc_rel, [|input_type;relation;mkVar rec_arg_id|]) ) ) ) [ - (* accesibility proof *) - tclTHENS - (observe_tac - "second assert" - (assert_tac + (* accesibility proof *) + tclTHENS + (observe_tac + "second assert" + (assert_tac (Name wf_thm) (mkApp (delayed_force well_founded,[|input_type;relation|])) ) ) - [ + [ (* interactive proof that the relation is well_founded *) observe_tac "wf_tac" (wf_tac is_mes (Some args_id)); (* this gives the accessibility argument *) - observe_tac - "apply wf_thm" + observe_tac + "apply wf_thm" (h_simplest_apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])) ) ] ; (* rest of the proof *) - tclTHENSEQ - [observe_tac "generalize" + tclTHENSEQ + [observe_tac "generalize" (onNLastHypsId (nargs+1) - (tclMAP (fun id -> + (tclMAP (fun id -> tclTHEN (h_generalize [mkVar id]) (h_clear false [id])) )) ; @@ -780,23 +780,23 @@ let termination_proof_header is_mes input_type ids args_id relation observe_tac "tac" (tac wf_rec_arg hrec acc_inv) ] ] - ) g + ) g end -let rec instantiate_lambda t l = +let rec instantiate_lambda t l = match l with | [] -> t - | a::l -> + | a::l -> let (bound_name, _, body) = destLambda t in instantiate_lambda (subst1 a body) l ;; -let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = - begin - fun g -> +let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = + begin + fun g -> let ids = ids_of_named_context (pf_hyps g) in let func_body = (def_of_const (constr_of_global func)) in let (f_name, _, body1) = destLambda func_body in @@ -805,13 +805,13 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a | Name f_id -> next_global_ident_away true f_id ids | Anonymous -> anomaly "Anonymous function" in - let n_names_types,_ = decompose_lam_n nb_args body1 in - let n_ids,ids = - List.fold_left - (fun (n_ids,ids) (n_name,_) -> - match n_name with - | Name id -> - let n_id = next_global_ident_away true id ids in + let n_names_types,_ = decompose_lam_n nb_args body1 in + let n_ids,ids = + List.fold_left + (fun (n_ids,ids) (n_name,_) -> + match n_name with + | Name id -> + let n_id = next_global_ident_away true id ids in n_id::n_ids,n_id::ids | _ -> anomaly "anonymous argument" ) @@ -819,151 +819,151 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a n_names_types in let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in - termination_proof_header + let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in + termination_proof_header is_mes input_type ids n_ids - relation + relation rec_arg_num rec_arg_id - (fun rec_arg_id hrec acc_inv g -> - (proveterminate + (fun rec_arg_id hrec acc_inv g -> + (proveterminate [rec_arg_id] is_mes - acc_inv + acc_inv hrec (mkVar f_id) func - base_leaf_terminate + base_leaf_terminate (rec_leaf_terminate (mkVar f_id) concl_tac) [] expr ) - g + g ) (tclUSER_if_not_mes concl_tac) - g + g end -let get_current_subgoals_types () = - let pts = get_pftreestate () in - let _,subs = extract_open_pftreestate pts in +let get_current_subgoals_types () = + let pts = get_pftreestate () in + let _,subs = extract_open_pftreestate pts in List.map snd ((* List.sort (fun (x,_) (y,_) -> x -y ) *)subs ) -let build_and_l l = - let and_constr = Coqlib.build_coq_and () in - let conj_constr = coq_conj () in - let mk_and p1 p2 = - Term.mkApp(and_constr,[|p1;p2|]) in - let rec f = function - | [] -> failwith "empty list of subgoals!" - | [p] -> p,tclIDTAC,1 - | p1::pl -> - let c,tac,nb = f pl in - mk_and p1 c, +let build_and_l l = + let and_constr = Coqlib.build_coq_and () in + let conj_constr = coq_conj () in + let mk_and p1 p2 = + Term.mkApp(and_constr,[|p1;p2|]) in + let rec f = function + | [] -> failwith "empty list of subgoals!" + | [p] -> p,tclIDTAC,1 + | p1::pl -> + let c,tac,nb = f pl in + mk_and p1 c, tclTHENS - (apply (constr_of_global conj_constr)) + (apply (constr_of_global conj_constr)) [tclIDTAC; tac ],nb+1 in f l -let is_rec_res id = - let rec_res_name = string_of_id rec_res_id in - let id_name = string_of_id id in - try - String.sub id_name 0 (String.length rec_res_name) = rec_res_name +let is_rec_res id = + let rec_res_name = string_of_id rec_res_id in + let id_name = string_of_id id in + try + String.sub id_name 0 (String.length rec_res_name) = rec_res_name with _ -> false -let clear_goals = - let rec clear_goal t = - match kind_of_term t with - | Prod(Name id as na,t,b) -> - let b' = clear_goal b in - if noccurn 1 b' && (is_rec_res id) - then pop b' - else if b' == b then t +let clear_goals = + let rec clear_goal t = + match kind_of_term t with + | Prod(Name id as na,t,b) -> + let b' = clear_goal b in + if noccurn 1 b' && (is_rec_res id) + then pop b' + else if b' == b then t else mkProd(na,t,b') | _ -> map_constr clear_goal t - in - List.map clear_goal + in + List.map clear_goal -let build_new_goal_type () = - let sub_gls_types = get_current_subgoals_types () in - let sub_gls_types = clear_goals sub_gls_types in - let res = build_and_l sub_gls_types in +let build_new_goal_type () = + let sub_gls_types = get_current_subgoals_types () in + let sub_gls_types = clear_goals sub_gls_types in + let res = build_and_l sub_gls_types in res - + (* -let prove_with_tcc lemma _ : tactic = +let prove_with_tcc lemma _ : tactic = fun gls -> - let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in - tclTHENSEQ + let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in + tclTHENSEQ [ h_generalize [lemma]; h_intro hid; - Elim.h_decompose_and (mkVar hid); + Elim.h_decompose_and (mkVar hid); gen_eauto(* default_eauto *) false (false,5) [] (Some []) (* default_auto *) ] gls *) - - -let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = + + +let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = let current_proof_name = get_current_proof_name () in - let name = match goal_name with - | Some s -> s - | None -> - try (add_suffix current_proof_name "_subproof") + let name = match goal_name with + | Some s -> s + | None -> + try (add_suffix current_proof_name "_subproof") with _ -> anomaly "open_new_goal with an unamed theorem" - in + in let sign = Global.named_context () in let sign = clear_proofs sign in let na = next_global_ident_away false name [] in if occur_existential gls_type then Util.error "\"abstract\" cannot handle existentials"; - let hook _ _ = - let opacity = - let na_ref = Libnames.Ident (dummy_loc,na) in + let hook _ _ = + let opacity = + let na_ref = Libnames.Ident (dummy_loc,na) in let na_global = Nametab.global na_ref in - match na_global with - ConstRef c -> - let cb = Global.lookup_constant c in - if cb.Declarations.const_opaque then true - else begin match cb.const_body with None -> true | _ -> false end + match na_global with + ConstRef c -> + let cb = Global.lookup_constant c in + if cb.Declarations.const_opaque then true + else begin match cb.const_body with None -> true | _ -> false end | _ -> anomaly "equation_lemma: not a constant" in - let lemma = mkConst (Lib.make_con na) in + let lemma = mkConst (Lib.make_con na) in ref_ := Some lemma ; - let lid = ref [] in - let h_num = ref (-1) in + let lid = ref [] in + let h_num = ref (-1) in Flags.silently Vernacentries.interp (Vernacexpr.VernacAbort None); - build_proof + build_proof ( fun gls -> - let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in - tclTHENSEQ + let hid = next_global_ident_away true h_id (pf_ids_of_hyps gls) in + tclTHENSEQ [ h_generalize [lemma]; h_intro hid; - (fun g -> - let ids = pf_ids_of_hyps g in + (fun g -> + let ids = pf_ids_of_hyps g in tclTHEN (Elim.h_decompose_and (mkVar hid)) - (fun g -> - let ids' = pf_ids_of_hyps g in + (fun g -> + let ids' = pf_ids_of_hyps g in lid := List.rev (list_subtract ids' ids); if !lid = [] then lid := [hid]; tclIDTAC g ) g - ); + ); ] gls) (fun g -> match kind_of_term (pf_concl g) with @@ -977,7 +977,7 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ tclFIRST[ tclTHEN (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) - e_assumption; + e_assumption; Eauto.eauto_with_bases false (true,5) @@ -993,24 +993,24 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ in start_proof na - (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) + (Decl_kinds.Global, Decl_kinds.Proof Decl_kinds.Lemma) sign - gls_type + gls_type hook ; if Indfun_common.is_strict_tcc () then - by (tclIDTAC) + by (tclIDTAC) else by ( - fun g -> - tclTHEN + fun g -> + tclTHEN (decompose_and_tac) - (tclORELSE - (tclFIRST + (tclORELSE + (tclFIRST (List.map - (fun c -> + (fun c -> tclTHENSEQ - [intros; - h_simplest_apply (interp_constr Evd.empty (Global.env()) c); + [intros; + h_simplest_apply (interp_constr Evd.empty (Global.env()) c); tclCOMPLETE Auto.default_auto ] ) @@ -1020,24 +1020,24 @@ let open_new_goal (build_proof:tactic -> tactic -> unit) using_lemmas ref_ goal_ try by tclIDTAC; (* raises UserError _ if the proof is complete *) if Flags.is_verbose () then (pp (Printer.pr_open_subgoals())) - with UserError _ -> + with UserError _ -> defined () - -;; + +;; -let com_terminate - tcc_lemma_name - tcc_lemma_ref - is_mes +let com_terminate + tcc_lemma_name + tcc_lemma_ref + is_mes fonctional_ref input_type - relation + relation rec_arg_num - thm_name using_lemmas + thm_name using_lemmas nb_args hook = - let start_proof (tac_start:tactic) (tac_end:tactic) = + let start_proof (tac_start:tactic) (tac_end:tactic) = let (evmap, env) = Command.get_current_context() in start_proof thm_name (Global, Proof Lemma) (Environ.named_context_val env) @@ -1045,45 +1045,45 @@ let com_terminate by (observe_tac "starting_tac" tac_start); by (observe_tac "whole_start" (whole_start tac_end nb_args is_mes fonctional_ref input_type relation rec_arg_num )) - + in start_proof tclIDTAC tclIDTAC; - try - let new_goal_type = build_new_goal_type () in + try + let new_goal_type = build_new_goal_type () in open_new_goal start_proof using_lemmas tcc_lemma_ref (Some tcc_lemma_name) (new_goal_type) - with Failure "empty list of subgoals!" -> + with Failure "empty list of subgoals!" -> (* a non recursive function declared with measure ! *) defined () - - -let ind_of_ref = function + + +let ind_of_ref = function | IndRef (ind,i) -> (ind,i) | _ -> anomaly "IndRef expected" let (value_f:constr list -> global_reference -> constr) = fun al fterm -> - let d0 = dummy_loc in - let rev_x_id_l = + let d0 = dummy_loc in + let rev_x_id_l = ( - List.fold_left - (fun x_id_l _ -> - let x_id = next_global_ident_away true x_id x_id_l in + List.fold_left + (fun x_id_l _ -> + let x_id = next_global_ident_away true x_id x_id_l in x_id::x_id_l ) [] al ) in - let fun_body = + let fun_body = RCases (d0,RegularStyle,None, [RApp(d0, RRef(d0,fterm), List.rev_map (fun x_id -> RVar(d0, x_id)) rev_x_id_l), (Anonymous,None)], - [d0, [v_id], [PatCstr(d0,(ind_of_ref + [d0, [v_id], [PatCstr(d0,(ind_of_ref (delayed_force coq_sig_ref),1), [PatVar(d0, Name v_id); PatVar(d0, Anonymous)], @@ -1091,12 +1091,12 @@ let (value_f:constr list -> global_reference -> constr) = RVar(d0,v_id)]) in let value = - List.fold_left2 - (fun acc x_id a -> + List.fold_left2 + (fun acc x_id a -> RLambda (d0, Name x_id, Explicit, RDynamic(d0, constr_in a), acc - ) + ) ) fun_body rev_x_id_l @@ -1121,16 +1121,16 @@ let rec n_x_id ids n = else let x = next_global_ident_away true x_id ids in x::n_x_id (x::ids) (n-1);; -let start_equation (f:global_reference) (term_f:global_reference) +let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:identifier list -> tactic) g = let ids = pf_ids_of_hyps g in - let terminate_constr = constr_of_global term_f in - let nargs = nb_prod (type_of_const terminate_constr) in + let terminate_constr = constr_of_global term_f in + let nargs = nb_prod (type_of_const terminate_constr) in let x = n_x_id ids nargs in tclTHENLIST [ h_intros x; unfold_in_concl [(all_occurrences, evaluable_of_global_reference f)]; - observe_tac "simplest_case" + observe_tac "simplest_case" (simplest_case (mkApp (terminate_constr, Array.of_list (List.map mkVar x)))); observe_tac "prove_eq" (cont_tactic x)] g;; @@ -1144,12 +1144,12 @@ let base_leaf_eq func eqs f_id g = let heq1 = next_global_ident_away true heq_id (heq::v::p::k::ids) in let hex = next_global_ident_away true hex_id (heq1::heq::v::p::k::ids) in tclTHENLIST [ - h_intros [v; hex]; + h_intros [v; hex]; simplest_elim (mkVar hex); h_intros [p;heq1]; tclTRY - (rewriteRL - (mkApp(mkVar heq1, + (rewriteRL + (mkApp(mkVar heq1, [|mkApp (delayed_force coq_S, [|mkVar p|]); mkApp(delayed_force lt_n_Sn, [|mkVar p|]); f_id|]))); simpl_iter onConcl; @@ -1160,7 +1160,7 @@ let base_leaf_eq func eqs f_id g = let f_S t = mkApp(delayed_force coq_S, [|t|]);; -let rec introduce_all_values_eq cont_tac functional termine +let rec introduce_all_values_eq cont_tac functional termine f p heq1 pmax bounds le_proofs eqs ids = function [] -> @@ -1169,14 +1169,14 @@ let rec introduce_all_values_eq cont_tac functional termine [pose_proof (Name heq2) (mkApp(mkVar heq1, [|f_S(f_S(mkVar pmax))|])); simpl_iter (onHyp heq2); - unfold_in_hyp [((true,[1]), evaluable_of_global_reference + unfold_in_hyp [((true,[1]), evaluable_of_global_reference (global_of_constr functional))] (heq2, InHyp); tclTHENS - (fun gls -> - let t_eq = compute_renamed_type gls (mkVar heq2) in - let def_id = - let _,_,t = destProd t_eq in let def_na,_,_ = destProd t in + (fun gls -> + let t_eq = compute_renamed_type gls (mkVar heq2) in + let def_id = + let _,_,t = destProd t_eq in let def_na,_,_ = destProd t in Nameops.out_name def_na in observe_tac "rewrite heq" (general_rewrite_bindings false all_occurrences @@ -1213,7 +1213,7 @@ let rec introduce_all_values_eq cont_tac functional termine simplest_elim(mkApp(delayed_force max_constr, [|mkVar pmax; mkVar p'|])); h_intros [new_pmax;hle1;hle2]; - introduce_all_values_eq + introduce_all_values_eq (fun pmax' le_proofs'-> tclTHENLIST [cont_tac pmax' le_proofs'; @@ -1221,12 +1221,12 @@ let rec introduce_all_values_eq cont_tac functional termine observe_tac ("rewriteRL " ^ (string_of_id heq2)) (tclTRY (rewriteLR (mkVar heq2))); tclTRY (tclTHENS - ( fun g -> - let t_eq = compute_renamed_type g (mkVar heq) in - let k_id,def_id = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in + ( fun g -> + let t_eq = compute_renamed_type g (mkVar heq) in + let k_id,def_id = + let k_na,_,t = destProd t_eq in + let _,_,t = destProd t in + let def_na,_,_ = destProd t in Nameops.out_name k_na,Nameops.out_name def_na in let c_b = (mkVar heq, @@ -1246,7 +1246,7 @@ let rec introduce_all_values_eq cont_tac functional termine functional termine f p heq1 new_pmax (p'::bounds)((mkVar pmax)::le_proofs) eqs (heq2::heq::hle2::hle1::new_pmax::p'::hex'::v'::ids) args] - + let rec_leaf_eq termine f ids functional eqs expr fn args = let p = next_global_ident_away true p_id ids in @@ -1276,15 +1276,15 @@ let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) (match kind_of_term expr with Case(ci,t,a,l) -> (match find_call_occs 0 f a with - _,[] -> - (fun g -> - let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in + _,[] -> + (fun g -> + let destruct_tac,rev_to_thin_intro = mkDestructEq [] a g in tclTHENS destruct_tac - (list_map_i + (list_map_i (fun i -> mk_intros_and_continue - (List.rev rev_to_thin_intro) true - (prove_eq termine f functional) + (List.rev rev_to_thin_intro) true + (prove_eq termine f functional) eqs ci.ci_cstr_nargs.(i)) 0 (Array.to_list l)) g) | _,_::_ -> @@ -1296,13 +1296,13 @@ let rec prove_eq (termine:constr) (f:constr)(functional:global_reference) rec_leaf_eq termine f ids (constr_of_global functional) eqs expr fn args g)) - | _ -> + | _ -> (match find_call_occs 0 f expr with _,[] -> base_leaf_eq functional eqs f | fn,args -> fun g -> let ids = ids_of_named_context (pf_hyps g) in - observe_tac "rec_leaf_eq" (rec_leaf_eq + observe_tac "rec_leaf_eq" (rec_leaf_eq termine f ids (constr_of_global functional) eqs expr fn args) g));; @@ -1310,14 +1310,14 @@ let (com_eqn : identifier -> global_reference -> global_reference -> global_reference -> constr -> unit) = fun eq_name functional_ref f_ref terminate_ref equation_lemma_type -> - let opacity = - match terminate_ref with - | ConstRef c -> - let cb = Global.lookup_constant c in - if cb.Declarations.const_opaque then true - else begin match cb.const_body with None -> true | _ -> false end + let opacity = + match terminate_ref with + | ConstRef c -> + let cb = Global.lookup_constant c in + if cb.Declarations.const_opaque then true + else begin match cb.const_body with None -> true | _ -> false end | _ -> anomaly "terminate_lemma: not a constant" - in + in let (evmap, env) = Command.get_current_context() in let f_constr = (constr_of_global f_ref) in let equation_lemma_type = subst1 f_constr equation_lemma_type in @@ -1326,9 +1326,9 @@ let (com_eqn : identifier -> by (start_equation f_ref terminate_ref (fun x -> - prove_eq + prove_eq (constr_of_global terminate_ref) - f_constr + f_constr functional_ref [] (instantiate_lambda @@ -1339,61 +1339,61 @@ let (com_eqn : identifier -> ); (* (try Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowProof) with _ -> ()); *) (* Vernacentries.interp (Vernacexpr.VernacShow Vernacexpr.ShowScript); *) - Flags.silently (fun () ->Command.save_named opacity) () ; + Flags.silently (fun () ->Command.save_named opacity) () ; (* Pp.msgnl (str "eqn finished"); *) - + );; -let nf_zeta env = +let nf_zeta env = Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) env Evd.empty -let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq +let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = let function_type = interp_constr Evd.empty (Global.env()) type_of_f in let env = push_named (function_name,None,function_type) (Global.env()) in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) - let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in + let equation_lemma_type = interp_gen (OfType None) Evd.empty env ~impls:([],rec_impls) eq in (* Pp.msgnl (Printer.pr_lconstr equation_lemma_type); *) - let res_vars,eq' = decompose_prod equation_lemma_type in + let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> (x,None,y)) res_vars) env in - let eq' = nf_zeta env_eq' eq' in - let res = + let eq' = nf_zeta env_eq' eq' in + let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) (* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) (* Pp.msgnl (str "eq' := " ++ str (string_of_int rec_arg_num)); *) - match kind_of_term eq' with - | App(e,[|_;_;eq_fix|]) -> + match kind_of_term eq' with + | App(e,[|_;_;eq_fix|]) -> mkLambda (Name function_name,function_type,subst_var function_name (compose_lam res_vars eq_fix)) | _ -> failwith "Recursive Definition (res not eq)" in - let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in + let pre_rec_args,function_type_before_rec_arg = decompose_prod_n (rec_arg_num - 1) function_type in let (_, rec_arg_type, _) = destProd function_type_before_rec_arg in let arg_types = List.rev_map snd (fst (decompose_prod_n (List.length res_vars) function_type)) in let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in let functional_ref = declare_fun functional_id (IsDefinition Definition) res in - let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in - let relation = + let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in + let relation = interp_constr - Evd.empty + Evd.empty env_with_pre_rec_args r - in + in let tcc_lemma_name = add_suffix function_name "_tcc" in - let tcc_lemma_constr = ref None in + let tcc_lemma_constr = ref None in (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook _ _ = + let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in (* message "start second proof"; *) - let stop = ref false in - begin + let stop = ref false in + begin try com_eqn equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type) - with e -> - begin + with e -> + begin if Tacinterp.get_debug () <> Tactic_debug.DebugOff then pperrnl (str "Cannot create equation Lemma " ++ Cerrors.explain_exn e) else anomaly "Cannot create equation Lemma" @@ -1405,20 +1405,20 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num if not !stop then let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in - let f_ref = destConst (constr_of_global f_ref) - and functional_ref = destConst (constr_of_global functional_ref) + let f_ref = destConst (constr_of_global f_ref) + and functional_ref = destConst (constr_of_global functional_ref) and eq_ref = destConst (constr_of_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; if Flags.is_verbose () - then msgnl (h 1 (Ppconstr.pr_id function_name ++ - spc () ++ str"is defined" )++ fnl () ++ - h 1 (Ppconstr.pr_id equation_id ++ + then msgnl (h 1 (Ppconstr.pr_id function_name ++ + spc () ++ str"is defined" )++ fnl () ++ + h 1 (Ppconstr.pr_id equation_id ++ spc () ++ str"is defined" ) ) in - try - com_terminate + try + com_terminate tcc_lemma_name tcc_lemma_constr is_mes functional_ref @@ -1428,7 +1428,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num using_lemmas (List.length res_vars) hook - with e -> + with e -> begin ignore(try Vernacentries.vernac_reset_name (Util.dummy_loc,functional_id) with _ -> ()); (* anomaly "Cannot create termination Lemma" *) diff --git a/plugins/groebner/GroebnerR.v b/plugins/groebner/GroebnerR.v index 9122540d72..fc01c58869 100644 --- a/plugins/groebner/GroebnerR.v +++ b/plugins/groebner/GroebnerR.v @@ -6,15 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* +(* Tactic groebnerR: proofs of polynomials equalities with variables in R. Use Hilbert Nullstellensatz and Buchberger algorithm (adapted version of L.Thery Coq proven implementation). Thanks to B.Gregoire and L.Thery for help on ring tactic. Examples at the end of the file. - + 3 versions: - + - groebnerR. - groebnerRp (a::b::c::nil) : give the list of variables are considered as @@ -41,7 +41,7 @@ Declare ML Module "groebner_plugin". Local Open Scope R_scope. Lemma psos_r1b: forall x y, x - y = 0 -> x = y. -intros x y H; replace x with ((x - y) + y); +intros x y H; replace x with ((x - y) + y); [rewrite H | idtac]; ring. Qed. @@ -71,8 +71,8 @@ auto. Qed. -Ltac equalities_to_goal := - lazymatch goal with +Ltac equalities_to_goal := + lazymatch goal with | H: (@eq R ?x 0) |- _ => try revert H | H: (@eq R 0 ?x) |- _ => try generalize (sym_equal H); clear H @@ -93,17 +93,17 @@ Qed. (* Removes x<>0 from hypothesis *) Ltac groebnerR_not_hyp:= - match goal with + match goal with | H: ?x<>?y |- _ => match y with - |0 => + |0 => let H1:=fresh "Hgroebner" in let y:=fresh "x" in destruct (@groebnerR_not1_0 _ H) as (y,H1); clear H |_ => generalize (@groebnerR_diff _ _ H); clear H; intro end end. - + Ltac groebnerR_not_goal := match goal with | |- ?x<>?y :> R => red; intro; apply groebnerR_not2 @@ -124,10 +124,10 @@ Definition PEZ := PExpr Z. Definition P0Z : PolZ := @P0 Z 0%Z. -Definition PolZadd : PolZ -> PolZ -> PolZ := +Definition PolZadd : PolZ -> PolZ -> PolZ := @Padd Z 0%Z Zplus Zeq_bool. -Definition PolZmul : PolZ -> PolZ -> PolZ := +Definition PolZmul : PolZ -> PolZ -> PolZ := @Pmul Z 0%Z 1%Z Zplus Zmult Zeq_bool. Definition PolZeq := @Peq Z Zeq_bool. @@ -143,7 +143,7 @@ Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := match lla with - | List.nil => lp + | List.nil => lp | la::lla => compute_list lla ((mult_l la lp)::lp) end. @@ -154,10 +154,10 @@ Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := (* Correction *) -Definition PhiR : list R -> PolZ -> R := +Definition PhiR : list R -> PolZ -> R := (Pphi 0 Rplus Rmult (gen_phiZ 0 1 Rplus Rmult Ropp)). -Definition PEevalR : list R -> PEZ -> R := +Definition PEevalR : list R -> PEZ -> R := PEeval 0 Rplus Rmult Rminus Ropp (gen_phiZ 0 1 Rplus Rmult Ropp) Nnat.nat_of_N pow. @@ -188,20 +188,20 @@ Proof. Qed. Lemma PolZeq_correct : forall P P' l, - PolZeq P P' = true -> + PolZeq P P' = true -> PhiR l P = PhiR l P'. Proof. - intros;apply + intros;apply (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext (F_R Rfield)));trivial. Qed. Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := - match l with + match l with | List.nil => True | a::l => Interp a = 0 /\ Cond0 A Interp l end. -Lemma mult_l_correct : forall l la lp, +Lemma mult_l_correct : forall l la lp, Cond0 PolZ (PhiR l) lp -> PhiR l (mult_l la lp) = 0. Proof. @@ -220,7 +220,7 @@ Proof. apply mult_l_correct;trivial. Qed. -Lemma check_correct : +Lemma check_correct : forall l lpe qe certif, check lpe qe certif = true -> Cond0 PEZ (PEevalR l) lpe -> @@ -228,11 +228,11 @@ Lemma check_correct : Proof. unfold check;intros l lpe qe (lla, lq) H2 H1. apply PolZeq_correct with (l:=l) in H2. - rewrite norm_correct, H2. + rewrite norm_correct, H2. apply mult_l_correct. apply compute_list_correct. clear H2 lq lla qe;induction lpe;simpl;trivial. - simpl in H1;destruct H1. + simpl in H1;destruct H1. rewrite <- norm_correct;auto. Qed. @@ -244,7 +244,7 @@ elim (Rmult_integral _ _ H0);intros. absurd (c=0);auto. clear H0; induction r; simpl in *. - contradict H1; discrR. + contradict H1; discrR. elim (Rmult_integral _ _ H1); auto. Qed. @@ -255,10 +255,10 @@ Ltac generalise_eq_hyps:= (match goal with |h : (?p = ?q)|- _ => revert h end). - + Ltac lpol_goal t := match t with - | ?a = 0 -> ?b => + | ?a = 0 -> ?b => let r:= lpol_goal b in constr:(a::r) | ?a = 0 => constr:(a::nil) @@ -274,25 +274,25 @@ Fixpoint IPR p {struct p}: R := end. Definition IZR1 z := - match z with Z0 => 0 - | Zpos p => IPR p - | Zneg p => -(IPR p) + match z with Z0 => 0 + | Zpos p => IPR p + | Zneg p => -(IPR p) end. Fixpoint interpret3 t fv {struct t}: R := match t with - | (PEadd t1 t2) => + | (PEadd t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 + v2) - | (PEmul t1 t2) => + | (PEmul t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 * v2) - | (PEsub t1 t2) => + | (PEsub t1 t2) => let v1 := interpret3 t1 fv in let v2 := interpret3 t2 fv in (v1 - v2) - | (PEopp t1) => + | (PEopp t1) => let v1 := interpret3 t1 fv in (-v1) - | (PEpow t1 t2) => + | (PEpow t1 t2) => let v1 := interpret3 t1 fv in v1 ^(Nnat.nat_of_N t2) | (PEc t1) => (IZR1 t1) | (PEX n) => List.nth (pred (nat_of_P n)) fv 0 @@ -303,7 +303,7 @@ Fixpoint interpret3 t fv {struct t}: R := Ltac parametres_en_tete fv lp := match fv with | (@nil _) => lp - | (@cons _ ?x ?fv1) => + | (@cons _ ?x ?fv1) => let res := AddFvTail x lp in parametres_en_tete fv1 res end. @@ -340,7 +340,7 @@ Ltac groebner_call nparam p lp kont := groebner_call_n nparam p n lp kont || let n' := eval compute in (Nsucc n) in try_n n' end in - try_n 1%N. + try_n 1%N. Ltac groebnerR_gen lparam lvar n RNG lH _rl := @@ -351,7 +351,7 @@ Ltac groebnerR_gen lparam lvar n RNG lH _rl := let t := Get_goal in let lpol := lpol_goal t in intros; - let fv := + let fv := match lvar with | nil => let fv1 := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in @@ -381,7 +381,7 @@ Ltac groebnerR_gen lparam lvar n RNG lH _rl := set (lp21:=lp); groebner_call nparam p lp ltac:(fun c r lq lci => set (q := PEmul c (PEpow p21 r)); - let Hg := fresh "Hg" in + let Hg := fresh "Hg" in assert (Hg:check lp21 q (lci,lq) = true); [ (vm_compute;reflexivity) || idtac "invalid groebner certificate" | let Hg2 := fresh "Hg" in diff --git a/plugins/groebner/GroebnerZ.v b/plugins/groebner/GroebnerZ.v index 8fd14aee2b..7c40bbb70f 100644 --- a/plugins/groebner/GroebnerZ.v +++ b/plugins/groebner/GroebnerZ.v @@ -26,7 +26,7 @@ intros x y H. contradict H. f_equal. assumption. Qed. Ltac groebnerZversR1 := - repeat + repeat (match goal with | H:(@eq Z ?x ?y) |- _ => generalize (@groebnerZhypR _ _ H); clear H; intro H @@ -68,6 +68,6 @@ Ltac groebnerZ_begin := simpl in *. (*cbv beta iota zeta delta [nat_of_P Pmult_nat plus mult] in *.*) -Ltac groebnerZ := +Ltac groebnerZ := groebnerZ_begin; (*idtac "groebnerZ_begin;";*) groebnerR. diff --git a/plugins/groebner/groebner.ml4 b/plugins/groebner/groebner.ml4 index da41a89b66..cc1b08a638 100644 --- a/plugins/groebner/groebner.ml4 +++ b/plugins/groebner/groebner.ml4 @@ -75,17 +75,17 @@ module BigInt = struct let hash x = try (int_of_big_int x) with _-> 1 - let puis = power_big_int_positive_int + let puis = power_big_int_positive_int (* a et b positifs, résultat positif *) - let rec pgcd a b = - if equal b coef0 + let rec pgcd a b = + if equal b coef0 then a else if lt a b then pgcd b a else pgcd b (modulo a b) (* signe du pgcd = signe(a)*signe(b) si non nuls. *) - let pgcd2 a b = + let pgcd2 a b = if equal a coef0 then b else if equal b coef0 then a else let c = pgcd (abs a) (abs b) in @@ -113,7 +113,7 @@ module Ent = struct let coef0 = Entiers.ent0 let coef1 = Entiers.ent1 let to_string = Entiers.string_of_ent - let to_int x = Entiers.int_of_ent x + let to_int x = Entiers.int_of_ent x let hash x =Entiers.hash_ent x let signe = Entiers.signe_ent @@ -122,14 +122,14 @@ module Ent = struct |_ -> (mult p (puis p (n-1))) (* a et b positifs, résultat positif *) - let rec pgcd a b = - if equal b coef0 + let rec pgcd a b = + if equal b coef0 then a else if lt a b then pgcd b a else pgcd b (modulo a b) (* signe du pgcd = signe(a)*signe(b) si non nuls. *) - let pgcd2 a b = + let pgcd2 a b = if equal a coef0 then b else if equal b coef0 then a else let c = pgcd (abs a) (abs b) in @@ -175,7 +175,7 @@ let tpexpr = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") -let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") +let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub") let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") @@ -202,7 +202,7 @@ let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]] let tllp () = mkt_app tlist [tlp()] -let rec mkt_pos n = +let rec mkt_pos n = if n =/ num_1 then Lazy.force pxH else if mod_num n num_2 =/ num_0 then mkt_app pxO [mkt_pos (quo_num n num_2)] @@ -214,7 +214,7 @@ let mkt_n n = then Lazy.force nN0 else mkt_app nNpos [mkt_pos n] -let mkt_z z = +let mkt_z z = if z =/ num_0 then Lazy.force z0 else if z >/ num_0 then mkt_app zpos [mkt_pos z] @@ -224,14 +224,14 @@ let mkt_z z = let rec mkt_term t = match t with | Zero -> mkt_term (Const num_0) | Const r -> let (n,d) = numdom r in - mkt_app ttconst [Lazy.force tz; mkt_z n] -| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] + mkt_app ttconst [Lazy.force tz; mkt_z n] +| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] | Opp t1 -> mkt_app ttopp [Lazy.force tz; mkt_term t1] | Add (t1,t2) -> mkt_app ttadd [Lazy.force tz; mkt_term t1; mkt_term t2] | Sub (t1,t2) -> mkt_app ttsub [Lazy.force tz; mkt_term t1; mkt_term t2] | Mul (t1,t2) -> mkt_app ttmul [Lazy.force tz; mkt_term t1; mkt_term t2] -| Pow (t1,n) -> if (n = 0) then - mkt_app ttconst [Lazy.force tz; mkt_z num_1] +| Pow (t1,n) -> if (n = 0) then + mkt_app ttconst [Lazy.force tz; mkt_z num_1] else mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)] @@ -270,10 +270,10 @@ let rec parse_term p = else Zero | _ -> Zero -let rec parse_request lp = +let rec parse_request lp = match kind_of_term lp with | App (_,[|_|]) -> [] - | App (_,[|_;p;lp1|]) -> + | App (_,[|_;p;lp1|]) -> (parse_term p)::(parse_request lp1) |_-> assert false @@ -433,7 +433,7 @@ let rec remove_list_tail l i = ... [cn+m n+m-1,...,cn+m 1]] - enleve les polynomes intermediaires inutiles pour calculer le dernier + enleve les polynomes intermediaires inutiles pour calculer le dernier *) let remove_zeros zero lci = @@ -491,7 +491,7 @@ let theoremedeszeros_termes lp = for i=m downto 1 do lvar:=["x"^string_of_int i^""]@(!lvar); done; name_var:=!lvar; - let lp = List.map (term_pol_sparse nparam) lp in + let lp = List.map (term_pol_sparse nparam) lp in match lp with | [] -> assert false | p::lp1 -> @@ -499,7 +499,7 @@ let theoremedeszeros_termes lp = let (cert,lp0,p,_lct) = theoremedeszeros lpol p in let lc = cert.last_comb::List.rev cert.gb_comb in match remove_zeros (fun x -> x=zeroP) lc with - | [] -> assert false + | [] -> assert false | (lq::lci) -> (* lci commence par les nouveaux polynomes *) let m= !nvars in @@ -524,7 +524,7 @@ let groebner lpol = init_constants (); let lp= parse_request lpol in let (_lp0,_p,c,r,_lci,_lq as rthz) = theoremedeszeros_termes lp in - let certif = certificat_vers_polynome_creux rthz in + let certif = certificat_vers_polynome_creux rthz in let certif = hash_certif certif in let certif = certif_term certif in let c = mkt_term c in diff --git a/plugins/groebner/ideal.ml4 b/plugins/groebner/ideal.ml4 index 73db36d467..eae8499219 100644 --- a/plugins/groebner/ideal.ml4 +++ b/plugins/groebner/ideal.ml4 @@ -9,15 +9,15 @@ (*i camlp4deps: "lib/refutpat.cmo" i*) (* NB: The above camlp4 extension adds a let* syntax for refutable patterns *) -(* +(* Nullstellensatz par calcul de base de Grobner On utilise une representation creuse des polynomes: - un monome est un tableau d'exposants (un par variable), + un monome est un tableau d'exposants (un par variable), avec son degre en tete. un polynome est une liste de (coefficient,monome). - L'algorithme de Buchberger a proprement parler est tire du code caml + L'algorithme de Buchberger a proprement parler est tire du code caml extrait du code Coq ecrit par L.Thery. *) @@ -250,10 +250,10 @@ let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); done; (match !s with - [] -> if coefone + [] -> if coefone then "1" else "" - | l -> if coefone + | l -> if coefone then (String.concat "*" l) else ( "*" ^ (String.concat "*" l))) @@ -267,22 +267,22 @@ let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef | "-1" ->( "-" ^" "^(string_of_mon m true)) | c -> if (String.get c 0)='-' then ( "- "^ - (String.sub c 1 + (String.sub c 1 ((String.length c)-1))^ (string_of_mon m false)) else (match start with true -> ( c^(string_of_mon m false)) |false -> ( "+ "^ c^(string_of_mon m false))) - and stringP p start = + and stringP p start = if (zeroP p) - then (if start + then (if start then ("0") else "") else ((string_of_term (hdP p) start)^ " "^ (stringP (tlP p) false)) - in + in (stringP p true) @@ -299,12 +299,12 @@ let print_pol zeroP hdP tlP coefterm monterm string_of_coef | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); done; (match !s with - [] -> if coefone + [] -> if coefone then print_string "1" else () - | l -> if coefone + | l -> if coefone then print_string (String.concat "*" l) - else (print_string "*"; + else (print_string "*"; print_string (String.concat "*" l))) and print_term t start = let a = coefterm t and m = monterm t in match (string_of_coef a) with @@ -316,16 +316,16 @@ let print_pol zeroP hdP tlP coefterm monterm string_of_coef | "-1" ->(print_string "-";print_space();print_mon m true) | c -> if (String.get c 0)='-' then (print_string "- "; - print_string (String.sub c 1 + print_string (String.sub c 1 ((String.length c)-1)); print_mon m false) else (match start with true -> (print_string c;print_mon m false) |false -> (print_string "+ "; print_string c;print_mon m false)) - and printP p start = + and printP p start = if (zeroP p) - then (if start + then (if start then print_string("0") else ()) else (print_term (hdP p) start; @@ -340,7 +340,7 @@ let print_pol zeroP hdP tlP coefterm monterm string_of_coef let name_var= ref [] -let stringP = string_of_pol +let stringP = string_of_pol (fun p -> match p with [] -> true | _ -> false) (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") @@ -362,7 +362,7 @@ let rec lstringP l = [] -> "" |p::l -> (stringP p)^("\n")^(lstringP l) -let printP = print_pol +let printP = print_pol (fun p -> match p with [] -> true | _ -> false) (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") @@ -388,17 +388,17 @@ let zeroP = [] (* Retourne un polynome constant à d variables *) let polconst d c = let m = Array.create (d+1) 0 in - let m = set_deg d m in + let m = set_deg d m in [(c,m)] - + (* somme de polynomes= liste de couples (int,monomes) *) let plusP d p q = let rec plusP p q = match p with [] -> q - |t::p' -> + |t::p' -> match q with [] -> p |t'::q' -> @@ -434,7 +434,7 @@ let rec selectdiv d m l = let gen d i = let m = Array.create (d+1) 0 in m.(i) <- 1; - let m = set_deg d m in + let m = set_deg d m in [(coef1,m)] @@ -503,13 +503,13 @@ let add_hmon m q = if !use_hmon then Hashtbl.add hmon m q let selectdiv_cache d m l = - try find_hmon m - with Not_found -> + try find_hmon m + with Not_found -> match selectdiv d m l with [] -> [] | q -> add_hmon m q; q -let div_pol d p q a b m = +let div_pol d p q a b m = (* info ".";*) plusP d (emultP a p) (mult_t_pol d b m q) @@ -532,7 +532,7 @@ let reduce2 d p l = let (c,r)=(reduce p') in (c,((P.multP a c,m)::r)) else (coef1,p) - |(b,m')::q' -> + |(b,m')::q' -> let c=(pgcdpos a b) in let a'= (P.divP b c) in let b'=(P.oppP (P.divP a c)) in @@ -544,7 +544,7 @@ let reduce2 d p l = (* trace des divisions *) (* liste des polynomes de depart *) -let poldep = ref [] +let poldep = ref [] let poldepcontent = ref [] @@ -552,7 +552,7 @@ module HashPolPair = Hashtbl.Make (struct type t = poly * poly let equal (p,q) (p',q') = equal p p' && equal q q' - let hash (p,q) = + let hash (p,q) = let c = List.map fst p @ List.map fst q in let m = List.map snd p @ List.map snd q in List.fold_left (fun h p -> h * 17 + P.hash p) (Hashtbl.hash m) c @@ -576,7 +576,7 @@ let initcoefpoldep d lp = (fun p -> coefpoldep_set p p (polconst d coef1)) lp -(* garde la trace dans coefpoldep +(* garde la trace dans coefpoldep divise sans pseudodivisions *) let reduce2_trace d p l lcp = @@ -586,10 +586,10 @@ let reduce2_trace d p l lcp = [] -> ([],[]) |t::p' -> let (a,m)=t in let q = - (try Hashtbl.find hmon m - with Not_found -> + (try Hashtbl.find hmon m + with Not_found -> let q = selectdiv d m l in - match q with + match q with t'::q' -> (Hashtbl.add hmon m q;q) |[] -> q) in match q with @@ -599,7 +599,7 @@ let reduce2_trace d p l lcp = let (lq,r)=(reduce p') in (lq,((a,m)::r)) else ([],p) - |(b,m')::q' -> + |(b,m')::q' -> let b' = P.oppP (P.divP a b) in let m''= div_mon d m m' in let p1=plusP d p' (mult_t_pol d b' m'' q') in @@ -627,7 +627,7 @@ let reduce2_trace d p l lcp = c) lcp !poldep, - r) + r) (*********************************************************************** Algorithme de Janet (V.P.Gerdt Involutive algorithms...) @@ -640,7 +640,7 @@ let homogeneous = ref false let pol_courant = ref [] -type pol3 = +type pol3 = {pol : poly; anc : poly; nmp : mon} @@ -697,7 +697,7 @@ let monom_multiplicative d u s = then m.(i)<- 1; done; m - + (* mu monome des variables multiplicative de u *) let janet_div_mon d u mu v = let res = ref true in @@ -709,7 +709,7 @@ let janet_div_mon d u mu v = i:= !i + 1; done; !res - + let find_multiplicative p mg = try Hashpol.find mg p.pol with Not_found -> (info "\nPROBLEME DANS LA TABLE DES VAR MULT"; @@ -727,7 +727,7 @@ let find_reductor d v lt mt = let r = List.find (fun q -> - let u = fst_mon q in + let u = fst_mon q in let mu = find_multiplicative q mt in janet_div_mon d u mu v ) @@ -793,11 +793,11 @@ let criteria d p g lt = let head_normal_form d p lt mt = let h = ref (p.pol) in - let res = + let res = try ( let v = snd(List.hd !h) in let g = ref (find_reductor d v lt mt) in - if snd(List.hd !h) <> lm_anc p && criteria d p !g lt + if snd(List.hd !h) <> lm_anc p && criteria d p !g lt then ((* info "=";*) []) else ( while !h <> [] && (!g).pol <> [] do @@ -848,14 +848,14 @@ let head_reduce d lq lt mt = (*info ("temps de head_reduce: " ^(Format.sprintf "@[%10.3f@]s\n" ((Unix.gettimeofday ())-.t1)));*) !lq - + let choose_irreductible d lf = List.hd lf (* bien plus lent (List.sort (fun p q -> compare_mon d (fst_mon p.pol) (fst_mon q.pol)) lf) *) - - + + let hashtbl_multiplicative d lf = let mg = Hashpol.create 51 in hashtbl_reductor := Hashtbl.create 51; @@ -867,10 +867,10 @@ let hashtbl_multiplicative d lf = (*info ("temps de hashtbl_multiplicative: " ^(Format.sprintf "@[%10.3f@]s\n" ((Unix.gettimeofday ())-.t1)));*) mg - + let list_diff l x = List.filter (fun y -> y <> x) l - + let janet2 d lf p0 = hashtbl_reductor := Hashtbl.create 51; let t1 = Unix.gettimeofday() in @@ -889,14 +889,14 @@ let janet2 d lf p0 = while !lq <> [] && !r <> [] do let p = choose_irreductible d !lq in lq := list_diff !lq p; - if p.pol = p.anc + if p.pol = p.anc then ( (* on enleve de lt les pol divisibles par p et on les met dans lq *) let m = fst_mon p in let lt1 = !lt in List.iter - (fun q -> + (fun q -> let m'= fst_mon q in - if div_strict d m m' + if div_strict d m m' then ( lq := (!lq) @ [q]; lt := list_diff !lt q)) @@ -916,13 +916,13 @@ let janet2 d lf p0 = if !r <> [] then ( List.iter - (fun q -> + (fun q -> let mq = find_multiplicative q !mt in for i=1 to d do if mq.(i) = 1 then q.nmp.(i)<- 0 else - if q.nmp.(i) = 0 + if q.nmp.(i) = 0 then ( (* info "+";*) lq := (!lq) @ @@ -945,17 +945,17 @@ let janet2 d lf p0 = info ("--- fin Janet2\n"); info ("temps: "^(Format.sprintf "@[%10.3f@]s\n" ((Unix.gettimeofday ())-.t1))); List. map (fun q -> q.pol) !lt - + (********************************************************************** version 3 *) let head_normal_form3 d p lt mt = let h = ref (p.pol) in - let res = + let res = try ( let v = snd(List.hd !h) in let g = ref (find_reductor d v lt mt) in - if snd(List.hd !h) <> lm_anc p && criteria d p !g lt + if snd(List.hd !h) <> lm_anc p && criteria d p !g lt then ((* info "=";*) []) else ( while !h <> [] && (!g).pol <> [] do @@ -979,7 +979,7 @@ let head_normal_form3 d p lt mt = ^(Format.sprintf "@[%10.3f@]s\n" ((Unix.gettimeofday ())-.t1)));*) res - + let janet3 d lf p0 = hashtbl_reductor := Hashtbl.create 51; let t1 = Unix.gettimeofday() in @@ -997,14 +997,14 @@ let janet3 d lf p0 = let* p::lq1 = !lq in lq := lq1; (* - if p.pol = p.anc + if p.pol = p.anc then ( (* on enleve de lt les pol divisibles par p et on les met dans lq *) let m = fst_mon (p.pol) in let lt1 = !lt in List.iter - (fun q -> + (fun q -> let m'= fst_mon (q.pol) in - if div_strict d m m' + if div_strict d m m' then ( lq := (!lq) @ [q]; lt := list_diff !lt q)) @@ -1040,7 +1040,7 @@ let janet3 d lf p0 = if mq.(i) = 1 then q.nmp.(i)<- 0 else - if q.nmp.(i) = 0 + if q.nmp.(i) = 0 then ( (* info "+";*) lq := (!lq) @ @@ -1116,7 +1116,7 @@ let etrangers d p p'= !res -(* teste si le monome dominant de p'' +(* teste si le monome dominant de p'' divise le ppcm des monomes dominants de p et p' *) let div_ppcm d p p' p'' = @@ -1150,10 +1150,10 @@ let rec slice d i a = function else addRes b (slice d i a q1) let rec addS x l = l @[x] - + let addSugar x l = if !sugar_flag - then + then let sx = sugar x in let rec insere l = match l with @@ -1165,13 +1165,13 @@ let addSugar x l = in insere l else addS x l -(* ajoute les spolynomes de i avec la liste de polynomes aP, +(* ajoute les spolynomes de i avec la liste de polynomes aP, a la liste q *) let rec genPcPf d i aP q = match aP with [] -> q - | a::l1 -> + | a::l1 -> (match slice d i a l1 with Keep l2 -> addSugar (spol d i a) (genPcPf d i l2 q) | DontKeep l2 -> genPcPf d i l2 q) @@ -1183,7 +1183,7 @@ let rec genOCPf d = function let step = ref 0 let infobuch p q = - if !step = 0 + if !step = 0 then (info ("[" ^ (string_of_int (List.length p)) ^ "," ^ (string_of_int (List.length q)) ^ "]")) @@ -1266,8 +1266,8 @@ let pbuchf d pq p lp0= info "calcul de la base de Groebner\n"; step:=0; Hashtbl.clear hmon; - let rec pbuchf lp lpc = - infobuch lp lpc; + let rec pbuchf lp lpc = + infobuch lp lpc; (* step:=(!step+1)mod 10;*) match lpc with [] -> test_dans_ideal d p lp lp0 @@ -1297,7 +1297,7 @@ let pbuchf d pq p lp0= poldepcontent:=addS ct (!poldepcontent); try test_dans_ideal d p (addS a0 lp) lp0 with NotInIdeal -> pbuchf (addS a0 lp) (genPcPf d a0 lp lpc2) - in pbuchf (fst pq) (snd pq) + in pbuchf (fst pq) (snd pq) let is_homogeneous p = match p with @@ -1315,8 +1315,8 @@ let is_homogeneous p = [a(n+m,n+m-1);...;a(n+m,1)]] lc = [qn+m; ... q1] - tels que - c*p = sum qi*pi + tels que + c*p = sum qi*pi ou pn+k = a(n+k,n+k-1)*pn+k-1 + ... + a(n+k,1)* p1 *) diff --git a/plugins/groebner/polynom.ml b/plugins/groebner/polynom.ml index 6d2ed26e8d..0a9c3e270e 100644 --- a/plugins/groebner/polynom.ml +++ b/plugins/groebner/polynom.ml @@ -127,17 +127,17 @@ end module Make (C:Coef) = struct type coef = C.t -let coef_of_int i = C.of_num (Num.Int i) +let coef_of_int i = C.of_num (Num.Int i) let coef0 = coef_of_int 0 let coef1 = coef_of_int 1 type variable = int -type t = +type t = Pint of coef (* polynome constant *) | Prec of variable * (t array) (* coefficients par degre croissant *) -(* sauf mention du contraire, les opérations ne concernent que des +(* sauf mention du contraire, les opérations ne concernent que des polynomes normalisés: - les variables sont des entiers strictement positifs. - les coefficients d'un polynome en x ne font intervenir que des variables < x. @@ -149,12 +149,12 @@ type t = let of_num x = Pint (C.of_num x) let cf0 = of_num (Num.Int 0) let cf1 = of_num (Num.Int 1) - + (* la n-ième variable *) let x n = Prec (n,[|cf0;cf1|]) (* crée rapidement v^n *) -let monome v n = +let monome v n = match n with 0->Pint coef1; |_->let tmp = Array.create (n+1) (Pint coef0) in @@ -169,7 +169,7 @@ let is_constantP = function (* conversion d'un poly cst en entier*) -let int_of_Pint = function +let int_of_Pint = function Pint x -> x | _ -> failwith "non" @@ -179,15 +179,15 @@ let is_zero p = match p with Pint n -> if C.equal n coef0 then true else false |_-> false (* variable max *) -let max_var_pol p = - match p with +let max_var_pol p = + match p with Pint _ -> 0 |Prec(x,_) -> x (* p n'est pas forcément normalisé *) let rec max_var_pol2 p = - match p with + match p with Pint _ -> 0 |Prec(v,c)-> Array.fold_right (fun q m -> max (max_var_pol2 q) m) c v @@ -196,11 +196,11 @@ let rec max_var_pol2 p = let rec max_var l = Array.fold_right (fun p m -> max (max_var_pol2 p) m) l 0 -(* Egalité de deux polynômes +(* Egalité de deux polynômes On ne peut pas utiliser = car elle ne marche pas sur les Big_int. *) let rec equal p q = - match (p,q) with + match (p,q) with (Pint a,Pint b) -> C.equal a b |(Prec(x,p1),Prec(y,q1)) -> if x<>y then false @@ -216,17 +216,17 @@ let rec equal p q = sont supposés normalisés. si constant, rend le coef constant. *) - + let rec norm p = match p with Pint _ -> p |Prec (x,a)-> let d = (Array.length a -1) in - let n = ref d in + let n = ref d in while !n>0 && (equal a.(!n) (Pint coef0)) do n:=!n-1; done; if !n<0 then Pint coef0 - else if !n=0 then a.(0) + else if !n=0 then a.(0) else if !n=d then p else (let b=Array.create (!n+1) (Pint coef0) in for i=0 to !n do b.(i)<-a.(i);done; @@ -235,14 +235,14 @@ let rec norm p = match p with (* degré en la variable v du polynome p, v >= max var de p *) let rec deg v p = - match p with + match p with Prec(x,p1) when x=v -> Array.length p1 -1 |_ -> 0 (* degré total *) let rec deg_total p = - match p with + match p with Prec (x,p1) -> let d = ref 0 in Array.iteri (fun i q -> d:= (max !d (i+(deg_total q)))) p1; !d @@ -258,7 +258,7 @@ let rec copyP p = (* coefficient de degre i en v, v >= max var de p *) let coef v i p = - match p with + match p with Prec (x,p1) when x=v -> if i<(Array.length p1) then p1.(i) else Pint coef0 |_ -> if i=0 then p else Pint coef0 @@ -273,20 +273,20 @@ let rec plusP p q = |(Prec (x,p1),Pint b) -> let p2=Array.map copyP p1 in p2.(0)<- plusP p1.(0) q; Prec (x,p2) - |(Prec (x,p1),Prec (y,q1)) -> + |(Prec (x,p1),Prec (y,q1)) -> if xy then (let p2=Array.map copyP p1 in p2.(0)<- plusP p1.(0) q; Prec (x,p2)) - else - (let n=max (deg x p) (deg x q) in + else + (let n=max (deg x p) (deg x q) in let r=Array.create (n+1) (Pint coef0) in for i=0 to n do r.(i)<- plusP (coef x i p) (coef x i q); done; - Prec(x,r))) + Prec(x,r))) in norm res @@ -324,8 +324,8 @@ let rec multx n v p = p2.(i+n)<-p1.(i); done; Prec (x,p2) - |_ -> if p = (Pint coef0) then (Pint coef0) - else (let p2=Array.create (n+1) (Pint coef0) in + |_ -> if p = (Pint coef0) then (Pint coef0) + else (let p2=Array.create (n+1) (Pint coef0) in p2.(n)<-p; Prec (v,p2)) @@ -338,13 +338,13 @@ let rec multP p q = if C.equal a coef0 then Pint coef0 else let q2 = Array.map (fun z-> multP p z) q1 in Prec (y,q2) - + |(Prec (x,p1), Pint b) -> if C.equal b coef0 then Pint coef0 else let p2 = Array.map (fun z-> multP z q) p1 in Prec (x,p2) |(Prec (x,p1), Prec(y,q1)) -> - if x multP p z) q1 in Prec (y,q2)) else if x>y @@ -357,7 +357,7 @@ let rec multP p q = (* derive p par rapport a la variable v, v >= max_var p *) let rec deriv v p = - match p with + match p with Pint a -> Pint coef0 | Prec(x,p1) when x=v -> let d = Array.length p1 -1 in @@ -373,7 +373,7 @@ let rec deriv v p = (* opposé de p *) let rec oppP p = - match p with + match p with Pint a -> Pint (C.opp a) |Prec(x,p1) -> Prec(x,Array.map oppP p1) @@ -428,7 +428,7 @@ let rec coef_constant p = match p with Pint a->a |Prec(_,q)->coef_constant q.(0) - + (*********************************************************************** 3. Affichage des polynômes. @@ -437,13 +437,13 @@ let rec coef_constant p = (* si univ=false, on utilise x,y,z,a,b,c,d... comme noms de variables, sinon, x1,x2,... *) -let univ=ref true +let univ=ref true (* joli jusqu'a trois variables -- sinon changer le 'w' *) let string_of_var x= if !univ then "u"^(string_of_int x) - else + else if x<=3 then String.make 1 (Char.chr(x+(Char.code 'w'))) else String.make 1 (Char.chr(x-4+(Char.code 'a'))) @@ -452,8 +452,8 @@ let nsP = ref 0 let rec string_of_Pcut p = if (!nsP)<=0 then "..." - else - match p with + else + match p with |Pint a-> nsP:=(!nsP)-1; if C.le coef0 a then C.to_string a @@ -467,7 +467,7 @@ let rec string_of_Pcut p = then s:=st0; let fin = ref false in for i=(Array.length t)-1 downto 1 do - if (!nsP)<0 + if (!nsP)<0 then (sp:="..."; if not (!fin) then s:=(!s)^"+"^(!sp); fin:=true) @@ -501,10 +501,10 @@ let rec string_of_Pcut p = if !s="" then (nsP:=(!nsP)-1; (s:="0")); !s - + let to_string p = nsP:=20; - string_of_Pcut p + string_of_Pcut p let printP p = Format.printf "@[%s@]" (to_string p) @@ -526,13 +526,13 @@ let print_lpoly lp = print_tpoly (Array.of_list lp) (* rend (s,r) tel que p = s*q+r *) let rec quo_rem_pol p q x = if x=0 - then (match (p,q) with + then (match (p,q) with |(Pint a, Pint b) -> - if C.equal (C.modulo a b) coef0 + if C.equal (C.modulo a b) coef0 then (Pint (C.div a b), cf0) else failwith "div_pol1" |_ -> assert false) - else + else let m = deg x q in let b = coefDom x q in let q1 = remP x q in (* q = b*x^m+q1 *) @@ -567,13 +567,13 @@ and div_pol p q x = ) -(* test de division exacte de p par q mais constantes rationnels +(* test de division exacte de p par q mais constantes rationnels à vérifier *) let divP p q= let x = max (max_var_pol p) (max_var_pol q) in div_pol p q x -(* test de division exacte de p par q mais constantes rationnels +(* test de division exacte de p par q mais constantes rationnels à vérifier *) let div_pol_rat p q= let x = max (max_var_pol p) (max_var_pol q) in @@ -600,7 +600,7 @@ let pseudo_div p q x = match q with Pint _ -> (cf0, q,1, p) | Prec (v,q1) when x<>v -> (cf0, q,1, p) - | Prec (v,q1) -> + | Prec (v,q1) -> ( (* pr "pseudo_division: c^d*p = s*q + r";*) let delta = ref 0 in @@ -636,7 +636,7 @@ let rec pgcdP p q = and pgcd_pol p q x = pgcd_pol_rec p q x -and content_pol p x = +and content_pol p x = match p with Prec(v,p1) when v=x -> Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) cf0 p1 @@ -647,8 +647,8 @@ and pgcd_coef_pol c p x = Prec(v,p1) when x=v -> Array.fold_left (fun a b -> pgcd_pol_rec a b (x-1)) c p1 |_ -> pgcd_pol_rec c p (x-1) - - + + and pgcd_pol_rec p q x = match (p,q) with (Pint a,Pint b) -> Pint (C.pgcd (C.abs a) (C.abs b)) @@ -686,7 +686,7 @@ and pgcd_pol_rec p q x = ai = (- ci+1)^(di + 1) b1 = 1 bi = ci*si^di si i>1 - + s1 = 1 si+1 = ((ci+1)^di*si)/si^di @@ -694,7 +694,7 @@ and pgcd_pol_rec p q x = and gcd_sub_res p q x = if equal q cf0 then p - else + else let d = deg x p in let d' = deg x q in if d +let factorise = + memoP "f" hfactorise + (fun p -> let rec fact p x = if x=0 then [] @@ -859,8 +859,8 @@ let set_of_array_facteurs tf = (* Factorise un tableau de polynômes f, et rend: - - un tableau p de facteurs (degré>0, contenu entier 1, - coefficient de tête >0) obtenu par décomposition sans carrés + - un tableau p de facteurs (degré>0, contenu entier 1, + coefficient de tête >0) obtenu par décomposition sans carrés puis par division mutuelle - un tableau l de couples (constante, listes d'indices l) tels que f.(i) = l.(i)_1*Produit(p.(j), j dans l.(i)_2) @@ -887,7 +887,7 @@ let factorise_tableauP2 f l1 = f l1 in pr ">"; res - + let factorise_tableauP f = factorise_tableauP2 f (Array.map facteurs2 f) @@ -901,9 +901,9 @@ let factorise_tableauP f = let rec is_positif p = let res = - match p with + match p with Pint a -> C.le coef0 a - |Prec(x,p1) -> + |Prec(x,p1) -> (array_for_all is_positif p1) && (try (Array.iteri (fun i c -> if (i mod 2)<>0 && not (equal c cf0) then failwith "pas pair") @@ -919,7 +919,7 @@ let is_negatif p = is_positif (oppP p) (* rend r tel que deg r < deg q et r a le signe de p en les racines de q. - le coefficient dominant de q est non nul + le coefficient dominant de q est non nul quand les polynômes de coef_non_nuls le sont. (rs,cs,ds,ss,crs,lpos,lpol)= pseudo_euclide coef_non_nuls vect.(s-1) res.(s-1) v *) @@ -943,7 +943,7 @@ let pseudo_euclide coef_non_nuls p q x = let r = if d mod 2 = 1 then c@@r else r in let s = if d mod 2 = 1 then c@@s else s in let d = if d mod 2 = 1 then d+1 else d in - + (* on encore c^d * p = s*q + r, mais d pair *) if equal r cf0 then ((*pr "reste nul"; *) (r,c,d,s,cf1,[],[])) @@ -960,7 +960,7 @@ let pseudo_euclide coef_non_nuls p q x = let k = ref 0 in (try (while true do let rd = div_pol !r f x in - (* verification de la division + (* verification de la division if not (equal cf0 ((!r)--(f@@rd))) then failwith "erreur dans la division"; *) @@ -972,7 +972,7 @@ let pseudo_euclide coef_non_nuls p q x = lf:=(f,!k)::(!lf))) coef_non_nuls; (* il faut éventuellement remultiplier pour garder le signe de r *) - let lpos = ref [] in + let lpos = ref [] in let lpol = ref [] in List.iter (fun (f,k) -> if k>0 @@ -1006,7 +1006,7 @@ let pseudo_euclide coef_non_nuls p q x = *) (* lpos = liste de (f,k) ou f est non nul positif, et f^k divise r0 lpol = liste de (f,k) ou f non nul, k est pair et f^k divise r0 - on c^d * p = s*q + r0 + on c^d * p = s*q + r0 avec d pair r0 = cr * r * PI_lpos f^k * PI_lpol g^k cr non nul positif @@ -1016,14 +1016,14 @@ let pseudo_euclide coef_non_nuls p q x = (* teste si la non-nullité des polynômes de lp entraîne celle de p: - chacun des facteurs de la décomposition sans carrés de p + chacun des facteurs de la décomposition sans carrés de p divise un des polynômes de lp (dans Q[x1...xn]) *) let implique_non_nul lp p = if equal p cf0 then false else( pr "["; - let lf = facteurs2 p in + let lf = facteurs2 p in let r =( try (List.iter (fun f -> if (try (List.iter (fun q -> diff --git a/plugins/groebner/utile.ml b/plugins/groebner/utile.ml index fc7de1e33d..40644489b2 100644 --- a/plugins/groebner/utile.ml +++ b/plugins/groebner/utile.ml @@ -21,7 +21,7 @@ let info s = (********************************************************************** Listes *) - + (* appartenance à une liste , on donne l'égalité *) let rec list_mem_eq eq x l = match l with @@ -32,13 +32,13 @@ let rec list_mem_eq eq x l = let set_of_list_eq eq l = let res = ref [] in List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l; - List.rev !res + List.rev !res (*********************************************************************** Un outil pour faire une mémo-fonction: fonction est la fonction(!) - memoire est une référence au graphe déjà calculé + memoire est une référence au graphe déjà calculé (liste de couples, c'est une variable globale) egal est l'égalité sur les arguments valeur est une valeur possible de la fonction (sert uniquement pour le typage) @@ -56,9 +56,9 @@ let memo memoire egal valeur fonction x = with _ -> !res -(* un autre plus efficace, +(* un autre plus efficace, utilisant une fonction intermediaire (utile si on n'a pas - l'égalité = sur les arguments de fonction) + l'égalité = sur les arguments de fonction) s chaîne imprimée s'il n'y a pas calcul *) let memos s memoire print fonction x = @@ -71,8 +71,8 @@ let memos s memoire print fonction x = (********************************************************************** Eléments minimaux pour un ordre partiel de division. - E est un ensemble, avec une multiplication - et une division partielle div (la fonction div peut échouer), + E est un ensemble, avec une multiplication + et une division partielle div (la fonction div peut échouer), constant est un prédicat qui définit un sous-ensemble C de E. *) (* @@ -128,7 +128,7 @@ let factorise_tableau div zero c f l1 = let r = ref p in let li = ref [] in if not (zero p) - then + then Array.iteri (fun j q -> try (while true do let rr = div !r q in @@ -140,12 +140,12 @@ let factorise_tableau div zero c f l1 = res.(i)<-(!r,!li)) f; (l1,res) - + (* exemples: let l = [1;2;6;24;720] -and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div") +and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div") and constant = (fun x -> x<2) and zero = (fun x -> x=0) diff --git a/plugins/interface/blast.ml b/plugins/interface/blast.ml index 2f0095a56c..55db032f30 100644 --- a/plugins/interface/blast.ml +++ b/plugins/interface/blast.ml @@ -71,11 +71,11 @@ let free_try tac g = else (failwith "not free") ;; let adrel (x,t) e = - match x with + match x with Name(xid) -> Environ.push_rel (x,None,t) e | Anonymous -> Environ.push_rel (x,None,t) e (* les constantes ayant une définition apparaissant dans x *) -let rec def_const_in_term_rec vl x = +let rec def_const_in_term_rec vl x = match (kind_of_term x) with Prod(n,t,c)-> let vl = (adrel (n,t) vl) in def_const_in_term_rec vl c @@ -89,7 +89,7 @@ let rec def_const_in_term_rec vl x = new_sort_in_family (inductive_sort_family mip) | Construct(c) -> def_const_in_term_rec vl (mkInd (inductive_of_constructor c)) - | Case(_,x,t,a) + | Case(_,x,t,a) -> def_const_in_term_rec vl x | Cast(x,_,t)-> def_const_in_term_rec vl t | Const(c) -> def_const_in_term_rec vl (Typeops.type_of_constant vl c) @@ -99,7 +99,7 @@ let def_const_in_term_ x = def_const_in_term_rec (Global.env()) (strip_outer_cast x) ;; (************************************************************************* - recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli + recopiés de refiner.ml, car print_subscript pas exportée dans refiner.mli modif de print_info_script avec pr_bar *) @@ -115,9 +115,9 @@ let rec print_info_script sigma osign pf = | [] -> (str " " ++ fnl()) | [pf1] -> - if pf1.ref = None then + if pf1.ref = None then (str " " ++ fnl()) - else + else (str";" ++ brk(1,3) ++ print_info_script sigma sign pf1) | _ -> ( str";[" ++ fnl() ++ @@ -125,11 +125,11 @@ let rec print_info_script sigma osign pf = (print_info_script sigma sign) spfl ++ str"]") -let format_print_info_script sigma osign pf = +let format_print_info_script sigma osign pf = hov 0 (print_info_script sigma osign pf) - -let print_subscript sigma sign pf = - (* if is_tactic_proof pf then + +let print_subscript sigma sign pf = + (* if is_tactic_proof pf then format_print_info_script sigma sign (subproof_of_proof pf) else *) format_print_info_script sigma sign pf @@ -150,98 +150,98 @@ let pp_string x = let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) -let unify_e_resolve (c,clenv) gls = +let unify_e_resolve (c,clenv) gls = let clenv' = connect_clenv gls clenv in let _ = clenv_unique_resolver false clenv' gls in Hiddentac.h_simplest_eapply c gls let rec e_trivial_fail_db db_list local_db goal = - let tacl = + let tacl = registered_e_assumption :: - (tclTHEN Tactics.intro + (tclTHEN Tactics.intro (function g'-> let d = pf_last_hyp g' in let hintl = make_resolve_hyp (pf_env g') (project g') d in (e_trivial_fail_db db_list (Hint_db.add_list hintl local_db) g'))) :: (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) - in - tclFIRST (List.map tclCOMPLETE tacl) goal + in + tclFIRST (List.map tclCOMPLETE tacl) goal -and e_my_find_search db_list local_db hdc concl = +and e_my_find_search db_list local_db hdc concl = let hdc = head_of_constr_reference hdc in let hintl = - if occur_existential concl then - list_map_append (fun db -> + if occur_existential concl then + list_map_append (fun db -> let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list) - else - list_map_append (fun db -> + else + list_map_append (fun db -> let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) - in - let tac_of_hint = - fun (st, ({pri=b; pat = p; code=t} as _patac)) -> - (b, + in + let tac_of_hint = + fun (st, ({pri=b; pat = p; code=t} as _patac)) -> + (b, let tac = match t with | Res_pf (term,cl) -> unify_resolve st (term,cl) | ERes_pf (term,cl) -> unify_e_resolve (term,cl) | Give_exact (c) -> e_give_exact c | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve (term,cl)) + tclTHEN (unify_e_resolve (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] | Extern tacast -> Auto.conclPattern concl p tacast - in + in (free_try tac,pr_autotactic t)) (*i - fun gls -> pPNL (pr_autotactic t); Format.print_flush (); + fun gls -> pPNL (pr_autotactic t); Format.print_flush (); try tac gls - with e when Logic.catchable_exception(e) -> - (Format.print_string "Fail\n"; - Format.print_flush (); + with e when Logic.catchable_exception(e) -> + (Format.print_string "Fail\n"; + Format.print_flush (); raise e) i*) - in + in List.map tac_of_hint hintl - -and e_trivial_resolve db_list local_db gl = - try - priority - (e_my_find_search db_list local_db + +and e_trivial_resolve db_list local_db gl = + try + priority + (e_my_find_search db_list local_db (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = - try List.map snd (e_my_find_search db_list local_db + try List.map snd (e_my_find_search db_list local_db (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let assumption_tac_list id = apply_tac_list (e_give_exact (mkVar id)) -let find_first_goal gls = +let find_first_goal gls = try first_goal gls with UserError _ -> assert false (*s The following module [SearchProblem] is used to instantiate the generic exploration functor [Explore.Make]. *) - + module MySearchProblem = struct - type state = { + type state = { depth : int; (*r depth of search before failing *) tacres : goal list sigma * validation; last_tactic : std_ppcmds; dblist : Auto.hint_db list; localdb : Auto.hint_db list } - + let success s = (sig_it (fst s.tacres)) = [] let rec filter_tactics (glls,v) = function | [] -> [] - | (tac,pptac) :: tacl -> - try - let (lgls,ptl) = apply_tac_list tac glls in + | (tac,pptac) :: tacl -> + try + let (lgls,ptl) = apply_tac_list tac glls in let v' p = v (ptl p) in ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl with e when Logic.catchable_exception e -> @@ -254,18 +254,18 @@ module MySearchProblem = struct let nbgoals s = List.length (sig_it (fst s.tacres)) in if d <> 0 then d else nbgoals s - nbgoals s' - let branching s = - if s.depth = 0 then + let branching s = + if s.depth = 0 then [] - else + else let lg = fst s.tacres in let nbgl = List.length (sig_it lg) in assert (nbgl > 0); let g = find_first_goal lg in - let assumption_tacs = - let l = + let assumption_tacs = + let l = filter_tactics s.tacres - (List.map + (List.map (fun id -> (e_give_exact (mkVar id), (str "Exact" ++ spc()++ pr_id id))) (pf_ids_of_hyps g)) @@ -274,40 +274,40 @@ module MySearchProblem = struct last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb }) l in - let intro_tac = - List.map - (fun ((lgls,_) as res,pp) -> - let g' = first_goal lgls in - let hintl = + let intro_tac = + List.map + (fun ((lgls,_) as res,pp) -> + let g' = first_goal lgls in + let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') in let ldb = Hint_db.add_list hintl (List.hd s.localdb) in - { depth = s.depth; tacres = res; + { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = ldb :: List.tl s.localdb }) (filter_tactics s.tacres [Tactics.intro,(str "Intro" )]) in - let rec_tacs = - let l = + let rec_tacs = + let l = filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) in - List.map - (fun ((lgls,_) as res, pp) -> + List.map + (fun ((lgls,_) as res, pp) -> let nbgl' = List.length (sig_it lgls) in if nbgl' < nbgl then { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb } - else - { depth = pred s.depth; tacres = res; + else + { depth = pred s.depth; tacres = res; dblist = s.dblist; last_tactic = pp; - localdb = + localdb = list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }) l in List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) - let pp s = + let pp s = msg (hov 0 (str " depth="++ int s.depth ++ spc() ++ s.last_tactic ++ str "\n")) @@ -331,31 +331,31 @@ let e_depth_search debug p db_list local_db gl = let e_breadth_search debug n db_list local_db gl = try - let tac = - if debug then MySearch.debug_breadth_first else MySearch.breadth_first + let tac = + if debug then MySearch.debug_breadth_first else MySearch.breadth_first in let s = tac (make_initial_state n gl db_list local_db) in s.MySearchProblem.tacres with Not_found -> error "EAuto: breadth first search failed" -let e_search_auto debug (n,p) db_list gl = - let local_db = make_local_hint_db true [] gl in - if n = 0 then +let e_search_auto debug (n,p) db_list gl = + let local_db = make_local_hint_db true [] gl in + if n = 0 then e_depth_search debug p db_list local_db gl - else + else e_breadth_search debug n db_list local_db gl -let eauto debug np dbnames = +let eauto debug np dbnames = let db_list = List.map - (fun x -> + (fun x -> try searchtable_map x with Not_found -> error ("EAuto: "^x^": No such Hint database")) - ("core"::dbnames) + ("core"::dbnames) in tclTRY (e_search_auto debug np db_list) -let full_eauto debug n gl = +let full_eauto debug n gl = let dbnames = current_db_names () in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map searchtable_map dbnames in @@ -373,49 +373,49 @@ let my_full_eauto n gl = full_eauto false (n,0) gl de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) let rec trivial_fail_db db_list local_db gl = - let intro_tac = - tclTHEN intro + let intro_tac = + tclTHEN intro (fun g'-> let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g') in - tclFIRST + tclFIRST (assumption::intro_tac:: - (List.map tclCOMPLETE + (List.map tclCOMPLETE (trivial_resolve db_list local_db (pf_concl gl)))) gl and my_find_search db_list local_db hdc concl = - let tacl = - if occur_existential concl then - list_map_append (fun db -> + let tacl = + if occur_existential concl then + list_map_append (fun db -> let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list) - else - list_map_append (fun db -> + else + list_map_append (fun db -> let flags = {Auto.auto_unif_flags with Unification.modulo_delta = Hint_db.transparent_state db} in List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) in - List.map - (fun (st, {pri=b; pat=p; code=t} as _patac) -> + List.map + (fun (st, {pri=b; pat=p; code=t} as _patac) -> (b, match t with | Res_pf (term,cl) -> unify_resolve st (term,cl) | ERes_pf (_,c) -> (fun gl -> error "eres_pf") | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN - (unify_resolve st (term,cl)) + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN + (unify_resolve st (term,cl)) (trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] | Extern tacast -> conclPattern concl p tacast)) tacl -and trivial_resolve db_list local_db cl = - try +and trivial_resolve db_list local_db cl = + try let hdconstr = fst (head_constr_bound cl) in - priority + priority (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) - with Bound | Not_found -> + with Bound | Not_found -> [] (**************************************************************************) @@ -423,88 +423,88 @@ and trivial_resolve db_list local_db cl = (**************************************************************************) let possible_resolve db_list local_db cl = - try + try let hdconstr = fst (head_constr_bound cl) in - List.map snd + List.map snd (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl) - with Bound | Not_found -> + with Bound | Not_found -> [] -let decomp_unary_term c gls = - let typc = pf_type_of gls c in - let t = head_constr typc in - if Hipattern.is_conjunction (applist t) then - simplest_case c gls - else +let decomp_unary_term c gls = + let typc = pf_type_of gls c in + let t = head_constr typc in + if Hipattern.is_conjunction (applist t) then + simplest_case c gls + else errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") -let decomp_empty_term c gls = - let typc = pf_type_of gls c in - let (hd,_) = decompose_app typc in - if Hipattern.is_empty_type hd then - simplest_case c gls - else +let decomp_empty_term c gls = + let typc = pf_type_of gls c in + let (hd,_) = decompose_app typc in + if Hipattern.is_empty_type hd then + simplest_case c gls + else errorlabstrm "Auto.decomp_empty_term" (str "not an empty type") -(* decomp is an natural number giving an indication on decomposition +(* decomp is an natural number giving an indication on decomposition of conjunction in hypotheses, 0 corresponds to no decomposition *) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) let rec search_gen decomp n db_list local_db extra_sign goal = if n=0 then error "BOUND 2"; - let decomp_tacs = match decomp with - | 0 -> [] - | p -> + let decomp_tacs = match decomp with + | 0 -> [] + | p -> (tclFIRST_PROGRESS_ON decomp_empty_term extra_sign) :: - (List.map - (fun id -> tclTHEN (decomp_unary_term (mkVar id)) - (tclTHEN + (List.map + (fun id -> tclTHEN (decomp_unary_term (mkVar id)) + (tclTHEN (clear [id]) (free_try (search_gen decomp p db_list local_db [])))) - (pf_ids_of_hyps goal)) + (pf_ids_of_hyps goal)) in - let intro_tac = - tclTHEN intro - (fun g' -> + let intro_tac = + tclTHEN intro + (fun g' -> let (hid,_,htyp) = pf_last_hyp g' in - let hintl = - try + let hintl = + try [make_apply_entry (pf_env g') (project g') - (true,true,false) + (true,true,false) None (mkVar hid,htyp)] - with Failure _ -> [] + with Failure _ -> [] in (free_try (search_gen decomp n db_list (Hint_db.add_list hintl local_db) [mkVar hid]) g')) in - let rec_tacs = - List.map - (fun ntac -> + let rec_tacs = + List.map + (fun ntac -> tclTHEN ntac (free_try (search_gen decomp (n-1) db_list local_db []))) (possible_resolve db_list local_db (pf_concl goal)) - in + in tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal let search = search_gen 0 let default_search_depth = ref 5 - -let full_auto n gl = + +let full_auto n gl = let dbnames = current_db_names () in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map searchtable_map dbnames in let hyps = List.map mkVar (pf_ids_of_hyps gl) in tclTRY (search n db_list (make_local_hint_db false [] gl) hyps) gl - + let default_full_auto gl = full_auto !default_search_depth gl (************************************************************************) @@ -518,15 +518,15 @@ let blast_auto = (free_try default_full_auto) ;; let blast_simpl = (free_try (reduce (Simpl None) onConcl)) ;; -let blast_induction1 = +let blast_induction1 = (free_try (tclTHEN (tclTRY intro) (tclTRY (onLastHyp simplest_elim)))) ;; -let blast_induction2 = +let blast_induction2 = (free_try (tclTHEN (tclTRY (tclTHEN intro intro)) (tclTRY (onLastHyp simplest_elim)))) ;; -let blast_induction3 = +let blast_induction3 = (free_try (tclTHEN (tclTRY (tclTHEN intro (tclTHEN intro intro))) (tclTRY (onLastHyp simplest_elim)))) ;; @@ -554,7 +554,7 @@ let vire_extvar s = if get s i = '?' then (interro := true; interro_pos := i) - else if (!interro && + else if (!interro && (List.mem (get s i) ['0';'1';'2';'3';'4';'5';'6';'7';'8';'9'])) then set s i ' ' @@ -570,13 +570,13 @@ let blast gls = ref = None } in try (let (sgl,v) as _res = !blast_tactic gls in let {it=lg} = sgl in - if lg = [] + if lg = [] then (let pf = v (List.map leaf (sig_it sgl)) in let sign = (sig_it gls).evar_hyps in - let x = print_subscript + let x = print_subscript (sig_sig gls) sign pf in msgnl (hov 0 (str"Blast ==> " ++ x)); - let x = print_subscript + let x = print_subscript (sig_sig gls) sign pf in let tac_string = pp_string (hov 0 x ) in @@ -589,15 +589,15 @@ let blast gls = with _ -> failwith "echec de blast" ;; -let blast_tac display_function = function - | (n::_) as _l -> +let blast_tac display_function = function + | (n::_) as _l -> (function g -> let exp_ast = (blast g) in (display_function exp_ast; tclIDTAC g)) | _ -> failwith "expecting other arguments";; -let blast_tac_txt = +let blast_tac_txt = blast_tac (function x -> msgnl(Pptactic.pr_glob_tactic (Global.env()) (Tacinterp.glob_tactic x)));; @@ -621,8 +621,8 @@ CAMLLIB=/usr/local/lib/ocaml CAMLP4LIB=/usr/local/lib/camlp4 export CAMLLIB export COQTOP -export CAMLP4LIB -d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe +export CAMLP4LIB +d:/Tools/coq-7.0-3mai/bin/coqtop.byte.exe Drop. #use "/cygdrive/D/Tools/coq-7.0-3mai/dev/base_include";; *) diff --git a/plugins/interface/centaur.ml4 b/plugins/interface/centaur.ml4 index ee46cef8b2..e7084fbb00 100644 --- a/plugins/interface/centaur.ml4 +++ b/plugins/interface/centaur.ml4 @@ -74,17 +74,17 @@ let pcoq_history = ref true;; let assert_pcoq_history f a = if !pcoq_history then f a else error "Pcoq-style history tracking deactivated";; -let current_proof_name () = - try +let current_proof_name () = + try string_of_id (get_current_proof_name ()) with UserError("Pfedit.get_proof", _) -> "";; let current_goal_index = ref 0;; -let guarded_force_eval_stream (s : std_ppcmds) = +let guarded_force_eval_stream (s : std_ppcmds) = let l = ref [] in - let f elt = l:= elt :: !l in + let f elt = l:= elt :: !l in (try Stream.iter f s with | _ -> f (Stream.next (str "error guarded_force_eval_stream"))); Stream.of_list (List.rev !l);; @@ -118,7 +118,7 @@ type vtp_tree = | P_text of ct_TEXT | P_ids of ct_ID_LIST;; -let print_tree t = +let print_tree t = (match t with | P_rl x -> fRULE_LIST x | P_r x -> fRULE x @@ -138,10 +138,10 @@ let ctf_header message_name request_id = int request_id ++ fnl();; let ctf_acknowledge_command request_id command_count opt_exn = - let goal_count, goal_index = + let goal_count, goal_index = if refining() then let g_count = - List.length + List.length (fst (frontier (proof_of_pftreestate (get_pftreestate ())))) in g_count, !current_goal_index else @@ -192,7 +192,7 @@ let ctf_AbortedAllMessage () = fnl() ++ str "message" ++ fnl() ++ str "aborted_all" ++ fnl();; let ctf_AbortedMessage request_id na = - ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ + ctf_header "aborted_proof" request_id ++ str na ++ fnl () ++ str "E-n-d---M-e-s-s-a-g-e" ++ fnl ();; let ctf_UserErrorMessage request_id stream = @@ -256,7 +256,7 @@ let show_nth n = ++ pr_nth_open_subgoal n) None with - | Invalid_argument s -> + | Invalid_argument s -> error "No focused proof (No proof-editing in progress)";; let show_subgoals () = @@ -265,7 +265,7 @@ let show_subgoals () = ++ pr_open_subgoals ()) None with - | Invalid_argument s -> + | Invalid_argument s -> error "No focused proof (No proof-editing in progress)";; (* The rest of the file contains commands that are changed from the plain @@ -280,11 +280,11 @@ let filter_by_module_from_varg_list l = *) let add_search (global_reference:global_reference) assumptions cstr = - try + try let id_string = string_of_qualid (Nametab.shortest_qualid_of_global Idset.empty global_reference) in - let ast = + let ast = try CT_premise (CT_ident id_string, translate_constr false assumptions cstr) with Not_found -> @@ -324,20 +324,20 @@ let ct_print_eval red_fun env evmap ast judg = translate_constr false env ntyp)]));; let pbp_tac_pcoq = - pbp_tac (function (x:raw_tactic_expr) -> + pbp_tac (function (x:raw_tactic_expr) -> output_results (ctf_header "pbp_results" !global_request_id) (Some (P_t(xlate_tactic x))));; let blast_tac_pcoq = - blast_tac (function (x:raw_tactic_expr) -> + blast_tac (function (x:raw_tactic_expr) -> output_results (ctf_header "pbp_results" !global_request_id) (Some (P_t(xlate_tactic x))));; -(* <\cpa> +(* <\cpa> let dad_tac_pcoq = - dad_tac(function x -> + dad_tac(function x -> output_results (ctf_header "pbp_results" !global_request_id) (Some (P_t(xlate_tactic x))));; @@ -368,7 +368,7 @@ Caution, this is in the middle of what looks like dead code. ; e -> match !the_goal with None -> raise e - | Some g -> + | Some g -> (output_results (ctf_Location !global_request_id) (Some (P_s_int @@ -376,7 +376,7 @@ Caution, this is in the middle of what looks like dead code. ; (List.map (fun n -> CT_coerce_INT_to_SIGNED_INT (CT_int n)) - (clean_path tac + (clean_path tac (List.rev !the_path))))))); (output_results (ctf_OtherGoal !global_request_id) @@ -417,7 +417,7 @@ let inspect n = add_search2 (Nametab.locate (qualid_of_path sp)) (Pretyping.Default.understand Evd.empty (Global.env()) (RRef(dummy_loc, IndRef(kn,0)))) - | _ -> failwith ("unexpected value 1 for "^ + | _ -> failwith ("unexpected value 1 for "^ (string_of_id (basename (fst oname))))) | _ -> failwith "unexpected value") with e -> ()) @@ -427,7 +427,7 @@ let inspect n = (Some (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; -let ct_int_to_TARG n = +let ct_int_to_TARG n = CT_coerce_FORMULA_OR_INT_to_TARG (CT_coerce_ID_OR_INT_to_FORMULA_OR_INT (CT_coerce_INT_to_ID_OR_INT (CT_int n)));; @@ -561,7 +561,7 @@ let pcoq_search s l = *) ctv_SEARCH_LIST:=[]; begin match s with - | SearchAbout sl -> + | SearchAbout sl -> raw_search_about (filter_by_module_from_list l) add_search (List.map (on_snd interp_search_about_item) sl) | SearchPattern c -> @@ -580,7 +580,7 @@ let pcoq_search s l = let rec hyp_pattern_filter pat name a c = let _c1 = strip_outer_cast c in match kind_of_term c with - | Prod(_, hyp, c2) -> + | Prod(_, hyp, c2) -> (try (* let _ = msgnl ((str "WHOLE ") ++ (Printer.pr_lconstr c)) in let _ = msgnl ((str "PAT ") ++ (Printer.pr_constr_pattern pat)) in *) @@ -605,7 +605,7 @@ let hyp_search_pattern c l = (Some (P_pl (CT_premises_list (List.rev !ctv_SEARCH_LIST))));; let pcoq_print_name ref = - output_results + output_results (fnl () ++ str "message" ++ fnl () ++ str "PRINT_VALUE" ++ fnl () ++ print_name ref ) None @@ -665,8 +665,8 @@ let pcoq_print_object_template object_to_ast_list sp = (* This function mirror what print_check does *) let pcoq_print_typed_value_in_env env (value, typ) = - let value_ct_ast = - (try translate_constr false (Global.env()) value + let value_ct_ast = + (try translate_constr false (Global.env()) value with UserError(f,str) -> raise(UserError(f,Printer.pr_lconstr value ++ fnl () ++ str ))) in @@ -797,7 +797,7 @@ let start_depends_dumps () = gen_start_depends_dumps output_depends output_depen let start_depends_dumps_debug () = gen_start_depends_dumps print_depends print_depends print_depends print_depends TACTIC EXTEND pbp -| [ "pbp" ident_opt(idopt) natural_list(nl) ] -> +| [ "pbp" ident_opt(idopt) natural_list(nl) ] -> [ if_pcoq pbp_tac_pcoq idopt nl ] END @@ -810,10 +810,10 @@ TACTIC EXTEND ct_debugtac2 END -let start_pcoq_mode debug = +let start_pcoq_mode debug = begin pcoq_started := Some debug; -(* <\cpa> +(* <\cpa> start_dad(); *) (* The following ones are added to enable rich comments in pcoq *) @@ -830,7 +830,7 @@ let start_pcoq_mode debug = *) set_pcoq_hook pcoq_hook; start_pcoq_objects(); - Flags.print_emacs := false; Pp.make_pp_nonemacs(); + Flags.print_emacs := false; Pp.make_pp_nonemacs(); end;; diff --git a/plugins/interface/coqparser.ml b/plugins/interface/coqparser.ml index df5e66b50f..730af3ca2f 100644 --- a/plugins/interface/coqparser.ml +++ b/plugins/interface/coqparser.ml @@ -53,13 +53,13 @@ let execute_when_necessary v = (match v with | VernacOpenCloseScope sc -> Vernacentries.interp v | VernacRequire (_,_,l) -> - (try + (try Vernacentries.interp v with _ -> let l=prlist_with_sep spc pr_reference l in msgnl (str "Reinterning of " ++ l ++ str " failed")) | VernacRequireFrom (_,_,f) -> - (try + (try Vernacentries.interp v with _ -> msgnl (str "Reinterning of " ++ Util.pr_str f ++ str " failed")) @@ -112,7 +112,7 @@ let rec get_sub_aux string_list snd_pos = let rec get_substring_list string_list fst_pos snd_pos = match string_list with [] -> [] - | s::l -> + | s::l -> let len = String.length s in if fst_pos > len then get_substring_list l (fst_pos - len - 1) (snd_pos - len - 1) @@ -146,10 +146,10 @@ let make_parse_error_item s l = let parse_command_list reqid stream string_list = let rec parse_whole_stream () = let this_pos = Stream.count stream in - let first_ast = + let first_ast = try ParseOK (Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) with - | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> + | (Stdpp.Exc_located(l, Stream.Error txt)) as e -> begin msgnl (ctf_SyntaxWarningMessage reqid (Cerrors.explain_exn e)); try @@ -161,7 +161,7 @@ let parse_command_list reqid stream string_list = (Stream.count stream)) with End_of_file -> ParseOK None end - | e-> + | e-> begin discard_to_dot stream; ParseError ("PARSING_ERROR2", @@ -172,11 +172,11 @@ let parse_command_list reqid stream string_list = let _ast0 = (execute_when_necessary ast) in (try xlate_vernac ast with e -> - make_parse_error_item "PARSING_ERROR2" + make_parse_error_item "PARSING_ERROR2" (get_substring_list string_list this_pos (Stream.count stream)))::parse_whole_stream() | ParseOK None -> [] - | ParseError (s,l) -> + | ParseError (s,l) -> (make_parse_error_item s l)::parse_whole_stream() in match parse_whole_stream () with @@ -200,21 +200,21 @@ let parse_string_action reqid phylum char_stream string_list = (Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream)))) | "TACTIC_COM" -> P_t - (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi + (xlate_tactic (Gram.Entry.parse Pcoq.Tactic.tactic_eoi (Gram.parsable char_stream))) | "FORMULA" -> P_f (xlate_formula - (Gram.Entry.parse + (Gram.Entry.parse (Pcoq.eoi_entry Pcoq.Constr.lconstr) (Gram.parsable char_stream))) | "ID" -> P_id (CT_ident - (Libnames.string_of_qualid - (snd + (Libnames.string_of_qualid + (snd (Gram.Entry.parse (Pcoq.eoi_entry Pcoq.Prim.qualid) (Gram.parsable char_stream))))) | "STRING" -> P_s - (CT_string (Gram.Entry.parse Pcoq.Prim.string + (CT_string (Gram.Entry.parse Pcoq.Prim.string (Gram.parsable char_stream))) | "INT" -> P_i (CT_int (Gram.Entry.parse Pcoq.Prim.natural @@ -225,7 +225,7 @@ let parse_string_action reqid phylum char_stream string_list = | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> flush_until_end_of_stream char_stream; msgnl (ctf_SyntaxErrorMessage reqid - (Cerrors.explain_exn + (Cerrors.explain_exn (Stdpp.Exc_located(l,Stream.Error "match failure")))) | e -> flush_until_end_of_stream char_stream; @@ -233,7 +233,7 @@ let parse_string_action reqid phylum char_stream string_list = let quiet_parse_string_action char_stream = - try let _ = + try let _ = Gram.Entry.parse Pcoq.Vernac_.vernac_eoi (Gram.parsable char_stream) in () with @@ -242,9 +242,9 @@ let quiet_parse_string_action char_stream = let parse_file_action reqid file_name = try let file_chan = open_in file_name in - (* file_chan_err, stream_err are the channel and stream used to + (* file_chan_err, stream_err are the channel and stream used to get the text when a syntax error occurs *) - let file_chan_err = open_in file_name in + let file_chan_err = open_in file_name in let stream = Stream.of_channel file_chan in let _stream_err = Stream.of_channel file_chan_err in let rec discard_to_dot () = @@ -252,21 +252,21 @@ let parse_file_action reqid file_name = with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() in match let rec parse_whole_file () = let this_pos = Stream.count stream in - match + match try ParseOK(Gram.Entry.parse Pcoq.main_entry (Gram.parsable stream)) with - | Stdpp.Exc_located(l,Stream.Error txt) -> + | Stdpp.Exc_located(l,Stream.Error txt) -> msgnl (ctf_SyntaxWarningMessage reqid (str "Error with file" ++ spc () ++ str file_name ++ fnl () ++ - Cerrors.explain_exn + Cerrors.explain_exn (Stdpp.Exc_located(l,Stream.Error txt)))); - (try + (try begin discard_to_dot (); ParseError ("PARSING_ERROR", - (make_string_list file_chan_err this_pos + (make_string_list file_chan_err this_pos (Stream.count stream))) end with End_of_file -> ParseOK None) @@ -277,10 +277,10 @@ let parse_file_action reqid file_name = (make_string_list file_chan this_pos (Stream.count stream))) end - + with | ParseOK (Some (_,ast)) -> - let _ast0=(execute_when_necessary ast) in + let _ast0=(execute_when_necessary ast) in let term = (try xlate_vernac ast with e -> @@ -291,10 +291,10 @@ let parse_file_action reqid file_name = "\n"); make_parse_error_item "PARSING_ERROR2" (make_string_list file_chan_err this_pos - (Stream.count stream))) in + (Stream.count stream))) in term::parse_whole_file () | ParseOK None -> [] - | ParseError (s,l) -> + | ParseError (s,l) -> (make_parse_error_item s l)::parse_whole_file () in parse_whole_file () with | first_one :: tail -> @@ -305,7 +305,7 @@ let parse_file_action reqid file_name = | Stdpp.Exc_located(l,Match_failure(_,_,_)) -> msgnl (ctf_SyntaxErrorMessage reqid - (str "Error with file" ++ spc () ++ str file_name ++ + (str "Error with file" ++ spc () ++ str file_name ++ fnl () ++ Cerrors.explain_exn (Stdpp.Exc_located(l,Stream.Error "match failure")))) @@ -320,7 +320,7 @@ let add_rec_path_action reqid string_arg ident_arg = begin add_rec_path directory_name (Libnames.dirpath_of_string ident_arg) end;; - + let add_path_action reqid string_arg = let directory_name = expand_path_macros string_arg in @@ -338,7 +338,7 @@ let load_syntax_action reqid module_name = (let qid = Libnames.qualid_of_ident (Names.id_of_string module_name) in require_library [dummy_loc,qid] None; msg (str "opening... "); - Declaremods.import_module false (Nametab.locate_module qid); + Declaremods.import_module false (Nametab.locate_module qid); msgnl (str "done" ++ fnl ()); ()) with @@ -365,11 +365,11 @@ let coqparser_loop inchan = add_path_action, add_rec_path_action, load_syntax_action) inchan;; if !Sys.interactive then () - else + else Libobject.relax true; -(let coqdir = +(let coqdir = try Sys.getenv "COQDIR" - with Not_found -> + with Not_found -> let coqdir = Envars.coqlib () in if Sys.file_exists coqdir then coqdir @@ -385,8 +385,8 @@ Libobject.relax true; try Sys.getenv "VERNACRC" with - Not_found -> - List.fold_left + Not_found -> + List.fold_left (fun s1 s2 -> (Filename.concat s1 s2)) coqdir [ "plugins"; "interface"; "vernacrc"] in try @@ -417,6 +417,6 @@ Libobject.relax true; msgnl (str "Starting Centaur Specialized Parser Loop"); try coqparser_loop stdin -with +with | End_of_file -> () | e -> msgnl(Cerrors.explain_exn e)) diff --git a/plugins/interface/dad.ml b/plugins/interface/dad.ml index c2ab2dc8d0..fb0562c571 100644 --- a/plugins/interface/dad.ml +++ b/plugins/interface/dad.ml @@ -58,9 +58,9 @@ let zz = Util.dummy_loc;; let rec get_subterm (depth:int) (path: int list) (constr:constr) = match depth, path, kind_of_term constr with 0, l, c -> (constr,l) - | n, 2::a::tl, App(func,arr) -> + | n, 2::a::tl, App(func,arr) -> get_subterm (n - 2) tl arr.(a-1) - | _,l,_ -> failwith (int_list_to_string + | _,l,_ -> failwith (int_list_to_string "wrong path or wrong form of term" l);; @@ -93,12 +93,12 @@ let rec find_cmd (l:(string * dad_rule) list) env constr p p1 p2 = if deg > length then failwith "internal" else - let term_to_match, p_r = - try + let term_to_match, p_r = + try get_subterm (length - deg) p constr with Failure s -> failwith "internal" in - let _, constr_pat = + let _, constr_pat = intern_constr_pattern Evd.empty (Global.env()) ((*ct_to_ast*) pat) in let subst = matches constr_pat term_to_match in @@ -136,26 +136,26 @@ let dad_tac display_function = function l -> let p1, p2 = part_tac_args [] l in (function g -> let (p_a, p1prime, p2prime) = decompose_path (List.rev p1,p2) in - (display_function + (display_function (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime)); tclIDTAC g);; *) let dad_tac display_function p1 p2 g = let (p_a, p1prime, p2prime) = decompose_path (p1,p2) in - (display_function + (display_function (find_cmd (!dad_rule_list) (pf_env g) (pf_concl g) p_a p1prime p2prime)); tclIDTAC g;; (* Now we enter dad rule list management. *) let add_dad_rule name patt p1 p2 depth pr command = - dad_rule_list := (name, + dad_rule_list := (name, (patt, p1, p2, depth, pr, command))::!dad_rule_list;; let rec remove_if_exists name = function [] -> false, [] - | ((a,b) as rule1)::tl -> if a = name then + | ((a,b) as rule1)::tl -> if a = name then let result1, l = (remove_if_exists name tl) in true, l else @@ -177,11 +177,11 @@ let constrain ((n : patvar),(pat : constr_pattern)) sigma = if List.mem_assoc n sigma then if pat = (List.assoc n sigma) then sigma else failwith "internal" - else + else (n,pat)::sigma - + (* This function is inspired from matches_core in pattern.ml *) -let more_general_pat pat1 pat2 = +let more_general_pat pat1 pat2 = let rec match_rec sigma p1 p2 = match p1, p2 with | PMeta (Some n), m -> constrain (n,m) sigma @@ -203,7 +203,7 @@ let more_general_pat pat1 pat2 = | PApp (c1,arg1), PApp (c2,arg2) -> (try array_fold_left2 match_rec (match_rec sigma c1 c2) arg1 arg2 with Invalid_argument _ -> failwith "internal") - | _ -> failwith "unexpected case in more_general_pat" in + | _ -> failwith "unexpected case in more_general_pat" in try let _ = match_rec [] pat1 pat2 in true with Failure "internal" -> false;; @@ -214,7 +214,7 @@ let more_general r1 r2 = (more_general_pat patt1 patt2) & (is_prefix p11 p21) & (is_prefix p12 p22);; -let not_less_general r1 r2 = +let not_less_general r1 r2 = not (match r1,r2 with (_,(patt1,p11,p12,_,_,_)), (_,(patt2,p21,p22,_,_,_)) -> @@ -235,7 +235,7 @@ let rec add_in_list_sorting rule1 = function rule1::this_list and add_in_list_sorting_aux rule1 = function [] -> [] - | b::tl -> + | b::tl -> if more_general rule1 b then b::(add_in_list_sorting rule1 tl) else @@ -245,7 +245,7 @@ and add_in_list_sorting_aux rule1 = function | _ -> rule1::tl2);; let rec sort_list = function - [] -> [] + [] -> [] | a::l -> add_in_list_sorting a (sort_list l);; let mk_dad_meta n = CPatVar (zz,(true,Nameops.make_ident "DAD" (Some n)));; diff --git a/plugins/interface/debug_tac.ml4 b/plugins/interface/debug_tac.ml4 index 79c5fe8a8e..9fade8b587 100644 --- a/plugins/interface/debug_tac.ml4 +++ b/plugins/interface/debug_tac.ml4 @@ -57,7 +57,7 @@ let no_failure = function [Report_node(true,_,_)] -> true | _ -> false;; -let check_subgoals_count2 +let check_subgoals_count2 : card_holder -> int -> bool ref -> (report_holder -> tactic) -> tactic = fun card_holder count flag t g -> let new_report_holder = ref ([] : report_tree list) in @@ -96,7 +96,7 @@ let count_subgoals : card_holder -> bool ref -> tactic -> tactic = e -> card_holder := Fail; flag := false; tclIDTAC g;; - + let count_subgoals2 : card_holder -> bool ref -> (report_holder -> tactic) -> tactic = fun card_holder flag t g -> @@ -139,24 +139,24 @@ let rec local_interp : glob_tactic_expr -> report_holder -> tactic = function - In case of success of the first tactic, but count mismatch, then Mismatch n is added to the report holder. *) -and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = +and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tactic = (fun report_holder t1 l g -> let flag = ref true in let traceable_t1 = traceable t1 in let card_holder = ref Fail in let new_holder = ref ([]:report_tree list) in - let tac_t1 = + let tac_t1 = if traceable_t1 then (check_subgoals_count2 card_holder (List.length l) flag (local_interp t1)) else (check_subgoals_count card_holder (List.length l) flag (Tacinterp.eval_tactic t1)) in - let (gls, _) as result = + let (gls, _) as result = tclTHEN_i tac_t1 (fun i -> if !flag then - (fun g -> + (fun g -> let tac_i = (List.nth l i) in if traceable tac_i then local_interp tac_i new_holder g @@ -174,7 +174,7 @@ and checked_thens: report_holder -> glob_tactic_expr -> glob_tactic_expr list -> tclIDTAC) g in let new_goal_list = sig_it gls in (if !flag then - report_holder := + report_holder := (Report_node(collect_status !new_holder, (List.length new_goal_list), List.rev !new_holder))::!report_holder @@ -206,7 +206,7 @@ and checked_then: report_holder -> glob_tactic_expr -> glob_tactic_expr -> tacti let new_tree_holder = ref ([] : report_tree list) in let (gls, _) as result = tclTHEN tac_t1 - (fun (g:goal sigma) -> + (fun (g:goal sigma) -> if !flag then if traceable t2 then local_interp t2 new_tree_holder g @@ -273,7 +273,7 @@ let rec select_success n = function let rec reconstruct_success_tac (tac:glob_tactic_expr) = match tac with TacThens (a,l) -> - (function + (function Report_node(true, n, l) -> tac | Report_node(false, n, rl) -> TacThens (a,List.map2 reconstruct_success_tac l rl) @@ -292,7 +292,7 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) = | Failed n -> TacId [] | Tree_fail r -> reconstruct_success_tac a r | _ -> error "this error case should not happen in a THEN tactic") - | _ -> + | _ -> (function Report_node(true, n, l) -> tac | Failed n -> TacId [] @@ -301,7 +301,7 @@ let rec reconstruct_success_tac (tac:glob_tactic_expr) = "this error case should not happen on an unknown tactic" (str "error in reconstruction with " ++ fnl () ++ (pr_glob_tactic tac)));; - + let rec path_to_first_error = function | Report_node(true, _, l) -> @@ -315,14 +315,14 @@ let rec path_to_first_error = function let debug_tac = function [(Tacexp ast)] -> - (fun g -> + (fun g -> let report = ref ([] : report_tree list) in let result = local_interp ast report g in let clean_ast = (* expand_tactic *) ast in let report_tree = try List.hd !report with Failure "hd" -> (msgnl (str "report is empty"); Failed 1) in - let success_tac = + let success_tac = reconstruct_success_tac clean_ast report_tree in let compact_success_tac = (* flatten_then *) success_tac in msgnl (fnl () ++ @@ -339,7 +339,7 @@ add_tactic "DebugTac" debug_tac;; Tacinterp.add_tactic "OnThen" on_then;; -let rec clean_path tac l = +let rec clean_path tac l = match tac, l with | TacThen (a,[||],b,[||]), fst::tl -> fst::(clean_path (if fst = 1 then a else b) tl) @@ -351,9 +351,9 @@ let rec clean_path tac l = | _, _ -> failwith "this case should not happen in clean_path";; let rec report_error - : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> + : glob_tactic_expr -> goal sigma option ref -> glob_tactic_expr ref -> int list ref -> int list -> tactic = - fun tac the_goal the_ast returned_path path -> + fun tac the_goal the_ast returned_path path -> match tac with TacThens (a,l) -> let the_card_holder = ref Fail in @@ -362,12 +362,12 @@ let rec report_error tclTHENS (fun g -> let result = - check_subgoals_count + check_subgoals_count the_card_holder - (List.length l) + (List.length l) the_flag - (fun g2 -> - try + (fun g2 -> + try (report_error a the_goal the_ast returned_path (1::path) g2) with e -> (the_exn := e; raise e)) @@ -376,10 +376,10 @@ let rec report_error result else (match !the_card_holder with - Fail -> + Fail -> the_ast := TacThens (!the_ast, l); raise !the_exn - | Goals_mismatch p -> + | Goals_mismatch p -> the_ast := tac; returned_path := path; error ("Wrong number of tactics: expected " ^ @@ -403,7 +403,7 @@ let rec report_error raise e)) (fun g -> try - let result = + let result = report_error b the_goal the_ast returned_path (2::path) g in the_count := !the_count + 1; result diff --git a/plugins/interface/depends.ml b/plugins/interface/depends.ml index 83c156f7bf..1a5bfaf33d 100644 --- a/plugins/interface/depends.ml +++ b/plugins/interface/depends.ml @@ -317,7 +317,7 @@ let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of | TacLApply c -> depends_of_'constr c acc (* Automation tactics *) - | TacTrivial (cl, bs) -> + | TacTrivial (cl, bs) -> (* TODO: Maybe make use of bs: list of hint bases to be used. *) list_union_map depends_of_'constr cl acc | TacAuto (_, cs, bs) -> @@ -336,7 +336,7 @@ let rec depends_of_gen_tactic_expr depends_of_'constr depends_of_'ind depends_of | TacClear _ | TacClearBody _ | TacMove _ - | TacRename _ + | TacRename _ | TacRevert _ -> acc (* Constructors *) diff --git a/plugins/interface/history.ml b/plugins/interface/history.ml index f73c20849a..cfd33c1861 100644 --- a/plugins/interface/history.ml +++ b/plugins/interface/history.ml @@ -12,7 +12,7 @@ type prf_info = { mutable border : tree list; prf_struct : tree};; -let theorem_proofs = ((Hashtbl.create 17): +let theorem_proofs = ((Hashtbl.create 17): (string, prf_info) Hashtbl.t);; @@ -54,12 +54,12 @@ let push_command s rank ngoals = this_tree.sub_proofs <- new_trees end;; -let get_tree_for_rank thm_name rank = - let {ranks_and_goals=l;prf_length=n} = +let get_tree_for_rank thm_name rank = + let {ranks_and_goals=l;prf_length=n} = Hashtbl.find theorem_proofs thm_name in let rec get_tree_aux = function [] -> - failwith + failwith "inconsistent values for thm_name and rank in get_tree_for_rank" | (_,_,({index=i} as tree))::tl -> if i = rank then @@ -88,9 +88,9 @@ let parent_from_rank thm_name rank = let first_child_command thm_name rank = let {sub_proofs = l} = get_tree_for_rank thm_name rank in - let rec first_child_rec = function + let rec first_child_rec = function [] -> None - | {index=i;is_open=b}::l -> + | {index=i;is_open=b}::l -> if b then (first_child_rec l) else @@ -104,7 +104,7 @@ let first_child_command_or_goal thm_name rank = let {sub_proofs=l}=get_tree_for_rank thm_name rank in match l with [] -> None - | ({index=i;is_open=b} as t)::_ -> + | ({index=i;is_open=b} as t)::_ -> if b then let rec get_rank n = function [] -> failwith "A goal is lost in first_child_command_or_goal" @@ -124,12 +124,12 @@ let next_sibling thm_name rank = | Some real_mommy -> let {sub_proofs=l}=real_mommy in let rec next_sibling_aux b = function - (opt_first, []) -> + (opt_first, []) -> if b then opt_first else failwith "inconsistency detected in next_sibling" - | (opt_first, {is_open=true}::l) -> + | (opt_first, {is_open=true}::l) -> next_sibling_aux b (opt_first, l) | (Some(first),({index=i; is_open=false} as t')::l) -> if b then @@ -149,7 +149,7 @@ let prefix l1 l2 = let rec remove_all_prefixes p = function [] -> [] - | a::l -> + | a::l -> if is_prefix p a then (remove_all_prefixes p l) else @@ -163,8 +163,8 @@ let recompute_border tree = else List.fold_right recompute_border_aux l acc in recompute_border_aux tree [];; - - + + let historical_undo thm_name rank = let ({ranks_and_goals=l} as proof_info)= Hashtbl.find theorem_proofs thm_name in @@ -180,7 +180,7 @@ let historical_undo thm_name rank = tree.is_open <- true; tree.sub_proofs <- []; proof_info.border <- recompute_border proof_info.prf_struct; - this_path_reversed::res + this_path_reversed::res end else begin @@ -208,7 +208,7 @@ let rec logical_undo_on_border the_tree rev_path = function (k,tree::res) else (0, the_tree::tree::tl);; - + let logical_undo thm_name rank = let ({ranks_and_goals=l; border=last_border} as proof_info)= @@ -223,7 +223,7 @@ let logical_undo thm_name rank = let new_rank, new_offset, new_width, kept = if is_prefix rev_ref_path this_path_rev then (r + lex_smaller_offset), lex_smaller_offset, - (family_width + 1 - n), false + (family_width + 1 - n), false else if lex_smaller this_path_rev rev_ref_path then r, (lex_smaller_offset - 1 + n), family_width, true else @@ -239,14 +239,14 @@ let logical_undo thm_name rank = begin tree.index <- current_rank; ranks_undone, ((i,new_rank)::ranks_kept), - ((new_rank, n, tree)::ranks_and_goals), + ((new_rank, n, tree)::ranks_and_goals), (current_rank + 1) end else ((i,new_rank)::ranks_undone), ranks_kept, ranks_and_goals, current_rank end in - let number_suffix, new_border = + let number_suffix, new_border = logical_undo_on_border ref_tree rev_ref_path last_border in let changed_ranks_undone, changed_ranks_kept, new_ranks_and_goals, new_length_plus_one = logical_aux 0 number_suffix l in @@ -265,19 +265,19 @@ let logical_undo thm_name rank = proof_info.border <- new_border; proof_info.ranks_and_goals <- new_ranks_and_goals; proof_info.prf_length <- new_length_plus_one - 1; - changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, + changed_ranks_undone, changed_ranks_kept, proof_info.prf_length, the_goal_index end;; - + let start_proof thm_name = - let the_tree = + let the_tree = {index=0;parent=None;path_to_root=[];is_open=true;sub_proofs=[]} in Hashtbl.add theorem_proofs thm_name {prf_length=0; ranks_and_goals=[]; border=[the_tree]; prf_struct=the_tree};; - + let dump_sequence chan s = match (Hashtbl.find theorem_proofs s) with {ranks_and_goals=l}-> @@ -294,7 +294,7 @@ let dump_sequence chan s = output_string chan "end\n" end;; - + let proof_info_as_string s = let res = ref "" in match (Hashtbl.find theorem_proofs s) with @@ -307,7 +307,7 @@ let proof_info_as_string s = None -> if op then res := !res ^ "\"open goal\"\n" - | Some {index=j} -> + | Some {index=j} -> begin res := !res ^ (string_of_int j); res := !res ^ " -> "; @@ -330,7 +330,7 @@ let proof_info_as_string s = !res;; -let dump_proof_info chan s = +let dump_proof_info chan s = match (Hashtbl.find theorem_proofs s) with {prf_struct=tree} -> let open_goal_counter = ref 0 in @@ -341,7 +341,7 @@ let dump_proof_info chan s = None -> if op then output_string chan "\"open goal\"\n" - | Some {index=j} -> + | Some {index=j} -> begin output_string chan (string_of_int j); output_string chan " -> "; diff --git a/plugins/interface/line_parser.ml4 b/plugins/interface/line_parser.ml4 index 0b13a092a4..1c5afc1be7 100755 --- a/plugins/interface/line_parser.ml4 +++ b/plugins/interface/line_parser.ml4 @@ -6,7 +6,7 @@ by a precise keyword, which is also expected to appear alone on a line. *) (* The main parsing loop procedure is "parser_loop", given at the end of this file. It read lines one by one and checks whether they can be parsed using a very simple parser. This very simple parser uses a lexer, which is also given -in this file. +in this file. The lexical analyser: There are only 5 sorts of tokens *) @@ -19,7 +19,7 @@ type simple_tokens = Tspace | Tid of string | Tint of int | Tstring of string | code in src/meta/lexer.ml of Coq revision 6.1) *) let add_in_buff,get_buff = let buff = ref (String.create 80) in - (fun i x -> + (fun i x -> let len = String.length !buff in if i >= len then (buff := !buff ^ (String.create len);()); String.set !buff i x; @@ -47,16 +47,16 @@ let get_digit c = Char.code c - code0;; let rec parse_int intval = parser [< ''0'..'9' as c ; i=parse_int (10 * intval + get_digit c)>] -> i | [< >] -> Tint intval;; - -(* The string lexer is borrowed from the string parser of Coq V6.1 + +(* The string lexer is borrowed from the string parser of Coq V6.1 This may be a problem if convention have changed in Coq, However this parser is only used to recognize file names which should not contain too many special characters *) let rec spec_char = parser - [< ''n' >] -> '\n' + [< ''n' >] -> '\n' | [< ''t' >] -> '\t' -| [< ''b' >] -> '\008' +| [< ''b' >] -> '\008' | [< ''r' >] -> '\013' | [< ''0'..'9' as c; v= (spec1 (get_digit c)) >] -> Char.chr v @@ -93,7 +93,7 @@ let rec next_token = parser _count | [< '']' >] -> Trbracket | [< '_ ; x = next_token >] -> x;; -(* A very simple lexical analyser to recognize a integer value behind +(* A very simple lexical analyser to recognize a integer value behind blank characters *) let rec next_int = parser _count @@ -139,7 +139,7 @@ let line_list_to_stream string_list = count := !count + !current_length + 1; match !reserve with | [] -> None - | s1::rest -> + | s1::rest -> begin buff := s1; current_length := String.length !buff; @@ -149,7 +149,7 @@ let line_list_to_stream string_list = end else Some(String.get !buff (i - !count)));; - + (* In older revisions of this file you would find a function that does line oriented breakdown of the input channel without resorting to @@ -196,14 +196,14 @@ let parser_loop functions input_channel = load_syntax_action = functions in let rec parser_loop_rec input_channel = (let line = input_line input_channel in - let reqid, parser_request = - try + let reqid, parser_request = + try (match Stream.from (token_stream (Stream.of_string line)) with parser | [< 'Tid "print_version" >] -> 0, PRINT_VERSION | [< 'Tid "parse_string" ; 'Tint reqid ; 'Tlbracket ; - 'Tid phylum ; 'Trbracket >] + 'Tid phylum ; 'Trbracket >] -> reqid,PARSE_STRING phylum | [< 'Tid "quiet_parse_string" >] -> 0,QUIET_PARSE_STRING diff --git a/plugins/interface/name_to_ast.ml b/plugins/interface/name_to_ast.ml index f5e8be31e0..ef61a8202d 100644 --- a/plugins/interface/name_to_ast.ml +++ b/plugins/interface/name_to_ast.ml @@ -26,7 +26,7 @@ open Topconstr;; of this procedure is taken from the function print_env in pretty.ml *) let convert_env = let convert_binder env (na, b, c) = - match b with + match b with | Some b -> LocalRawDef ((dummy_loc,na), extern_constr true env b) | None -> LocalRawAssum ([dummy_loc,na], default_binder_kind, extern_constr true env c) in let rec cvrec env = function @@ -34,7 +34,7 @@ let convert_env = | b::rest -> (convert_binder env b)::(cvrec (push_rel b env) rest) in cvrec (Global.env());; -(* let mib string = +(* let mib string = let sp = Nametab.sp_of_id CCI (id_of_string string) in let lobj = Lib.map_leaf (objsp_of sp) in let (cmap, _) = outMutualInductive lobj in @@ -52,10 +52,10 @@ let impl_args_to_string_by_pos = function (* This function is directly inspired by implicit_args_id in pretty.ml *) -let impl_args_to_string l = +let impl_args_to_string l = impl_args_to_string_by_pos (positions_of_implicits l) -let implicit_args_id_to_ast_list id l ast_list = +let implicit_args_id_to_ast_list id l ast_list = (match impl_args_to_string l with None -> ast_list | Some(s) -> CommentString s:: @@ -67,7 +67,7 @@ let implicit_args_id_to_ast_list id l ast_list = implicit_args_msg in pretty.ml. *) let implicit_args_to_ast_list sp mipv = - let implicit_args_descriptions = + let implicit_args_descriptions = let ast_list = ref [] in (Array.iteri (fun i mip -> @@ -78,7 +78,7 @@ let implicit_args_to_ast_list sp mipv = (fun j idc -> let impls = implicits_of_global (ConstructRef ((sp,i),j+1)) in - ast_list := + ast_list := implicit_args_id_to_ast_list idc impls !ast_list) mip.mind_consnames)) mipv; @@ -86,19 +86,19 @@ let implicit_args_to_ast_list sp mipv = match implicit_args_descriptions with [] -> [] | _ -> [VernacComments (List.rev implicit_args_descriptions)];; - + (* This function converts constructors for an inductive definition to a Coqast.t. It is obtained directly from print_constructors in pretty.ml *) let convert_constructors envpar names types = - let array_idC = - array_map2 - (fun n t -> + let array_idC = + array_map2 + (fun n t -> let coercion_flag = false (* arbitrary *) in (coercion_flag, ((dummy_loc,n), extern_constr true envpar t))) names types in Array.to_list array_idC;; - + (* this function converts one inductive type in a possibly multiple inductive definition *) @@ -124,7 +124,7 @@ let mutual_to_ast_list sp mib = VernacInductive ((if mib.mind_finite then Decl_kinds.Finite else Decl_kinds.CoFinite), false, l) :: (implicit_args_to_ast_list sp mipv);; -let constr_to_ast v = +let constr_to_ast v = extern_constr true (Global.env()) v;; let implicits_to_ast_list implicits = @@ -137,10 +137,10 @@ let make_variable_ast name typ implicits = ((Local,Definitional),false,(*inline flag*) [false,([dummy_loc,name], constr_to_ast typ)])) ::(implicits_to_ast_list implicits);; - + let make_definition_ast name c typ implicits = - VernacDefinition ((Global,false,Definition), (dummy_loc,name), + VernacDefinition ((Global,false,Definition), (dummy_loc,name), DefineBody ([], None, constr_to_ast c, Some (constr_to_ast typ)), (fun _ _ -> ())) ::(implicits_to_ast_list implicits);; @@ -152,7 +152,7 @@ let constant_to_ast_list kn = let typ = Typeops.type_of_constant_type (Global.env()) cb.const_type in let l = implicits_of_global (ConstRef kn) in (match c with - None -> + None -> make_variable_ast (id_of_label (con_label kn)) typ l | Some c1 -> make_definition_ast (id_of_label (con_label kn)) (Declarations.force c1) typ l) @@ -161,7 +161,7 @@ let variable_to_ast_list sp = let (id, c, v) = Global.lookup_named sp in let l = implicits_of_global (VarRef sp) in (match c with - None -> + None -> make_variable_ast id v l | Some c1 -> make_definition_ast id c1 v l);; @@ -180,8 +180,8 @@ let leaf_entry_to_ast_list ((sp,kn),lobj) = | "VARIABLE" -> variable_to_ast_list (basename sp) | "CONSTANT" -> constant_to_ast_list (constant_of_kn kn) | "INDUCTIVE" -> inductive_to_ast_list kn - | s -> - errorlabstrm + | s -> + errorlabstrm "print" (str ("printing of unrecognized object " ^ s ^ " has been required"));; @@ -191,18 +191,18 @@ let leaf_entry_to_ast_list ((sp,kn),lobj) = (* this function is inspired by print_name *) let name_to_ast ref = let (loc,qid) = qualid_of_reference ref in - let l = - try + let l = + try match Nametab.locate qid with | ConstRef sp -> constant_to_ast_list sp | IndRef (sp,_) -> inductive_to_ast_list sp | ConstructRef ((sp,_),_) -> inductive_to_ast_list sp | VarRef sp -> variable_to_ast_list sp - with Not_found -> + with Not_found -> try (* Var locale de but, pas var de section... donc pas d'implicits *) - let dir,name = repr_qualid qid in + let dir,name = repr_qualid qid in if (repr_dirpath dir) <> [] then raise Not_found; - let (_,c,typ) = Global.lookup_named name in + let (_,c,typ) = Global.lookup_named name in (match c with None -> make_variable_ast name typ [] | Some c1 -> make_definition_ast name c1 typ []) diff --git a/plugins/interface/paths.ml b/plugins/interface/paths.ml index a157ca9254..dcccc39e83 100644 --- a/plugins/interface/paths.ml +++ b/plugins/interface/paths.ml @@ -1,5 +1,5 @@ let int_list_to_string s l = - List.fold_left + List.fold_left (fun s -> (fun v -> s ^ " " ^ (string_of_int v))) s l;; diff --git a/plugins/interface/pbp.ml b/plugins/interface/pbp.ml index 663e4ce925..b4dfe8a769 100644 --- a/plugins/interface/pbp.ml +++ b/plugins/interface/pbp.ml @@ -33,8 +33,8 @@ let next_global_ident = next_global_ident_away true let get_hyp_by_name g name = let evd = project g in let env = pf_env g in - try (let judgment = - Pretyping.Default.understand_judgment + try (let judgment = + Pretyping.Default.understand_judgment evd env (RVar(zz, name)) in ("hyp",judgment.uj_type)) (* je sais, c'est pas beau, mais je ne sais pas trop me servir de look_up... @@ -132,7 +132,7 @@ let (imply_intro2: pbp_rule) = function (f (h'::avoid) clear_names clear_flag None (kind_of_term body) path)) | _ -> None;; - + (* let (imply_intro1: pbp_rule) = function avoid, clear_names, @@ -140,7 +140,7 @@ let (imply_intro1: pbp_rule) = function let h' = next_global_ident hyp_radix avoid in let str_h' = h' in Some(chain_tactics [make_named_intro str_h'] - (f (h'::avoid) clear_names clear_flag (Some str_h') + (f (h'::avoid) clear_names clear_flag (Some str_h') (kind_of_term prem) path)) | _ -> None;; *) @@ -162,7 +162,7 @@ let make_pbp_atomic_tactic = function | PbpTryAssumption None -> TacTry (TacAtom (zz, TacAssumption)) | PbpTryAssumption (Some a) -> TacTry (TacAtom (zz, TacExact (make_var a))) - | PbpExists x -> + | PbpExists x -> TacAtom (zz, TacSplit (false,true,[ImplicitBindings [make_pbp_pattern x]])) | PbpGeneralize (h,args) -> let l = List.map make_pbp_pattern args in @@ -176,7 +176,7 @@ let make_pbp_atomic_tactic = function let bind = List.map (fun s ->(zz,NamedHyp s,make_pbp_pattern s)) names in TacAtom (zz, TacElim (false,(make_var hyp_name,ExplicitBindings bind),None)) - | PbpTryClear l -> + | PbpTryClear l -> TacTry (TacAtom (zz, TacClear (false,List.map (fun s -> AI (zz,s)) l))) | PbpSplit -> TacAtom (zz, TacSplit (false,false,[NoBindings]));; @@ -188,7 +188,7 @@ let rec make_pbp_tactic = function List.map make_pbp_tactic tl) let (forall_elim: pbp_rule) = function - avoid, clear_names, clear_flag, + avoid, clear_names, clear_flag, Some h, Prod(Name x, _, body), 2::path, f -> let h' = next_global_ident hyp_radix avoid in let clear_names' = if clear_flag then h::clear_names else clear_names in @@ -219,7 +219,7 @@ let (imply_elim2: pbp_rule) = function Some(PbpThens ([PbpLApply h], [chain_tactics [make_named_intro h'] - (f (h'::avoid) clear_names' false (Some h') + (f (h'::avoid) clear_names' false (Some h') (kind_of_term body) path); make_clears clear_names])) | _ -> None;; @@ -241,8 +241,8 @@ let notTconstr () = constant ["Logic_Type"] "notT";; let is_matching_local a b = is_matching (pattern_of_constr a) b;; -let rec (or_and_tree_to_intro_pattern: identifier list -> - constr -> int list -> +let rec (or_and_tree_to_intro_pattern: identifier list -> + constr -> int list -> intro_pattern_expr * identifier list * identifier *constr * int list * int * int) = fun avoid c path -> match kind_of_term c, path with @@ -251,19 +251,19 @@ fun avoid c path -> match kind_of_term c, path with (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> let id2 = next_global_ident hyp_radix avoid in let cont_expr = if a = 1 then c1 else c2 in - let cont_patt, avoid_names, id, c, path, rank, total_branches = + let cont_patt, avoid_names, id, c, path, rank, total_branches = or_and_tree_to_intro_pattern (id2::avoid) cont_expr path in - let patt_list = + let patt_list = if a = 1 then [zz,cont_patt; zz,IntroIdentifier id2] else [zz,IntroIdentifier id2; zz,cont_patt] in - (IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, + (IntroOrAndPattern[patt_list], avoid_names, id, c, path, rank, total_branches) | (App(oper, [|c1; c2|]), 2::3::path) when ((is_matching_local (exconstr()) oper) or (is_matching_local (sigconstr()) oper)) -> - (match (kind_of_term c2) with + (match (kind_of_term c2) with Lambda (Name x, _, body) -> let id1 = next_global_ident x avoid in let cont_patt, avoid_names, id, c, path, rank, total_branches = @@ -285,13 +285,13 @@ fun avoid c path -> match kind_of_term c, path with [[zz,cont_patt];[zz,IntroIdentifier id2]] else [[zz,IntroIdentifier id2];[zz,cont_patt]] in - (IntroOrAndPattern patt_list, + (IntroOrAndPattern patt_list, avoid_names, id, c, path, new_rank, total_branches+1) | (_, path) -> let id = next_global_ident hyp_radix avoid in (IntroIdentifier id, (id::avoid), id, c, path, 1, 1);; let auxiliary_goals clear_names clear_flag this_name n_aux others = - let clear_cmd = + let clear_cmd = make_clears (if clear_flag then (this_name ::clear_names) else clear_names) in let rec clear_list = function 0 -> others @@ -316,25 +316,25 @@ let (imply_intro3: pbp_rule) = function (rank - 1) ((f avoid_names clear_names clear_flag (Some id) (kind_of_term c) path):: - auxiliary_goals clear_names clear_flag id + auxiliary_goals clear_names clear_flag id (total_branches - rank) []))) | _ -> None;; - + let (and_intro: pbp_rule) = function avoid, clear_names, clear_flag, - None, App(and_oper, [|c1; c2|]), 2::a::path, f + None, App(and_oper, [|c1; c2|]), 2::a::path, f -> if ((is_matching_local (andconstr()) and_oper) or (is_matching_local (prodconstr ()) and_oper)) & (a = 1 or a = 2) then let cont_term = if a = 1 then c1 else c2 in - let cont_cmd = f avoid clear_names false None + let cont_cmd = f avoid clear_names false None (kind_of_term cont_term) path in let clear_cmd = make_clears clear_names in let cmds = - (if a = 1 - then [cont_cmd;clear_cmd] + (if a = 1 + then [cont_cmd;clear_cmd] else [clear_cmd;cont_cmd]) in Some (PbpThens ([PbpSplit],cmds)) else None @@ -342,7 +342,7 @@ let (and_intro: pbp_rule) = function let exists_from_lambda avoid clear_names clear_flag c2 path f = match kind_of_term c2 with - Lambda(Name x, _, body) -> + Lambda(Name x, _, body) -> Some (PbpThens ([PbpExists x], [f avoid clear_names false None (kind_of_term body) path])) | _ -> None;; @@ -367,28 +367,28 @@ let (or_intro: pbp_rule) = function avoid, clear_names, clear_flag, None, App(or_oper, [|c1; c2 |]), 2::a::path, f -> if ((is_matching_local (orconstr ()) or_oper) or - (is_matching_local (sumboolconstr ()) or_oper) or + (is_matching_local (sumboolconstr ()) or_oper) or (is_matching_local (sumconstr ()) or_oper)) & (a = 1 or a = 2) then let cont_term = if a = 1 then c1 else c2 in let fst_cmd = if a = 1 then PbpLeft else PbpRight in - let cont_cmd = f avoid clear_names false None + let cont_cmd = f avoid clear_names false None (kind_of_term cont_term) path in Some(chain_tactics [fst_cmd] cont_cmd) else None | _ -> None;; - + let dummy_id = id_of_string "Dummy";; let (not_intro: pbp_rule) = function avoid, clear_names, clear_flag, None, App(not_oper, [|c1|]), 2::1::path, f -> - if(is_matching_local (notconstr ()) not_oper) or + if(is_matching_local (notconstr ()) not_oper) or (is_matching_local (notTconstr ()) not_oper) then let h' = next_global_ident hyp_radix avoid in Some(chain_tactics [make_named_intro h'] - (f (h'::avoid) clear_names false (Some h') + (f (h'::avoid) clear_names false (Some h') (kind_of_term c1) path)) else None @@ -407,7 +407,7 @@ let elim_with_bindings hyp_name names = crossed. Result is: - a list of string indicating the names of universally quantified variables. - - a list of integers indicating the positions of the successive + - a list of integers indicating the positions of the successive universally quantified variables. - an integer indicating the number of non-dependent products. - the last constr object encountered during the walk down, and @@ -421,16 +421,16 @@ let elim_with_bindings hyp_name names = *) -let rec down_prods: (types, constr) kind_of_term * (int list) * int -> +let rec down_prods: (types, constr) kind_of_term * (int list) * int -> identifier list * (int list) * int * (types, constr) kind_of_term * - (int list) = + (int list) = function Prod(Name x, _, body), 2::path, k -> - let res_sl, res_il, res_i, res_cstr, res_p + let res_sl, res_il, res_i, res_cstr, res_p = down_prods (kind_of_term body, path, k+1) in x::res_sl, (k::res_il), res_i, res_cstr, res_p | Prod(Anonymous, _, body), 2::path, k -> - let res_sl, res_il, res_i, res_cstr, res_p + let res_sl, res_il, res_i, res_cstr, res_p = down_prods (kind_of_term body, path, k+1) in res_sl, res_il, res_i+1, res_cstr, res_p | cstr, path, _ -> [], [], 0, cstr, path;; @@ -444,7 +444,7 @@ exception Pbp_internal of int list;; The knowledge I have on constr structures is incomplete. *) -let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = +let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = function c -> function l -> let rec delete n = function | [] -> [] @@ -464,7 +464,7 @@ let (check_apply: (types, constr) kind_of_term -> (int list) -> bool) = else result | _ -> raise (Pbp_internal l) in - try + try (check_rec l c) = [] with Pbp_internal l -> l = [];; @@ -475,12 +475,12 @@ let (mk_db_indices: int list -> int -> int list) = [] -> [] | a::l -> (total - a)::(mk_db_aux l) in mk_db_aux int_list;; - + (* This proof-by-pointing rule is quite complicated, as it attempts to foresee usages of head tactics. A first operation is to follow the path as far as possible while staying on the spine of products (function down_prods) - and then to check whether the next step will be an elim step. If the + and then to check whether the next step will be an elim step. If the answer is true, then the built command takes advantage of the power of head tactics. *) @@ -497,37 +497,37 @@ let (head_tactic_patt: pbp_rule) = function let x' = next_global_ident x avoid in let cont_body = Prod(Name x', c1, - mkProd(Anonymous, body, + mkProd(Anonymous, body, mkVar(dummy_id))) in - let cont_tac + let cont_tac = f avoid (h::clear_names) false None cont_body (2::1::path) in cont_tac::(auxiliary_goals clear_names clear_flag h nprems []))) | _ -> None) - | (str_list, _, nprems, - App(oper,[|c1|]), 2::1::path) + | (str_list, _, nprems, + App(oper,[|c1|]), 2::1::path) when (is_matching_local (notconstr ()) oper) or (is_matching_local (notTconstr ()) oper) -> Some(chain_tactics [elim_with_bindings h str_list] (f avoid clear_names false None (kind_of_term c1) path)) - | (str_list, _, nprems, - App(oper, [|c1; c2|]), 2::a::path) + | (str_list, _, nprems, + App(oper, [|c1; c2|]), 2::a::path) when ((is_matching_local (andconstr()) oper) or (is_matching_local (prodconstr()) oper)) & (a = 1 or a = 2) -> let h1 = next_global_ident hyp_radix avoid in let h2 = next_global_ident hyp_radix (h1::avoid) in Some(PbpThens ([elim_with_bindings h str_list], - let cont_body = + let cont_body = if a = 1 then c1 else c2 in - let cont_tac = - f (h2::h1::avoid) (h::clear_names) + let cont_tac = + f (h2::h1::avoid) (h::clear_names) false (Some (if 1 = a then h1 else h2)) (kind_of_term cont_body) path in - (chain_tactics + (chain_tactics [make_named_intro h1; make_named_intro h2] cont_tac):: (auxiliary_goals clear_names clear_flag h nprems []))) @@ -540,9 +540,9 @@ let (head_tactic_patt: pbp_rule) = function let x' = next_global_ident x avoid in let cont_body = Prod(Name x', c1, - mkProd(Anonymous, body, + mkProd(Anonymous, body, mkVar(dummy_id))) in - let cont_tac + let cont_tac = f avoid (h::clear_names) false None cont_body (2::1::path) in cont_tac::(auxiliary_goals @@ -561,26 +561,26 @@ let (head_tactic_patt: pbp_rule) = function (* h' is the name for the new intro *) let h' = next_global_ident hyp_radix avoid in let cont_tac = - chain_tactics + chain_tactics [make_named_intro h'] - (f + (f (* h' should not be used again *) (h'::avoid) (* the disjunct itself can be discarded *) (h::clear_names) false (Some h') (kind_of_term cont_body) path) in - let snd_tac = + let snd_tac = chain_tactics [make_named_intro h'] (make_clears (h::clear_names)) in - let tacs1 = + let tacs1 = if a = 1 then [cont_tac; snd_tac] else [snd_tac; cont_tac] in tacs1@(auxiliary_goals (h::clear_names) false dummy_id nprems []))) - | (str_list, int_list, nprems, c, []) + | (str_list, int_list, nprems, c, []) when (check_apply c (mk_db_indices int_list nprems)) & (match c with Prod(_,_,_) -> false | _ -> true) & @@ -588,7 +588,7 @@ let (head_tactic_patt: pbp_rule) = function Some(add_clear_names_if_necessary (PbpThen [PbpApply h]) clear_names) | _ -> None) | _ -> None;; - + let pbp_rules = ref [rem_cast;head_tactic_patt;forall_intro;imply_intro2; forall_elim; imply_intro3; imply_elim1; imply_elim2; @@ -622,7 +622,7 @@ let default_ast optname constr path = PbpThen [PbpTryAssumption optname] let rec pbpt final_cmd avoid clear_names clear_flag opt_name constr path = let rec try_all_rules rl = - match rl with + match rl with f::tl -> (match f (avoid, clear_names, clear_flag, opt_name, constr, path, pbpt final_cmd) with @@ -674,7 +674,7 @@ let rec optim3_aux str_list = function (match cleanup_clears str_list names with [] -> other | l -> (PbpTryClear l)::other) - | a::l -> a::(optim3_aux str_list l) + | a::l -> a::(optim3_aux str_list l) | [] -> [];; let rec optim3 str_list = function @@ -694,8 +694,8 @@ let rec tactic_args_to_ints = function | _ -> failwith "expecting only numbers";; (* -let pbp_tac display_function = function - (Identifier a)::l -> +let pbp_tac display_function = function + (Identifier a)::l -> (function g -> let str = (string_of_id a) in let (ou,tstr) = (get_hyp_by_name g str) in @@ -711,7 +711,7 @@ let pbp_tac display_function = function (tactic_args_to_ints l) in (display_function (optim exp_ast); tclIDTAC g)) - | ((Integer n)::_) as l -> + | ((Integer n)::_) as l -> (function g -> let exp_ast = (pbpt default_ast (pf_ids_of_hyps g) [] false diff --git a/plugins/interface/showproof.ml b/plugins/interface/showproof.ml index aa11609ae7..8eeeee34aa 100644 --- a/plugins/interface/showproof.ml +++ b/plugins/interface/showproof.ml @@ -32,7 +32,7 @@ open Genarg (*****************************************************************************) (* Arbre de preuve maison: - + *) (* hypotheses *) @@ -92,9 +92,9 @@ let tactic t = ;; -(* +(* un arbre est clos s'il ne contient pas de sous-but non prouves, -ou bien s'il a un cousin gauche qui n'est pas clos +ou bien s'il a un cousin gauche qui n'est pas clos ce qui fait qu'on a au plus un sous-but non clos, le premier sous-but. *) let update_closed nt = @@ -117,8 +117,8 @@ let update_closed nt = t_proof=Proof(tac,lt1)}) in update nt ;; - - + + (* type complet avec les hypotheses. *) @@ -138,7 +138,7 @@ let long_type_hyp lh t= let seq_to_lnhyp sign sign' cl = let lh= ref (List.map (fun (x,c,t) -> (Name x, t)) sign) in - let nh=List.map (fun (id,c,ty) -> + let nh=List.map (fun (id,c,ty) -> {hyp_name=id; hyp_type=ty; hyp_full_type= @@ -156,7 +156,7 @@ let seq_to_lnhyp sign sign' cl = let rule_is_complex r = match r with - Nested (Tactic + Nested (Tactic ((TacArg (Tacexp _) |TacAtom (_,(TacAuto _|TacSymmetry _))),_),_) -> true |_ -> false @@ -219,10 +219,10 @@ let to_nproof sigma osign pf = let rec to_nproof_rec sigma osign pf = let {evar_hyps=sign;evar_concl=cl} = pf.goal in let sign = Environ.named_context_of_val sign in - let nsign = new_sign osign sign in - let oldsign = old_sign osign sign in + let nsign = new_sign osign sign in + let oldsign = old_sign osign sign in match pf.ref with - + None -> {t_info="to_prove"; t_goal=(seq_to_lnhyp oldsign nsign cl); t_proof=Notproved} @@ -230,7 +230,7 @@ let to_nproof sigma osign pf = if rule_is_complex r then ( let p1= to_nproof_rec sigma sign (subproof_of_proof pf) in - let ntree= fill_unproved p1 + let ntree= fill_unproved p1 (List.map (fun x -> (to_nproof_rec sigma sign x).t_proof) spfl) in (match r with @@ -253,7 +253,7 @@ let to_nproof sigma osign pf = in update_closed (to_nproof_rec sigma osign pf) ;; -(* +(* recupere l'arbre de preuve courant. *) @@ -262,7 +262,7 @@ let get_nproof () = (Tacmach.proof_of_pftreestate (get_pftreestate())) ;; - + (*****************************************************************************) (* Pprinter @@ -273,14 +273,14 @@ let pr_void () = sphs "";; let list_rem l = match l with [] -> [] |x::l1->l1;; (* liste de chaines *) -let prls l = +let prls l = let res = ref (sps (List.hd l)) in - List.iter (fun s -> + List.iter (fun s -> res:= sphv [ !res; spb; sps s]) (list_rem l); !res ;; -let prphrases f l = +let prphrases f l = spv (List.map (fun s -> sphv [f s; sps ","]) l) ;; @@ -288,13 +288,13 @@ let prphrases f l = let spi = spnb 3;; (* en colonne *) -let prl f l = +let prl f l = if l=[] then spe else spv (List.map f l);; (*en colonne, avec indentation *) -let prli f l = +let prli f l = if l=[] then spe else sph [spi; spv (List.map f l)];; -(* +(* Langues. *) @@ -377,9 +377,9 @@ let enumerate f ln = match ln with [] -> [] | [x] -> [f x] - |ln -> - let rec enum_rec f ln = - (match ln with + |ln -> + let rec enum_rec f ln = + (match ln with [x;y] -> [f x; spb; sph [_et ();spb;f y]] |x::l -> [sph [(f x);sps ","];spb]@(enum_rec f l) | _ -> assert false) @@ -506,28 +506,28 @@ let reste_a_montrer g = match !natural_language with spb; spt g; sps ". "] | English -> sph[ (prls ["It remains";"to"; rand ["prove";"show"]]); - spb; spt g; sps ". "] + spb; spt g; sps ". "] ;; let discutons_avec_A type_arg = match !natural_language with French -> sphv [sps "Discutons"; spb; sps "avec"; spb; - spt type_arg; sps ":"] + spt type_arg; sps ":"] | English -> sphv [sps "Let us discuss"; spb; sps "with"; spb; - spt type_arg; sps ":"] + spt type_arg; sps ":"] ;; let utilisons_A arg1 = match !natural_language with French -> sphv [sps (rand ["Utilisons";"Avec";"A l'aide de"]); - spb; spt arg1; sps ":"] + spb; spt arg1; sps ":"] | English -> sphv [sps (rand ["Let us use";"With";"With the help of"]); - spb; spt arg1; sps ":"] + spb; spt arg1; sps ":"] ;; let selon_les_valeurs_de_A arg1 = match !natural_language with French -> sphv [ (prls ["Selon";"les";"valeurs";"de"]); - spb; spt arg1; sps ":"] + spb; spt arg1; sps ":"] | English -> sphv [ (prls ["According";"values";"of"]); - spb; spt arg1; sps ":"] + spb; spt arg1; sps ":"] ;; let de_A_on_a arg1 = match !natural_language with @@ -547,9 +547,9 @@ let procedons_par_recurrence_sur_A arg1 = match !natural_language with ;; -let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A +let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A nfun tfun narg = match !natural_language with - French -> sphv [ + French -> sphv [ sphv [ prls ["Calculons";"la";"fonction"]; spb; sps (string_of_id nfun);spb; prls ["de";"type"]; @@ -557,7 +557,7 @@ let calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A prls ["par";"récurrence";"sur";"son";"argument"]; spb; sps (string_of_int narg); sps ":"] ] -| English -> sphv [ +| English -> sphv [ sphv [ prls ["Let us compute";"the";"function"]; spb; sps (string_of_id nfun);spb; prls ["of";"type"]; @@ -594,7 +594,7 @@ let coq_le_demontre_seul () = match !natural_language with sps "Fastoche."; sps "Trop cool"] | English -> rand [prls ["Coq";"shows";"it"; "alone."]; - sps "Fingers in the nose."] + sps "Fingers in the nose."] ;; let de_A_on_deduit_donc_B arg g = match !natural_language with @@ -608,31 +608,31 @@ let de_A_on_deduit_donc_B arg g = match !natural_language with let _A_est_immediat_par_B g arg = match !natural_language with French -> sph [ spt g; spb; (prls ["est";"immédiat";"par"]); - spb; spt arg ] + spb; spt arg ] | English -> sph [ spt g; spb; (prls ["is";"immediate";"from"]); - spb; spt arg ] + spb; spt arg ] ;; let le_resultat_est arg = match !natural_language with French -> sph [ (prls ["le";"résultat";"est"]); - spb; spt arg ] + spb; spt arg ] | English -> sph [ (prls ["the";"result";"is"]); spb; spt arg ];; let on_applique_la_tactique tactic tac = match !natural_language with - French -> sphv + French -> sphv [ sps "on applique";spb;sps "la tactique"; spb;tactic;spb;tac] -| English -> sphv +| English -> sphv [ sps "we apply";spb;sps "the tactic"; spb;tactic;spb;tac] ;; let de_A_il_vient_B arg g = match !natural_language with French -> sph - [ sps "De"; spb; spt arg; spb; - sps "il";spb; sps "vient";spb; spt g; sps ". " ] + [ sps "De"; spb; spt arg; spb; + sps "il";spb; sps "vient";spb; spt g; sps ". " ] | English -> sph - [ sps "From"; spb; spt arg; spb; - sps "it";spb; sps "comes";spb; spt g; sps ". " ] + [ sps "From"; spb; spt arg; spb; + sps "it";spb; sps "comes";spb; spt g; sps ". " ] ;; let ce_qui_est_trivial () = match !natural_language with @@ -690,12 +690,12 @@ type n_sort= | Nfunction ;; - + let sort_of_type t ts = let t=(strip_outer_cast t) in if is_Prop t then Nprop - else + else match ts with Prop(Null) -> Nformula |_ -> (match (kind_of_term t) with @@ -704,11 +704,11 @@ let sort_of_type t ts = ;; let adrel (x,t) e = - match x with + match x with Name(xid) -> Environ.push_rel (x,None,t) e | Anonymous -> Environ.push_rel (x,None,t) e -let rec nsortrec vl x = +let rec nsortrec vl x = match (kind_of_term x) with Prod(n,t,c)-> let vl = (adrel (n,t) vl) in nsortrec vl c @@ -722,7 +722,7 @@ let rec nsortrec vl x = new_sort_in_family (inductive_sort_family mip) | Construct(c) -> nsortrec vl (mkInd (inductive_of_constructor c)) - | Case(_,x,t,a) + | Case(_,x,t,a) -> nsortrec vl x | Cast(x,_, t)-> nsortrec vl t | Const c -> nsortrec vl (Typeops.type_of_constant vl c) @@ -732,7 +732,7 @@ let nsort x = nsortrec (Global.env()) (strip_outer_cast x) ;; -let sort_of_hyp h = +let sort_of_hyp h = (sort_of_type h.hyp_type (nsort h.hyp_full_type)) ;; @@ -744,14 +744,14 @@ let rec group_lhyp lh = |[h] -> [[h]] |h::lh -> match group_lhyp lh with - (h1::lh1)::lh2 -> + (h1::lh1)::lh2 -> if h.hyp_type=h1.hyp_type || ((sort_of_hyp h)=(sort_of_hyp h1) && (sort_of_hyp h1)=Nformula) then (h::(h1::lh1))::lh2 else [h]::((h1::lh1)::lh2) |_-> assert false ;; - + (* ln noms des hypotheses, lt leurs types *) let natural_ghyp (sort,ln,lt) intro = let t=List.hd lt in @@ -761,13 +761,13 @@ let natural_ghyp (sort,ln,lt) intro = Nprop -> soit_A_une_proposition nh ln t | Ntype -> soit_X_un_element_de_T nh ln t | Nfunction -> soit_F_une_fonction_de_type_T nh ln t - | Nformula -> + | Nformula -> sphv ((sps intro)::(enumerate (fun (n,t) -> tag_hypt n t) (List.combine ln lt))) ;; (* Cas d'une hypothese *) -let natural_hyp h = +let natural_hyp h = let ns= string_of_id h.hyp_name in let t=h.hyp_type in let ts= (nsort h.hyp_full_type) in @@ -782,18 +782,18 @@ let rec pr_ghyp lh intro= Nformula -> [natural_ghyp(sort,ln,t) intro; sps ". "] | _ -> [natural_ghyp(sort,ln,t) ""; sps ". "]) | (sort,ln,t)::lh -> - let hp= + let hp= ([natural_ghyp(sort,ln,t) intro] @(match lh with [] -> [sps ". "] |(sort1,ln1,t1)::lh1 -> match sort1 with - Nformula -> + Nformula -> (let nh=List.length ln in match sort with - Nprop -> telle_que nh - |Nfunction -> telle_que nh - |Ntype -> tel_que nh + Nprop -> telle_que nh + |Nfunction -> telle_que nh + |Ntype -> tel_que nh |Nformula -> [sps ". "]) | _ -> [sps ". "])) in (sphv hp)::(pr_ghyp lh "") @@ -860,7 +860,7 @@ let par_hypothese_de_recurrence () = match !natural_language with let natural_lhyp lh hi = match hi with - All_subgoals_hyp -> + All_subgoals_hyp -> ( match lh with [] -> spe |_-> prnatural_ghyp (group_lhyp lh) (supposons ())) @@ -896,21 +896,21 @@ let natural_lhyp lh hi = for i=1 to nlhci do let targ=(List.nth lhci (i-1))in let nh=(List.nth lh (i-1)) in - if targ="arg" || targ="argrec" + if targ="arg" || targ="argrec" then (s:=(!s)^" "^(string_of_id nh.hyp_name); lh0:=(!lh0)@[nh]) else lh1:=(!lh1)@[nh]; done; let introhyprec= - (if (!lh1)=[] then spe + (if (!lh1)=[] then spe else par_hypothese_de_recurrence () ) - in + in if a>0 then s:="("^(!s)^")"; spv [sphv [(if ncase>1 then sph[ sps ("-"^(cas ()));spb] else spe); - sps !s; sps ":"]; + sps !s; sps ":"]; prnatural_ghyp (group_lhyp !lh0) (supposons ()); introhyprec; prl (natural_hyp) !lh1] @@ -958,7 +958,7 @@ let rec show_goal lh ig g gs = "intros" -> if lh = [] then spe - else show_goal lh "standard" g gs + else show_goal lh "standard" g gs |"standard" -> (match (sort_of_type g gs) with Nprop -> donnons_une_proposition () @@ -967,7 +967,7 @@ let rec show_goal lh ig g gs = | Nfunction ->calculons_une_fonction_de_type g) | "apply" -> show_goal lh "" g gs | "simpl" ->en_simplifiant_on_obtient g - | "rewrite" -> on_obtient g + | "rewrite" -> on_obtient g | "equality" -> reste_a_montrer g | "trivial_equality" -> reste_a_montrer g | "" -> spe @@ -1002,14 +1002,14 @@ let first_name_hyp_of_ntree {t_goal={newhyp=lh}}= ;; let rec find_type x t= - match (kind_of_term (strip_outer_cast t)) with + match (kind_of_term (strip_outer_cast t)) with Prod(y,ty,t) -> (match y with - Name y -> + Name y -> if x=(string_of_id y) then ty else find_type x t | _ -> find_type x t) - |_-> assert false + |_-> assert false ;; (*********************************************************************** @@ -1061,7 +1061,7 @@ let is_equality_tac = function let equalities_ntree ig ntree = let rec equalities_ntree ig ntree = - if not (is_equality (concl ntree)) + if not (is_equality (concl ntree)) then [] else match (proof ntree) with @@ -1075,8 +1075,8 @@ let equalities_ntree ig ntree = then res else (ig,ntree)::res) else [(ig,ntree)] - in - equalities_ntree ig ntree + in + equalities_ntree ig ntree ;; let remove_seq_of_terms l = @@ -1091,7 +1091,7 @@ let remove_seq_of_terms l = let list_to_eq l o= let switch = fun h h' -> (if o then h else h') in match l with - [a] -> spt (fst a) + [a] -> spt (fst a) | (a,h)::(b,h')::l -> let rec list_to_eq h l = match l with @@ -1100,7 +1100,7 @@ let list_to_eq l o= (sph [sps "="; spb; spt b; spb;tag_uselemma (switch h h') spe]) :: (list_to_eq (switch h' h) l) in sph [spt a; spb; - spv ((sph [sps "="; spb; spt b; spb; + spv ((sph [sps "="; spb; spt b; spb; tag_uselemma (switch h h') spe]) ::(list_to_eq (switch h' h) l))] | _ -> assert false @@ -1131,7 +1131,7 @@ let rec natural_ntree ig ntree = [] ->spe | [_] -> spe | _::l -> sphv[sps ": "; - prli (natural_ntree + prli (natural_ntree {ihsg=All_subgoals_hyp; isgintro="standard"}) l])]) @@ -1157,7 +1157,7 @@ let rec natural_ntree ig ntree = spv [(natural_lhyp lh ig.ihsg); (show_goal2 lh ig g (nsort gf) ""); sph !ltext; - + natural_ntree {ihsg=All_subgoals_hyp; isgintro= let (t1,t2)= terms_of_equality (concl ntree) in @@ -1171,13 +1171,13 @@ let rec natural_ntree ig ntree = let gs=nsort gf in match p with Notproved -> spv [ (natural_lhyp lh ig.ihsg); - sph [spi; sps (intro_not_proved_goal gs); spb; + sph [spi; sps (intro_not_proved_goal gs); spb; tag_toprove g ] ] | Proof (TacId _,ltree) -> natural_ntree ig (List.hd ltree) - | Proof (TacAtom (_,tac),ltree) -> - (let ntext = + | Proof (TacAtom (_,tac),ltree) -> + (let ntext = match tac with (* Pas besoin de l'argument éventuel de la tactique *) TacIntroPattern _ -> natural_intros ig lh g gs ltree @@ -1197,9 +1197,9 @@ let rec natural_ntree ig ntree = | TacAssumption -> natural_trivial ig lh g gs ltree | TacClear _ -> natural_clear ig lh g gs ltree (* Besoin de l'argument de la tactique *) - | TacSimpleInductionDestruct (true,NamedHyp id) -> + | TacSimpleInductionDestruct (true,NamedHyp id) -> natural_induction ig lh g gs ge id ltree false - | TacExtend (_,"InductionIntro",[a]) -> + | TacExtend (_,"InductionIntro",[a]) -> let id=(out_gen wit_ident a) in natural_induction ig lh g gs ge id ltree true | TacApply (_,false,[c,_],None) -> @@ -1232,7 +1232,7 @@ let rec natural_ntree ig ntree = ntext (* spwithtac ntext tactic*) ) | Proof _ -> failwith "Don't know what to do with that" - in + in if info<>"not_proved" then spshrink info ntext else ntext @@ -1241,7 +1241,7 @@ and natural_generic ig lh g gs tactic tac ltree = [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); on_applique_la_tactique tactic tac ; - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp; isgintro="standard"}) ltree) @@ -1258,7 +1258,7 @@ and natural_intros ig lh g gs ltree = spv [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); - (prl (natural_ntree + (prl (natural_ntree {ihsg=All_subgoals_hyp; isgintro="intros"}) ltree) @@ -1269,7 +1269,7 @@ and natural_apply ig lh g gs arg ltree = [] -> spv [ (natural_lhyp lh ig.ihsg); - de_A_il_vient_B arg g + de_A_il_vient_B arg g ] | [sg]-> spv @@ -1280,10 +1280,10 @@ and natural_apply ig lh g gs arg ltree = else ""} g gs ""); grace_a_A_il_suffit_de_montrer_LA arg [spt sg]; - sph [spi ; natural_ntree + sph [spi ; natural_ntree {ihsg=All_subgoals_hyp; isgintro="apply"} (List.hd ltree)] - ] + ] | _ -> let ln = List.map (fun _ -> new_name()) lg in spv @@ -1298,7 +1298,7 @@ and natural_apply ig lh g gs arg ltree = lg ln); sph [spi; spv (List.map2 (fun x n -> sph [sps ("("^n^"):"); spb; - natural_ntree + natural_ntree {ihsg=All_subgoals_hyp; isgintro="apply"} x]) ltree ln)] @@ -1310,26 +1310,26 @@ and natural_rem_goals ltree = | [sg]-> spv [ reste_a_montrer_LA [spt sg]; - sph [spi ; natural_ntree + sph [spi ; natural_ntree {ihsg=All_subgoals_hyp; isgintro="apply"} (List.hd ltree)] - ] + ] | _ -> let ln = List.map (fun _ -> new_name()) lg in spv - [ reste_a_montrer_LA + [ reste_a_montrer_LA (List.map2 (fun g n -> sph [sps ("("^n^")"); spb; spt g]) lg ln); sph [spi; spv (List.map2 (fun x n -> sph [sps ("("^n^"):"); spb; - natural_ntree + natural_ntree {ihsg=All_subgoals_hyp; isgintro="apply"} x]) ltree ln)] ] and natural_exact ig lh g gs arg ltree = spv - [ + [ (natural_lhyp lh ig.ihsg); (let {ihsg=pi;isgintro=ig}= ig in (show_goal2 lh {ihsg=pi;isgintro=""} @@ -1343,7 +1343,7 @@ and natural_cut ig lh g gs arg ltree = spv [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) (List.rev ltree)); de_A_on_deduit_donc_B arg g @@ -1353,18 +1353,18 @@ and natural_cutintro ig lh g gs arg ltree = [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); sph [spi; - (natural_ntree + (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""} (List.nth ltree 1))]; sph [spi; - (natural_ntree + (natural_ntree {ihsg=No_subgoals_hyp;isgintro=""} (List.nth ltree 0))] ] and whd_betadeltaiota x = whd_betaiota Evd.empty x and type_of_ast s c = type_of (Global.env()) Evd.empty (constr_of_ast c) and prod_head t = - match (kind_of_term (strip_outer_cast t)) with + match (kind_of_term (strip_outer_cast t)) with Prod(_,_,c) -> prod_head c (* |App(f,a) -> f *) | _ -> t @@ -1386,7 +1386,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = let type_arg= targ1 (* List.nth targ (mis_index dmi)*) in if ncti<>1 (* Zéro ou Plusieurs constructeurs *) - then ( + then ( spv [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); @@ -1404,7 +1404,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = then (arity_of_constr_of_mind env indf !ci) else 0 in let ici= (!ci) in - sph[ (natural_ntree + sph[ (natural_ntree {ihsg= (match (nsort targ1) with Prop(Null) -> @@ -1420,7 +1420,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = (nhd ltree ((List.length ltree)- ncti)))]) ] ) (* Cas d'un seul constructeur *) - else ( + else ( spv [ (natural_lhyp lh ig.ihsg); @@ -1433,7 +1433,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = then (arity_of_constr_of_mind env indf 1) else 0 in let _ici= 1 in - sph[ (natural_ntree + sph[ (natural_ntree {ihsg= (match (nsort targ1) with Prop(Null) -> @@ -1446,7 +1446,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = ]); (sph [spi; (natural_rem_goals (nhd ltree ((List.length ltree)- 1)))]) - ] + ] ) (* with _ ->natural_generic ig lh g gs (sps "Case") (spt arg1) ltree *) @@ -1455,7 +1455,7 @@ and natural_case ig lh g gs ge arg1 ltree with_intros = Elim *) and prod_list_var t = - match (kind_of_term (strip_outer_cast t)) with + match (kind_of_term (strip_outer_cast t)) with Prod(_,t,c) -> t::(prod_list_var c) |_ -> [] and hd_is_mind t ti = @@ -1486,7 +1486,7 @@ and mind_ind_info_hyp_constr indf c = !lr (* mind_ind_info_hyp_constr "le" 2;; -donne ["arg"; "argrec"] +donne ["arg"; "argrec"] mind_ind_info_hyp_constr "le" 1;; donne [] mind_ind_info_hyp_constr "nat" 2;; @@ -1518,7 +1518,7 @@ and natural_elim ig lh g gs ge arg1 ltree with_intros= then mind_ind_info_hyp_constr indf !ci else [] in let ici= (!ci) in - sph[ (natural_ntree + sph[ (natural_ntree {ihsg= (match (nsort targ1) with Prop(Null) -> @@ -1538,7 +1538,7 @@ and natural_elim ig lh g gs ge arg1 ltree with_intros= (*****************************************************************************) (* InductionIntro n -*) +*) and natural_induction ig lh g gs ge arg2 ltree with_intros= let env = (gLOB (g_env (List.hd ltree))) in let arg1= mkVar arg2 in @@ -1572,12 +1572,12 @@ and natural_induction ig lh g gs ge arg2 ltree with_intros= (fun treearg -> ci:=!ci+1; let nci=(constr_of_mind mip !ci) in let aci=(arity_of_constr_of_mind env indf !ci) in - let hci= + let hci= if with_intros then mind_ind_info_hyp_constr indf !ci else [] in let ici= (!ci) in - sph[ (natural_ntree + sph[ (natural_ntree {ihsg= (match (nsort targ1) with Prop(Null) -> @@ -1606,47 +1606,47 @@ and natural_fix ig lh g gs narg ltree = spv [ (natural_lhyp lh ig.ihsg); calculons_la_fonction_F_de_type_T_par_recurrence_sur_son_argument_A nfun tfun narg; - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro=""}) ltree) ] | _ -> assert false and natural_reduce ig lh g gs ge mode la ltree = match la with - {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr -> + {onhyps=Some[]} when la.concl_occs <> no_occurrences_expr -> spv [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree + (show_goal2 lh ig g gs ""); + (prl (natural_ntree {ihsg=All_subgoals_hyp;isgintro="simpl"}) ltree) ] | {onhyps=Some[hyp]} when la.concl_occs = no_occurrences_expr -> spv [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); - (prl (natural_ntree + (show_goal2 lh ig g gs ""); + (prl (natural_ntree {ihsg=Reduce_hyp;isgintro=""}) ltree) ] | _ -> assert false and natural_split ig lh g gs ge la ltree = match la with - [arg] -> + [arg] -> let _env= (gLOB ge) in let arg1= (*dbize _env*) arg in spv [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); + (show_goal2 lh ig g gs ""); pour_montrer_G_la_valeur_recherchee_est_A g arg1; - (prl (natural_ntree + (prl (natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) ltree) ] | [] -> spv [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) ltree) ] @@ -1660,9 +1660,9 @@ and natural_generalize ig lh g gs ge la ltree = (* let type_arg=type_of_ast ge arg in*) spv [ (natural_lhyp lh ig.ihsg); - (show_goal2 lh ig g gs ""); + (show_goal2 lh ig g gs ""); on_se_sert_de_A arg1; - (prl (natural_ntree + (prl (natural_ntree {ihsg=All_subgoals_hyp;isgintro=""}) ltree) ] @@ -1670,23 +1670,23 @@ and natural_generalize ig lh g gs ge la ltree = and natural_right ig lh g gs ltree = spv [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree); - d_ou_A g + ltree); + d_ou_A g ] and natural_left ig lh g gs ltree = spv [ (natural_lhyp lh ig.ihsg); - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) - ltree); - d_ou_A g + ltree); + d_ou_A g ] and natural_auto ig lh g gs ltree = match ig.isgintro with "trivial_equality" -> spe - | _ -> + | _ -> if ltree=[] then sphv [(natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); @@ -1717,7 +1717,7 @@ and natural_trivial ig lh g gs ltree = ce_qui_est_trivial () ] else spv [(natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ". "); - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="standard"}) ltree)] and natural_rewrite ig lh g gs arg ltree = @@ -1725,7 +1725,7 @@ and natural_rewrite ig lh g gs arg ltree = [ (natural_lhyp lh ig.ihsg); (show_goal2 lh ig g gs ""); en_utilisant_l_egalite_A arg; - (prli(natural_ntree + (prli(natural_ntree {ihsg=All_subgoals_hyp;isgintro="rewrite"}) ltree) ] @@ -1768,18 +1768,18 @@ CAMLLIB=/usr/local/lib/ocaml CAMLP4LIB=/usr/local/lib/camlp4 export CAMLLIB export COQTOP -export CAMLP4LIB +export CAMLP4LIB cd d:/Tools/pcoq/src/text d:/Tools/coq-7avril/bin/coqtop.byte.exe -I /cygdrive/D/Tools/pcoq/src/abs_syntax -I /cygdrive/D/Tools/pcoq/src/text -I /cygdrive/D/Tools/pcoq/src/coq -I /cygdrive/D/Tools/pcoq/src/pbp -I /cygdrive/D/Tools/pcoq/src/dad -I /cygdrive/D/Tools/pcoq/src/history - - + + Lemma l1: (A, B : Prop) A \/ B -> B -> A. Intros. Elim H. Auto. Qed. - + Drop. @@ -1806,7 +1806,7 @@ Pp_control.set_depth_boxes 100;; #install_printer pproof;; ep();; -let bidon = ref (constr_of_string "O");; +let bidon = ref (constr_of_string "O");; #trace to_nproof;; ***********************************************************************) diff --git a/plugins/interface/showproof_ct.ml b/plugins/interface/showproof_ct.ml index dd7f455d79..7632ebdfb5 100644 --- a/plugins/interface/showproof_ct.ml +++ b/plugins/interface/showproof_ct.ml @@ -26,20 +26,20 @@ let spe = sphs "";; let spb = sps " ";; let spr = sps "Retour chariot pour Show proof";; -let spnb n = +let spnb n = let s = ref "" in for i=1 to n do s:=(!s)^" "; done; sps !s ;; let rec spclean l = - match l with + match l with [] -> [] |x::l -> if x=spe then (spclean l) else x::(spclean l) ;; -let spnb n = +let spnb n = let s = ref "" in for i=1 to n do s:=(!s)^" "; done; sps !s ;; @@ -62,13 +62,13 @@ let root_of_text_proof t= CT_text_op [ct_text "root_of_text_proof"; t] ;; - + let spshrink info t = CT_text_op [ct_text "shrink"; CT_text_op [ct_text info; t]] ;; - + let spuselemma intro x y = CT_text_op [ct_text "uselemma"; ct_text intro; @@ -105,7 +105,7 @@ let spv l = let l= spclean l in CT_text_v l ;; - + let sph l = let l= spclean l in CT_text_h l @@ -118,12 +118,12 @@ let sphv l = ;; let rec prlist_with_sep f g l = - match l with + match l with [] -> hov 0 (mt ()) |x::l1 -> hov 0 ((g x) ++ (f ()) ++ (prlist_with_sep f g l1)) ;; - -let rec sp_print x = + +let rec sp_print x = match x with | CT_coerce_ID_to_TEXT (CT_ident s) -> (match s with @@ -162,7 +162,7 @@ let rec sp_print x = (CT_coerce_INT_to_SIGNED_INT (CT_int x)) -> x | _ -> raise (Failure "sp_print")) p) in - h 0 (sp_print g ++ spc () ++ str "(" ++ str hyp ++ str ")") + h 0 (sp_print g ++ spc () ++ str "(" ++ str hyp ++ str ")") | CT_text_h l -> h 0 (prlist_with_sep (fun () -> mt ()) @@ -178,7 +178,7 @@ let rec sp_print x = h 0 (str ("("^info^": ") ++ sp_print t ++ str ")") | CT_text_op [CT_coerce_ID_to_TEXT (CT_ident "root_of_text_proof"); t]-> - sp_print t + sp_print t | _ -> str "..." ;; - + diff --git a/plugins/interface/translate.ml b/plugins/interface/translate.ml index 559860b2fc..48f35ebab2 100644 --- a/plugins/interface/translate.ml +++ b/plugins/interface/translate.ml @@ -25,9 +25,9 @@ let translate_constr at_top env c = (*translates a named_context into a centaur-tree --> PREMISES_LIST *) (* this code is inspired from printer.ml (function pr_named_context_of) *) let translate_sign env = - let l = + let l = Environ.fold_named_context - (fun env (id,v,c) l -> + (fun env (id,v,c) l -> (match v with None -> CT_premise(CT_ident(string_of_id id), translate_constr false env c) @@ -36,19 +36,19 @@ let translate_sign env = (CT_coerce_ID_to_FORMULA (CT_ident (string_of_id id)), translate_constr false env v1, translate_constr false env c))::l) - env ~init:[] + env ~init:[] in CT_premises_list l;; - + (* the function rev_and_compact performs two operations: 1- it reverses the list of integers given as argument 2- it replaces sequences of "1" by a negative number that is the length of the sequence. *) let rec rev_and_compact l = function [] -> l - | 1::tl -> + | 1::tl -> (match l with - n::tl' -> + n::tl' -> if n < 0 then rev_and_compact ((n - 1)::tl') tl else diff --git a/plugins/interface/xlate.ml b/plugins/interface/xlate.ml index be7472a486..a322c7a72b 100644 --- a/plugins/interface/xlate.ml +++ b/plugins/interface/xlate.ml @@ -17,7 +17,7 @@ open Goptions;; (* // Verify whether this is dead code, as of coq version 7 *) -(* The following three sentences have been added to cope with a change +(* The following three sentences have been added to cope with a change of strategy from the Coq team in the way rules construct ast's. The problem is that now grammar rules will refer to identifiers by giving their absolute name, using the mutconstruct when needed. Unfortunately, @@ -80,7 +80,7 @@ let ctv_FORMULA_OPT_NONE = let ctv_PATTERN_OPT_NONE = CT_coerce_NONE_to_PATTERN_OPT CT_none;; -let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT +let ctv_DEF_BODY_OPT_NONE = CT_coerce_FORMULA_OPT_to_DEF_BODY_OPT ctv_FORMULA_OPT_NONE;; let ctf_ID_OPT_OR_ALL_SOME s = @@ -202,7 +202,7 @@ let apply_or_by_notation f = function | AN x -> f x | ByNotation _ -> xlate_error "TODO: ByNotation" -let tac_qualid_to_ct_ID ref = +let tac_qualid_to_ct_ID ref = CT_ident (Libnames.string_of_qualid (snd (qualid_of_reference ref))) let loc_qualid_to_ct_ID ref = @@ -229,10 +229,10 @@ let xlate_class = function let id_to_pattern_var ctid = match ctid with | CT_metaid _ -> xlate_error "metaid not expected in pattern_var" - | CT_ident "_" -> + | CT_ident "_" -> CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_NONE_to_ID_OPT CT_none) | CT_ident id_string -> - CT_coerce_ID_OPT_to_MATCH_PATTERN + CT_coerce_ID_OPT_to_MATCH_PATTERN (CT_coerce_ID_to_ID_OPT (CT_ident id_string)) | CT_metac _ -> assert false;; @@ -250,7 +250,7 @@ let xlate_qualid a = let d,i = Libnames.repr_qualid a in let l = Names.repr_dirpath d in List.fold_left (fun s i1 -> (string_of_id i1) ^ "." ^ s) (string_of_id i) l;; - + (* // The next two functions should be modified to make direct reference to a notation operator *) let notation_to_formula s l = CT_notation(CT_string s, CT_formula_list l);; @@ -267,19 +267,19 @@ let rec xlate_match_pattern = CT_pattern_app (id_to_pattern_var (xlate_reference f1), CT_match_pattern_ne_list - (xlate_match_pattern arg1, + (xlate_match_pattern arg1, List.map xlate_match_pattern args)) | CPatAlias (_, pattern, id) -> CT_pattern_as (xlate_match_pattern pattern, CT_coerce_ID_to_ID_OPT (xlate_ident id)) | CPatOr (_,l) -> xlate_error "CPatOr: TODO" - | CPatDelimiters(_, key, p) -> + | CPatDelimiters(_, key, p) -> CT_pattern_delimitors(CT_num_type key, xlate_match_pattern p) | CPatPrim (_,Numeral n) -> CT_coerce_NUM_to_MATCH_PATTERN (CT_int_encapsulator(Bigint.to_string n)) | CPatPrim (_,String _) -> xlate_error "CPatPrim (String): TODO" - | CPatNotation(_, s, (l,[])) -> + | CPatNotation(_, s, (l,[])) -> CT_pattern_notation(CT_string s, CT_match_pattern_list(List.map xlate_match_pattern l)) | CPatNotation(_, s, (l,_)) -> @@ -331,26 +331,26 @@ and xlate_binder_l = function LocalRawAssum(l,_,t) -> CT_binder(xlate_id_opt_ne_list l, xlate_formula t) | LocalRawDef(n,v) -> CT_coerce_DEF_to_BINDER(CT_def(xlate_id_opt n, xlate_formula v)) -and +and xlate_match_pattern_ne_list = function [] -> assert false - | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, + | a::l -> CT_match_pattern_ne_list(xlate_match_pattern a, List.map xlate_match_pattern l) and translate_one_equation = function (_,[_,lp], a) -> CT_eqn (xlate_match_pattern_ne_list lp, xlate_formula a) | _ -> xlate_error "TODO: disjunctive multiple patterns" -and +and xlate_binder_ne_list = function [] -> assert false | a::l -> CT_binder_ne_list(xlate_binder a, List.map xlate_binder l) -and +and xlate_binder_list = function l -> CT_binder_list( List.map xlate_binder_l l) and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function CRef r -> varc (xlate_reference r) | CArrow(_,a,b)-> CT_arrowc (xlate_formula a, xlate_formula b) - | CProdN(_,ll,b) as whole_term -> + | CProdN(_,ll,b) as whole_term -> let rec gather_binders = function CProdN(_, ll, b) -> ll@(gather_binders b) @@ -358,27 +358,27 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function let rec fetch_ultimate_body = function CProdN(_, _, b) -> fetch_ultimate_body b | a -> a in - CT_prodc(xlate_binder_ne_list (gather_binders whole_term), + CT_prodc(xlate_binder_ne_list (gather_binders whole_term), xlate_formula (fetch_ultimate_body b)) | CLambdaN(_,ll,b)-> CT_lambdac(xlate_binder_ne_list ll, xlate_formula b) - | CLetIn(_, v, a, b) -> + | CLetIn(_, v, a, b) -> CT_letin(CT_def(xlate_id_opt v, xlate_formula a), xlate_formula b) - | CAppExpl(_, (Some n, r), l) -> + | CAppExpl(_, (Some n, r), l) -> let l', last = decompose_last l in CT_proj(xlate_formula last, CT_formula_ne_list (CT_bang(varc (xlate_reference r)), List.map xlate_formula l')) | CAppExpl(_, (None, r), []) -> CT_bang(varc(xlate_reference r)) - | CAppExpl(_, (None, r), l) -> + | CAppExpl(_, (None, r), l) -> CT_appc(CT_bang(varc (xlate_reference r)), xlate_formula_ne_list l) - | CApp(_, (Some n,f), l) -> + | CApp(_, (Some n,f), l) -> let l', last = decompose_last l in - CT_proj(xlate_formula_expl last, + CT_proj(xlate_formula_expl last, CT_formula_ne_list (xlate_formula f, List.map xlate_formula_expl l')) - | CApp(_, (_,f), l) -> + | CApp(_, (_,f), l) -> CT_appc(xlate_formula f, xlate_formula_expl_ne_list l) | CRecord (_,_,_) -> xlate_error "CRecord: TODO" | CCases (_, _, _, [], _) -> assert false @@ -387,14 +387,14 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function List.map xlate_matched_formula tml), xlate_formula_opt ret_type, CT_eqn_list (List.map (fun x -> translate_one_equation x) eqns)) - | CLetTuple (_,a::l, ret_info, c, b) -> + | CLetTuple (_,a::l, ret_info, c, b) -> CT_let_tuple(CT_id_opt_ne_list(xlate_id_opt_aux a, List.map xlate_id_opt_aux l), xlate_return_info ret_info, xlate_formula c, xlate_formula b) | CLetTuple (_, [], _, _, _) -> xlate_error "NOT parsed: Let with ()" - | CIf (_,c, ret_info, b1, b2) -> + | CIf (_,c, ret_info, b1, b2) -> CT_if (xlate_formula c, xlate_return_info ret_info, xlate_formula b1, xlate_formula b2) @@ -403,16 +403,16 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function | CNotation(_, s,(l,[])) -> notation_to_formula s (List.map xlate_formula l) | CNotation(_, s,(l,_)) -> xlate_error "CNotation (recursive): TODO" | CGeneralization(_,_,_,_) -> xlate_error "CGeneralization: TODO" - | CPrim (_, Numeral i) -> + | CPrim (_, Numeral i) -> CT_coerce_NUM_to_FORMULA(CT_int_encapsulator(Bigint.to_string i)) | CPrim (_, String _) -> xlate_error "CPrim (String): TODO" - | CHole _ -> CT_existvarc + | CHole _ -> CT_existvarc (* I assume CDynamic has been inserted to make free form extension of the language possible, but this would go against the logic of pcoq anyway. *) | CDynamic (_, _) -> assert false - | CDelimiters (_, key, num) -> + | CDelimiters (_, key, num) -> CT_num_encapsulator(CT_num_type key , xlate_formula num) - | CCast (_, e, CastConv (_, t)) -> + | CCast (_, e, CastConv (_, t)) -> CT_coerce_TYPED_FORMULA_to_FORMULA (CT_typed_formula(xlate_formula e, xlate_formula t)) | CCast (_, e, CastCoerce) -> assert false @@ -423,13 +423,13 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function | CPatVar (_, (true, s)) -> xlate_error "Second order variable not supported" | CEvar _ -> xlate_error "CEvar not supported" - | CCoFix (_, (_, id), lm::lmi) -> + | CCoFix (_, (_, id), lm::lmi) -> let strip_mutcorec ((_, fid), bl,arf, ardef) = CT_cofix_rec (xlate_ident fid, xlate_binder_list bl, xlate_formula arf, xlate_formula ardef) in CT_cofixc(xlate_ident id, (CT_cofix_rec_list (strip_mutcorec lm, List.map strip_mutcorec lmi))) - | CFix (_, (_, id), lm::lmi) -> + | CFix (_, (_, id), lm::lmi) -> let strip_mutrec ((_, fid), (n, ro), bl, arf, ardef) = let struct_arg = make_fix_struct (n, bl) in let arf = xlate_formula arf in @@ -439,12 +439,12 @@ and (xlate_formula:Topconstr.constr_expr -> Ascent.ct_FORMULA) = function CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), struct_arg, arf, ardef) | _ -> xlate_error "mutual recursive" in - CT_fixc (xlate_ident id, + CT_fixc (xlate_ident id, CT_fix_binder_list - (CT_coerce_FIX_REC_to_FIX_BINDER - (strip_mutrec lm), List.map + (CT_coerce_FIX_REC_to_FIX_BINDER + (strip_mutrec lm), List.map (fun x-> CT_coerce_FIX_REC_to_FIX_BINDER (strip_mutrec x)) - lmi)) + lmi)) | CCoFix _ -> assert false | CFix _ -> assert false and xlate_matched_formula = function @@ -454,18 +454,18 @@ and xlate_matched_formula = function CT_formula_in(xlate_formula f, xlate_formula y) | (f, (Some x, None)) -> CT_formula_as(xlate_formula f, xlate_id_opt_aux x) - | (f, (None, None)) -> + | (f, (None, None)) -> CT_coerce_FORMULA_to_MATCHED_FORMULA(xlate_formula f) and xlate_formula_expl = function (a, None) -> xlate_formula a - | (a, Some (_,ExplByPos (i, _))) -> + | (a, Some (_,ExplByPos (i, _))) -> xlate_error "explicitation of implicit by rank not supported" | (a, Some (_,ExplByName i)) -> CT_labelled_arg(CT_ident (string_of_id i), xlate_formula a) and xlate_formula_expl_ne_list = function [] -> assert false | a::l -> CT_formula_ne_list(xlate_formula_expl a, List.map xlate_formula_expl l) -and xlate_formula_ne_list = function +and xlate_formula_ne_list = function [] -> assert false | a::l -> CT_formula_ne_list(xlate_formula a, List.map xlate_formula l);; @@ -489,17 +489,17 @@ let xlate_hyp_location = | (occs, AI (_,id)), InHypValueOnly -> CT_invalue(xlate_ident id, nums_or_var_to_int_list (nums_of_occs occs)) | (occs, AI (_,id)), InHyp when occs = all_occurrences_expr -> - CT_coerce_UNFOLD_to_HYP_LOCATION + CT_coerce_UNFOLD_to_HYP_LOCATION (CT_coerce_ID_to_UNFOLD (xlate_ident id)) | ((_,a::l as occs), AI (_,id)), InHyp -> let nums = nums_of_occs occs in let a = List.hd nums and l = List.tl nums in - CT_coerce_UNFOLD_to_HYP_LOCATION - (CT_unfold_occ (xlate_ident id, - CT_int_ne_list(num_or_var_to_int a, + CT_coerce_UNFOLD_to_HYP_LOCATION + (CT_unfold_occ (xlate_ident id, + CT_int_ne_list(num_or_var_to_int a, nums_or_var_to_int_list_aux l))) | (_, AI (_,id)), InHyp -> xlate_error "Unused" (* (true,]) *) - | (_, MetaId _),_ -> + | (_, MetaId _),_ -> xlate_error "MetaId not supported in xlate_hyp_location (should occur only in quotations)" @@ -510,8 +510,8 @@ let xlate_clause cls = None -> CT_coerce_STAR_to_HYP_LOCATION_LIST_OR_STAR CT_star | Some l -> CT_hyp_location_list(List.map xlate_hyp_location l) in CT_clause - (hyps_info, - if cls.concl_occs <> no_occurrences_expr then + (hyps_info, + if cls.concl_occs <> no_occurrences_expr then CT_coerce_STAR_to_STAR_OPT CT_star else CT_coerce_NONE_to_STAR_OPT CT_none) @@ -577,7 +577,7 @@ let xlate_quantified_hypothesis = function | NamedHyp id -> CT_coerce_ID_to_ID_OR_INT (xlate_ident id) let xlate_quantified_hypothesis_opt = function - | None -> + | None -> CT_coerce_ID_OPT_to_ID_OR_INT_OPT ctv_ID_OPT_NONE | Some (AnonHyp n) -> xlate_int_to_id_or_int_opt n | Some (NamedHyp id) -> xlate_id_to_id_or_int_opt id;; @@ -586,7 +586,7 @@ let xlate_id_or_int = function ArgArg n -> CT_coerce_INT_to_ID_OR_INT(CT_int n) | ArgVar(_, s) -> CT_coerce_ID_to_ID_OR_INT(xlate_ident s);; -let xlate_explicit_binding (loc,h,c) = +let xlate_explicit_binding (loc,h,c) = CT_binding (xlate_quantified_hypothesis h, xlate_formula c) let xlate_bindings = function @@ -630,7 +630,7 @@ let rec xlate_intro_pattern (loc,pat) = match pat with | IntroOrAndPattern (fp::ll) -> CT_disj_pattern (CT_intro_patt_list(List.map xlate_intro_pattern fp), - List.map + List.map (fun l -> CT_intro_patt_list(List.map xlate_intro_pattern l)) ll) @@ -651,7 +651,7 @@ let is_tactic_special_case = function | _ -> false;; let xlate_context_pattern = function - | Term v -> + | Term v -> CT_coerce_FORMULA_to_CONTEXT_PATTERN (xlate_formula v) | Subterm (b, idopt, v) -> (* TODO: application pattern *) CT_context(xlate_ident_opt idopt, xlate_formula v) @@ -677,7 +677,7 @@ let xlate_int_or_constr = function | ElimOnIdent(_,i) -> CT_coerce_ID_OR_INT_to_FORMULA_OR_INT (CT_coerce_ID_to_ID_OR_INT(xlate_ident i)) - | ElimOnAnonHyp i -> + | ElimOnAnonHyp i -> CT_coerce_ID_OR_INT_to_FORMULA_OR_INT (CT_coerce_INT_to_ID_OR_INT(CT_int i));; @@ -686,11 +686,11 @@ let xlate_using = function | Some (c2,sl2) -> CT_using (xlate_formula c2, xlate_bindings sl2);; let xlate_one_unfold_block = function - ((true,[]),qid) -> + ((true,[]),qid) -> CT_coerce_ID_to_UNFOLD(apply_or_by_notation tac_qualid_to_ct_ID qid) | (((_,_::_) as occs), qid) -> let l = nums_of_occs occs in - CT_unfold_occ(apply_or_by_notation tac_qualid_to_ct_ID qid, + CT_unfold_occ(apply_or_by_notation tac_qualid_to_ct_ID qid, nums_or_var_to_int_ne_list (List.hd l) (List.tl l)) | ((false,[]), qid) -> xlate_error "Unused" ;; @@ -705,7 +705,7 @@ let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) = function | TacVoid -> CT_void - | Tacexp t -> + | Tacexp t -> CT_coerce_TACTIC_COM_to_TACTIC_ARG(xlate_tactic t) | Integer n -> CT_coerce_FORMULA_OR_INT_to_TACTIC_ARG @@ -724,7 +724,7 @@ let rec (xlate_tacarg:raw_tactic_arg -> ct_TACTIC_ARG) = CT_coerce_EVAL_CMD_to_TACTIC_ARG (CT_eval(CT_coerce_NONE_to_INT_OPT CT_none, xlate_red_tactic r, xlate_formula c)) - | ConstrMayEval(ConstrTypeOf(c)) -> + | ConstrMayEval(ConstrTypeOf(c)) -> CT_coerce_TERM_CHANGE_to_TACTIC_ARG(CT_check_term(xlate_formula c)) | MetaIdArg _ -> xlate_error "MetaIdArg should only be used in quotations" @@ -753,9 +753,9 @@ and xlate_red_tactic = | CbvVm -> CT_cbvvm | Hnf -> CT_hnf | Simpl None -> CT_simpl ctv_PATTERN_OPT_NONE - | Simpl (Some (occs,c)) -> + | Simpl (Some (occs,c)) -> let l = nums_of_occs occs in - CT_simpl + CT_simpl (CT_coerce_PATTERN_to_PATTERN_OPT (CT_pattern_occ (CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c))) @@ -770,7 +770,7 @@ and xlate_red_tactic = (match ct_unf_list with | first :: others -> CT_unfold (CT_unfold_ne_list (first, others)) | [] -> error "there should be at least one thing to unfold") - | Fold formula_list -> + | Fold formula_list -> CT_fold(CT_formula_list(List.map xlate_formula formula_list)) | Pattern l -> let pat_list = List.map (fun (occs,c) -> @@ -782,7 +782,7 @@ and xlate_red_tactic = | [] -> error "Expecting at least one pattern in a Pattern command") | ExtraRedExpr _ -> xlate_error "TODO LATER: ExtraRedExpr (probably dead code)" -and xlate_local_rec_tac = function +and xlate_local_rec_tac = function (* TODO LATER: local recursive tactics and global ones should be handled in the same manner *) | ((_,x),Tacexp (TacFun (argl,tac))) -> @@ -797,7 +797,7 @@ and xlate_tactic = | TacFun (largs, t) -> let fst, rest = xlate_largs_to_id_opt largs in CT_tactic_fun (CT_id_opt_ne_list(fst, rest), xlate_tactic t) - | TacThen (t1,[||],t2,[||]) -> + | TacThen (t1,[||],t2,[||]) -> (match xlate_tactic t1 with CT_then(a,l) -> CT_then(a,l@[xlate_tactic t2]) | t -> CT_then (t,[xlate_tactic t2])) @@ -817,7 +817,7 @@ and xlate_tactic = | TacDo(count, t) -> CT_do(xlate_id_or_int count, xlate_tactic t) | TacTry t -> CT_try (xlate_tactic t) | TacRepeat t -> CT_repeat(xlate_tactic t) - | TacAbstract(t,id_opt) -> + | TacAbstract(t,id_opt) -> CT_abstract((match id_opt with None -> ctv_ID_OPT_NONE | Some id -> ctf_ID_OPT_SOME (CT_ident (string_of_id id))), @@ -827,8 +827,8 @@ and xlate_tactic = | TacMatch (true,_,_) -> failwith "TODO: lazy match" | TacMatch (false, exp, rules) -> CT_match_tac(xlate_tactic exp, - match List.map - (function + match List.map + (function | Pat ([],p,tac) -> CT_match_tac_rule(xlate_context_pattern p, mk_let_value tac) @@ -836,7 +836,7 @@ and xlate_tactic = | All tac -> CT_match_tac_rule (CT_coerce_FORMULA_to_CONTEXT_PATTERN - CT_existvarc, + CT_existvarc, mk_let_value tac)) rules with | [] -> assert false | fst::others -> @@ -856,27 +856,27 @@ and xlate_tactic = CT_coerce_NONE_to_TACTIC_OPT CT_none, CT_coerce_DEF_BODY_to_LET_VALUE (formula_to_def_body v)) - | ((_,s),Tacexp t) -> + | ((_,s),Tacexp t) -> CT_let_clause(xlate_ident s, CT_coerce_NONE_to_TACTIC_OPT CT_none, CT_coerce_TACTIC_COM_to_LET_VALUE (xlate_tactic t)) - | ((_,s),t) -> + | ((_,s),t) -> CT_let_clause(xlate_ident s, CT_coerce_NONE_to_TACTIC_OPT CT_none, CT_coerce_TACTIC_COM_to_LET_VALUE (xlate_call_or_tacarg t)) in let cl_l = List.map cvt_clause l in (match cl_l with - | [] -> assert false + | [] -> assert false | fst::others -> CT_let_ltac (CT_let_clauses(fst, others), mk_let_value t)) | TacLetIn(true, [], _) -> xlate_error "recursive definition with no definition" - | TacLetIn(true, f1::l, t) -> + | TacLetIn(true, f1::l, t) -> let tl = CT_rec_tactic_fun_list (xlate_local_rec_tac f1, List.map xlate_local_rec_tac l) in CT_rec_tactic_in(tl, xlate_tactic t) - | TacAtom (_, t) -> xlate_tac t + | TacAtom (_, t) -> xlate_tac t | TacFail (count, []) -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_NONE) | TacFail (count, [MsgString s]) -> CT_fail(xlate_id_or_int count, ctf_STRING_OPT_SOME (CT_string s)) @@ -898,17 +898,17 @@ and xlate_tac = | Some t2 -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic t2) in (match l with [] -> CT_firstorder t1 - | [l1] -> + | [l1] -> (match genarg_tag l1 with - List1ArgType PreIdentArgType -> - let l2 = List.map + List1ArgType PreIdentArgType -> + let l2 = List.map (fun x -> CT_ident x) (out_gen (wit_list1 rawwit_pre_ident) l1) in - let fst,l3 = + let fst,l3 = match l2 with fst::l3 -> fst,l3 | [] -> assert false in CT_firstorder_using(t1, CT_id_ne_list(fst, l3)) | List1ArgType RefArgType -> - let l2 = List.map reference_to_ct_ID + let l2 = List.map reference_to_ct_ID (out_gen (wit_list1 rawwit_ref) l1) in let fst,l3 = match l2 with fst::l3 -> fst, l3 | [] -> assert false in @@ -927,11 +927,11 @@ and xlate_tac = let bindings = xlate_bindings b in CT_contradiction_thm(c1, bindings)) | TacChange (None, f, b) -> CT_change (xlate_formula f, xlate_clause b) - | TacChange (Some(l,c), f, b) -> + | TacChange (Some(l,c), f, b) -> (* TODO LATER: combine with other constructions of pattern_occ *) let l = nums_of_occs l in CT_change_local( - CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), + CT_pattern_occ(CT_int_list(nums_or_var_to_int_list_aux l), xlate_formula c), xlate_formula f, xlate_clause b) @@ -978,9 +978,9 @@ and xlate_tac = CT_cofix_tac_list (List.map f cofixtac_list)) | TacMutualCofix (true, id, cofixtac_list) -> xlate_error "TODO: non user-visible cofix" - | TacIntrosUntil (NamedHyp id) -> + | TacIntrosUntil (NamedHyp id) -> CT_intros_until (CT_coerce_ID_to_ID_OR_INT (xlate_ident id)) - | TacIntrosUntil (AnonHyp n) -> + | TacIntrosUntil (AnonHyp n) -> CT_intros_until (CT_coerce_INT_to_ID_OR_INT (CT_int n)) | TacIntroMove (Some id1, MoveAfter id2) -> CT_intro_after(CT_coerce_ID_to_ID_OPT (xlate_ident id1),xlate_hyp id2) @@ -1002,41 +1002,41 @@ and xlate_tac = | TacRight (false,bindl) -> CT_right (xlate_bindings bindl) | TacSplit (false,false,[bindl]) -> CT_split (xlate_bindings bindl) | TacSplit (false,true,[bindl]) -> CT_exists (xlate_bindings bindl) - | TacSplit _ | TacRight _ | TacLeft _ -> + | TacSplit _ | TacRight _ | TacLeft _ -> xlate_error "TODO: esplit, eright, etc" | TacExtend (_,"replace", [c1; c2;cl;tac_opt]) -> let c1 = xlate_formula (out_gen rawwit_constr c1) in let c2 = xlate_formula (out_gen rawwit_constr c2) in - let cl = - (* J.F. : 18/08/2006 - Hack to coerce the "clause" argument of replace to a real clause + let cl = + (* J.F. : 18/08/2006 + Hack to coerce the "clause" argument of replace to a real clause To be remove if we can reuse the clause grammar entrie defined in g_tactic *) - let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in - let cl_as_xlate_arg = - {cl_as_clause with - Tacexpr.onhyps = - Option.map - (fun l -> + let cl_as_clause = Extraargs.raw_in_arg_hyp_to_clause (out_gen Extraargs.rawwit_in_arg_hyp cl) in + let cl_as_xlate_arg = + {cl_as_clause with + Tacexpr.onhyps = + Option.map + (fun l -> List.map (fun ((l,id),hyp_flag) -> ((l, Tacexpr.AI ((),id)) ,hyp_flag)) l ) cl_as_clause.Tacexpr.onhyps } in cl_as_xlate_arg - in - let cl = xlate_clause cl in - let tac_opt = + in + let cl = xlate_clause cl in + let tac_opt = match out_gen (Extraargs.rawwit_by_arg_tac) tac_opt with | None -> CT_coerce_NONE_to_TACTIC_OPT CT_none | Some tac -> let tac = xlate_tactic tac in CT_coerce_TACTIC_COM_to_TACTIC_OPT tac - in + in CT_replace_with (c1, c2,cl,tac_opt) - | TacRewrite(false,[b,Precisely 1,cbindl],cl,None) -> - let cl = xlate_clause cl - and c = xlate_formula (fst cbindl) + | TacRewrite(false,[b,Precisely 1,cbindl],cl,None) -> + let cl = xlate_clause cl + and c = xlate_formula (fst cbindl) and bindl = xlate_bindings (snd cbindl) in if b then CT_rewrite_lr (c, bindl, cl) else CT_rewrite_rl (c, bindl, cl) @@ -1047,7 +1047,7 @@ and xlate_tac = let b = out_gen Extraargs.rawwit_orient b in let c = xlate_formula (out_gen rawwit_constr c) in (match c with - | CT_coerce_ID_to_FORMULA (CT_ident _ as id) -> + | CT_coerce_ID_to_FORMULA (CT_ident _ as id) -> if b then CT_deprewrite_lr id else CT_deprewrite_rl id | _ -> xlate_error "dependent rewrite on term: not supported") | TacExtend (_,"dependent_rewrite", [b; c; id]) -> @@ -1103,7 +1103,7 @@ and xlate_tac = match id_list with [] -> assert false | a::tl -> a,tl in let t1 = match t with - [t0] -> + [t0] -> CT_coerce_TACTIC_COM_to_TACTIC_OPT (xlate_tactic(out_gen rawwit_main_tactic t0)) | [] -> CT_coerce_NONE_to_TACTIC_OPT CT_none @@ -1130,7 +1130,7 @@ and xlate_tac = second_n, CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) | Some [] -> CT_eauto(first_n, second_n) - | Some (a::l) -> + | Some (a::l) -> CT_eauto_with(first_n, second_n, CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR (CT_id_ne_list @@ -1141,11 +1141,11 @@ and xlate_tac = (match out_gen rawwit_int_or_var n with | ArgVar _ -> xlate_error "" | ArgArg n -> CT_prolog (CT_formula_list cl, CT_int n)) - (* eapply now represented by TacApply (true,cbindl) - | TacExtend (_,"eapply", [cbindl]) -> + (* eapply now represented by TacApply (true,cbindl) + | TacExtend (_,"eapply", [cbindl]) -> *) | TacTrivial ([],Some []) -> CT_trivial - | TacTrivial ([],None) -> + | TacTrivial ([],None) -> CT_trivial_with(CT_coerce_STAR_to_ID_NE_LIST_OR_STAR CT_star) | TacTrivial ([],Some (id1::idl)) -> CT_trivial_with(CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STAR( @@ -1171,7 +1171,7 @@ and xlate_tac = when List.for_all (fun ((o,_),na) -> o = all_occurrences_expr & na = Anonymous) cl -> CT_generalize - (CT_formula_ne_list (xlate_formula first, + (CT_formula_ne_list (xlate_formula first, List.map (fun ((_,c),_) -> xlate_formula c) cl)) | TacGeneralize _ -> xlate_error "TODO: Generalize at and as" | TacGeneralizeDep c -> @@ -1213,7 +1213,7 @@ and xlate_tac = CT_id_list (List.map xlate_hyp idl)) | TacInversion (DepInversion (k,copt,l),quant_hyp) -> let id = xlate_quantified_hypothesis quant_hyp in - CT_depinversion (compute_INV_TYPE k, id, + CT_depinversion (compute_INV_TYPE k, id, xlate_with_names l, xlate_formula_opt copt) | TacInversion (InversionUsing (c,idlist), id) -> let id = xlate_quantified_hypothesis id in @@ -1223,7 +1223,7 @@ and xlate_tac = | TacRename [id1, id2] -> CT_rename(xlate_hyp id1, xlate_hyp id2) | TacRename _ -> xlate_error "TODO: add support for n-ary rename" | TacClearBody([]) -> assert false - | TacClearBody(a::l) -> + | TacClearBody(a::l) -> CT_clear_body (CT_id_ne_list (xlate_hyp a, List.map xlate_hyp l)) | TacDAuto (a, b, []) -> CT_dauto(xlate_int_or_var_opt_to_int_opt a, xlate_int_opt b) @@ -1231,39 +1231,39 @@ and xlate_tac = xlate_error "TODO: dauto using" | TacInductionDestruct(true,false,[a,b,(None,c),None]) -> CT_new_destruct - (List.map xlate_int_or_constr a, xlate_using b, + (List.map xlate_int_or_constr a, xlate_using b, xlate_with_names c) | TacInductionDestruct(false,false,[a,b,(None,c),None]) -> CT_new_induction (List.map xlate_int_or_constr a, xlate_using b, xlate_with_names c) - | TacInductionDestruct(_,false,_) -> + | TacInductionDestruct(_,false,_) -> xlate_error "TODO: clause 'in' and full 'as' of destruct/induction" - | TacLetTac (na, c, cl, true) when cl = nowhere -> + | TacLetTac (na, c, cl, true) when cl = nowhere -> CT_pose(xlate_id_opt_aux na, xlate_formula c) | TacLetTac (na, c, cl, true) -> - CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c, + CT_lettac(xlate_id_opt ((0,0),na), xlate_formula c, (* TODO LATER: This should be shared with Unfold, but the structures are different *) xlate_clause cl) | TacLetTac (na, c, cl, false) -> xlate_error "TODO: remember" - | TacAssert (None, Some (_,IntroIdentifier id), c) -> + | TacAssert (None, Some (_,IntroIdentifier id), c) -> CT_assert(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (None, None, c) -> + | TacAssert (None, None, c) -> CT_assert(xlate_id_opt ((0,0),Anonymous), xlate_formula c) - | TacAssert (Some (TacId []), Some (_,IntroIdentifier id), c) -> + | TacAssert (Some (TacId []), Some (_,IntroIdentifier id), c) -> CT_truecut(xlate_id_opt ((0,0),Name id), xlate_formula c) - | TacAssert (Some (TacId []), None, c) -> + | TacAssert (Some (TacId []), None, c) -> CT_truecut(xlate_id_opt ((0,0),Anonymous), xlate_formula c) | TacAssert _ -> xlate_error "TODO: assert with 'as' and 'by' and pose proof with 'as'" - | TacAnyConstructor(false,Some tac) -> + | TacAnyConstructor(false,Some tac) -> CT_any_constructor (CT_coerce_TACTIC_COM_to_TACTIC_OPT(xlate_tactic tac)) - | TacAnyConstructor(false,None) -> + | TacAnyConstructor(false,None) -> CT_any_constructor(CT_coerce_NONE_to_TACTIC_OPT CT_none) | TacAnyConstructor _ -> xlate_error "TODO: econstructor" - | TacExtend(_, "ring", [args]) -> + | TacExtend(_, "ring", [args]) -> CT_ring (CT_formula_list (List.map xlate_formula @@ -1328,7 +1328,7 @@ and coerce_genarg_to_TARG x = (CT_coerce_FORMULA_to_SCOMMENT_CONTENT (xlate_formula (out_gen rawwit_constr x))) | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" - | OpenConstrArgType b -> + | OpenConstrArgType b -> CT_coerce_SCOMMENT_CONTENT_to_TARG (CT_coerce_FORMULA_to_SCOMMENT_CONTENT(xlate_formula (snd (out_gen @@ -1367,7 +1367,7 @@ and formula_to_def_body = | ConstrTypeOf f -> CT_type_of (xlate_formula f) | ConstrTerm c -> ct_coerce_FORMULA_to_DEF_BODY(xlate_formula c) -and mk_let_value = function +and mk_let_value = function TacArg (ConstrMayEval v) -> CT_coerce_DEF_BODY_to_LET_VALUE(formula_to_def_body v) | v -> CT_coerce_TACTIC_COM_to_LET_VALUE(xlate_tactic v);; @@ -1383,7 +1383,7 @@ let coerce_genarg_to_VARG x = (CT_coerce_INT_to_INT_OPT (CT_int n))) | IntOrVarArgType -> (match out_gen rawwit_int_or_var x with - | ArgArg n -> + | ArgArg n -> CT_coerce_ID_OR_INT_OPT_to_VARG (CT_coerce_INT_OPT_to_ID_OR_INT_OPT (CT_coerce_INT_to_INT_OPT (CT_int n))) @@ -1420,11 +1420,11 @@ let coerce_genarg_to_VARG x = (CT_coerce_ID_to_ID_OPT id)) (* Specific types *) | SortArgType -> - CT_coerce_FORMULA_OPT_to_VARG + CT_coerce_FORMULA_OPT_to_VARG (CT_coerce_FORMULA_to_FORMULA_OPT (CT_coerce_SORT_TYPE_to_FORMULA (xlate_sort (out_gen rawwit_sort x)))) | ConstrArgType -> - CT_coerce_FORMULA_OPT_to_VARG + CT_coerce_FORMULA_OPT_to_VARG (CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula (out_gen rawwit_constr x))) | ConstrMayEvalArgType -> xlate_error"TODO: generic constr-may-eval argument" | QuantHypArgType ->xlate_error"TODO: generic quantified hypothesis argument" @@ -1529,8 +1529,8 @@ let cvt_optional_eval_for_definition c1 optional_eval = let cvt_vernac_binder = function | b,(id::idl,c) -> - let l,t = - CT_id_opt_ne_list + let l,t = + CT_id_opt_ne_list (xlate_ident_opt (Some (snd id)), List.map (fun id -> xlate_ident_opt (Some (snd id))) idl), xlate_formula c in @@ -1556,8 +1556,8 @@ let xlate_comment = function let translate_opt_notation_decl = function None -> CT_coerce_NONE_to_DECL_NOTATION_OPT(CT_none) | Some(s, f, sc) -> - let tr_sc = - match sc with + let tr_sc = + match sc with None -> ctv_ID_OPT_NONE | Some id -> CT_coerce_ID_to_ID_OPT (CT_ident id) in CT_decl_notation(CT_string s, xlate_formula f, tr_sc);; @@ -1588,18 +1588,18 @@ let xlate_syntax_modifier = function let rec xlate_module_type = function - | CMTEident(_, qid) -> + | CMTEident(_, qid) -> CT_coerce_ID_to_MODULE_TYPE(CT_ident (xlate_qualid qid)) | CMTEwith(mty, decl) -> let mty1 = xlate_module_type mty in (match decl with CWith_Definition((_, idl), c) -> - CT_module_type_with_def(mty1, + CT_module_type_with_def(mty1, CT_id_list (List.map xlate_ident idl), xlate_formula c) | CWith_Module((_, idl), (_, qid)) -> CT_module_type_with_mod(mty1, - CT_id_list (List.map xlate_ident idl), + CT_id_list (List.map xlate_ident idl), CT_ident (xlate_qualid qid))) | CMTEapply (_,_) -> xlate_error "TODO: Funsig application";; @@ -1607,7 +1607,7 @@ let rec xlate_module_type = function let xlate_module_binder_list (l:module_binder list) = CT_module_binder_list (List.map (fun (_, idl, mty) -> - let idl1 = + let idl1 = List.map (fun (_, x) -> CT_ident (string_of_id x)) idl in let fst,idl2 = match idl1 with [] -> assert false @@ -1619,7 +1619,7 @@ let xlate_module_type_check_opt = function None -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK (CT_coerce_ID_OPT_to_MODULE_TYPE_OPT ctv_ID_OPT_NONE) | Some(mty, true) -> CT_only_check(xlate_module_type mty) - | Some(mty, false) -> + | Some(mty, false) -> CT_coerce_MODULE_TYPE_OPT_to_MODULE_TYPE_CHECK (CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT (xlate_module_type mty));; @@ -1633,7 +1633,7 @@ let rec xlate_module_expr = function let rec xlate_vernac = function | VernacDeclareTacticDefinition (true, tacs) -> - (match List.map + (match List.map (function (id, _, body) -> CT_tac_def(reference_to_ct_ID id, xlate_tactic body)) @@ -1642,7 +1642,7 @@ let rec xlate_vernac = | fst::tacs1 -> CT_tactic_definition (CT_tac_def_ne_list(fst, tacs1))) - | VernacDeclareTacticDefinition(false, _) -> + | VernacDeclareTacticDefinition(false, _) -> xlate_error "obsolete tactic definition not handled" | VernacLoad (verbose,s) -> CT_load ( @@ -1682,14 +1682,14 @@ let rec xlate_vernac = | VernacAbort None -> CT_abort ctv_ID_OPT_OR_ALL_NONE | VernacAbortAll -> CT_abort ctv_ID_OPT_OR_ALL_ALL | VernacRestart -> CT_restart - | VernacSolve (n, tac, b) -> + | VernacSolve (n, tac, b) -> CT_solve (CT_int n, xlate_tactic tac, if b then CT_dotdot else CT_coerce_NONE_to_DOTDOT_OPT CT_none) (* MMode *) - | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> + | (VernacDeclProof | VernacReturn | VernacProofInstr _) -> anomaly "No MMode in CTcoq" @@ -1701,7 +1701,7 @@ let rec xlate_vernac = let file = out_gen rawwit_string f in let l1 = out_gen (wit_list1 rawwit_ref) l in let fst,l2 = match l1 with [] -> assert false | fst::l2 -> fst, l2 in - CT_extract_to_file(CT_string file, + CT_extract_to_file(CT_string file, CT_id_ne_list(loc_qualid_to_ct_ID fst, List.map loc_qualid_to_ct_ID l2)) | VernacExtend("ExtractionInline", [l]) -> @@ -1714,7 +1714,7 @@ let rec xlate_vernac = let fst, l2 = match l1 with [] -> assert false | fst ::l2 -> fst, l2 in CT_no_inline(CT_id_ne_list(loc_qualid_to_ct_ID fst, List.map loc_qualid_to_ct_ID l2)) - | VernacExtend("Field", + | VernacExtend("Field", [fth;ainv;ainvl;div]) -> (match List.map (fun v -> xlate_formula(out_gen rawwit_constr v)) [fth;ainv;ainvl] @@ -1728,7 +1728,7 @@ let rec xlate_vernac = let orient = out_gen Extraargs.rawwit_orient o in let formula_list = out_gen (wit_list1 rawwit_constr) f in let base = out_gen rawwit_pre_ident b in - let t = + let t = match args with [t;_] -> out_gen rawwit_main_tactic t | _ -> TacId [] in let ct_orient = match orient with @@ -1754,17 +1754,17 @@ let rec xlate_vernac = CT_hints(CT_ident "Constructors", CT_id_ne_list(n1, names), dblist) | HintsExtern (n, c, t) -> - let pat = match c with + let pat = match c with | None -> CT_coerce_ID_OPT_to_FORMULA_OPT (CT_coerce_NONE_to_ID_OPT CT_none) - | Some c -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula c) + | Some c -> CT_coerce_FORMULA_to_FORMULA_OPT (xlate_formula c) in CT_hint_extern(CT_int n, pat, xlate_tactic t, dblist) - | HintsImmediate l -> + | HintsImmediate l -> let f1, formulas = match List.map xlate_formula l with a :: tl -> a, tl | _ -> failwith "" in let l' = CT_formula_ne_list(f1, formulas) in if local then - (match h with + (match h with HintsResolve _ -> CT_local_hints_resolve(l', dblist) | HintsImmediate _ -> @@ -1775,13 +1775,13 @@ let rec xlate_vernac = HintsResolve _ -> CT_hints_resolve(l', dblist) | HintsImmediate _ -> CT_hints_immediate(l', dblist) | _ -> assert false) - | HintsResolve l -> + | HintsResolve l -> let f1, formulas = match List.map xlate_formula (List.map pi3 l) with a :: tl -> a, tl | _ -> failwith "" in let l' = CT_formula_ne_list(f1, formulas) in if local then - (match h with + (match h with HintsResolve _ -> CT_local_hints_resolve(l', dblist) | HintsImmediate _ -> @@ -1792,16 +1792,16 @@ let rec xlate_vernac = HintsResolve _ -> CT_hints_resolve(l', dblist) | HintsImmediate _ -> CT_hints_immediate(l', dblist) | _ -> assert false) - | HintsUnfold l -> + | HintsUnfold l -> let n1, names = match List.map loc_qualid_to_ct_ID l with n1 :: names -> n1, names | _ -> failwith "" in if local then CT_local_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist) - else + else CT_hints(CT_ident "Unfold", CT_id_ne_list(n1, names), dblist) - | HintsTransparency (l,b) -> + | HintsTransparency (l,b) -> let n1, names = match List.map loc_qualid_to_ct_ID l with n1 :: names -> n1, names | _ -> failwith "" in @@ -1809,7 +1809,7 @@ let rec xlate_vernac = if local then CT_local_hints(CT_ident ty, CT_id_ne_list(n1, names), dblist) - else + else CT_hints(CT_ident ty, CT_id_ne_list(n1, names), dblist) | HintsDestruct(id, n, loc, f, t) -> let dl = match loc with @@ -1869,9 +1869,9 @@ let rec xlate_vernac = | PrintModules -> CT_print_modules | PrintGrammar name -> CT_print_grammar CT_grammar_none | PrintHintDb -> CT_print_hintdb (CT_coerce_STAR_to_ID_OR_STAR CT_star) - | PrintHintDbName id -> + | PrintHintDbName id -> CT_print_hintdb (CT_coerce_ID_to_ID_OR_STAR (CT_ident id)) - | PrintRewriteHintDbName id -> + | PrintRewriteHintDbName id -> CT_print_rewrite_hintdb (CT_ident id) | PrintHint id -> CT_print_hint (CT_coerce_ID_to_ID_OPT (loc_smart_global_to_ct_ID id)) @@ -1884,15 +1884,15 @@ let rec xlate_vernac = | PrintClasses -> CT_print_classes | PrintLtac qid -> CT_print_ltac (loc_qualid_to_ct_ID qid) | PrintCoercions -> CT_print_coercions - | PrintCoercionPaths (id1, id2) -> + | PrintCoercionPaths (id1, id2) -> CT_print_path (xlate_class id1, xlate_class id2) | PrintCanonicalConversions -> xlate_error "TODO: Print Canonical Structures" - | PrintAssumptions _ -> + | PrintAssumptions _ -> xlate_error "TODO: Print Needed Assumptions" - | PrintInstances _ -> + | PrintInstances _ -> xlate_error "TODO: Print Instances" - | PrintTypeClasses -> + | PrintTypeClasses -> xlate_error "TODO: Print TypeClasses" | PrintInspect n -> CT_inspect (CT_int n) | PrintUniverses opt_s -> CT_print_universes(ctf_STRING_OPT opt_s) @@ -1902,7 +1902,7 @@ let rec xlate_vernac = | PrintScopes -> CT_print_scopes | PrintScope id -> CT_print_scope (CT_ident id) | PrintVisibility id_opt -> - CT_print_visibility + CT_print_visibility (match id_opt with Some id -> CT_coerce_ID_to_ID_OPT(CT_ident id) | None -> ctv_ID_OPT_NONE) @@ -1947,9 +1947,9 @@ let rec xlate_vernac = let xlate_search_about_item (b,it) = if not b then xlate_error "TODO: negative searchabout constraint"; match it with - SearchSubPattern (CRef x) -> + SearchSubPattern (CRef x) -> CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) - | SearchString (s,None) -> + | SearchString (s,None) -> CT_coerce_STRING_to_ID_OR_STRING(CT_string s) | SearchString _ | SearchSubPattern _ -> xlate_error @@ -1992,7 +1992,7 @@ let rec xlate_vernac = let ardef = xlate_formula ardef in match xlate_binder_list bl with | CT_binder_list (b :: bl) -> - CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), + CT_fix_rec (xlate_ident fid, CT_binder_ne_list (b, bl), struct_arg, arf, ardef) | _ -> xlate_error "mutual recursive" in CT_fix_decl @@ -2009,7 +2009,7 @@ let rec xlate_vernac = let strip_ind = function | (Some (_,id), InductionScheme (depstr, inde, sort)) -> CT_scheme_spec - (xlate_ident id, xlate_dep depstr, + (xlate_ident id, xlate_dep depstr, CT_coerce_ID_to_FORMULA (loc_smart_global_to_ct_ID inde), xlate_sort sort) | (None, InductionScheme (depstr, inde, sort)) -> @@ -2027,7 +2027,7 @@ let rec xlate_vernac = xlate_error"TODO: Local abbreviations and abbreviations with parameters" (* Modules and Module Types *) | VernacInclude (_) -> xlate_error "TODO : Include " - | VernacDeclareModuleType((_, id), bl, mty_o) -> + | VernacDeclareModuleType((_, id), bl, mty_o) -> CT_module_type_decl(xlate_ident id, xlate_module_binder_list bl, match mty_o with @@ -2038,20 +2038,20 @@ let rec xlate_vernac = CT_coerce_MODULE_TYPE_to_MODULE_TYPE_OPT (xlate_module_type mty1)) | VernacDefineModule(_,(_, id), bl, mty_o, mexpr_o) -> - CT_module(xlate_ident id, + CT_module(xlate_ident id, xlate_module_binder_list bl, xlate_module_type_check_opt mty_o, match mexpr_o with None -> CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE | Some m -> xlate_module_expr m) - | VernacDeclareModule(_,(_, id), bl, mty_o) -> - CT_declare_module(xlate_ident id, + | VernacDeclareModule(_,(_, id), bl, mty_o) -> + CT_declare_module(xlate_ident id, xlate_module_binder_list bl, xlate_module_type_check_opt (Some mty_o), CT_coerce_ID_OPT_to_MODULE_EXPR ctv_ID_OPT_NONE) | VernacRequire (impexp, spec, id::idl) -> let ct_impexp, ct_spec = get_require_flags impexp spec in - CT_require (ct_impexp, ct_spec, + CT_require (ct_impexp, ct_spec, CT_coerce_ID_NE_LIST_to_ID_NE_LIST_OR_STRING( CT_id_ne_list(loc_qualid_to_ct_ID id, List.map loc_qualid_to_ct_ID idl))) @@ -2059,14 +2059,14 @@ let rec xlate_vernac = xlate_error "Require should have at least one id argument" | VernacRequireFrom (impexp, spec, filename) -> let ct_impexp, ct_spec = get_require_flags impexp spec in - CT_require(ct_impexp, ct_spec, + CT_require(ct_impexp, ct_spec, CT_coerce_STRING_to_ID_NE_LIST_OR_STRING(CT_string filename)) | VernacOpenCloseScope(true, true, s) -> CT_local_open_scope(CT_ident s) | VernacOpenCloseScope(false, true, s) -> CT_open_scope(CT_ident s) | VernacOpenCloseScope(true, false, s) -> CT_local_close_scope(CT_ident s) | VernacOpenCloseScope(false, false, s) -> CT_close_scope(CT_ident s) - | VernacArgumentsScope(true, qid, l) -> + | VernacArgumentsScope(true, qid, l) -> CT_arguments_scope(loc_smart_global_to_ct_ID qid, CT_id_opt_list (List.map @@ -2074,10 +2074,10 @@ let rec xlate_vernac = match x with None -> ctv_ID_OPT_NONE | Some x -> ctf_ID_OPT_SOME(CT_ident x)) l)) - | VernacArgumentsScope(false, qid, l) -> + | VernacArgumentsScope(false, qid, l) -> xlate_error "TODO: Arguments Scope Global" | VernacDelimiters(s1,s2) -> CT_delim_scope(CT_ident s1, CT_ident s2) - | VernacBindScope(id, a::l) -> + | VernacBindScope(id, a::l) -> let xlate_class_rawexpr = function FunClass -> CT_ident "Funclass" | SortClass -> CT_ident "Sortclass" | RefClass qid -> loc_smart_global_to_ct_ID qid in @@ -2085,10 +2085,10 @@ let rec xlate_vernac = CT_id_ne_list(xlate_class_rawexpr a, List.map xlate_class_rawexpr l)) | VernacBindScope(id, []) -> assert false - | VernacNotation(b, c, (s,modif_list), opt_scope) -> + | VernacNotation(b, c, (s,modif_list), opt_scope) -> let translated_s = CT_string s in let formula = xlate_formula c in - let translated_modif_list = + let translated_modif_list = CT_modifier_list(List.map xlate_syntax_modifier modif_list) in let translated_scope = match opt_scope with None -> ctv_ID_OPT_NONE @@ -2097,11 +2097,11 @@ let rec xlate_vernac = CT_local_define_notation (translated_s, formula, translated_modif_list, translated_scope) else - CT_define_notation(translated_s, formula, + CT_define_notation(translated_s, formula, translated_modif_list, translated_scope) - | VernacSyntaxExtension(b,(s,modif_list)) -> + | VernacSyntaxExtension(b,(s,modif_list)) -> let translated_s = CT_string s in - let translated_modif_list = + let translated_modif_list = CT_modifier_list(List.map xlate_syntax_modifier modif_list) in if b then CT_local_reserve_notation(translated_s, translated_modif_list) @@ -2118,7 +2118,7 @@ let rec xlate_vernac = CT_local_infix(s, id1,modl1, translated_scope) else CT_infix(s, id1,modl1, translated_scope) - | VernacInfix (b,(str,modl),_ , opt_scope) -> + | VernacInfix (b,(str,modl),_ , opt_scope) -> xlate_error "TODO: Infix not ref" | VernacCoercion (s, id1, id2, id3) -> let id_opt = CT_coerce_NONE_to_IDENTITY_OPT CT_none in @@ -2140,7 +2140,7 @@ let rec xlate_vernac = CT_coercion (local_opt, id_opt, xlate_ident id1, xlate_class id2, xlate_class id3) - (* Type Classes *) + (* Type Classes *) | VernacDeclareInstance _|VernacContext _| VernacInstance (_, _, _, _, _) -> xlate_error "TODO: Type Classes commands" @@ -2150,20 +2150,20 @@ let rec xlate_vernac = | VernacExtend (s, l) -> CT_user_vernac (CT_ident s, CT_varg_list (List.map coerce_genarg_to_VARG l)) - | VernacList((_, a)::l) -> + | VernacList((_, a)::l) -> CT_coerce_COMMAND_LIST_to_COMMAND - (CT_command_list(xlate_vernac a, + (CT_command_list(xlate_vernac a, List.map (fun (_, x) -> xlate_vernac x) l)) | VernacList([]) -> assert false | VernacNop -> CT_proof_no_op - | VernacComments l -> + | VernacComments l -> CT_scomments(CT_scomment_content_list (List.map xlate_comment l)) | VernacDeclareImplicits(true, id, opt_positions) -> CT_implicits (loc_smart_global_to_ct_ID id, match opt_positions with None -> CT_coerce_NONE_to_ID_LIST_OPT CT_none - | Some l -> + | Some l -> CT_coerce_ID_LIST_to_ID_LIST_OPT (CT_id_list (List.map @@ -2174,7 +2174,7 @@ let rec xlate_vernac = | VernacDeclareImplicits(false, id, opt_positions) -> xlate_error "TODO: Implicit Arguments Global" | VernacReserve((_,a)::l, f) -> - CT_reserve(CT_id_ne_list(xlate_ident a, + CT_reserve(CT_id_ne_list(xlate_ident a, List.map (fun (_,x) -> xlate_ident x) l), xlate_formula f) | VernacReserve([], _) -> assert false @@ -2186,15 +2186,15 @@ let rec xlate_vernac = | VernacTimeout(n,v) -> CT_timeout(CT_int n,xlate_vernac v) | VernacSetOption (_,["Implicit"; "Arguments"], BoolValue true)->CT_user_vernac (CT_ident "IMPLICIT_ARGS_ON", CT_varg_list[]) |VernacExactProof f -> CT_proof(xlate_formula f) - | VernacSetOption (_,table, BoolValue true) -> - let table1 = + | VernacSetOption (_,table, BoolValue true) -> + let table1 = match table with [s] -> CT_coerce_ID_to_TABLE(CT_ident s) | [s1;s2] -> CT_table(CT_ident s1, CT_ident s2) | _ -> xlate_error "TODO: arbitrary-length Table names" in CT_set_option(table1) - | VernacSetOption (_,table, v) -> - let table1 = + | VernacSetOption (_,table, v) -> + let table1 = match table with [s] -> CT_coerce_ID_to_TABLE(CT_ident s) | [s1;s2] -> CT_table(CT_ident s1, CT_ident s2) @@ -2208,7 +2208,7 @@ let rec xlate_vernac = CT_coerce_INT_to_SINGLE_OPTION_VALUE(CT_int n) in CT_set_option_value(table1, value) | VernacUnsetOption(_,table) -> - let table1 = + let table1 = match table with [s] -> CT_coerce_ID_to_TABLE(CT_ident s) | [s1;s2] -> CT_table(CT_ident s1, CT_ident s2) @@ -2218,13 +2218,13 @@ let rec xlate_vernac = let values = List.map (function - | QualidRefValue x -> + | QualidRefValue x -> CT_coerce_ID_to_ID_OR_STRING(loc_qualid_to_ct_ID x) - | StringRefValue x -> + | StringRefValue x -> CT_coerce_STRING_to_ID_OR_STRING(CT_string x)) l in - let fst, values1 = + let fst, values1 = match values with [] -> assert false | a::b -> (a,b) in - let table1 = + let table1 = match table with [s] -> CT_coerce_ID_to_TABLE(CT_ident s) | [s1;s2] -> CT_table(CT_ident s1, CT_ident s2) diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v index 631417e0e9..231004bca2 100644 --- a/plugins/micromega/Env.v +++ b/plugins/micromega/Env.v @@ -17,9 +17,9 @@ Require Import Coq.Arith.Max. Require Import List. Set Implicit Arguments. -(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v) +(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v) -- this is harmless and spares a lot of Empty. - This means smaller proof-terms. + This means smaller proof-terms. BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up. *) @@ -40,7 +40,7 @@ Section S. Lemma psucc : forall p, (match p with | xI y' => xO (Psucc y') | xO y' => xI y' - | 1%positive => 2%positive + | 1%positive => 2%positive end) = (p+1)%positive. Proof. destruct p. @@ -50,7 +50,7 @@ Section S. reflexivity. Qed. - Lemma jump_Pplus : forall i j l, + Lemma jump_Pplus : forall i j l, forall x, jump (i + j) l x = jump i (jump j l) x. Proof. unfold jump. @@ -60,7 +60,7 @@ Section S. Qed. Lemma jump_simpl : forall p l, - forall x, jump p l x = + forall x, jump p l x = match p with | xH => tail l x | xO p => jump p (jump p l) x @@ -80,15 +80,15 @@ Section S. Qed. Ltac jump_s := - repeat + repeat match goal with | |- context [jump xH ?e] => rewrite (jump_simpl xH) | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p)) | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p)) end. - + Lemma jump_tl : forall j l, forall x, tail (jump j l) x = jump j (tail l) x. - Proof. + Proof. unfold tail. intros. repeat rewrite <- jump_Pplus. @@ -96,7 +96,7 @@ Section S. reflexivity. Qed. - Lemma jump_Psucc : forall j l, + Lemma jump_Psucc : forall j l, forall x, (jump (Psucc j) l x) = (jump 1 (jump j l) x). Proof. intros. @@ -129,13 +129,13 @@ Section S. reflexivity. Qed. - Lemma nth_spec : forall p l x, - nth p l = + Lemma nth_spec : forall p l x, + nth p l = match p with | xH => hd x l | xO p => nth p (jump p l) | xI p => nth p (jump p (tail l)) - end. + end. Proof. unfold nth. destruct p. diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 04e68272ee..e58f8e6868 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -55,12 +55,12 @@ Section MakeRingPol. Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). - (* C notations *) + (* C notations *) Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - (* Usefull tactics *) + (* Usefull tactics *) Add Setoid R req Rsth as R_set1. Ltac rrefl := gen_reflexivity Rsth. Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. @@ -554,7 +554,7 @@ Section MakeRingPol. intros;simpl;apply (morph0 CRmorph). Qed. -Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) -> +Lemma env_morph : forall p e1 e2, (forall x, e1 x = e2 x) -> p @ e1 = p @ e2. Proof. induction p ; simpl. @@ -578,7 +578,7 @@ Proof. reflexivity. Qed. -Lemma Pjump_xO_tail : forall P p l, +Lemma Pjump_xO_tail : forall P p l, P @ (jump (xO p) (tail l)) = P @ (jump (xI p) l). Proof. intros. @@ -743,9 +743,9 @@ Qed. induction P;simpl;intros;try apply (ARadd_comm ARth). destruct p2; simpl; try apply (ARadd_comm ARth). rewrite Pjump_xO_tail. - apply (ARadd_comm ARth). + apply (ARadd_comm ARth). rewrite Pjump_Pdouble_minus_one. - apply (ARadd_comm ARth). + apply (ARadd_comm ARth). assert (H1 := ZPminus_spec p2 k);destruct (ZPminus p2 k);Esimpl2. rewrite IHP'1;rsimpl; rewrite H1;add_push (P5 @ (tail l0));rrefl. rewrite IHP'1;simpl;Esimpl. @@ -785,7 +785,7 @@ Qed. destruct p0;simpl;Esimpl2. rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial. rewrite Pjump_xO_tail. - add_push (P @ ((jump (xI p0) l)));rrefl. + add_push (P @ ((jump (xI p0) l)));rrefl. rewrite IHP'2;simpl;rewrite Pjump_Pdouble_minus_one;rsimpl. add_push (- (P'1 @ l * pow_pos rmul (hd 0 l) p));rrefl. unfold tail. @@ -931,7 +931,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. rrefl. Qed. - Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) -> + Lemma Mphi_morph : forall P env env', (forall x, env x = env' x ) -> Mphi env P = Mphi env' P. Proof. induction P ; simpl. @@ -952,7 +952,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. intros. symmetry. apply H. Qed. -Lemma Mjump_xO_tail : forall M p l, +Lemma Mjump_xO_tail : forall M p l, Mphi (jump (xO p) (tail l)) M = Mphi (jump (xI p) l) M. Proof. intros. @@ -1117,7 +1117,7 @@ Qed. rewrite Padd_ok; rewrite PmulC_ok; rsimpl. intros i P5 H; rewrite H. intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. + rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. assert (P4 = Q1 ++ P3 ** PX i P5 P6). injection H2; intros; subst;trivial. @@ -1385,13 +1385,13 @@ Section POWER. intros. induction pe;simpl;Esimpl3. apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. + rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. rewrite IHpe1;rewrite IHpe2;rrefl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. rewrite IHpe;rrefl. - rewrite Ppow_N_ok by reflexivity. + rewrite Ppow_N_ok by reflexivity. rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; repeat rewrite Pmul_ok;rrefl. Qed. diff --git a/plugins/micromega/OrderedRing.v b/plugins/micromega/OrderedRing.v index 149b773167..803dd903a9 100644 --- a/plugins/micromega/OrderedRing.v +++ b/plugins/micromega/OrderedRing.v @@ -162,7 +162,7 @@ Qed. Theorem Rminus_eq_0 : forall n m : R, n - m == 0 <-> n == m. Proof. intros n m. -split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. +split; intro H. setoid_replace n with ((n - m) + m) by ring. rewrite H. now rewrite Rplus_0_l. rewrite H; ring. Qed. diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v index 9e675165fa..a2b10ebaa3 100644 --- a/plugins/micromega/Psatz.v +++ b/plugins/micromega/Psatz.v @@ -26,20 +26,20 @@ Declare ML Module "micromega_plugin". Ltac xpsatz dom d := let tac := lazymatch dom with - | Z => + | Z => (sos_Z || psatz_Z d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity | R => (sos_R || psatz_R d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity | Q => (sos_Q || psatz_Q d) ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity | _ => fail "Unsupported domain" end in tac. @@ -52,27 +52,27 @@ Ltac psatzl dom := | Z => psatzl_Z ; intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity | Q => - psatzl_Q ; - intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + psatzl_Q ; + intros __wit __varmap __ff ; + change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; apply (QTautoChecker_sound __ff __wit); vm_compute ; reflexivity - | R => + | R => psatzl_R ; intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity | _ => fail "Unsupported domain" end in tac. -Ltac lia := +Ltac lia := xlia ; intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; apply (ZTautoChecker_sound __ff __wit); vm_compute ; reflexivity. diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index b266a1ab80..ae22b0c78c 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -80,7 +80,7 @@ Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := end. Lemma Qeval_expr_simpl : forall env e, - Qeval_expr env e = + Qeval_expr env e = match e with | PEc c => c | PEX j => env j @@ -179,7 +179,7 @@ Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := - @tauto_checker (Formula Q) (NFormula Q) + @tauto_checker (Formula Q) (NFormula Q) Qnormalise Qnegate QWitness QWeakChecker f w. diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 2e8c3daec0..21f991ef87 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -159,7 +159,7 @@ Definition Rnormalise := @cnf_normalise Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bo Definition Rnegate := @cnf_negate Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool. Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness) : bool := - @tauto_checker (Formula Z) (NFormula Z) + @tauto_checker (Formula Z) (NFormula Z) Rnormalise Rnegate RWitness RWeakChecker f w. diff --git a/plugins/micromega/Refl.v b/plugins/micromega/Refl.v index 801d8b2122..c86fe8fb64 100644 --- a/plugins/micromega/Refl.v +++ b/plugins/micromega/Refl.v @@ -107,7 +107,7 @@ Proof. Qed. Lemma not_make_conj_app : forall (A:Type) (t:list A) a eval - (no_middle_eval : forall d, eval d \/ ~ eval d) , + (no_middle_eval : forall d, eval d \/ ~ eval d) , ~ make_conj eval (t ++ a) -> (~ make_conj eval t) \/ (~ make_conj eval a). Proof. induction t. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 88b53583d5..d556cd03e9 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -170,10 +170,10 @@ let (p, op) := f in eval_op1 op (eval_pol env p). Definition OpMult (o o' : Op1) : option Op1 := match o with | Equal => Some Equal -| NonStrict => +| NonStrict => match o' with | Equal => Some Equal - | NonEqual => None + | NonEqual => None | Strict => Some NonStrict | NonStrict => Some NonStrict end @@ -203,20 +203,20 @@ Definition OpAdd (o o': Op1) : option Op1 := end | NonEqual => match o' with | Equal => Some NonEqual - | _ => None + | _ => None end end. Lemma OpMult_sound : - forall (o o' om: Op1) (x y : R), + forall (o o' om: Op1) (x y : R), eval_op1 o x -> eval_op1 o' y -> OpMult o o' = Some om -> eval_op1 om (x * y). Proof. unfold eval_op1; destruct o; simpl; intros o' om x y H1 H2 H3. (* x == 0 *) inversion H3. rewrite H1. now rewrite (Rtimes_0_l sor). (* x ~= 0 *) -destruct o' ; inversion H3. +destruct o' ; inversion H3. (* y == 0 *) rewrite H2. now rewrite (Rtimes_0_r sor). (* y ~= 0 *) @@ -240,7 +240,7 @@ destruct o' ; inversion H3. Qed. Lemma OpAdd_sound : - forall (o o' oa : Op1) (e e' : R), + forall (o o' oa : Op1) (e e' : R), eval_op1 o e -> eval_op1 o' e' -> OpAdd o o' = Some oa -> eval_op1 oa (e + e'). Proof. unfold eval_op1; destruct o; simpl; intros o' oa e e' H1 H2 Hoa. @@ -298,7 +298,7 @@ Inductive Psatz : Type := (** Given a list [l] of NFormula and an extended polynomial expression [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a logic consequence of the conjunction of the formulae in l. - Moreover, the polynomial expression is obtained by replacing the (PsatzIn n) + Moreover, the polynomial expression is obtained by replacing the (PsatzIn n) by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *) (* Might be defined elsewhere *) @@ -310,12 +310,12 @@ Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B : Implicit Arguments map_option [A B]. -Definition map_option2 (A B C : Type) (f : A -> B -> option C) - (o: option A) (o': option B) : option C := - match o , o' with - | None , _ => None - | _ , None => None - | Some x , Some x' => f x x' +Definition map_option2 (A B C : Type) (f : A -> B -> option C) + (o: option A) (o': option B) : option C := + match o , o' with + | None , _ => None + | _ , None => None + | Some x , Some x' => f x x' end. Implicit Arguments map_option2 [A B C]. @@ -344,51 +344,51 @@ Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula := Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula := - match e with + match e with | PsatzIn n => Some (nth n l (Pc cO, Equal)) | PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e , NonStrict) | PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e) | PsatzMulE f1 f2 => map_option2 nformula_times_nformula (eval_Psatz l f1) (eval_Psatz l f2) | PsatzAdd f1 f2 => map_option2 nformula_plus_nformula (eval_Psatz l f1) (eval_Psatz l f2) - | PsatzC c => if cltb cO c then Some (Pc c, Strict) else None + | PsatzC c => if cltb cO c then Some (Pc c, Strict) else None (* This could be 0, or <> 0 -- but these cases are useless *) | PsatzZ => Some (Pc cO, Equal) (* Just to make life easier *) end. Lemma pexpr_times_nformula_correct : forall (env: PolEnv) (e: PolC) (f f' : NFormula), - eval_nformula env f -> pexpr_times_nformula e f = Some f' -> + eval_nformula env f -> pexpr_times_nformula e f = Some f' -> eval_nformula env f'. Proof. unfold pexpr_times_nformula. destruct f. intros. destruct o ; inversion H0 ; try discriminate. - simpl in *. unfold eval_pol in *. - rewrite (Pmul_ok sor.(SORsetoid) Rops_wd + simpl in *. unfold eval_pol in *. + rewrite (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). rewrite H. apply (Rtimes_0_r sor). Qed. - + Lemma nformula_times_nformula_correct : forall (env:PolEnv) - (f1 f2 f : NFormula), - eval_nformula env f1 -> eval_nformula env f2 -> - nformula_times_nformula f1 f2 = Some f -> + (f1 f2 f : NFormula), + eval_nformula env f1 -> eval_nformula env f2 -> + nformula_times_nformula f1 f2 = Some f -> eval_nformula env f. Proof. unfold nformula_times_nformula. destruct f1 ; destruct f2. case_eq (OpMult o o0) ; simpl ; try discriminate. intros. inversion H2 ; simpl. - unfold eval_pol. + unfold eval_pol. destruct o1; simpl; - rewrite (Pmul_ok sor.(SORsetoid) Rops_wd + rewrite (Pmul_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); apply OpMult_sound with (3:= H);assumption. Qed. Lemma nformula_plus_nformula_correct : forall (env:PolEnv) - (f1 f2 f : NFormula), - eval_nformula env f1 -> eval_nformula env f2 -> - nformula_plus_nformula f1 f2 = Some f -> + (f1 f2 f : NFormula), + eval_nformula env f1 -> eval_nformula env f2 -> + nformula_plus_nformula f1 f2 = Some f -> eval_nformula env f. Proof. unfold nformula_plus_nformula. @@ -397,15 +397,15 @@ Proof. intros. inversion H2 ; simpl. unfold eval_pol. destruct o1; simpl; - rewrite (Padd_ok sor.(SORsetoid) Rops_wd + rewrite (Padd_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); apply OpAdd_sound with (3:= H);assumption. Qed. -Lemma eval_Psatz_Sound : +Lemma eval_Psatz_Sound : forall (l : list NFormula) (env : PolEnv), (forall (f : NFormula), In f l -> eval_nformula env f) -> - forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f -> + forall (e : Psatz) (f : NFormula), eval_Psatz l e = Some f -> eval_nformula env f. Proof. induction e. @@ -416,17 +416,17 @@ Proof. apply H ; congruence. (* index is out-of-bounds *) inversion H0. - rewrite e. simpl. + rewrite e. simpl. now apply addon.(SORrm).(morph0). (* PsatzSquare *) simpl. intros. inversion H0. simpl. unfold eval_pol. - rewrite (Psquare_ok sor.(SORsetoid) Rops_wd + rewrite (Psquare_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)); now apply (Rtimes_square_nonneg sor). (* PsatzMulC *) simpl. - intro. + intro. case_eq (eval_Psatz l e) ; simpl ; intros. apply IHe in H0. apply pexpr_times_nformula_correct with (1:=H0) (2:= H1). @@ -441,7 +441,7 @@ Proof. (* PsatzAdd *) simpl ; intro. case_eq (eval_Psatz l e1) ; simpl ; try discriminate. - case_eq (eval_Psatz l e2) ; simpl ; try discriminate. + case_eq (eval_Psatz l e2) ; simpl ; try discriminate. intros. apply IHe1 in H1. apply IHe2 in H0. apply (nformula_plus_nformula_correct env n0 n) ; assumption. @@ -457,14 +457,14 @@ Proof. Qed. Fixpoint ge_bool (n m : nat) : bool := - match n with - | O => match m with + match n with + | O => match m with | O => true | S _ => false end - | S n => match m with + | S n => match m with | O => true - | S m => ge_bool n m + | S m => ge_bool n m end end. @@ -483,7 +483,7 @@ Qed. Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := - match prf with + match prf with | PsatzC _ | PsatzZ | PsatzSquare _ => acc | PsatzMulC _ prf => xhyps_of_psatz base acc prf | PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1 @@ -495,7 +495,7 @@ Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz) : list nat := forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *) (*****) -Definition paddC := PaddC cplus. +Definition paddC := PaddC cplus. Definition psubC := PsubC cminus. Definition PsubC_ok : forall c P env, eval_pol env (psubC P c) == eval_pol env P - [c] := @@ -536,7 +536,7 @@ Lemma check_inconsistent_sound : check_inconsistent (p, op) = true -> forall env, ~ eval_op1 op (eval_pol env p). Proof. intros p op H1 env. unfold check_inconsistent in H1. -destruct op; simpl ; +destruct op; simpl ; (*****) destruct p ; simpl; try discriminate H1; try rewrite <- addon.(SORrm).(morph0); trivial. @@ -547,7 +547,7 @@ apply cltb_sound in H1. now apply -> (Rlt_nge sor). Qed. Definition check_normalised_formulas : list NFormula -> Psatz -> bool := - fun l cm => + fun l cm => match eval_Psatz l cm with | None => false | Some f => check_inconsistent f @@ -640,14 +640,14 @@ let (lhs, op, rhs) := f in Lemma eval_pol_sub : forall env lhs rhs, eval_pol env (psub lhs rhs) == eval_pol env lhs - eval_pol env rhs. Proof. intros. - apply (Psub_ok sor.(SORsetoid) Rops_wd + apply (Psub_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. Lemma eval_pol_add : forall env lhs rhs, eval_pol env (padd lhs rhs) == eval_pol env lhs + eval_pol env rhs. Proof. intros. - apply (Padd_ok sor.(SORsetoid) Rops_wd + apply (Padd_ok sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm)). Qed. @@ -656,7 +656,7 @@ Proof. intros. apply (norm_aux_spec sor.(SORsetoid) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd sor.(SORrt)) addon.(SORrm) addon.(SORpower) ). Qed. - + Theorem normalise_sound : forall (env : PolEnv) (f : Formula), @@ -694,7 +694,7 @@ Definition xnormalise (t:Formula) : list (NFormula) := let lhs := norm lhs in let rhs := norm rhs in match o with - | OpEq => + | OpEq => (psub lhs rhs, Strict)::(psub rhs lhs , Strict)::nil | OpNEq => (psub lhs rhs,Equal) :: nil | OpGt => (psub rhs lhs,NonStrict) :: nil @@ -716,7 +716,7 @@ Proof. unfold cnf_normalise, xnormalise ; simpl ; intros env t. unfold eval_cnf. destruct t as [lhs o rhs]; case_eq o ; simpl; - repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; + repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros. (**) @@ -751,7 +751,7 @@ Proof. unfold cnf_negate, xnegate ; simpl ; intros env t. unfold eval_cnf. destruct t as [lhs o rhs]; case_eq o ; simpl; - repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; + repeat rewrite eval_pol_sub ; repeat rewrite <- eval_pol_norm in * ; generalize (eval_pexpr env lhs); generalize (eval_pexpr env rhs) ; intros z1 z2 ; intros ; intuition. (**) @@ -774,7 +774,7 @@ Proof. intros. destruct d ; simpl. generalize (eval_pol env p); intros. - destruct o ; simpl. + destruct o ; simpl. apply (Req_em sor r 0). destruct (Req_em sor r 0) ; tauto. rewrite <- (Rle_ngt sor r 0). generalize (Rle_gt_cases sor r 0). tauto. @@ -787,7 +787,7 @@ Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := match p with | Pc c => PEc c | Pinj j p => xdenorm (Pplus j jmp ) p - | PX p j q => PEadd + | PX p j q => PEadd (PEmul (xdenorm jmp p) (PEpow (PEX _ jmp) (Npos j))) (xdenorm (Psucc jmp) q) end. @@ -802,7 +802,7 @@ Proof. intros. rewrite Pplus_succ_permute_r. rewrite <- IHp. - symmetry. + symmetry. rewrite Pplus_comm. rewrite Pjump_Pplus. reflexivity. (* PX *) @@ -821,7 +821,7 @@ Proof. Qed. Definition denorm (p : Pol C) := xdenorm xH p. - + Lemma denorm_correct : forall p env, eval_pol env p == eval_pexpr env (denorm p). Proof. unfold denorm. @@ -836,25 +836,25 @@ Proof. unfold Env.tail. rewrite xdenorm_correct. change (Psucc xH) with 2%positive. - rewrite addon.(SORpower).(rpow_pow_N). + rewrite addon.(SORpower).(rpow_pow_N). simpl. reflexivity. Qed. - + (** Some syntactic simplifications of expressions *) Definition simpl_cone (e:Psatz) : Psatz := match e with - | PsatzSquare t => + | PsatzSquare t => match t with | Pc c => if ceqb cO c then PsatzZ else PsatzC (ctimes c c) | _ => PsatzSquare t end - | PsatzMulE t1 t2 => + | PsatzMulE t1 t2 => match t1 , t2 with - | PsatzZ , x => PsatzZ - | x , PsatzZ => PsatzZ + | PsatzZ , x => PsatzZ + | x , PsatzZ => PsatzZ | PsatzC c , PsatzC c' => PsatzC (ctimes c c') | PsatzC p1 , PsatzMulE (PsatzC p2) x => PsatzMulE (PsatzC (ctimes p1 p2)) x | PsatzC p1 , PsatzMulE x (PsatzC p2) => PsatzMulE (PsatzC (ctimes p1 p2)) x @@ -865,7 +865,7 @@ Definition simpl_cone (e:Psatz) : Psatz := | _ , PsatzC c => if ceqb cI c then t1 else PsatzMulE t1 t2 | _ , _ => e end - | PsatzAdd t1 t2 => + | PsatzAdd t1 t2 => match t1 , t2 with | PsatzZ , x => x | x , PsatzZ => x diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 42e0acb582..b1d0217685 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -20,14 +20,14 @@ Set Implicit Arguments. Inductive BFormula (A:Type) : Type := - | TT : BFormula A + | TT : BFormula A | FF : BFormula A | X : Prop -> BFormula A - | A : A -> BFormula A + | A : A -> BFormula A | Cj : BFormula A -> BFormula A -> BFormula A | D : BFormula A-> BFormula A -> BFormula A | N : BFormula A -> BFormula A - | I : BFormula A-> BFormula A-> BFormula A. + | I : BFormula A-> BFormula A-> BFormula A. Fixpoint eval_f (A:Type) (ev:A -> Prop ) (f:BFormula A) {struct f}: Prop := match f with @@ -42,7 +42,7 @@ Set Implicit Arguments. end. - Lemma map_simpl : forall A B f l, @map A B f l = match l with + Lemma map_simpl : forall A B f l, @map A B f l = match l with | nil => nil | a :: l=> (f a) :: (@map A B f l) end. @@ -57,7 +57,7 @@ Set Implicit Arguments. Variable Env : Type. Variable Term : Type. Variable eval : Env -> Term -> Prop. - Variable Term' : Type. + Variable Term' : Type. Variable eval' : Env -> Term' -> Prop. @@ -78,17 +78,17 @@ Set Implicit Arguments. Definition or_clause_cnf (t:clause) (f:cnf) : cnf := List.map (fun x => (t++x)) f. - + Fixpoint or_cnf (f : cnf) (f' : cnf) {struct f}: cnf := match f with | nil => tt | e :: rst => (or_cnf rst f') ++ (or_clause_cnf e f') end. - + Definition and_cnf (f1 : cnf) (f2 : cnf) : cnf := f1 ++ f2. - + Fixpoint xcnf (pol : bool) (f : BFormula Term) {struct f}: cnf := match f with | TT => if pol then tt else ff @@ -96,14 +96,14 @@ Set Implicit Arguments. | X p => if pol then ff else ff (* This is not complete - cannot negate any proposition *) | A x => if pol then normalise x else negate x | N e => xcnf (negb pol) e - | Cj e1 e2 => + | Cj e1 e2 => (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) | D e1 e2 => (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) | I e1 e2 => (if pol then or_cnf else and_cnf) (xcnf (negb pol) e1) (xcnf pol e2) end. Definition eval_cnf (env : Term' -> Prop) (f:cnf) := make_conj (fun cl => ~ make_conj env cl) f. - + Lemma eval_cnf_app : forall env x y, eval_cnf (eval' env) (x++y) -> eval_cnf (eval' env) x /\ eval_cnf (eval' env) y. Proof. @@ -111,7 +111,7 @@ Set Implicit Arguments. intros. rewrite make_conj_app in H ; auto. Qed. - + Lemma or_clause_correct : forall env t f, eval_cnf (eval' env) (or_clause_cnf t f) -> (~ make_conj (eval' env) t) \/ (eval_cnf (eval' env) f). Proof. @@ -258,8 +258,8 @@ Set Implicit Arguments. unfold and_cnf in H. simpl in H. destruct (eval_cnf_app _ _ _ H). - generalize (IHf1 _ _ H0). - generalize (IHf2 _ _ H1). + generalize (IHf1 _ _ H0). + generalize (IHf2 _ _ H1). simpl. tauto. Qed. @@ -267,13 +267,13 @@ Set Implicit Arguments. Variable Witness : Type. Variable checker : list Term' -> Witness -> bool. - + Variable checker_sound : forall t w, checker t w = true -> forall env, make_impl (eval' env) t False. Fixpoint cnf_checker (f : cnf) (l : list Witness) {struct f}: bool := match f with | nil => true - | e::f => match l with + | e::f => match l with | nil => false | c::l => match checker e c with | true => cnf_checker f l diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index ed204d92b6..c0b86f5ed3 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -17,21 +17,21 @@ Require Import Coq.Arith.Max. Require Import List. Set Implicit Arguments. -(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v) +(* I have addded a Leaf constructor to the varmap data structure (/plugins/ring/Quote.v) -- this is harmless and spares a lot of Empty. - This means smaller proof-terms. + This means smaller proof-terms. BTW, by dropping the polymorphism, I get small (yet noticeable) speed-up. *) Section MakeVarMap. Variable A : Type. Variable default : A. - + Inductive t : Type := - | Empty : t - | Leaf : A -> t + | Empty : t + | Leaf : A -> t | Node : t -> A -> t -> t . - + Fixpoint find (vm : t ) (p:positive) {struct vm} : A := match vm with | Empty => default @@ -49,7 +49,7 @@ Section MakeVarMap. - Definition jump (j:positive) (l:off_map ) := + Definition jump (j:positive) (l:off_map ) := let (o,m) := l in match o with | None => (Some j,m) @@ -74,7 +74,7 @@ Section MakeVarMap. Lemma psucc : forall p, (match p with | xI y' => xO (Psucc y') | xO y' => xI y' - | 1%positive => 2%positive + | 1%positive => 2%positive end) = (p+1)%positive. Proof. destruct p. @@ -84,7 +84,7 @@ Section MakeVarMap. reflexivity. Qed. - Lemma jump_Pplus : forall i j l, + Lemma jump_Pplus : forall i j l, (jump (i + j) l) = (jump i (jump j l)). Proof. unfold jump. @@ -96,7 +96,7 @@ Section MakeVarMap. Qed. Lemma jump_simpl : forall p l, - jump p l = + jump p l = match p with | xH => tail l | xO p => jump p (jump p l) @@ -116,15 +116,15 @@ Section MakeVarMap. Qed. Ltac jump_s := - repeat + repeat match goal with | |- context [jump xH ?e] => rewrite (jump_simpl xH) | |- context [jump (xO ?p) ?e] => rewrite (jump_simpl (xO p)) | |- context [jump (xI ?p) ?e] => rewrite (jump_simpl (xI p)) end. - + Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). - Proof. + Proof. unfold tail. intros. repeat rewrite <- jump_Pplus. @@ -132,7 +132,7 @@ Section MakeVarMap. reflexivity. Qed. - Lemma jump_Psucc : forall j l, + Lemma jump_Psucc : forall j l, (jump (Psucc j) l) = (jump 1 (jump j l)). Proof. intros. @@ -162,14 +162,14 @@ Section MakeVarMap. reflexivity. Qed. - - Lemma nth_spec : forall p l, - nth p l = + + Lemma nth_spec : forall p l, + nth p l = match p with | xH => hd l | xO p => nth p (jump p l) | xI p => nth p (jump p (tail l)) - end. + end. Proof. unfold nth. destruct l. diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v index ced67e39d0..f27cd15e3b 100644 --- a/plugins/micromega/ZCoeff.v +++ b/plugins/micromega/ZCoeff.v @@ -56,7 +56,7 @@ Proof. destruct sor.(SORsetoid). apply Equivalence_Transitive. Qed. - + Add Relation R req reflexivity proved by sor.(SORsetoid).(@Equivalence_Reflexive _ _) diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 70eb2331c7..b02a9850eb 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -33,7 +33,7 @@ Ltac inv H := inversion H ; try subst ; clear H. Require Import EnvRing. Open Scope Z_scope. - + Lemma Zsor : SOR 0 1 Zplus Zmult Zminus Zopp (@eq Z) Zle Zlt. Proof. constructor ; intros ; subst ; try (intuition (auto with zarith)). @@ -100,7 +100,7 @@ match o with | OpGt => Zgt end. -Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= +Definition Zeval_formula (env : PolEnv Z) (f : Formula Z):= let (lhs, op, rhs) := f in (Zeval_op2 op) (Zeval_expr env lhs) (Zeval_expr env rhs). @@ -109,16 +109,16 @@ Definition Zeval_formula' := Lemma Zeval_formula_compat : forall env f, Zeval_formula env f <-> Zeval_formula' env f. Proof. - destruct f ; simpl. + destruct f ; simpl. rewrite Zeval_expr_compat. rewrite Zeval_expr_compat. unfold eval_expr. - generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + generalize (eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) (fun x : N => x) (pow_N 1 Zmult) env Flhs). - generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) + generalize ((eval_pexpr Zplus Zmult Zminus Zopp (fun x : Z => x) (fun x : N => x) (pow_N 1 Zmult) env Frhs)). destruct Fop ; simpl; intros ; intuition (auto with zarith). Qed. - + Definition eval_nformula := eval_nformula 0 Zplus Zmult (@eq Z) Zle Zlt (fun x => x) . @@ -131,7 +131,7 @@ match o with | NonStrict => fun x : Z => 0 <= x end. - + Lemma Zeval_nformula_dec : forall env d, (eval_nformula env d) \/ ~ (eval_nformula env d). Proof. intros. @@ -179,13 +179,13 @@ Proof. intros. apply (eval_pol_norm Zsor ZSORaddon). Qed. - + Definition xnormalise (t:Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in let lhs := norm lhs in let rhs := norm rhs in match o with - | OpEq => + | OpEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil | OpNEq => (psub lhs rhs,Equal) :: nil | OpGt => (psub rhs lhs,NonStrict) :: nil @@ -218,7 +218,7 @@ Proof. intuition (auto with zarith). Transparent padd. Qed. - + Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in let lhs := norm lhs in @@ -331,11 +331,11 @@ Definition makeLbCut (v:PExprC Z) (q:Q) : NFormula Z := Definition neg_nformula (f : NFormula Z) := let (e,o) := f in (PEopp (PEadd e (PEc 1%Z)), o). - + Lemma neg_nformula_sound : forall env f, snd f = NonStrict ->( ~ (Zeval_nformula env (neg_nformula f)) <-> Zeval_nformula env f). Proof. unfold neg_nformula. - destruct f. + destruct f. simpl. intros ; subst ; simpl in *. split; auto with zarith. @@ -346,9 +346,9 @@ Qed. - b is the constant - a is the gcd of the other coefficient. *) -Require Import Znumtheory. +Require Import Znumtheory. -Definition isZ0 (x:Z) := +Definition isZ0 (x:Z) := match x with | Z0 => true | _ => false @@ -371,7 +371,7 @@ Fixpoint Zgcd_pol (p : PolC Z) : (Z * Z) := match p with | Pc c => (0,c) | Pinj _ p => Zgcd_pol p - | PX p _ q => + | PX p _ q => let (g1,c1) := Zgcd_pol p in let (g2,c2) := Zgcd_pol q in (ZgcdM (ZgcdM g1 c1) g2 , c2) @@ -393,7 +393,7 @@ Inductive Zdivide_pol (x:Z): PolC Z -> Prop := | Zdiv_PX : forall p q, Zdivide_pol x p -> Zdivide_pol x q -> forall j, Zdivide_pol x (PX p j q). -Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p -> +Lemma Zdiv_pol_correct : forall a p, 0 < a -> Zdivide_pol a p -> forall env, eval_pol env p = a * eval_pol env (Zdiv_pol p a). Proof. intros until 2. @@ -441,7 +441,7 @@ Proof. constructor. auto. constructor ; auto. Qed. - + Lemma Zdivide_pol_one : forall p, Zdivide_pol 1 p. Proof. induction p ; constructor ; auto. @@ -458,15 +458,15 @@ Proof. rewrite <- Hq, Hb, Ha. ring. Qed. -Lemma Zdivide_pol_sub : forall p a b, - 0 < Zgcd a b -> - Zdivide_pol a (PsubC Zminus p b) -> +Lemma Zdivide_pol_sub : forall p a b, + 0 < Zgcd a b -> + Zdivide_pol a (PsubC Zminus p b) -> Zdivide_pol (Zgcd a b) p. Proof. induction p. simpl. intros. inversion H0. - constructor. + constructor. apply Zgcd_minus ; auto. intros. constructor. @@ -480,8 +480,8 @@ Proof. apply IHp2 ; assumption. Qed. -Lemma Zdivide_pol_sub_0 : forall p a, - Zdivide_pol a (PsubC Zminus p 0) -> +Lemma Zdivide_pol_sub_0 : forall p a, + Zdivide_pol a (PsubC Zminus p 0) -> Zdivide_pol a p. Proof. induction p. @@ -499,7 +499,7 @@ Proof. Qed. -Lemma Zgcd_pol_div : forall p g c, +Lemma Zgcd_pol_div : forall p g c, Zgcd_pol p = (g, c) -> Zdivide_pol g (PsubC Zminus p c). Proof. induction p ; simpl. @@ -541,7 +541,7 @@ Proof. Qed. - + Lemma Zgcd_pol_correct_lt : forall p env g c, Zgcd_pol p = (g,c) -> 0 < g -> eval_pol env p = g * (eval_pol env (Zdiv_pol (PsubC Zminus p c) g)) + c. Proof. @@ -555,9 +555,9 @@ Qed. -Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z := +Definition makeCuttingPlane (p : PolC Z) : PolC Z * Z := let (g,c) := Zgcd_pol p in - if Zgt_bool g Z0 + if Zgt_bool g Z0 then (Zdiv_pol (PsubC Zminus p c) g , Zopp (ceiling (Zopp c) g)) else (p,Z0). @@ -594,7 +594,7 @@ Proof. destruct z ; try discriminate. reflexivity. Qed. - + @@ -609,37 +609,37 @@ Definition check_inconsistent := check_inconsistent 0 Zeq_bool Zle_bool. Fixpoint ZChecker (l:list (NFormula Z)) (pf : ZArithProof) {struct pf} : bool := match pf with - | DoneProof => false - | RatProof w pf => + | DoneProof => false + | RatProof w pf => match eval_Psatz l w with | None => false - | Some f => + | Some f => if check_inconsistent f then true else ZChecker (f::l) pf end - | CutProof w pf => + | CutProof w pf => match eval_Psatz l w with | None => false - | Some f => + | Some f => match genCuttingPlane f with | None => true | Some cp => ZChecker (nformula_of_cutting_plane cp::l) pf end end - | EnumProof w1 w2 pf => + | EnumProof w1 w2 pf => match eval_Psatz l w1 , eval_Psatz l w2 with - | Some f1 , Some f2 => + | Some f1 , Some f2 => match genCuttingPlane f1 , genCuttingPlane f2 with - |Some (e1,z1,op1) , Some (e2,z2,op2) => + |Some (e1,z1,op1) , Some (e2,z2,op2) => match op1 , op2 with - | NonStrict , NonStrict => + | NonStrict , NonStrict => if is_pol_Z0 (padd e1 e2) then (fix label (pfs:list ZArithProof) := - fun lb ub => + fun lb ub => match pfs with | nil => if Zgt_bool lb ub then true else false - | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) + | pf::rsr => andb (ZChecker ((psub e1 (Pc lb), Equal) :: l) pf) (label rsr (Zplus lb 1%Z) ub) end) pf (Zopp z1) z2 else false @@ -693,18 +693,18 @@ Proof. Qed. -Lemma eval_Psatz_sound : forall env w l f', - make_conj (eval_nformula env) l -> +Lemma eval_Psatz_sound : forall env w l f', + make_conj (eval_nformula env) l -> eval_Psatz l w = Some f' -> eval_nformula env f'. Proof. intros. apply (eval_Psatz_Sound Zsor ZSORaddon) with (l:=l) (e:= w) ; auto. - apply make_conj_in ; auto. + apply make_conj_in ; auto. Qed. -Lemma makeCuttingPlane_sound : forall env e e' c, - eval_nformula env (e, NonStrict) -> - makeCuttingPlane e = (e',c) -> +Lemma makeCuttingPlane_sound : forall env e e' c, + eval_nformula env (e, NonStrict) -> + makeCuttingPlane e = (e',c) -> eval_nformula env (nformula_of_cutting_plane (e', c, NonStrict)). Proof. unfold nformula_of_cutting_plane. @@ -728,10 +728,10 @@ Proof. (* g <= 0 *) intros. inv H2. auto with zarith. Qed. - -Lemma cutting_plane_sound : forall env f p, - eval_nformula env f -> + +Lemma cutting_plane_sound : forall env f p, + eval_nformula env f -> genCuttingPlane f = Some p -> eval_nformula env (nformula_of_cutting_plane p). Proof. @@ -758,25 +758,25 @@ Proof. rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). simpl. auto with zarith. (* Strict *) - destruct p as [[e' z] op]. + destruct p as [[e' z] op]. case_eq (makeCuttingPlane (PsubC Zminus e 1)). intros. inv H1. apply makeCuttingPlane_sound with (env:=env) (2:= H). simpl in *. - rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). + rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). auto with zarith. (* NonStrict *) - destruct p as [[e' z] op]. + destruct p as [[e' z] op]. case_eq (makeCuttingPlane e). intros. inv H1. apply makeCuttingPlane_sound with (env:=env) (2:= H). assumption. -Qed. +Qed. -Lemma genCuttingPlaneNone : forall env f, - genCuttingPlane f = None -> +Lemma genCuttingPlaneNone : forall env f, + genCuttingPlane f = None -> eval_nformula env f -> False. Proof. unfold genCuttingPlane. @@ -784,7 +784,7 @@ Proof. destruct o. case_eq (Zgcd_pol p) ; intros g c. case_eq (Zgt_bool g 0 && (Zgt_bool c 0 && negb (Zeq_bool (Zgcd g c) g))). - intros. + intros. flatten_bool. rewrite negb_true_iff in H5. apply Zeq_bool_neq in H5. @@ -805,7 +805,7 @@ Proof. destruct (makeCuttingPlane p) ; discriminate. Qed. - + Lemma ZChecker_sound : forall w l, ZChecker l w = true -> forall env, make_impl (eval_nformula env) l False. Proof. induction w using (well_founded_ind (well_founded_ltof _ bdepth)). @@ -815,7 +815,7 @@ Proof. (* RatProof *) simpl. intro l. case_eq (eval_Psatz l w) ; [| discriminate]. - intros f Hf. + intros f Hf. case_eq (check_inconsistent f). intros. apply (checker_nf_sound Zsor ZSORaddon l w). @@ -831,7 +831,7 @@ Proof. rewrite <- make_conj_impl in H2. rewrite make_conj_cons in H2. rewrite <- make_conj_impl. - intro. + intro. apply H2. split ; auto. apply eval_Psatz_sound with (2:= Hf) ; assumption. @@ -840,7 +840,7 @@ Proof. intro l. case_eq (eval_Psatz l w) ; [ | discriminate]. intros f' Hlc. - case_eq (genCuttingPlane f'). + case_eq (genCuttingPlane f'). intros. assert (make_impl (eval_nformula env) (nformula_of_cutting_plane p::l) False). eapply (H pf) ; auto. @@ -850,7 +850,7 @@ Proof. rewrite <- make_conj_impl in H2. rewrite make_conj_cons in H2. rewrite <- make_conj_impl. - intro. + intro. apply H2. split ; auto. apply eval_Psatz_sound with (env:=env) in Hlc. @@ -887,7 +887,7 @@ Proof. unfold RingMicromega.eval_nformula in H4. change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H4. unfold eval_op1 in H4. - rewrite eval_pol_add in H4. simpl in H4. + rewrite eval_pol_add in H4. simpl in H4. auto with zarith. (**) apply is_pol_Z0_eval_pol with (env := env) in H0. @@ -900,7 +900,7 @@ Proof. unfold RingMicromega.eval_nformula in H3. change (RingMicromega.eval_pol 0 Zplus Zmult (fun x : Z => x)) with eval_pol in H3. unfold eval_op1 in H3. - rewrite eval_pol_add in H3. simpl in H3. + rewrite eval_pol_add in H3. simpl in H3. omega. revert H5. set (FF := (fix label (pfs : list ZArithProof) (lb ub : Z) {struct pfs} : bool := @@ -911,7 +911,7 @@ Proof. label rsr (lb + 1)%Z ub)%bool end)). intros. - assert (HH :forall x, -z1 <= x <= z2 -> exists pr, + assert (HH :forall x, -z1 <= x <= z2 -> exists pr, (In pr pf /\ ZChecker ((PsubC Zminus p1 x,Equal) :: l) pr = true)%Z). clear H. @@ -972,7 +972,7 @@ Fixpoint xhyps_of_pt (base:nat) (acc : list nat) (pt:ZArithProof) : list nat := | DoneProof => acc | RatProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt | CutProof c pt => xhyps_of_pt (S base ) (xhyps_of_psatz base acc c) pt - | EnumProof c1 c2 l => + | EnumProof c1 c2 l => let acc := xhyps_of_psatz base (xhyps_of_psatz base acc c2) c1 in List.fold_left (xhyps_of_pt (S base)) l acc end. @@ -989,7 +989,7 @@ Definition hyps_of_pt (pt : ZArithProof) : list nat := xhyps_of_pt 0 nil pt. Open Scope Z_scope. - + (** To ease bindings from ml code **) (*Definition varmap := Quote.varmap.*) Definition make_impl := Refl.make_impl. @@ -1019,5 +1019,5 @@ Definition n_of_Z (z:Z) : BinNat.N := (* Local Variables: *) (* coding: utf-8 *) (* End: *) - + diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 2a1c2fe225..c5760229c5 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -47,28 +47,28 @@ struct (* A monomial is represented by a multiset of variables *) module Map = Map.Make(struct type t = var let compare = Pervasives.compare end) open Map - + type t = int Map.t (* The monomial that corresponds to a constant *) let const = Map.empty - + (* The monomial 'x' *) let var x = Map.add x 1 Map.empty (* Get the degre of a variable in a monomial *) let find x m = try find x m with Not_found -> 0 - + (* Multiply a monomial by a variable *) let mult x m = add x ( (find x m) + 1) m - + (* Product of monomials *) let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 - + (* Total ordering of monomials *) let compare m1 m2 = Map.compare Pervasives.compare m1 m2 - let pp o m = Map.iter (fun k v -> + let pp o m = Map.iter (fun k v -> if v = 1 then Printf.fprintf o "x%i." (C2Ml.index k) else Printf.fprintf o "x%i^%i." (C2Ml.index k) v) m @@ -79,8 +79,8 @@ end module Poly : (* A polynomial is a map of monomials *) - (* - This is probably a naive implementation + (* + This is probably a naive implementation (expected to be fast enough - Coq is probably the bottleneck) *The new ring contribution is using a sparse Horner representation. *) @@ -106,22 +106,22 @@ struct type t = num P.t - let pp o p = P.iter (fun k v -> + let pp o p = P.iter (fun k v -> if compare_num v (Int 0) <> 0 - then + then if Monomial.compare Monomial.const k = 0 then Printf.fprintf o "%s " (string_of_num v) - else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p + else Printf.fprintf o "%s*%a " (string_of_num v) Monomial.pp k) p (* Get the coefficient of monomial mn *) - let get : Monomial.t -> t -> num = + let get : Monomial.t -> t -> num = fun mn p -> try find mn p with Not_found -> (Int 0) (* The polynomial 1.x *) let variable : var -> t = fun x -> add (Monomial.var x) (Int 1) empty - + (*The constant polynomial *) let constant : num -> t = fun c -> add (Monomial.const) c empty @@ -129,27 +129,27 @@ struct (* The addition of a monomial *) let add : Monomial.t -> num -> t -> t = - fun mn v p -> + fun mn v p -> let vl = (get mn p) <+> v in add mn vl p - (** Design choice: empty is not a polynomial - I do not remember why .... + (** Design choice: empty is not a polynomial + I do not remember why .... **) (* The product by a monomial *) let mult : Monomial.t -> num -> t -> t = - fun mn v p -> + fun mn v p -> fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty let addition : t -> t -> t = fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 - + let product : t -> t -> t = - fun p1 p2 -> + fun p1 p2 -> fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty @@ -181,7 +181,7 @@ let z_spec = { mult = Mc.zmult; eqb = Mc.zeq_bool } - + let q_spec = { bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); @@ -198,53 +198,53 @@ let r_spec = z_spec let dev_form n_spec p = - let rec dev_form p = + let rec dev_form p = match p with | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) | Mc.PEX v -> Poly.variable v - | Mc.PEmul(p1,p2) -> + | Mc.PEmul(p1,p2) -> let p1 = dev_form p1 in let p2 = dev_form p2 in - Poly.product p1 p2 + Poly.product p1 p2 | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2) | Mc.PEopp p -> Poly.uminus (dev_form p) | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) - | Mc.PEpow(p,n) -> + | Mc.PEpow(p,n) -> let p = dev_form p in let n = C2Ml.n n in - let rec pow n = - if n = 0 + let rec pow n = + if n = 0 then Poly.constant (n_spec.number_to_num n_spec.unit) else Poly.product p (pow (n-1)) in pow n in dev_form p -let monomial_to_polynomial mn = - Monomial.fold - (fun v i acc -> +let monomial_to_polynomial mn = + Monomial.fold + (fun v i acc -> let mn = if i = 1 then Mc.PEX v else Mc.PEpow (Mc.PEX v ,Ml2C.n i) in if acc = Mc.PEc (Mc.Zpos Mc.XH) - then mn + then mn else Mc.PEmul(mn,acc)) - mn + mn (Mc.PEc (Mc.Zpos Mc.XH)) - -let list_to_polynomial vars l = + +let list_to_polynomial vars l = assert (List.for_all (fun x -> ceiling_num x =/ x) l); - let var x = monomial_to_polynomial (List.nth vars x) in + let var x = monomial_to_polynomial (List.nth vars x) in let rec xtopoly p i = function | [] -> p - | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l + | c::l -> if c =/ (Int 0) then xtopoly p (i+1) l else let c = Mc.PEc (Ml2C.bigint (numerator c)) in - let mn = + let mn = if c = Mc.PEc (Mc.Zpos Mc.XH) then var i else Mc.PEmul (c,var i) in let p' = if p = Mc.PEc Mc.Z0 then mn else Mc.PEadd (mn, p) in xtopoly p' (i+1) l in - + xtopoly (Mc.PEc Mc.Z0) 0 l let rec fixpoint f x = @@ -259,54 +259,54 @@ let rec fixpoint f x = -let rec_simpl_cone n_spec e = - let simpl_cone = +let rec_simpl_cone n_spec e = + let simpl_cone = Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in let rec rec_simpl_cone = function - | Mc.PsatzMulE(t1, t2) -> + | Mc.PsatzMulE(t1, t2) -> simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) - | Mc.PsatzAdd(t1,t2) -> + | Mc.PsatzAdd(t1,t2) -> simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) | x -> simpl_cone x in rec_simpl_cone e - - + + let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c - -type cone_prod = - Const of cone - | Ideal of cone *cone - | Mult of cone * cone + +type cone_prod = + Const of cone + | Ideal of cone *cone + | Mult of cone * cone | Other of cone and cone = Mc.zWitness let factorise_linear_cone c = - - let rec cone_list c l = + + let rec cone_list c l = match c with | Mc.PsatzAdd (x,r) -> cone_list r (x::l) | _ -> c :: l in - + let factorise c1 c2 = match c1 , c2 with - | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> + | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> if x = x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None - | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> + | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> if x = x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None | _ -> None in - + let rec rebuild_cone l pending = match l with | [] -> (match pending with | None -> Mc.PsatzZ | Some p -> p ) - | e::l -> + | e::l -> (match pending with - | None -> rebuild_cone l (Some e) + | None -> rebuild_cone l (Some e) | Some p -> (match factorise p e with | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e)) | Some f -> rebuild_cone l (Some f) ) @@ -316,15 +316,15 @@ let factorise_linear_cone c = -(* The binding with Fourier might be a bit obsolete +(* The binding with Fourier might be a bit obsolete -- how does it handle equalities ? *) (* Certificates are elements of the cone such that P = 0 *) (* To begin with, we search for certificates of the form: - a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 + a1.p1 + ... an.pn + b1.q1 +... + bn.qn + c = 0 where pi >= 0 qi > 0 - ai >= 0 + ai >= 0 bi >= 0 Sum bi + c >= 1 This is a linear problem: each monomial is considered as a variable. @@ -343,96 +343,96 @@ open Mfourier (* fold_left followed by a rev ! *) -let constrain_monomial mn l = +let constrain_monomial mn l = let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in if mn = Monomial.const - then - { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; - op = Eq ; + then + { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; + op = Eq ; cst = Big_int zero_big_int } else - { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; - op = Eq ; + { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; + op = Eq ; cst = Big_int zero_big_int } - -let positivity l = - let rec xpositivity i l = + +let positivity l = + let rec xpositivity i l = match l with | [] -> [] | (_,Mc.Equal)::l -> xpositivity (i+1) l - | (_,_)::l -> - {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; - op = Ge ; + | (_,_)::l -> + {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; + op = Ge ; cst = Int 0 } :: (xpositivity (i+1) l) in xpositivity 0 l let string_of_op = function - | Mc.Strict -> "> 0" - | Mc.NonStrict -> ">= 0" + | Mc.Strict -> "> 0" + | Mc.NonStrict -> ">= 0" | Mc.Equal -> "= 0" | Mc.NonEqual -> "<> 0" -(* If the certificate includes at least one strict inequality, +(* If the certificate includes at least one strict inequality, the obtained polynomial can also be 0 *) let build_linear_system l = (* Gather the monomials: HINT add up of the polynomials *) let l' = List.map fst l in - let monomials = + let monomials = List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l' in (* For each monomial, compute a constraint *) - let s0 = + let s0 = Poly.fold (fun mn _ res -> (constrain_monomial mn l')::res) monomials [] in (* I need at least something strictly positive *) let strict = { coeffs = Vect.from_list ((Big_int unit_big_int):: - (List.map (fun (x,y) -> - match y with Mc.Strict -> - Big_int unit_big_int + (List.map (fun (x,y) -> + match y with Mc.Strict -> + Big_int unit_big_int | _ -> Big_int zero_big_int) l)); op = Ge ; cst = Big_int unit_big_int } in (* Add the positivity constraint *) - {coeffs = Vect.from_list ([Big_int unit_big_int]) ; - op = Ge ; + {coeffs = Vect.from_list ([Big_int unit_big_int]) ; + op = Ge ; cst = Big_int zero_big_int}::(strict::(positivity l)@s0) let big_int_to_z = Ml2C.bigint - -(* For Q, this is a pity that the certificate has been scaled + +(* For Q, this is a pity that the certificate has been scaled -- at a lower layer, certificates are using nums... *) -let make_certificate n_spec (cert,li) = +let make_certificate n_spec (cert,li) = let bint_to_cst = n_spec.bigint_to_number in match cert with | [] -> failwith "empty_certificate" - | e::cert' -> + | e::cert' -> let cst = match compare_big_int e zero_big_int with | 0 -> Mc.PsatzZ - | 1 -> Mc.PsatzC (bint_to_cst e) - | _ -> failwith "positivity error" + | 1 -> Mc.PsatzC (bint_to_cst e) + | _ -> failwith "positivity error" in let rec scalar_product cert l = match cert with | [] -> Mc.PsatzZ | c::cert -> match l with | [] -> failwith "make_certificate(1)" - | i::l -> + | i::l -> let r = scalar_product cert l in match compare_big_int c zero_big_int with | -1 -> Mc.PsatzAdd ( - Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), + Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), r) | 0 -> r | _ -> Mc.PsatzAdd ( Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), r) in - - ((factorise_linear_cone + + ((factorise_linear_cone (simplify_cone n_spec (Mc.PsatzAdd (cst, scalar_product cert' li))))) @@ -440,59 +440,59 @@ exception Found of Monomial.t exception Strict -let primal l = +let primal l = let vr = ref 0 in let module Mmn = Map.Make(Monomial) in let vect_of_poly map p = - Poly.fold (fun mn vl (map,vect) -> - if mn = Monomial.const + Poly.fold (fun mn vl (map,vect) -> + if mn = Monomial.const then (map,vect) - else + else let (mn,m) = try (Mmn.find mn map,map) with Not_found -> let res = (!vr, Mmn.add mn !vr map) in incr vr ; res in (m,if sign_num vl = 0 then vect else (mn,vl)::vect)) p (map,[]) in - + let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in let cmp x y = Pervasives.compare (fst x) (fst y) in snd (List.fold_right (fun (p,op) (map,l) -> - let (mp,vect) = vect_of_poly map p in + let (mp,vect) = vect_of_poly map p in let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in (mp,cstr::l)) l (Mmn.empty,[])) -let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = +let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = (* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *) - - + + let sys = build_linear_system l in - try + try match Fourier.find_point sys with | Inr _ -> None - | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) + | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) (* should not use rats_to_ints *) - with x -> - if debug - then (Printf.printf "raw certificate %s" (Printexc.to_string x); + with x -> + if debug + then (Printf.printf "raw certificate %s" (Printexc.to_string x); flush stdout) ; None -let raw_certificate l = - try +let raw_certificate l = + try let p = primal l in match Fourier.find_point p with - | Inr prf -> - if debug then Printf.printf "AProof : %a\n" pp_proof prf ; + | Inr prf -> + if debug then Printf.printf "AProof : %a\n" pp_proof prf ; let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in - if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; + if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; Some (rats_to_ints (Vect.to_list cert)) | Inl _ -> None - with Strict -> + with Strict -> (* Fourier elimination should handle > *) - dual_raw_certificate l + dual_raw_certificate l let simple_linear_prover (*to_constant*) l = @@ -500,26 +500,26 @@ let simple_linear_prover (*to_constant*) l = match raw_certificate lc with | None -> None (* No certificate *) | Some cert -> (* make_certificate to_constant*)Some (cert,li) - - + + let linear_prover n_spec l = let li = List.combine l (interval 0 (List.length l -1)) in - let (l1,l') = List.partition + let (l1,l') = List.partition (fun (x,_) -> if snd x = Mc.NonEqual then true else false) li in - let l' = List.map + let l' = List.map (fun ((x,y),i) -> match y with Mc.NonEqual -> failwith "cannot happen" | y -> ((dev_form n_spec x, y),i)) l' in - - simple_linear_prover (*n_spec*) l' + + simple_linear_prover (*n_spec*) l' let linear_prover n_spec l = try linear_prover n_spec l with x -> (print_string (Printexc.to_string x); None) -let linear_prover_with_cert spec l = +let linear_prover_with_cert spec l = match linear_prover spec l with | None -> None | Some cert -> Some (make_certificate spec cert) @@ -529,21 +529,21 @@ let linear_prover_with_cert spec l = (* zprover.... *) (* I need to gather the set of variables ---> - Then go for fold + Then go for fold Once I have an interval, I need a certificate : 2 other fourier elims. - (I could probably get the certificate directly + (I could probably get the certificate directly as it is done in the fourier contrib.) *) let make_linear_system l = let l' = List.map fst l in - let monomials = List.fold_left (fun acc p -> Poly.addition p acc) + let monomials = List.fold_left (fun acc p -> Poly.addition p acc) (Poly.constant (Int 0)) l' in - let monomials = Poly.fold + let monomials = Poly.fold (fun mn _ l -> if mn = Monomial.const then l else mn::l) monomials [] in - (List.map (fun (c,op) -> - {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; - op = op ; + (List.map (fun (c,op) -> + {coeffs = Vect.from_list (List.map (fun mn -> (Poly.get mn c)) monomials) ; + op = op ; cst = minus_num ( (Poly.get Monomial.const c))}) l ,monomials) @@ -552,106 +552,106 @@ let pplus x y = Mc.PEadd(x,y) let pmult x y = Mc.PEmul(x,y) let pconst x = Mc.PEc x let popp x = Mc.PEopp x - + let debug = false - + (* keep track of enumerated vectors *) -let rec mem p x l = +let rec mem p x l = match l with [] -> false | e::l -> if p x e then true else mem p x l -let rec remove_assoc p x l = +let rec remove_assoc p x l = match l with [] -> [] | e::l -> if p x (fst e) then - remove_assoc p x l else e::(remove_assoc p x l) + remove_assoc p x l else e::(remove_assoc p x l) let eq x y = Vect.compare x y = 0 let remove e l = List.fold_left (fun l x -> if eq x e then l else x::l) [] l -(* The prover is (probably) incomplete -- +(* The prover is (probably) incomplete -- only searching for naive cutting planes *) -let candidates sys = +let candidates sys = let ll = List.fold_right ( fun (e,k) r -> - match k with + match k with | Mc.NonStrict -> (dev_form z_spec e , Ge)::r - | Mc.Equal -> (dev_form z_spec e , Eq)::r + | Mc.Equal -> (dev_form z_spec e , Eq)::r (* we already know the bound -- don't compute it again *) | _ -> failwith "Cannot happen candidates") sys [] in let (sys,var_mn) = make_linear_system ll in let vars = mapi (fun _ i -> Vect.set i (Int 1) Vect.null) var_mn in - (List.fold_left (fun l cstr -> + (List.fold_left (fun l cstr -> let gcd = Big_int (Vect.gcd cstr.coeffs) in - if gcd =/ (Int 1) && cstr.op = Eq - then l + if gcd =/ (Int 1) && cstr.op = Eq + then l else (Vect.mul (Int 1 // gcd) cstr.coeffs)::l) [] sys) @ vars -let rec xzlinear_prover planes sys = +let rec xzlinear_prover planes sys = match linear_prover z_spec sys with | Some prf -> Some (Mc.RatProof (make_certificate z_spec prf,Mc.DoneProof)) | None -> (* find the candidate with the smallest range *) (* Grrr - linear_prover is also calling 'make_linear_system' *) let ll = List.fold_right (fun (e,k) r -> match k with - Mc.NonEqual -> r - | k -> (dev_form z_spec e , + Mc.NonEqual -> r + | k -> (dev_form z_spec e , match k with - Mc.NonStrict -> Ge + Mc.NonStrict -> Ge | Mc.Equal -> Eq | Mc.Strict | Mc.NonEqual -> failwith "Cannot happen") :: r) sys [] in let (ll,var) = make_linear_system ll in - let candidates = List.fold_left (fun acc vect -> + let candidates = List.fold_left (fun acc vect -> match Fourier.optimise vect ll with | None -> acc - | Some i -> + | Some i -> (* Printf.printf "%s in %s\n" (Vect.string vect) (string_of_intrvl i) ; *) - flush stdout ; + flush stdout ; (vect,i) ::acc) [] planes in - let smallest_interval = - match List.fold_left (fun (x1,i1) (x2,i2) -> - if Itv.smaller_itv i1 i2 - then (x1,i1) else (x2,i2)) (Vect.null,(None,None)) candidates + let smallest_interval = + match List.fold_left (fun (x1,i1) (x2,i2) -> + if Itv.smaller_itv i1 i2 + then (x1,i1) else (x2,i2)) (Vect.null,(None,None)) candidates with | (x,(Some i, Some j)) -> Some(i,x,j) | x -> None (* This might be a cutting plane *) in match smallest_interval with - | Some (lb,e,ub) -> - let (lbn,lbd) = + | Some (lb,e,ub) -> + let (lbn,lbd) = (Ml2C.bigint (sub_big_int (numerator lb) unit_big_int), Ml2C.bigint (denominator lb)) in - let (ubn,ubd) = - (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) , + let (ubn,ubd) = + (Ml2C.bigint (add_big_int unit_big_int (numerator ub)) , Ml2C.bigint (denominator ub)) in let expr = list_to_polynomial var (Vect.to_list e) in - (match + (match (*x <= ub -> x > ub *) - linear_prover z_spec + linear_prover z_spec ((pplus (pmult (pconst ubd) expr) (popp (pconst ubn)), Mc.NonStrict) :: sys), (* lb <= x -> lb > x *) - linear_prover z_spec + linear_prover z_spec ((pplus (popp (pmult (pconst lbd) expr)) (pconst lbn), - Mc.NonStrict)::sys) + Mc.NonStrict)::sys) with - | Some cub , Some clb -> - (match zlinear_enum (remove e planes) expr - (ceiling_num lb) (floor_num ub) sys + | Some cub , Some clb -> + (match zlinear_enum (remove e planes) expr + (ceiling_num lb) (floor_num ub) sys with | None -> None - | Some prf -> - let bound_proof (c,l) = make_certificate z_spec (List.tl c , List.tl (List.map (fun x -> x -1) l)) in - + | Some prf -> + let bound_proof (c,l) = make_certificate z_spec (List.tl c , List.tl (List.map (fun x -> x -1) l)) in + Some (Mc.EnumProof((*Ml2C.q lb,expr,Ml2C.q ub,*) bound_proof clb, bound_proof cub,prf))) | _ -> None ) | _ -> None -and zlinear_enum planes expr clb cub l = +and zlinear_enum planes expr clb cub l = if clb >/ cub then Some [] else @@ -665,9 +665,9 @@ and zlinear_enum planes expr clb cub l = | None -> None | Some prfl -> Some (prf :: prfl) -let zlinear_prover sys = +let zlinear_prover sys = let candidates = candidates sys in - (* Printf.printf "candidates %d" (List.length candidates) ; *) + (* Printf.printf "candidates %d" (List.length candidates) ; *) (*let t0 = Sys.time () in*) let res = xzlinear_prover candidates sys in (*Printf.printf "Time prover : %f" (Sys.time () -. t0) ;*) res @@ -675,7 +675,7 @@ let zlinear_prover sys = open Sos_types open Mutils -let rec scale_term t = +let rec scale_term t = match t with | Zero -> unit_big_int , Zero | Const n -> (denominator n) , Const (Big_int (numerator n)) @@ -708,7 +708,7 @@ let get_index_of_ith_match f i l = match l with | [] -> failwith "bad index" | e::l -> if f e - then + then (if j = i then res else get (j+1) (res+1) l ) else get j (res+1) l in get 0 0 l @@ -722,19 +722,19 @@ let rec scale_certificate pos = match pos with | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) - | Square t -> let s,t' = scale_term t in + | Square t -> let s,t' = scale_term t in mult_big_int s s , Square t' | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in mult_big_int s1 s2 , Eqmul (y1,y2) - | Sum (y, z) -> let s1,y1 = scale_certificate y + | Sum (y, z) -> let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in let g = gcd_big_int s1 s2 in let s1' = div_big_int s1 g in let s2' = div_big_int s2 g in - mult_big_int g (mult_big_int s1' s2'), + mult_big_int g (mult_big_int s1' s2'), Sum (Product(Rational_le (Big_int s2'), y1), Product (Rational_le (Big_int s1'), y2)) - | Product (y, z) -> + | Product (y, z) -> let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in mult_big_int s1 s2 , Product (y1,y2) @@ -743,7 +743,7 @@ open Micromega let rec term_to_q_expr = function | Const n -> PEc (Ml2C.q n) | Zero -> PEc ( Ml2C.q (Int 0)) - | Var s -> PEX (Ml2C.index + | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) @@ -755,20 +755,20 @@ open Micromega let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) - let rec product l = + let rec product l = match l with | [] -> Mc.PsatzZ | [i] -> Mc.PsatzIn (Ml2C.nat i) | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) -let q_cert_of_pos pos = +let q_cert_of_pos pos = let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l - | Rational_eq n | Rational_le n | Rational_lt n -> + | Rational_eq n | Rational_le n | Rational_lt n -> if compare_num n (Int 0) = 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.q n) | Square t -> Mc.PsatzSquare (term_to_q_pol t) @@ -781,7 +781,7 @@ let q_cert_of_pos pos = let rec term_to_z_expr = function | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) | Zero -> PEc ( Z0) - | Var s -> PEX (Ml2C.index + | Var s -> PEX (Ml2C.index (int_of_string (String.sub s 1 (String.length s - 1)))) | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) @@ -792,14 +792,14 @@ let q_cert_of_pos pos = let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.zplus Mc.zmult Mc.zminus Mc.zopp Mc.zeq_bool (term_to_z_expr e) -let z_cert_of_pos pos = +let z_cert_of_pos pos = let s,pos = (scale_certificate pos) in let rec _cert_of_pos = function Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) | Monoid l -> product l - | Rational_eq n | Rational_le n | Rational_lt n -> + | Rational_eq n | Rational_le n | Rational_lt n -> if compare_num n (Int 0) = 0 then Mc.PsatzZ else Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) | Square t -> Mc.PsatzSquare (term_to_z_pol t) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 5e13db1b69..d10ae00c82 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -15,12 +15,12 @@ open Mutils let debug = false -let time str f x = +let time str f x = let t0 = (Unix.times()).Unix.tms_utime in - let res = f x in - let t1 = (Unix.times()).Unix.tms_utime in - (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ; - flush stdout); + let res = f x in + let t1 = (Unix.times()).Unix.tms_utime in + (*if debug then*) (Printf.printf "time %s %f\n" str (t1 -. t0) ; + flush stdout); res @@ -28,30 +28,30 @@ type tag = Tag.t type 'cst atom = 'cst Micromega.formula type 'cst formula = - | TT - | FF + | TT + | FF | X of Term.constr | A of 'cst atom * tag * Term.constr - | C of 'cst formula * 'cst formula - | D of 'cst formula * 'cst formula - | N of 'cst formula - | I of 'cst formula * Names.identifier option * 'cst formula + | C of 'cst formula * 'cst formula + | D of 'cst formula * 'cst formula + | N of 'cst formula + | I of 'cst formula * Names.identifier option * 'cst formula -let rec pp_formula o f = +let rec pp_formula o f = match f with | TT -> output_string o "tt" | FF -> output_string o "ff" - | X c -> output_string o "X " + | X c -> output_string o "X " | A(_,t,_) -> Printf.fprintf o "A(%a)" Tag.pp t | C(f1,f2) -> Printf.fprintf o "C(%a,%a)" pp_formula f1 pp_formula f2 | D(f1,f2) -> Printf.fprintf o "D(%a,%a)" pp_formula f1 pp_formula f2 - | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" - pp_formula f1 - (match n with - | Some id -> Names.string_of_id id + | I(f1,n,f2) -> Printf.fprintf o "I(%a%s,%a)" + pp_formula f1 + (match n with + | Some id -> Names.string_of_id id | None -> "") pp_formula f2 - | N(f) -> Printf.fprintf o "N(%a)" pp_formula f + | N(f) -> Printf.fprintf o "N(%a)" pp_formula f let rec ids_of_formula f = match f with @@ -60,15 +60,15 @@ let rec ids_of_formula f = module ISet = Set.Make(struct type t = int let compare : int -> int -> int = Pervasives.compare end) -let selecti s m = - let rec xselect i m = +let selecti s m = + let rec xselect i m = match m with | [] -> [] | e::m -> if ISet.mem i s then e:: (xselect (i+1) m) else xselect (i+1) m in xselect 0 m -type 'cst clause = ('cst Micromega.nFormula * tag) list +type 'cst clause = ('cst Micromega.nFormula * tag) list type 'cst cnf = ('cst clause) list @@ -78,7 +78,7 @@ let ff : 'cst cnf = [ [] ] type 'cst mc_cnf = ('cst Micromega.nFormula) list list -let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) = +let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) (f:'cst formula) = let negate a t = List.map (fun cl -> List.map (fun x -> (x,t)) cl) (negate a) in @@ -88,12 +88,12 @@ let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) let and_cnf x y = x @ y in let or_clause_cnf t f = List.map (fun x -> t@x) f in - + let rec or_cnf f f' = match f with | [] -> tt | e :: rst -> (or_cnf rst f') @ (or_clause_cnf e f') in - + let rec xcnf (pol : bool) f = match f with | TT -> if pol then tt else ff (* ?? *) @@ -101,11 +101,11 @@ let cnf (negate: 'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) | X p -> if pol then ff else ff (* ?? *) | A(x,t,_) -> if pol then normalise x t else negate x t | N(e) -> xcnf (not pol) e - | C(e1,e2) -> + | C(e1,e2) -> (if pol then and_cnf else or_cnf) (xcnf pol e1) (xcnf pol e2) - | D(e1,e2) -> + | D(e1,e2) -> (if pol then or_cnf else and_cnf) (xcnf pol e1) (xcnf pol e2) - | I(e1,_,e2) -> + | I(e1,_,e2) -> (if pol then or_cnf else and_cnf) (xcnf (not pol) e1) (xcnf pol e2) in xcnf true f @@ -116,12 +116,12 @@ struct open Coqlib open Term (* let constant = gen_constant_in_modules "Omicron" coq_modules*) - - + + let logic_dir = ["Coq";"Logic";"Decidable"] let coq_modules = - init_modules @ - [logic_dir] @ arith_modules @ zarith_base_modules @ + init_modules @ + [logic_dir] @ arith_modules @ zarith_base_modules @ [ ["Coq";"Lists";"List"]; ["ZMicromega"]; ["Tauto"]; @@ -135,7 +135,7 @@ struct ["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"]; ["LRing_normalise"]] - + let constant = gen_constant_in_modules "ZMicromega" coq_modules let coq_and = lazy (constant "and") @@ -144,7 +144,7 @@ struct let coq_iff = lazy (constant "iff") let coq_True = lazy (constant "True") let coq_False = lazy (constant "False") - + let coq_cons = lazy (constant "cons") let coq_nil = lazy (constant "nil") let coq_list = lazy (constant "list") @@ -153,9 +153,9 @@ struct let coq_S = lazy (constant "S") let coq_nat = lazy (constant "nat") - let coq_NO = lazy + let coq_NO = lazy (gen_constant_in_modules "N" [ ["Coq";"NArith";"BinNat" ]] "N0") - let coq_Npos = lazy + let coq_Npos = lazy (gen_constant_in_modules "N" [ ["Coq";"NArith"; "BinNat"]] "Npos") (* let coq_n = lazy (constant "N")*) @@ -166,7 +166,7 @@ struct let coq_xH = lazy (constant "xH") let coq_xO = lazy (constant "xO") let coq_xI = lazy (constant "xI") - + let coq_N0 = lazy (constant "N0") let coq_N0 = lazy (constant "Npos") @@ -179,11 +179,11 @@ struct let coq_POS = lazy (constant "Zpos") let coq_NEG = lazy (constant "Zneg") - let coq_QWitness = lazy - (gen_constant_in_modules "QMicromega" + let coq_QWitness = lazy + (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "QMicromega"]] "QWitness") - let coq_ZWitness = lazy - (gen_constant_in_modules "QMicromega" + let coq_ZWitness = lazy + (gen_constant_in_modules "QMicromega" [["Coq"; "micromega"; "ZMicromega"]] "ZWitness") @@ -212,8 +212,8 @@ struct let coq_Zopp = lazy (constant "Zopp") let coq_Zmult = lazy (constant "Zmult") let coq_Zpower = lazy (constant "Zpower") - let coq_N_of_Z = lazy - (gen_constant_in_modules "ZArithRing" + let coq_N_of_Z = lazy + (gen_constant_in_modules "ZArithRing" [["Coq";"setoid_ring";"ZArithRing"]] "N_of_Z") let coq_Qgt = lazy (constant "Qgt") @@ -271,27 +271,27 @@ struct let coq_PsatzC = lazy (constant "PsatzC") let coq_PsatzZ = lazy (constant "PsatzZ") let coq_coneMember = lazy (constant "coneMember") - - let coq_make_impl = lazy + + let coq_make_impl = lazy (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_impl") - let coq_make_conj = lazy + let coq_make_conj = lazy (gen_constant_in_modules "Zmicromega" [["Refl"]] "make_conj") - let coq_Build = lazy - (gen_constant_in_modules "RingMicromega" - [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] + let coq_Build = lazy + (gen_constant_in_modules "RingMicromega" + [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Build_Formula") - let coq_Cstr = lazy - (gen_constant_in_modules "RingMicromega" + let coq_Cstr = lazy + (gen_constant_in_modules "RingMicromega" [["Coq" ; "micromega" ; "RingMicromega"] ; ["RingMicromega"] ] "Formula") - type parse_error = - | Ukn - | BadStr of string - | BadNum of int - | BadTerm of Term.constr + type parse_error = + | Ukn + | BadStr of string + | BadNum of int + | BadTerm of Term.constr | Msg of string | Goal of (Term.constr list ) * Term.constr * parse_error @@ -304,73 +304,73 @@ struct | Goal _ -> "Goal" - exception ParseError + exception ParseError - let get_left_construct term = + let get_left_construct term = match Term.kind_of_term term with | Term.Construct(_,i) -> (i,[| |]) - | Term.App(l,rst) -> + | Term.App(l,rst) -> (match Term.kind_of_term l with | Term.Construct(_,i) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError - + module Mc = Micromega - - let rec parse_nat term = + + let rec parse_nat term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.O | 2 -> Mc.S (parse_nat (c.(0))) | i -> raise ParseError - + let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) - let rec dump_nat x = + let rec dump_nat x = match x with | Mc.O -> Lazy.force coq_O | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |]) - let rec parse_positive term = + let rec parse_positive term = let (i,c) = get_left_construct term in match i with | 1 -> Mc.XI (parse_positive c.(0)) | 2 -> Mc.XO (parse_positive c.(0)) | 3 -> Mc.XH | i -> raise ParseError - - let rec dump_positive x = + + let rec dump_positive x = match x with | Mc.XH -> Lazy.force coq_xH | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_positive p |]) | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_positive p |]) - let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) + let pp_positive o x = Printf.fprintf o "%i" (CoqToCaml.positive x) - let rec dump_n x = - match x with + let rec dump_n x = + match x with | Mc.N0 -> Lazy.force coq_N0 | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p|]) - let rec dump_index x = + let rec dump_index x = match x with | Mc.XH -> Lazy.force coq_xH | Mc.XO p -> Term.mkApp(Lazy.force coq_xO,[| dump_index p |]) | Mc.XI p -> Term.mkApp(Lazy.force coq_xI,[| dump_index p |]) - let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) + let pp_index o x = Printf.fprintf o "%i" (CoqToCaml.index x) - let rec dump_n x = + let rec dump_n x = match x with | Mc.N0 -> Lazy.force coq_NO | Mc.Npos p -> Term.mkApp(Lazy.force coq_Npos,[| dump_positive p |]) @@ -392,30 +392,30 @@ struct let dump_z x = match x with | Mc.Z0 ->Lazy.force coq_ZERO - | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|]) - | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) + | Mc.Zpos p -> Term.mkApp(Lazy.force coq_POS,[| dump_positive p|]) + | Mc.Zneg p -> Term.mkApp(Lazy.force coq_NEG,[| dump_positive p|]) let pp_z o x = Printf.fprintf o "%i" (CoqToCaml.z x) -let dump_num bd1 = +let dump_num bd1 = Term.mkApp(Lazy.force coq_Qmake, - [|dump_z (CamlToCoq.bigint (numerator bd1)) ; + [|dump_z (CamlToCoq.bigint (numerator bd1)) ; dump_positive (CamlToCoq.positive_big_int (denominator bd1)) |]) -let dump_q q = - Term.mkApp(Lazy.force coq_Qmake, +let dump_q q = + Term.mkApp(Lazy.force coq_Qmake, [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) -let parse_q term = +let parse_q term = match Term.kind_of_term term with | Term.App(c, args) -> if c = Lazy.force coq_Qmake then {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } else raise ParseError | _ -> raise ParseError - - let rec parse_list parse_elt term = + + let rec parse_list parse_elt term = let (i,c) = get_left_construct term in match i with | 1 -> [] @@ -430,20 +430,20 @@ let parse_q term = [| typ; dump_elt e;dump_list typ dump_elt l|]) - let pp_list op cl elt o l = - let rec _pp o l = + let pp_list op cl elt o l = + let rec _pp o l = match l with | [] -> () | [e] -> Printf.fprintf o "%a" elt e | e::l -> Printf.fprintf o "%a ,%a" elt e _pp l in - Printf.fprintf o "%s%a%s" op _pp l cl + Printf.fprintf o "%s%a%s" op _pp l cl let pp_var = pp_positive let dump_var = dump_positive - let pp_expr pp_z o e = - let rec pp_expr o e = + let pp_expr pp_z o e = + let rec pp_expr o e = match e with | Mc.PEX n -> Printf.fprintf o "V %a" pp_var n | Mc.PEc z -> pp_z o z @@ -474,62 +474,62 @@ let parse_q term = dump_expr e - let dump_pol typ dump_c e = - let rec dump_pol e = - match e with + let dump_pol typ dump_c e = + let rec dump_pol e = + match e with | Mc.Pc n -> mkApp(Lazy.force coq_Pc, [|typ ; dump_c n|]) | Mc.Pinj(p,pol) -> mkApp(Lazy.force coq_Pinj , [| typ ; dump_positive p ; dump_pol pol|]) | Mc.PX(pol1,p,pol2) -> mkApp(Lazy.force coq_PX, [| typ ; dump_pol pol1 ; dump_positive p ; dump_pol pol2|]) in dump_pol e - let pp_pol pp_c o e = - let rec pp_pol o e = - match e with + let pp_pol pp_c o e = + let rec pp_pol o e = + match e with | Mc.Pc n -> Printf.fprintf o "Pc %a" pp_c n | Mc.Pinj(p,pol) -> Printf.fprintf o "Pinj(%a,%a)" pp_positive p pp_pol pol | Mc.PX(pol1,p,pol2) -> Printf.fprintf o "PX(%a,%a,%a)" pp_pol pol1 pp_positive p pp_pol pol2 in pp_pol o e - - - let pp_cnf pp_c o f = + + + let pp_cnf pp_c o f = let pp_clause o l = List.iter (fun ((p,_),t) -> Printf.fprintf o "(%a @%a)" (pp_pol pp_c) p Tag.pp t) l in List.iter (fun l -> Printf.fprintf o "[%a]" pp_clause l) f - - let dump_psatz typ dump_z e = - let z = Lazy.force typ in + + let dump_psatz typ dump_z e = + let z = Lazy.force typ in let rec dump_cone e = match e with | Mc.PsatzIn n -> mkApp(Lazy.force coq_PsatzIn,[| z; dump_nat n |]) - | Mc.PsatzMulC(e,c) -> mkApp(Lazy.force coq_PsatzMultC, + | Mc.PsatzMulC(e,c) -> mkApp(Lazy.force coq_PsatzMultC, [| z; dump_pol z dump_z e ; dump_cone c |]) - | Mc.PsatzSquare e -> mkApp(Lazy.force coq_PsatzSquare, + | Mc.PsatzSquare e -> mkApp(Lazy.force coq_PsatzSquare, [| z;dump_pol z dump_z e|]) | Mc.PsatzAdd(e1,e2) -> mkApp(Lazy.force coq_PsatzAdd, [| z; dump_cone e1; dump_cone e2|]) | Mc.PsatzMulE(e1,e2) -> mkApp(Lazy.force coq_PsatzMulE, [| z; dump_cone e1; dump_cone e2|]) | Mc.PsatzC p -> mkApp(Lazy.force coq_PsatzC,[| z; dump_z p|]) - | Mc.PsatzZ -> mkApp( Lazy.force coq_PsatzZ,[| z|]) in + | Mc.PsatzZ -> mkApp( Lazy.force coq_PsatzZ,[| z|]) in dump_cone e - let pp_psatz pp_z o e = - let rec pp_cone o e = - match e with - | Mc.PsatzIn n -> + let pp_psatz pp_z o e = + let rec pp_cone o e = + match e with + | Mc.PsatzIn n -> Printf.fprintf o "(In %a)%%nat" pp_nat n - | Mc.PsatzMulC(e,c) -> + | Mc.PsatzMulC(e,c) -> Printf.fprintf o "( %a [*] %a)" (pp_pol pp_z) e pp_cone c - | Mc.PsatzSquare e -> + | Mc.PsatzSquare e -> Printf.fprintf o "(%a^2)" (pp_pol pp_z) e - | Mc.PsatzAdd(e1,e2) -> + | Mc.PsatzAdd(e1,e2) -> Printf.fprintf o "(%a [+] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzMulE(e1,e2) -> + | Mc.PsatzMulE(e1,e2) -> Printf.fprintf o "(%a [*] %a)" pp_cone e1 pp_cone e2 - | Mc.PsatzC p -> + | Mc.PsatzC p -> Printf.fprintf o "(%a)%%positive" pp_z p - | Mc.PsatzZ -> + | Mc.PsatzZ -> Printf.fprintf o "0" in pp_cone o e @@ -544,8 +544,8 @@ let parse_q term = - let pp_op o e= - match e with + let pp_op o e= + match e with | Mc.OpEq-> Printf.fprintf o "=" | Mc.OpNEq-> Printf.fprintf o "<>" | Mc.OpLe -> Printf.fprintf o "=<" @@ -561,29 +561,29 @@ let parse_q term = let dump_cstr typ dump_constant {Mc.flhs = e1 ; Mc.fop = o ; Mc.frhs = e2} = Term.mkApp(Lazy.force coq_Build, - [| typ; dump_expr typ dump_constant e1 ; - dump_op o ; + [| typ; dump_expr typ dump_constant e1 ; + dump_op o ; dump_expr typ dump_constant e2|]) - let assoc_const x l = - try + let assoc_const x l = + try snd (List.find (fun (x',y) -> x = Lazy.force x') l) with Not_found -> raise ParseError - let zop_table = [ - coq_Zgt, Mc.OpGt ; + let zop_table = [ + coq_Zgt, Mc.OpGt ; coq_Zge, Mc.OpGe ; coq_Zlt, Mc.OpLt ; coq_Zle, Mc.OpLe ] - let rop_table = [ - coq_Rgt, Mc.OpGt ; + let rop_table = [ + coq_Rgt, Mc.OpGt ; coq_Rge, Mc.OpGe ; coq_Rlt, Mc.OpLt ; coq_Rle, Mc.OpLe ] - let qop_table = [ + let qop_table = [ coq_Qlt, Mc.OpLt ; coq_Qle, Mc.OpLe ; coq_Qeq, Mc.OpEq @@ -593,7 +593,7 @@ let parse_q term = let parse_zop (op,args) = match kind_of_term op with | Const x -> (assoc_const op zop_table, args.(0) , args.(1)) - | Ind(n,0) -> + | Ind(n,0) -> if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_Z then (Mc.OpEq, args.(1), args.(2)) else raise ParseError @@ -603,7 +603,7 @@ let parse_q term = let parse_rop (op,args) = match kind_of_term op with | Const x -> (assoc_const op rop_table, args.(0) , args.(1)) - | Ind(n,0) -> + | Ind(n,0) -> if op = Lazy.force coq_Eq && args.(0) = Lazy.force coq_R then (Mc.OpEq, args.(1), args.(2)) else raise ParseError @@ -614,25 +614,25 @@ let parse_q term = module Env = - struct + struct type t = constr list - + let compute_rank_add env v = let rec _add env n v = match env with | [] -> ([v],n) - | e::l -> - if eq_constr e v + | e::l -> + if eq_constr e v then (env,n) - else + else let (env,n) = _add l ( n+1) v in (e::env,n) in let (env, n) = _add env 1 v in (env, CamlToCoq.idx n) - + let empty = [] - + let elements env = env end @@ -640,63 +640,63 @@ let parse_q term = let is_constant t = (* This is an approx *) match kind_of_term t with - | Construct(i,_) -> true + | Construct(i,_) -> true | _ -> false - type 'a op = - | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) - | Opp - | Power + type 'a op = + | Binop of ('a Mc.pExpr -> 'a Mc.pExpr -> 'a Mc.pExpr) + | Opp + | Power | Ukn of string - let assoc_ops x l = - try + let assoc_ops x l = + try snd (List.find (fun (x',y) -> x = Lazy.force x') l) with Not_found -> Ukn "Oups" - let parse_expr parse_constant parse_exp ops_spec env term = - if debug - then (Pp.pp (Pp.str "parse_expr: "); + let parse_expr parse_constant parse_exp ops_spec env term = + if debug + then (Pp.pp (Pp.str "parse_expr: "); Pp.pp_flush ();Pp.pp (Printer.prterm term); Pp.pp_flush ()); - let constant_or_variable env term = - try + let constant_or_variable env term = + try ( Mc.PEc (parse_constant term) , env) - with ParseError -> + with ParseError -> let (env,n) = Env.compute_rank_add env term in (Mc.PEX n , env) in - let rec parse_expr env term = + let rec parse_expr env term = let combine env op (t1,t2) = let (expr1,env) = parse_expr env t1 in let (expr2,env) = parse_expr env t2 in (op expr1 expr2,env) in match kind_of_term term with - | App(t,args) -> + | App(t,args) -> ( match kind_of_term t with - | Const c -> + | Const c -> ( match assoc_ops t ops_spec with | Binop f -> combine env f (args.(0),args.(1)) | Opp -> let (expr,env) = parse_expr env args.(0) in (Mc.PEopp expr, env) - | Power -> + | Power -> begin - try + try let (expr,env) = parse_expr env args.(0) in - let exp = (parse_exp args.(1)) in - (Mc.PEpow(expr, exp) , env) + let exp = (parse_exp args.(1)) in + (Mc.PEpow(expr, exp) , env) with _ -> (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end - | Ukn s -> - if debug + | Ukn s -> + if debug then (Printf.printf "unknown op: %s\n" s; flush stdout;); let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) ) @@ -704,47 +704,47 @@ let parse_q term = ) | _ -> constant_or_variable env term in parse_expr env term - - let zop_spec = - [ + + let zop_spec = + [ coq_Zplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Zminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Zopp , Opp ; + coq_Zmult , Binop (fun x y -> Mc.PEmul (x,y)) ; + coq_Zopp , Opp ; coq_Zpower , Power] -let qop_spec = +let qop_spec = [ coq_Qplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Qminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Qopp , Opp ; + coq_Qmult , Binop (fun x y -> Mc.PEmul (x,y)) ; + coq_Qopp , Opp ; coq_Qpower , Power] -let rop_spec = +let rop_spec = [ coq_Rplus , Binop (fun x y -> Mc.PEadd(x,y)) ; coq_Rminus , Binop (fun x y -> Mc.PEsub(x,y)) ; - coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; - coq_Ropp , Opp ; + coq_Rmult , Binop (fun x y -> Mc.PEmul (x,y)) ; + coq_Ropp , Opp ; coq_Rpower , Power] - + let zconstant = parse_z let qconstant = parse_q -let rconstant term = - if debug +let rconstant term = + if debug then (Pp.pp_flush (); Pp.pp (Pp.str "rconstant: "); Pp.pp (Printer.prterm term); Pp.pp_flush ()); match Term.kind_of_term term with - | Const x -> + | Const x -> if term = Lazy.force coq_R0 then Mc.Z0 else if term = Lazy.force coq_R1 @@ -753,37 +753,37 @@ let rconstant term = | _ -> raise ParseError -let parse_zexpr = - parse_expr zconstant (fun x -> Mc.n_of_Z (parse_z x)) zop_spec -let parse_qexpr = - parse_expr qconstant (fun x -> Mc.n_of_Z (parse_z x)) qop_spec -let parse_rexpr = +let parse_zexpr = + parse_expr zconstant (fun x -> Mc.n_of_Z (parse_z x)) zop_spec +let parse_qexpr = + parse_expr qconstant (fun x -> Mc.n_of_Z (parse_z x)) qop_spec +let parse_rexpr = parse_expr rconstant (fun x -> Mc.n_of_nat (parse_nat x)) rop_spec - let parse_arith parse_op parse_expr env cstr = - if debug + let parse_arith parse_op parse_expr env cstr = + if debug then (Pp.pp_flush (); Pp.pp (Pp.str "parse_arith: "); - Pp.pp (Printer.prterm cstr); + Pp.pp (Printer.prterm cstr); Pp.pp_flush ()); match kind_of_term cstr with - | App(op,args) -> + | App(op,args) -> let (op,lhs,rhs) = parse_op (op,args) in let (e1,env) = parse_expr env lhs in let (e2,env) = parse_expr env rhs in ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) | _ -> failwith "error : parse_arith(2)" - let parse_zarith = parse_arith parse_zop parse_zexpr - + let parse_zarith = parse_arith parse_zop parse_zexpr + let parse_qarith = parse_arith parse_qop parse_qexpr - + let parse_rarith = parse_arith parse_rop parse_rexpr - - + + (* generic parsing of arithmetic expressions *) - + @@ -797,7 +797,7 @@ let parse_rexpr = | N (a) -> Mc.N(f2f a) | I(a,_,b) -> Mc.I(f2f a,f2f b) - let is_prop t = + let is_prop t = match t with | Names.Anonymous -> true (* Not quite right *) | Names.Name x -> false @@ -814,7 +814,7 @@ let parse_rexpr = let parse_formula parse_atom env term = - let parse_atom env tg t = try let (at,env) = parse_atom env t in + let parse_atom env tg t = try let (at,env) = parse_atom env t in (A(at,tg,t), env,Tag.next tg) with _ -> (X(t),env,tg) in let rec xparse_formula env tg term = @@ -845,36 +845,36 @@ let parse_rexpr = | _ -> X(term),env,tg in xparse_formula env term - let coq_TT = lazy - (gen_constant_in_modules "ZMicromega" + let coq_TT = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "TT") - let coq_FF = lazy - (gen_constant_in_modules "ZMicromega" + let coq_FF = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "FF") - let coq_And = lazy - (gen_constant_in_modules "ZMicromega" + let coq_And = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "Cj") - let coq_Or = lazy - (gen_constant_in_modules "ZMicromega" + let coq_Or = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "D") - let coq_Neg = lazy - (gen_constant_in_modules "ZMicromega" + let coq_Neg = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "N") - let coq_Atom = lazy - (gen_constant_in_modules "ZMicromega" + let coq_Atom = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "A") - let coq_X = lazy - (gen_constant_in_modules "ZMicromega" + let coq_X = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "X") - let coq_Impl = lazy - (gen_constant_in_modules "ZMicromega" + let coq_Impl = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "I") - let coq_Formula = lazy - (gen_constant_in_modules "ZMicromega" + let coq_Formula = lazy + (gen_constant_in_modules "ZMicromega" [["Coq" ; "micromega" ; "Tauto"];["Tauto"]] "BFormula") - let dump_formula typ dump_atom f = - let rec xdump f = + let dump_formula typ dump_atom f = + let rec xdump f = match f with | TT -> mkApp(Lazy.force coq_TT,[| typ|]) | FF -> mkApp(Lazy.force coq_FF,[| typ|]) @@ -882,11 +882,11 @@ let parse_rexpr = | D(x,y) -> mkApp(Lazy.force coq_Or,[| typ ; xdump x ; xdump y|]) | I(x,_,y) -> mkApp(Lazy.force coq_Impl,[| typ ; xdump x ; xdump y|]) | N(x) -> mkApp(Lazy.force coq_Neg,[| typ ; xdump x|]) - | A(x,_,_) -> mkApp(Lazy.force coq_Atom,[| typ ; dump_atom x|]) + | A(x,_,_) -> mkApp(Lazy.force coq_Atom,[| typ ; dump_atom x|]) | X(t) -> mkApp(Lazy.force coq_X,[| typ ; t|]) in xdump f - + @@ -894,7 +894,7 @@ let parse_rexpr = let set l concl = let rec _set acc = function | [] -> acc - | (e::l) -> + | (e::l) -> let (name,expr,typ) = e in _set (Term.mkNamedLetIn (Names.id_of_string name) @@ -902,7 +902,7 @@ let parse_rexpr = _set concl l -end +end open M @@ -916,33 +916,33 @@ let rec sig_of_cone = function | _ -> [] let same_proof sg cl1 cl2 = - let rec xsame_proof sg = + let rec xsame_proof sg = match sg with | [] -> true - | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) + | n::sg -> (try List.nth cl1 n = List.nth cl2 n with _ -> false) && (xsame_proof sg ) in xsame_proof sg -let tags_of_clause tgs wit clause = +let tags_of_clause tgs wit clause = let rec xtags tgs = function - | Mc.PsatzIn n -> Names.Idset.union tgs + | Mc.PsatzIn n -> Names.Idset.union tgs (snd (List.nth clause (CoqToCaml.nat n) )) | Mc.PsatzMulC(e,w) -> xtags tgs w | Mc.PsatzMulE (w1,w2) | Mc.PsatzAdd(w1,w2) -> xtags (xtags tgs w1) w2 | _ -> tgs in xtags tgs wit -let tags_of_cnf wits cnf = - List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) +let tags_of_cnf wits cnf = + List.fold_left2 (fun acc w cl -> tags_of_clause acc w cl) Names.Idset.empty wits cnf let find_witness prover polys1 = try_any prover polys1 -let rec witness prover l1 l2 = +let rec witness prover l1 l2 = match l2 with | [] -> Some [] | e :: l2 -> @@ -955,23 +955,23 @@ let rec witness prover l1 l2 = ) -let rec apply_ids t ids = +let rec apply_ids t ids = match ids with | [] -> t | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids - -let coq_Node = lazy - (Coqlib.gen_constant_in_modules "VarMap" + +let coq_Node = lazy + (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = lazy - (Coqlib.gen_constant_in_modules "VarMap" +let coq_Leaf = lazy + (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") -let coq_Empty = lazy - (Coqlib.gen_constant_in_modules "VarMap" +let coq_Empty = lazy + (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") - - + + let btree_of_array typ a = let size_of_a = Array.length a in let semi_size_of_a = size_of_a lsr 1 in @@ -979,25 +979,25 @@ let btree_of_array typ a = and leaf = Lazy.force coq_Leaf and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in let rec aux n = - if n > size_of_a + if n > size_of_a then empty - else if n > semi_size_of_a + else if n > semi_size_of_a then Term.mkApp (leaf, [| typ; a.(n-1) |]) else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |]) - in + in aux 1 -let btree_of_array typ a = - try +let btree_of_array typ a = + try btree_of_array typ a - with x -> + with x -> failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x)) let dump_varmap typ env = btree_of_array typ (Array.of_list env) -let rec pp_varmap o vm = +let rec pp_varmap o vm = match vm with | Mc.Empty -> output_string o "[]" | Mc.Leaf z -> Printf.fprintf o "[%a]" pp_z z @@ -1005,37 +1005,37 @@ let rec pp_varmap o vm = -let rec dump_proof_term = function +let rec dump_proof_term = function | Micromega.DoneProof -> Lazy.force coq_doneProof - | Micromega.RatProof(cone,rst) -> + | Micromega.RatProof(cone,rst) -> Term.mkApp(Lazy.force coq_ratProof, [| dump_psatz coq_Z dump_z cone; dump_proof_term rst|]) | Micromega.CutProof(cone,prf) -> - Term.mkApp(Lazy.force coq_cutProof, - [| dump_psatz coq_Z dump_z cone ; + Term.mkApp(Lazy.force coq_cutProof, + [| dump_psatz coq_Z dump_z cone ; dump_proof_term prf|]) - | Micromega.EnumProof(c1,c2,prfs) -> + | Micromega.EnumProof(c1,c2,prfs) -> Term.mkApp (Lazy.force coq_enumProof, - [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; + [| dump_psatz coq_Z dump_z c1 ; dump_psatz coq_Z dump_z c2 ; dump_list (Lazy.force coq_proofTerm) dump_proof_term prfs |]) let pp_q o q = Printf.fprintf o "%a/%a" pp_z q.Micromega.qnum pp_positive q.Micromega.qden - - + + let rec pp_proof_term o = function | Micromega.DoneProof -> Printf.fprintf o "D" | Micromega.RatProof(cone,rst) -> Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.CutProof(cone,rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst - | Micromega.EnumProof(c1,c2,rst) -> - Printf.fprintf o "EP[%a,%a,%a]" - (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 + | Micromega.EnumProof(c1,c2,rst) -> + Printf.fprintf o "EP[%a,%a,%a]" + (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 (pp_list "[" "]" pp_proof_term) rst let rec parse_hyps parse_arith env tg hyps = match hyps with | [] -> ([],env,tg) - | (i,t)::l -> + | (i,t)::l -> let (lhyps,env,tg) = parse_hyps parse_arith env tg l in - try + try let (c,env,tg) = parse_formula parse_arith env tg t in ((i,c)::lhyps, env,tg) with _ -> (lhyps,env,tg) @@ -1044,7 +1044,7 @@ let rec parse_hyps parse_arith env tg hyps = exception ParseError -let parse_goal parse_arith env hyps term = +let parse_goal parse_arith env hyps term = (* try*) let (f,env,tg) = parse_formula parse_arith env (Tag.from 0) term in let (lhyps,env,tg) = parse_hyps parse_arith env tg hyps in @@ -1052,11 +1052,11 @@ let parse_goal parse_arith env hyps term = (* with Failure x -> raise ParseError*) -type ('d, 'prf) domain_spec = { +type ('d, 'prf) domain_spec = { typ : Term.constr; (* Z, Q , R *) coeff : Term.constr ; (* Z, Q *) - dump_coeff : 'd -> Term.constr ; - proof_typ : Term.constr ; + dump_coeff : 'd -> Term.constr ; + proof_typ : Term.constr ; dump_proof : 'prf -> Term.constr } @@ -1085,25 +1085,25 @@ let rz_domain_spec = lazy { } -let abstract_formula hyps f = - - let rec xabs f = +let abstract_formula hyps f = + + let rec xabs f = match f with | X c -> X c | A(a,t,term) -> if TagSet.mem t hyps then A(a,t,term) else X(term) - | C(f1,f2) -> + | C(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_and, [|a1;a2|])) | f1 , f2 -> C(f1,f2) ) - | D(f1,f2) -> + | D(f1,f2) -> (match xabs f1 , xabs f2 with | X a1 , X a2 -> X (Term.mkApp(Lazy.force coq_or, [|a1;a2|])) | f1 , f2 -> D(f1,f2) ) - | N(f) -> + | N(f) -> (match xabs f with | X a -> X (Term.mkApp(Lazy.force coq_not, [|a|])) | f -> N f) - | I(f1,hyp,f2) -> + | I(f1,hyp,f2) -> (match xabs f1 , hyp, xabs f2 with | X a1 , Some _ , af2 -> af2 | X a1 , None , X a2 -> X (Term.mkArrow a1 a2) @@ -1117,25 +1117,25 @@ let abstract_formula hyps f = -let micromega_order_change spec cert cert_typ env ff gl = +let micromega_order_change spec cert cert_typ env ff gl = let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in let vm = dump_varmap ( spec.typ) env in Tactics.change_in_concl None - (set - [ + (set + [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula ,[| formula_typ |])); - ("__varmap", vm , Term.mkApp - (Coqlib.gen_constant_in_modules "VarMap" + ("__varmap", vm , Term.mkApp + (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "t", [| spec.typ|])); ("__wit", cert,cert_typ) - ] + ] (Tacmach.pf_concl gl ) ) - gl - + gl + type ('a,'prf) prover = { name : string ; (* name of the prover *) @@ -1147,18 +1147,18 @@ type ('a,'prf) prover = { } let find_witness provers polys1 = - - let provers = List.map (fun p -> - (fun l -> + + let provers = List.map (fun p -> + (fun l -> match p.prover l with | None -> None | Some prf -> Some(prf,p)) , p.name) provers in - + try_any provers (List.map fst polys1) -let witness_list prover l = - let rec xwitness_list l = +let witness_list prover l = + let rec xwitness_list l = match l with | [] -> Some [] | e :: l -> @@ -1173,79 +1173,79 @@ let witness_list prover l = let witness_list_tags = witness_list - + let is_singleton = function [] -> true | [e] -> true | _ -> false -let pp_ml_list pp_elt o l = +let pp_ml_list pp_elt o l = output_string o "[" ; - List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ; - output_string o "]" + List.iter (fun x -> Printf.fprintf o "%a ;" pp_elt x) l ; + output_string o "]" -let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = +let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = - let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = + let compact_proof (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = let new_cl = Mutils.mapi (fun (f,_) i -> (f,i)) new_cl in - let remap i = + let remap i = let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in List.assoc formula new_cl in - if debug then + if debug then begin - Printf.printf "\ncompact_proof : %a %a %a" - (pp_ml_list prover.pp_f) (List.map fst old_cl) - prover.pp_prf prf + Printf.printf "\ncompact_proof : %a %a %a" + (pp_ml_list prover.pp_f) (List.map fst old_cl) + prover.pp_prf prf (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout end ; let res = try prover.compact prf remap with x -> - if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; + if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) - match prover.prover (List.map fst new_cl) with + match prover.prover (List.map fst new_cl) with | None -> failwith "proof compaction error" - | Some p -> p + | Some p -> p in - if debug then + if debug then begin - Printf.printf " -> %a\n" + Printf.printf " -> %a\n" prover.pp_prf res ; flush stdout end - ; + ; res in - let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = + let is_proof_compatible (old_cl:'cst clause) (prf,prover) (new_cl:'cst clause) = let hyps_idx = prover.hyps prf in let hyps = selecti hyps_idx old_cl in is_sublist hyps new_cl in let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) - - List.map (fun x -> - let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res - in compact_proof o p x) cnf_ff' - - - - -let micromega_tauto negate normalise spec prover env polys1 polys2 gl = - let spec = Lazy.force spec in - let (ff,ids) = - List.fold_right - (fun (id,f) (cc,ids) -> - match f with - X _ -> (cc,ids) - | _ -> (I(f,Some id,cc), id::ids)) + + List.map (fun x -> + let (o,p) = List.find (fun (l,p) -> is_proof_compatible l p x) cnf_res + in compact_proof o p x) cnf_ff' + + + + +let micromega_tauto negate normalise spec prover env polys1 polys2 gl = + let spec = Lazy.force spec in + let (ff,ids) = + List.fold_right + (fun (id,f) (cc,ids) -> + match f with + X _ -> (cc,ids) + | _ -> (I(f,Some id,cc), id::ids)) polys1 (polys2,[]) in let cnf_ff = cnf negate normalise ff in - if debug then + if debug then begin Pp.pp (Pp.str "Formula....\n") ; let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff = dump_formula formula_typ + let ff = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff in Pp.pp (Printer.prterm ff) ; Pp.pp_flush (); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff @@ -1255,30 +1255,30 @@ let micromega_tauto negate normalise spec prover env polys1 polys2 gl = | None -> Tacticals.tclFAIL 0 (Pp.str "Cannot find witness") gl | Some res -> (*Printf.printf "\nList %i" (List.length `res); *) - let hyps = List.fold_left (fun s (cl,(prf,p)) -> + let hyps = List.fold_left (fun s (cl,(prf,p)) -> let tags = ISet.fold (fun i s -> let t = snd (List.nth cl i) in if debug then (Printf.fprintf stdout "T : %i -> %a" i Tag.pp t) ; (*try*) TagSet.add t s (* with Invalid_argument _ -> s*)) (p.hyps prf) TagSet.empty in TagSet.union s tags) TagSet.empty (List.combine cnf_ff res) in if debug then (Printf.printf "TForm : %a\n" pp_formula ff ; flush stdout; - Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; - + Printf.printf "Hyps : %a\n" (fun o s -> TagSet.fold (fun i _ -> Printf.fprintf o "%a " Tag.pp i) s ()) hyps) ; + let ff' = abstract_formula hyps ff in - + let cnf_ff' = cnf negate normalise ff' in if debug then begin - Pp.pp (Pp.str "\nAFormula\n") ; + Pp.pp (Pp.str "\nAFormula\n") ; let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in - let ff' = dump_formula formula_typ + let ff' = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff' in Pp.pp (Printer.prterm ff') ; Pp.pp_flush (); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' end; - (* Even if it does not work, this does not mean it is not provable + (* Even if it does not work, this does not mean it is not provable -- the prover is REALLY incomplete *) (* if debug then begin @@ -1295,15 +1295,15 @@ let micromega_tauto negate normalise spec prover env polys1 polys2 gl = (Tacticals.tclTHENSEQ [ Tactics.generalize ids; - micromega_order_change spec res' + micromega_order_change spec res' (Term.mkApp(Lazy.force coq_list,[| spec.proof_typ|])) env ff' ; ]) gl -let micromega_gen - parse_arith - (negate:'cst atom -> 'cst mc_cnf) - (normalise:'cst atom -> 'cst mc_cnf) +let micromega_gen + parse_arith + (negate:'cst atom -> 'cst mc_cnf) + (normalise:'cst atom -> 'cst mc_cnf) spec prover gl = let concl = Tacmach.pf_concl gl in let hyps = Tacmach.pf_hyps_types gl in @@ -1311,8 +1311,8 @@ let micromega_gen let (hyps,concl,env) = parse_goal parse_arith Env.empty hyps concl in let env = Env.elements env in micromega_tauto negate normalise spec prover env hyps concl gl - with - | Failure x -> flush stdout ; Pp.pp_flush () ; + with + | Failure x -> flush stdout ; Pp.pp_flush () ; Tacticals.tclFAIL 0 (Pp.str x) gl | ParseError -> Tacticals.tclFAIL 0 (Pp.str "Bad logical fragment") gl @@ -1328,16 +1328,16 @@ type provername = string * int option open Persistent_cache -module Cache = PHashtable(struct - type t = (provername * micromega_polys) +module Cache = PHashtable(struct + type t = (provername * micromega_polys) let equal = (=) let hash = Hashtbl.hash end) -let csdp_cache = "csdp.cache" +let csdp_cache = "csdp.cache" let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivstellensatz option = - fun provername poly -> + fun provername poly -> let cmdname = List.fold_left Filename.concat (Envars.coqlib ()) @@ -1355,36 +1355,36 @@ let xcall_csdpcert = let call_csdpcert prover pb = xcall_csdpcert (prover,pb) -let rec z_to_q_pol e = +let rec z_to_q_pol e = match e with | Mc.Pc z -> Mc.Pc {Mc.qnum = z ; Mc.qden = Mc.XH} | Mc.Pinj(p,pol) -> Mc.Pinj(p,z_to_q_pol pol) | Mc.PX(pol1,p,pol2) -> Mc.PX(z_to_q_pol pol1, p, z_to_q_pol pol2) -let call_csdpcert_q provername poly = +let call_csdpcert_q provername poly = match call_csdpcert provername poly with | None -> None - | Some cert -> + | Some cert -> let cert = Certificate.q_cert_of_pos cert in if Mc.qWeakChecker poly cert then Some cert else ((print_string "buggy certificate" ; flush stdout) ;None) -let call_csdpcert_z provername poly = +let call_csdpcert_z provername poly = let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in match call_csdpcert provername l with | None -> None - | Some cert -> + | Some cert -> let cert = Certificate.z_cert_of_pos cert in if Mc.zWeakChecker poly cert then Some cert else ((print_string "buggy certificate" ; flush stdout) ;None) -let xhyps_of_cone base acc prf = - let rec xtract e acc = +let xhyps_of_cone base acc prf = + let rec xtract e acc = match e with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> acc | Mc.PsatzIn n -> let n = (CoqToCaml.nat n) in @@ -1401,7 +1401,7 @@ let hyps_of_cone prf = xhyps_of_cone 0 ISet.empty prf let compact_cone prf f = let np n = CamlToCoq.nat (f (CoqToCaml.nat n)) in - let rec xinterp prf = + let rec xinterp prf = match prf with | Mc.PsatzC _ | Mc.PsatzZ | Mc.PsatzSquare _ -> prf | Mc.PsatzIn n -> Mc.PsatzIn (np n) @@ -1411,31 +1411,31 @@ let compact_cone prf f = xinterp prf -let hyps_of_pt pt = - let rec xhyps base pt acc = +let hyps_of_pt pt = + let rec xhyps base pt acc = match pt with | Mc.DoneProof -> acc | Mc.RatProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) | Mc.CutProof(c,pt) -> xhyps (base+1) pt (xhyps_of_cone base acc c) - | Mc.EnumProof(c1,c2,l) -> + | Mc.EnumProof(c1,c2,l) -> let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in List.fold_left (fun s x -> xhyps (base + 1) x s) s l in - + xhyps 0 pt ISet.empty -let hyps_of_pt pt = +let hyps_of_pt pt = let res = hyps_of_pt pt in - if debug + if debug then (Printf.fprintf stdout "\nhyps_of_pt : %a -> " pp_proof_term pt ; ISet.iter (fun i -> Printf.printf "%i " i) res); res - - -let compact_pt pt f = + + +let compact_pt pt f = let translate ofset x = if x < ofset then x else (f (x-ofset) + ofset) in - let rec compact_pt ofset pt = + let rec compact_pt ofset pt = match pt with | Mc.DoneProof -> Mc.DoneProof | Mc.RatProof(c,pt) -> Mc.RatProof(compact_cone c (translate (ofset)), compact_pt (ofset+1) pt ) @@ -1451,8 +1451,8 @@ let compact_pt pt f = let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) let linear_prover_Z = { - name = "linear prover" ; - prover = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ; + name = "linear prover" ; + prover = lift_ratproof (lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec)) ; hyps = hyps_of_pt ; compact = compact_pt ; pp_prf = pp_proof_term; @@ -1461,8 +1461,8 @@ let linear_prover_Z = { let linear_prover_Q = { name = "linear prover"; - prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ; - hyps = hyps_of_cone ; + prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.q_spec) ; + hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; pp_f = fun o x -> pp_pol pp_q o (fst x) @@ -1470,8 +1470,8 @@ let linear_prover_Q = { let linear_prover_R = { name = "linear prover"; - prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec) ; - hyps = hyps_of_cone ; + prover = lift_pexpr_prover (Certificate.linear_prover_with_cert Certificate.z_spec) ; + hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_z ; pp_f = fun o x -> pp_pol pp_z o (fst x) @@ -1504,7 +1504,7 @@ let non_linear_prover_Z str o = { pp_f = fun o x -> pp_pol pp_z o (fst x) } -module CacheZ = PHashtable(struct +module CacheZ = PHashtable(struct type t = (Mc.z Mc.pol * Mc.op1) list let equal = (=) let hash = Hashtbl.hash @@ -1515,7 +1515,7 @@ let memo_zlinear_prover = CacheZ.memo "lia.cache" (lift_pexpr_prover Certificate let linear_Z = { name = "lia"; - prover = memo_zlinear_prover ; + prover = memo_zlinear_prover ; hyps = hyps_of_pt; compact = compact_pt; pp_prf = pp_proof_term; @@ -1526,52 +1526,52 @@ let linear_Z = { (** Instantiation of the tactics *) -let psatzl_Z gl = +let psatzl_Z gl = micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec [linear_prover_Z ] gl -let psatzl_Q gl = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec +let psatzl_Q gl = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec [ linear_prover_Q ] gl -let psatz_Q i gl = +let psatz_Q i gl = micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] gl -let psatzl_R gl = - micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec +let psatzl_R gl = + micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec [ linear_prover_R ] gl -let psatz_R i gl = +let psatz_R i gl = micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec [ non_linear_prover_R "real_nonlinear_prover" (Some i)] gl -let psatz_Z i gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec +let psatz_Z i gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec [non_linear_prover_Z "real_nonlinear_prover" (Some i) ] gl -let sos_Z gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec +let sos_Z gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec [non_linear_prover_Z "pure_sos" None] gl -let sos_Q gl = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec +let sos_Q gl = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise qq_domain_spec [non_linear_prover_Q "pure_sos" None] gl -let sos_R gl = - micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec +let sos_R gl = + micromega_gen parse_rarith Mc.rnegate Mc.rnormalise rz_domain_spec [non_linear_prover_R "pure_sos" None] gl -let xlia gl = - micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec +let xlia gl = + micromega_gen parse_zarith Mc.negate Mc.normalise zz_domain_spec [linear_Z] gl (* Local Variables: *) diff --git a/plugins/micromega/csdpcert.ml b/plugins/micromega/csdpcert.ml index 78087c0704..d4e6d920bd 100644 --- a/plugins/micromega/csdpcert.ml +++ b/plugins/micromega/csdpcert.ml @@ -29,7 +29,7 @@ type provername = string * int option let debug = true -let flags = [Open_append;Open_binary;Open_creat] +let flags = [Open_append;Open_binary;Open_creat] let chan = open_out_gen flags 0o666 "trace" @@ -41,7 +41,7 @@ struct let rec expr_to_term = function | PEc z -> Const (C2Ml.q_to_num z) | PEX v -> Var ("x"^(string_of_int (C2Ml.index v))) - | PEmul(p1,p2) -> + | PEmul(p1,p2) -> let p1 = expr_to_term p1 in let p2 = expr_to_term p2 in let res = Mul(p1,p2) in res @@ -51,12 +51,12 @@ struct | PEpow(p,n) -> Pow(expr_to_term p , C2Ml.n n) | PEopp p -> Opp (expr_to_term p) - -end -open M + +end +open M open List -open Mutils +open Mutils @@ -65,29 +65,29 @@ let rec canonical_sum_to_string = function s -> failwith "not implemented" let print_canonical_sum m = Format.print_string (canonical_sum_to_string m) -let print_list_term o l = +let print_list_term o l = output_string o "print_list_term\n"; List.iter (fun (e,k) -> Printf.fprintf o "q: %s %s ;" - (string_of_poly (poly_of_term (expr_to_term e))) - (match k with - Mc.Equal -> "= " - | Mc.Strict -> "> " - | Mc.NonStrict -> ">= " + (string_of_poly (poly_of_term (expr_to_term e))) + (match k with + Mc.Equal -> "= " + | Mc.Strict -> "> " + | Mc.NonStrict -> ">= " | _ -> failwith "not_implemented")) (List.map (fun (e, o) -> Mc.denorm e , o) l) ; output_string o "\n" -let partition_expr l = +let partition_expr l = let rec f i = function | [] -> ([],[],[]) | (e,k)::l -> let (eq,ge,neq) = f (i+1) l in - match k with + match k with | Mc.Equal -> ((e,i)::eq,ge,neq) | Mc.NonStrict -> (eq,(e,Axiom_le i)::ge,neq) - | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *) + | Mc.Strict -> (* e > 0 == e >= 0 /\ e <> 0 *) (eq, (e,Axiom_lt i)::ge,(e,Axiom_lt i)::neq) - | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) + | Mc.NonEqual -> (eq,ge,(e,Axiom_eq i)::neq) (* Not quite sure -- Coq interface has changed *) in f 0 l @@ -96,28 +96,28 @@ let rec sets_of_list l = match l with | [] -> [[]] | e::l -> let s = sets_of_list l in - s@(List.map (fun s0 -> e::s0) s) + s@(List.map (fun s0 -> e::s0) s) (* The exploration is probably not complete - for simple cases, it works... *) let real_nonlinear_prover d l = let l = List.map (fun (e,op) -> (Mc.denorm e,op)) l in - try + try let (eq,ge,neq) = partition_expr l in let rec elim_const = function [] -> [] | (x,y)::l -> let p = poly_of_term (expr_to_term x) in - if poly_isconst p - then elim_const l + if poly_isconst p + then elim_const l else (p,y)::(elim_const l) in let eq = elim_const eq in let peq = List.map fst eq in - - let pge = List.map + + let pge = List.map (fun (e,psatz) -> poly_of_term (expr_to_term e),psatz) ge in - - let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y -> + + let monoids = List.map (fun m -> (List.fold_right (fun (p,kd) y -> let p = poly_of_term (expr_to_term p) in match kd with | Axiom_lt i -> poly_mul p y @@ -125,30 +125,30 @@ let real_nonlinear_prover d l = | _ -> failwith "monoids") m (poly_const (Int 1)) , map snd m)) (sets_of_list neq) in - let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> - list_try_find (fun m -> let (ci,cc) = + let (cert_ideal, cert_cone,monoid) = deepen_until d (fun d -> + list_try_find (fun m -> let (ci,cc) = real_positivnullstellensatz_general false d peq pge (poly_neg (fst m) ) in (ci,cc,snd m)) monoids) 0 in - - let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i)) + + let proofs_ideal = map2 (fun q i -> Eqmul(term_of_poly q,Axiom_eq i)) cert_ideal (List.map snd eq) in let proofs_cone = map term_of_sos cert_cone in - - let proof_ne = - let (neq , lt) = List.partition + + let proof_ne = + let (neq , lt) = List.partition (function Axiom_eq _ -> true | _ -> false ) monoid in - let sq = match - (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq) + let sq = match + (List.map (function Axiom_eq i -> i | _ -> failwith "error") neq) with | [] -> Rational_lt (Int 1) | l -> Monoid l in List.fold_right (fun x y -> Product(x,y)) lt sq in - let proof = list_fold_right_elements + let proof = list_fold_right_elements (fun s t -> Sum(s,t)) (proof_ne :: proofs_ideal @ proofs_cone) in S (Some proof) - with + with | Sos_lib.TooDeep -> S None | x -> F (Printexc.to_string x) @@ -156,17 +156,17 @@ let real_nonlinear_prover d l = let pure_sos l = let l = List.map (fun (e,o) -> Mc.denorm e, o) l in - (* If there is no strict inequality, + (* If there is no strict inequality, I should nonetheless be able to try something - over Z > is equivalent to -1 >= *) - try + try let l = List.combine l (interval 0 (length l -1)) in let (lt,i) = try (List.find (fun (x,_) -> snd x = Mc.Strict) l) with Not_found -> List.hd l in let plt = poly_neg (poly_of_term (expr_to_term (fst lt))) in let (n,polys) = sumofsquares plt in (* n * (ci * pi^2) *) - let pos = Product (Rational_lt n, + let pos = Product (Rational_lt n, List.fold_right (fun (c,p) rst -> Sum (Product (Rational_lt c, Square - (term_of_poly p)), rst)) + (term_of_poly p)), rst)) polys (Rational_lt (Int 0))) in let proof = Sum(Axiom_lt i, pos) in (* let s,proof' = scale_certificate proof in @@ -174,11 +174,11 @@ let pure_sos l = S (Some proof) with (* | Sos.CsdpNotFound -> F "Sos.CsdpNotFound" *) - | x -> (* May be that could be refined *) S None + | x -> (* May be that could be refined *) S None -let run_prover prover pb = +let run_prover prover pb = match prover with | "real_nonlinear_prover", Some d -> real_nonlinear_prover d pb | "pure_sos", None -> pure_sos pb @@ -192,17 +192,17 @@ let output_csdp_certificate o = function let main () = - try + try let (prover,poly) = (input_value stdin : provername * micromega_polys) in let cert = run_prover prover poly in (* Printf.fprintf chan "%a -> %a" print_list_term poly output_csdp_certificate cert ; close_out chan ; *) - + output_value stdout (cert:csdp_certificate); - flush stdout ; + flush stdout ; Marshal.to_channel chan (cert:csdp_certificate) [] ; - flush chan ; - exit 0 + flush chan ; + exit 0 with x -> (Printf.fprintf chan "error %s" (Printexc.to_string x) ; exit 1) ;; diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index c547b3d4ae..6250e324a5 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -8,100 +8,100 @@ let debug = false type ('a,'b) lr = Inl of 'a | Inr of 'b -module Vect = - struct +module Vect = + struct (** [t] is the type of vectors. A vector [(x1,v1) ; ... ; (xn,vn)] is such that: - variables indexes are ordered (x1 < ... < xn - values are all non-zero *) type var = int - type t = (var * num) list + type t = (var * num) list -(** [equal v1 v2 = true] if the vectors are syntactically equal. +(** [equal v1 v2 = true] if the vectors are syntactically equal. ([num] is not handled by [Pervasives.equal] *) - let rec equal v1 v2 = + let rec equal v1 v2 = match v1 , v2 with | [] , [] -> true | [] , _ -> false | _::_ , [] -> false - | (i1,n1)::v1 , (i2,n2)::v2 -> + | (i1,n1)::v1 , (i2,n2)::v2 -> (i1 = i2) && n1 =/ n2 && equal v1 v2 - let hash v = - let rec hash i = function + let hash v = + let rec hash i = function | [] -> i | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in Hashtbl.hash (hash 0 v ) - + let null = [] - let pp_vect o vect = + let pp_vect o vect = List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect - - let from_list (l: num list) = - let rec xfrom_list i l = + + let from_list (l: num list) = + let rec xfrom_list i l = match l with | [] -> [] - | e::l -> - if e <>/ Int 0 + | e::l -> + if e <>/ Int 0 then (i,e)::(xfrom_list (i+1) l) else xfrom_list (i+1) l in - + xfrom_list 0 l let zero_num = Int 0 let unit_num = Int 1 - - - let to_list m = + + + let to_list m = let rec xto_list i l = match l with | [] -> [] - | (x,v)::l' -> + | (x,v)::l' -> if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in xto_list 0 m - + let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst - - let rec update i f t = + + let rec update i f t = match t with | [] -> cons i (f zero_num) [] - | (k,v)::l -> + | (k,v)::l -> match Pervasives.compare i k with | 0 -> cons k (f v) l | -1 -> cons i (f zero_num) t | 1 -> (k,v) ::(update i f l) | _ -> failwith "compare_num" - + let rec set i n t = match t with | [] -> cons i n [] - | (k,v)::l -> + | (k,v)::l -> match Pervasives.compare i k with | 0 -> cons k n l | -1 -> cons i n t | 1 -> (k,v) :: (set i n l) | _ -> failwith "compare_num" - - let gcd m = + + let gcd m = let res = List.fold_left (fun x (i,e) -> Big_int.gcd_big_int x (Utils.numerator e)) Big_int.zero_big_int m in - if Big_int.compare_big_int res Big_int.zero_big_int = 0 + if Big_int.compare_big_int res Big_int.zero_big_int = 0 then Big_int.unit_big_int else res - - let rec mul z t = + + let rec mul z t = match z with | Int 0 -> [] | Int 1 -> t | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t - let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical + let compare : t -> t -> int = Utils.Cmp.compare_list (fun x y -> Utils.Cmp.compare_lexical [ (fun () -> Pervasives.compare (fst x) (fst y)); - (fun () -> compare_num (snd x) (snd y))]) + (fun () -> compare_num (snd x) (snd y))]) (** [tail v vect] returns - [None] if [v] is not a variable of the vector [vect] @@ -109,16 +109,16 @@ module Vect = and [rst] is the remaining of the vector We exploit that vectors are ordered lists *) - let rec tail (v:var) (vect:t) = + let rec tail (v:var) (vect:t) = match vect with | [] -> None - | (v',vl)::vect' -> + | (v',vl)::vect' -> match Pervasives.compare v' v with | 0 -> Some (vl,vect) (* Ok, found *) | -1 -> tail v vect' (* Might be in the tail *) | _ -> None (* Hopeless *) - - let get v vect = + + let get v vect = match tail v vect with | None -> None | Some(vl,_) -> Some vl @@ -134,13 +134,13 @@ module Vect = open Vect (** Implementation of intervals *) -module Itv = -struct - +module Itv = +struct + (** The type of intervals is *) type interval = num option * num option (** None models the absence of bound i.e. infinity *) - (** As a result, + (** As a result, - None , None -> ]-oo,+oo[ - None , Some v -> ]-oo,v] - Some v, None -> [v,+oo[ @@ -148,36 +148,36 @@ struct Intervals needs to be explicitely normalised. *) - type who = Left | Right + type who = Left | Right - (** if then interval [itv] is empty, [norm_itv itv] returns [None] + (** if then interval [itv] is empty, [norm_itv itv] returns [None] otherwise, it returns [Some itv] *) - - let norm_itv itv = + + let norm_itv itv = match itv with | Some a , Some b -> if a <=/ b then Some itv else None | _ -> Some itv - + (** [opp_itv itv] computes the opposite interval *) - let opp_itv itv = + let opp_itv itv = let (l,r) = itv in (map_option minus_num r, map_option minus_num l) - + (** [inter i1 i2 = None] if the intersection of intervals is empty [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) - let inter i1 i2 = + let inter i1 i2 = let (l1,r1) = i1 and (l2,r2) = i2 in - - let inter f o1 o2 = + + let inter f o1 o2 = match o1 , o2 with | None , None -> None | Some _ , None -> o1 - | None , Some _ -> o2 + | None , Some _ -> o2 | Some n1 , Some n2 -> Some (f n1 n2) in norm_itv (inter max_num l1 l2 , inter min_num r1 r2) @@ -185,9 +185,9 @@ struct let range = function | None,_ | _,None -> None | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) - - let smaller_itv i1 i2 = + + let smaller_itv i1 i2 = match range i1 , range i2 with | None , _ -> false | _ , None -> true @@ -204,7 +204,7 @@ let in_bound bnd v = | Some a , Some b -> a <=/ v && v <=/ b end -open Itv +open Itv type vector = Vect.t type cstr = { coeffs : vector ; bound : interval } @@ -220,22 +220,22 @@ module PSet = ISet module System = Hashtbl.Make(Vect) - type proof = - | Hyp of int + type proof = + | Hyp of int | Elim of var * proof * proof | And of proof * proof -type system = { - sys : cstr_info ref System.t ; +type system = { + sys : cstr_info ref System.t ; vars : ISet.t -} -and cstr_info = { +} +and cstr_info = { bound : interval ; prf : proof ; pos : int ; - neg : int ; + neg : int ; } @@ -247,85 +247,85 @@ and cstr_info = { When a new constraint c is computed by a function f(c1,...,cn), its proof_idx is ISet.fold union (List.map (fun x -> x.proof_idx) [c1;...;cn] - [pos] is the number of positive values of the vector - [neg] is the number of negative values of the vector - ( [neg] + [pos] is therefore the length of the vector) + ( [neg] + [pos] is therefore the length of the vector) [v] is an upper-bound of the set of variables which appear in [s]. *) (** To be thrown when a system has no solution *) exception SystemContradiction of proof -let hyps prf = - let rec hyps prf acc = +let hyps prf = + let rec hyps prf acc = match prf with | Hyp i -> ISet.add i acc - | Elim(_,prf1,prf2) + | Elim(_,prf1,prf2) | And(prf1,prf2) -> hyps prf1 (hyps prf2 acc) in hyps prf ISet.empty (** Pretty printing *) - let rec pp_proof o prf = + let rec pp_proof o prf = match prf with | Hyp i -> Printf.fprintf o "H%i" i | Elim(v, prf1,prf2) -> Printf.fprintf o "E(%i,%a,%a)" v pp_proof prf1 pp_proof prf2 | And(prf1,prf2) -> Printf.fprintf o "A(%a,%a)" pp_proof prf1 pp_proof prf2 - + let pp_bound o = function | None -> output_string o "oo" | Some a -> output_string o (string_of_num a) let pp_itv o (l,r) = Printf.fprintf o "(%a,%a)" pp_bound l pp_bound r -let rec pp_list f o l = +let rec pp_list f o l = match l with | [] -> () | e::l -> f o e ; output_string o ";" ; pp_list f o l -let pp_iset o s = +let pp_iset o s = output_string o "{" ; ISet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); - output_string o "}" + output_string o "}" -let pp_pset o s = +let pp_pset o s = output_string o "{" ; PSet.fold (fun i _ -> Printf.fprintf o "%i " i) s (); - output_string o "}" + output_string o "}" let pp_info o i = pp_itv o i.bound -let pp_cstr o (vect,bnd) = +let pp_cstr o (vect,bnd) = let (l,r) = bnd in (match l with | None -> () | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) ; - pp_vect o vect ; + pp_vect o vect ; (match r with | None -> output_string o"\n" | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) -let pp_system o sys= - System.iter (fun vect ibnd -> +let pp_system o sys= + System.iter (fun vect ibnd -> pp_cstr o (vect,(!ibnd).bound)) sys -let pp_split_cstr o (vl,v,c,_) = +let pp_split_cstr o (vl,v,c,_) = Printf.fprintf o "(val x = %s ,%a,%s)" (string_of_num vl) pp_vect v (string_of_num c) (** [merge_cstr_info] takes: - - the intersection of bounds and + - the intersection of bounds and - the union of proofs - [pos] and [neg] fields should be identical *) -let merge_cstr_info i1 i2 = +let merge_cstr_info i1 i2 = let { pos = p1 ; neg = n1 ; bound = i1 ; prf = prf1 } = i1 and { pos = p2 ; neg = n2 ; bound = i2 ; prf = prf2 } = i2 in - assert (p1 = p2 && n1 = n2) ; + assert (p1 = p2 && n1 = n2) ; match inter i1 i2 with | None -> None (* Could directly raise a system contradiction exception *) - | Some bnd -> + | Some bnd -> Some { pos = p1 ; neg = n1 ; bound = bnd ; prf = And(prf1,prf2) } (** [xadd_cstr vect cstr_info] loads an constraint into the system. @@ -333,18 +333,18 @@ let merge_cstr_info i1 i2 = @raise SystemContradiction if [cstr_info] returns [None] *) -let xadd_cstr vect cstr_info sys = - if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ; - try +let xadd_cstr vect cstr_info sys = + if debug && System.length sys mod 1000 = 0 then (print_string "*" ; flush stdout) ; + try let info = System.find sys vect in match merge_cstr_info cstr_info !info with | None -> raise (SystemContradiction (And(cstr_info.prf, (!info).prf))) | Some info' -> info := info' - with + with | Not_found -> System.replace sys vect (ref cstr_info) -type cstr_ext = +type cstr_ext = | Contradiction (** The constraint is contradictory. Typically, a [SystemContradiction] exception will be raised. *) | Redundant (** The constrain is redundant. @@ -353,16 +353,16 @@ type cstr_ext = Typically, it will be added to the constraint system. *) (** [normalise_cstr] : vector -> cstr_info -> cstr_ext *) -let normalise_cstr vect cinfo = +let normalise_cstr vect cinfo = match norm_itv cinfo.bound with | None -> Contradiction - | Some (l,r) -> + | Some (l,r) -> match vect with | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction | (_,n)::_ -> Cstr( - (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), + (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), let divn x = x // n in - if sign_num n = 1 + if sign_num n = 1 then{cinfo with bound = (map_option divn l , map_option divn r) } else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (map_option divn r , map_option divn l)}) @@ -378,21 +378,21 @@ let eval_op = function | Eq -> (=/) | Ge -> (>=/) -let count v = +let count v = let rec count n p v = match v with | [] -> (n,p) - | (_,vl)::v -> let sg = sign_num vl in - assert (sg <> 0) ; + | (_,vl)::v -> let sg = sign_num vl in + assert (sg <> 0) ; if sg = 1 then count n (p+1) v else count (n+1) p v in count 0 0 v let norm_cstr {coeffs = v ; op = o ; cst = c} idx = - let (n,p) = count v in + let (n,p) = count v in - normalise_cstr v {pos = p ; neg = n ; bound = - (match o with + normalise_cstr v {pos = p ; neg = n ; bound = + (match o with | Eq -> Some c , Some c | Ge -> Some c , None) ; prf = Hyp idx } @@ -402,60 +402,60 @@ let norm_cstr {coeffs = v ; op = o ; cst = c} idx = @return a system of constraints @raise SystemContradiction if a contradiction is found *) -let load_system l = - +let load_system l = + let sys = System.create 1000 in - + let li = Mutils.mapi (fun e i -> (e,i)) l in - let vars = List.fold_left (fun vrs (cstr,i) -> + let vars = List.fold_left (fun vrs (cstr,i) -> match norm_cstr cstr i with | Contradiction -> raise (SystemContradiction (Hyp i)) | Redundant -> vrs - | Cstr(vect,info) -> + | Cstr(vect,info) -> xadd_cstr vect info sys ; List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in {sys = sys ;vars = vars} -let system_list sys = - let { sys = s ; vars = v } = sys in - System.fold (fun k bi l -> (k, !bi)::l) s [] +let system_list sys = + let { sys = s ; vars = v } = sys in + System.fold (fun k bi l -> (k, !bi)::l) s [] -(** [add (v1,c1) (v2,c2) ] +(** [add (v1,c1) (v2,c2) ] precondition: (c1 <>/ Int 0 && c2 <>/ Int 0) - @return a pair [(v,ln)] such that + @return a pair [(v,ln)] such that [v] is the sum of vector [v1] divided by [c1] and vector [v2] divided by [c2] Note that the resulting vector is not normalised. *) -let add (v1,c1) (v2,c2) = +let add (v1,c1) (v2,c2) = assert (c1 <>/ Int 0 && c2 <>/ Int 0) ; - let rec xadd v1 v2 = + let rec xadd v1 v2 = match v1 , v2 with - | (x1,n1)::v1' , (x2,n2)::v2' -> - if x1 = x2 - then + | (x1,n1)::v1' , (x2,n2)::v2' -> + if x1 = x2 + then let n' = (n1 // c1) +/ (n2 // c2) in - if n' =/ Int 0 then xadd v1' v2' - else + if n' =/ Int 0 then xadd v1' v2' + else let res = xadd v1' v2' in (x1,n') ::res else if x1 < x2 then let res = xadd v1' v2 in - (x1, n1 // c1)::res + (x1, n1 // c1)::res else let res = xadd v1 v2' in (x2, n2 // c2)::res | [] , [] -> [] | [] , _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2 | _ , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in - + let res = xadd v1 v2 in (res, count res) -let add (v1,c1) (v2,c2) = +let add (v1,c1) (v2,c2) = let res = add (v1,c1) (v2,c2) in (* Printf.printf "add(%a,%s,%a,%s) -> %a\n" pp_vect v1 (string_of_num c1) pp_vect v2 (string_of_num c2) pp_vect (fst res) ;*) res @@ -464,27 +464,27 @@ type tlr = (num * vector * cstr_info) list type tm = (vector * cstr_info ) list (** To perform Fourier elimination, constraints are categorised depending on the sign of the variable to eliminate. *) - + (** [split x vect info (l,m,r)] @param v is the variable to eliminate - @param l contains constraints such that (e + a*x) // a >= c / a + @param l contains constraints such that (e + a*x) // a >= c / a @param r contains constraints such that (e + a*x) // - a >= c / -a @param m contains constraints which do not mention [x] *) let split x (vect: vector) info (l,m,r) = - match get x vect with + match get x vect with | None -> (* The constraint does not mention [x], store it in m *) - (l,(vect,info)::m,r) + (l,(vect,info)::m,r) | Some vl -> (* otherwise *) - let cons_bound lst bd = + let cons_bound lst bd = match bd with | None -> lst | Some bnd -> (vl,vect,{info with bound = Some bnd,None})::lst in - + let lb,rb = info.bound in - if sign_num vl = 1 + if sign_num vl = 1 then (cons_bound l lb,m,cons_bound r rb) else (* sign_num vl = -1 *) (cons_bound l rb,m,cons_bound r lb) @@ -493,36 +493,36 @@ let split x (vect: vector) info (l,m,r) = (** [project vr sys] projects system [sys] over the set of variables [ISet.remove vr sys.vars ]. This is a one step Fourier elimination. *) -let project vr sys = - +let project vr sys = + let (l,m,r) = System.fold (fun vect rf l_m_r -> split vr vect !rf l_m_r) sys.sys ([],[],[]) in let new_sys = System.create (System.length sys.sys) in - + (* Constraints in [m] belong to the projection - for those [vr] is already projected out *) List.iter (fun (vect,info) -> System.replace new_sys vect (ref info) ) m ; - let elim (v1,vect1,info1) (v2,vect2,info2) = + let elim (v1,vect1,info1) (v2,vect2,info2) = let {neg = n1 ; pos = p1 ; bound = bound1 ; prf = prf1} = info1 and {neg = n2 ; pos = p2 ; bound = bound2 ; prf = prf2} = info2 in - let bnd1 = from_option (fst bound1) + let bnd1 = from_option (fst bound1) and bnd2 = from_option (fst bound2) in let bound = (bnd1 // v1) +/ (bnd2 // minus_num v2) in let vres,(n,p) = add (vect1,v1) (vect2,minus_num v2) in (vres,{neg = n ; pos = p ; bound = (Some bound, None); prf = Elim(vr,info1.prf,info2.prf)}) in - List.iter(fun l_elem -> List.iter (fun r_elem -> + List.iter(fun l_elem -> List.iter (fun r_elem -> let (vect,info) = elim l_elem r_elem in match normalise_cstr vect info with | Redundant -> () | Contradiction -> raise (SystemContradiction info.prf) | Cstr(vect,info) -> xadd_cstr vect info new_sys) r ) l; {sys = new_sys ; vars = ISet.remove vr sys.vars} - + (** [project_using_eq] performs elimination by pivoting using an equation. - This is the counter_part of the [elim] sub-function of [!project]. + This is the counter_part of the [elim] sub-function of [!project]. @param vr is the variable to be used as pivot @param c is the coefficient of variable [vr] in vector [vect] @param len is the length of the equation @@ -530,42 +530,42 @@ let project vr sys = @param prf is the proof of the equation *) -let project_using_eq vr c vect bound prf (vect',info') = +let project_using_eq vr c vect bound prf (vect',info') = match get vr vect' with - | Some c2 -> + | Some c2 -> let c1 = if c2 >=/ Int 0 then minus_num c else c in - + let c2 = abs_num c2 in - + let (vres,(n,p)) = add (vect,c1) (vect', c2) in - + let cst = bound // c1 in - - let bndres = + + let bndres = let f x = cst +/ x // c2 in let (l,r) = info'.bound in (map_option f l , map_option f r) in - + (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) | None -> (vect',info') let elim_var_using_eq vr vect cst prf sys = let c = from_option (get vr vect) in - + let elim_var = project_using_eq vr c vect cst prf in let new_sys = System.create (System.length sys.sys) in - System.iter(fun vect iref -> + System.iter(fun vect iref -> let (vect',info') = elim_var (vect,!iref) in match normalise_cstr vect' info' with | Redundant -> () | Contradiction -> raise (SystemContradiction info'.prf) - | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ; - + | Cstr(vect,info') -> xadd_cstr vect info' new_sys) sys.sys ; + {sys = new_sys ; vars = ISet.remove vr sys.vars} - + (** [size sys] computes the number of entries in the system of constraints *) let size sys = System.fold (fun v iref s -> s + (!iref).neg + (!iref).pos) sys 0 @@ -577,23 +577,23 @@ let pp_map o map = IMap.fold (fun k elt () -> Printf.fprintf o "%i -> %s\n" k (s If [map] binds all the variables of [vect], we get [eval_vect map [(x1,v1);...;(xn,vn)] = (IMap.find x1 map * v1) + ... + (IMap.find xn map) * vn , []] The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *) - -let eval_vect map vect = - let rec xeval_vect vect sum rst = + +let eval_vect map vect = + let rec xeval_vect vect sum rst = match vect with | [] -> (sum,rst) - | (v,vl)::vect -> - try + | (v,vl)::vect -> + try let val_v = IMap.find v map in xeval_vect vect (sum +/ (val_v */ vl)) rst with Not_found -> xeval_vect vect sum ((v,vl)::rst) in xeval_vect vect (Int 0) [] - + (** [restrict_bound n sum itv] returns the interval of [x] given that (fst itv) <= x * n + sum <= (snd itv) *) -let restrict_bound n sum (itv:interval) = +let restrict_bound n sum (itv:interval) = let f x = (x -/ sum) // n in let l,r = itv in match sign_num n with @@ -606,8 +606,8 @@ let restrict_bound n sum (itv:interval) = (** [bound_of_variable map v sys] computes the interval of [v] in [sys] given a mapping [map] binding all the other variables *) -let bound_of_variable map v sys = - System.fold (fun vect iref bnd -> +let bound_of_variable map v sys = + System.fold (fun vect iref bnd -> let sum,rst = eval_vect map vect in let vl = match get v rst with | None -> Int 0 @@ -618,53 +618,53 @@ let bound_of_variable map v sys = (** [pick_small_value bnd] picks a value being closed to zero within the interval *) -let pick_small_value bnd = +let pick_small_value bnd = match bnd with | None , None -> Int 0 | None , Some i -> if (Int 0) <=/ (floor_num i) then Int 0 else floor_num i | Some i,None -> if i <=/ (Int 0) then Int 0 else ceiling_num i - | Some i,Some j -> - if i <=/ Int 0 && Int 0 <=/ j + | Some i,Some j -> + if i <=/ Int 0 && Int 0 <=/ j then Int 0 - else if ceiling_num i <=/ floor_num j + else if ceiling_num i <=/ floor_num j then ceiling_num i (* why not *) else i -(** [solution s1 sys_l = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)] +(** [solution s1 sys_l = Some(sn,[(vn-1,sn-1);...; (v1,s1)]@sys_l)] then [sn] is a system which contains only [black_v] -- if it existed in [s1] - and [sn+1] is obtained by projecting [vn] out of [sn] - @raise SystemContradiction if system [s] has no solution + and [sn+1] is obtained by projecting [vn] out of [sn] + @raise SystemContradiction if system [s] has no solution *) -let solve_sys black_v choose_eq choose_variable sys sys_l = +let solve_sys black_v choose_eq choose_variable sys sys_l = - let rec solve_sys sys sys_l = + let rec solve_sys sys sys_l = if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys); - + let eqs = choose_eq sys in - try + try let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in - if debug then + if debug then (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ; flush stdout); let sys' = elim_var_using_eq v vect cst ln sys in - solve_sys sys' ((v,sys)::sys_l) - with Not_found -> + solve_sys sys' ((v,sys)::sys_l) + with Not_found -> let vars = choose_variable sys in - try + try let (v,est) = (List.find (fun (v,_) -> v <> black_v) vars) in - if debug then (Printf.printf "\nV : %i esimate %f\n" v est ; flush stdout) ; + if debug then (Printf.printf "\nV : %i esimate %f\n" v est ; flush stdout) ; let sys' = project v sys in - solve_sys sys' ((v,sys)::sys_l) + solve_sys sys' ((v,sys)::sys_l) with Not_found -> (* we are done *) Inl (sys,sys_l) in solve_sys sys sys_l -let solve black_v choose_eq choose_variable cstrs = +let solve black_v choose_eq choose_variable cstrs = - try + try let sys = load_system cstrs in (* Printf.printf "solve :\n %a" pp_system sys.sys ; *) solve_sys black_v choose_eq choose_variable sys [] @@ -675,22 +675,22 @@ let solve black_v choose_eq choose_variable cstrs = The output is an ordered list of (variable,cost). *) -module EstimateElimVar = +module EstimateElimVar = struct type sys_list = (vector * cstr_info) list let abstract_partition (v:int) (l: sys_list) = - let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) = + let rec xpart (l:sys_list) (ltl:sys_list) (n:int list) (z:int) (p:int list) = match l with | [] -> (ltl, n,z,p) - | (l1,info) ::rl -> + | (l1,info) ::rl -> match l1 with | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p - | (vr,vl)::rl1 -> + | (vr,vl)::rl1 -> if v = vr then - let cons_bound lst bd = + let cons_bound lst bd = match bd with | None -> lst | Some bnd -> info.neg+info.pos::lst in @@ -701,7 +701,7 @@ struct else xpart rl ((rl1,info)::ltl) (cons_bound n rb) z (cons_bound p lb) else (* the variable is greater *) - xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p + xpart rl ((l1,info)::ltl) n (info.neg+info.pos+z) p in let (sys',n,z,p) = xpart l [] [] 0 [] in @@ -711,72 +711,72 @@ struct let lp = float_of_int (List.length p) in let sp = float_of_int (List.fold_left (+) 0 p) in (sys', float_of_int z +. lp *. sn +. ln *. sp -. lp*.ln) - - + + let choose_variable sys = let {sys = s ; vars = v} = sys in - + let sl = system_list sys in let evals = fst (ISet.fold (fun v (eval,s) -> let ts,vl = abstract_partition v s in ((v,vl)::eval, ts)) v ([],sl)) in - + List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) evals -end +end open EstimateElimVar (** The module [EstimateElimEq] is similar to [EstimateElimVar] but it orders equations. *) module EstimateElimEq = -struct - - let itv_point bnd = +struct + + let itv_point bnd = match bnd with |(Some a, Some b) -> a =/ b | _ -> false - let eq_bound bnd c = + let eq_bound bnd c = match bnd with |(Some a, Some b) -> a =/ b && c =/ b | _ -> false - - let rec unroll_until v l = + + let rec unroll_until v l = match l with | [] -> (false,[]) - | (i,_)::rl -> if i = v - then (true,rl) + | (i,_)::rl -> if i = v + then (true,rl) else if i < v then unroll_until v rl else (false,l) - let choose_primal_equation eqs sys_l = + let choose_primal_equation eqs sys_l = - let is_primal_equation_var v = - List.fold_left (fun (nb_eq,nb_cst) (vect,info) -> - if fst (unroll_until v vect) + let is_primal_equation_var v = + List.fold_left (fun (nb_eq,nb_cst) (vect,info) -> + if fst (unroll_until v vect) then if itv_point info.bound then (nb_eq + 1,nb_cst) else (nb_eq,nb_cst) else (nb_eq,nb_cst)) (0,0) sys_l in - let rec find_var vect = + let rec find_var vect = match vect with | [] -> None - | (i,_)::vect -> + | (i,_)::vect -> let (nb_eq,nb_cst) = is_primal_equation_var i in if nb_eq = 2 && nb_cst = 0 then Some i else find_var vect in - let rec find_eq_var eqs = + let rec find_eq_var eqs = match eqs with | [] -> None - | (vect,a,prf,ln)::l -> - match find_var vect with + | (vect,a,prf,ln)::l -> + match find_var vect with | None -> find_eq_var l - | Some r -> Some (r,vect,a,prf,ln) + | Some r -> Some (r,vect,a,prf,ln) in - + find_eq_var eqs @@ -787,33 +787,33 @@ struct let sys_l = system_list sys in - let equalities = List.fold_left - (fun l (vect,info) -> + let equalities = List.fold_left + (fun l (vect,info) -> match info.bound with - | Some a , Some b -> + | Some a , Some b -> if a =/ b then (* This an equation *) (vect,a,info.prf,info.neg+info.pos)::l else l | _ -> l ) [] sys_l in - let rec estimate_cost v ct sysl acc tlsys = + let rec estimate_cost v ct sysl acc tlsys = match sysl with | [] -> (acc,tlsys) | (l,info)::rsys -> let ln = info.pos + info.neg in let (b,l) = unroll_until v l in match b with - | true -> - if itv_point info.bound + | true -> + if itv_point info.bound then estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) (* this is free *) else estimate_cost v ct rsys (acc+ln+ct) ((l,info)::tlsys) (* should be more ? *) | false -> estimate_cost v ct rsys (acc+ln) ((l,info)::tlsys) in match choose_primal_equation equalities sys_l with - | None -> - let cost_eq eq const prf ln acc_costs = - - let rec cost_eq eqr sysl costs = + | None -> + let cost_eq eq const prf ln acc_costs = + + let rec cost_eq eqr sysl costs = match eqr with | [] -> costs | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in @@ -823,7 +823,7 @@ struct let all_costs = List.fold_left (fun all_costs (vect,const,prf,ln) -> cost_eq vect const prf ln all_costs) [] equalities in (* pp_list (fun o ((v,eq,_,_),cst) -> Printf.fprintf o "((%i,%a),%i)\n" v pp_vect eq cst) stdout all_costs ; *) - + List.sort (fun x y -> Pervasives.compare (snd x) (snd y) ) all_costs | Some (v,vect, const,prf,_) -> [(v,vect,const,prf),0] @@ -834,33 +834,33 @@ open EstimateElimEq module Fourier = struct - let optimise vect l = + let optimise vect l = (* We add a dummy (fresh) variable for vector *) - let fresh = + let fresh = List.fold_left (fun fr c -> Pervasives.max fr (Vect.fresh c.coeffs)) 0 l in let cstr = { - coeffs = Vect.set fresh (Int (-1)) vect ; - op = Eq ; + coeffs = Vect.set fresh (Int (-1)) vect ; + op = Eq ; cst = (Int 0)} in match solve fresh choose_equality_var choose_variable (cstr::l) with | Inr prf -> None (* This is an unsatisfiability proof *) - | Inl (s,_) -> - try + | Inl (s,_) -> + try Some (bound_of_variable IMap.empty fresh s.sys) with x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x) ; None - let find_point cstrs = - + let find_point cstrs = + match solve max_int choose_equality_var choose_variable cstrs with | Inr prf -> Inr prf - | Inl (_,l) -> - - let rec rebuild_solution l map = + | Inl (_,l) -> + + let rec rebuild_solution l map = match l with | [] -> map - | (v,e)::l -> + | (v,e)::l -> let itv = bound_of_variable map v e.sys in let map = IMap.add v (pick_small_value itv) map in rebuild_solution l map @@ -877,9 +877,9 @@ end module Proof = -struct - - +struct + + (** A proof term in the sense of a ZMicromega.RatProof is a positive combination of the hypotheses which leads to a contradiction. @@ -893,49 +893,49 @@ struct let forall_pairs f l1 l2 = List.fold_left (fun acc e1 -> - List.fold_left (fun acc e2 -> + List.fold_left (fun acc e2 -> match f e1 e2 with | None -> acc | Some v -> v::acc) acc l2) [] l1 - let add_op x y = + let add_op x y = match x , y with | Eq , Eq -> Eq | _ -> Ge - let pivot v (p1,c1) (p2,c2) = + let pivot v (p1,c1) (p2,c2) = let {coeffs = v1 ; op = op1 ; cst = n1} = c1 and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in - + match Vect.get v v1 , Vect.get v v2 with | None , _ | _ , None -> None - | Some a , Some b -> + | Some a , Some b -> if (sign_num a) * (sign_num b) = -1 - then Some (add (p1,abs_num a) (p2,abs_num b) , - {coeffs = add (v1,abs_num a) (v2,abs_num b) ; + then Some (add (p1,abs_num a) (p2,abs_num b) , + {coeffs = add (v1,abs_num a) (v2,abs_num b) ; op = add_op op1 op2 ; cst = n1 // (abs_num a) +/ n2 // (abs_num b) }) else if op1 = Eq - then Some (add (p1,minus_num (a // b)) (p2,Int 1), - {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ; + then Some (add (p1,minus_num (a // b)) (p2,Int 1), + {coeffs = add (v1,minus_num (a// b)) (v2 ,Int 1) ; op = add_op op1 op2; cst = n1 // (minus_num (a// b)) +/ n2 // (Int 1)}) else if op2 = Eq then - Some (add (p2,minus_num (b // a)) (p1,Int 1), - {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ; + Some (add (p2,minus_num (b // a)) (p1,Int 1), + {coeffs = add (v2,minus_num (b// a)) (v1 ,Int 1) ; op = add_op op1 op2; cst = n2 // (minus_num (b// a)) +/ n1 // (Int 1)}) - else None (* op2 could be Eq ... this might happen *) - + else None (* op2 could be Eq ... this might happen *) + - let normalise_proofs l = - List.fold_left (fun acc (prf,cstr) -> + let normalise_proofs l = + List.fold_left (fun acc (prf,cstr) -> match acc with | Inr _ -> acc (* I already found a contradiction *) - | Inl acc -> + | Inl acc -> match norm_cstr cstr 0 with | Redundant -> Inl acc | Contradiction -> Inr (prf,cstr) @@ -944,11 +944,11 @@ struct type oproof = (vector * cstr_compat * num) option - let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = + let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = let (l,r) = info.bound in - let keep p ob bd = - match ob , bd with + let keep p ob bd = + match ob , bd with | None , None -> None | None , Some b -> Some(prf,cstr,b) | Some _ , None -> ob @@ -959,24 +959,24 @@ struct (* Now, there might be a contradiction *) match oleft , oright with | None , _ | _ , None -> Inl (oleft,oright) - | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) -> - if l <=/ r + | Some(prfl,cstrl,l) , Some(prfr,cstrr,r) -> + if l <=/ r then Inl (oleft,oright) else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) match cstrr.coeffs with | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) - | (v,_)::_ -> + | (v,_)::_ -> match pivot v (prfl,cstrl) (prfr,cstrr) with | None -> failwith "merge_proof : pivot is not possible" | Some x -> Inr x -let mk_proof hyps prf = +let mk_proof hyps prf = (* I am keeping list - I might have a proof for the left bound and a proof for the right bound. If I perform aggressive elimination of redundancies, I expect the list to be of length at most 2. For each proof list, all the vectors should be of the form a.v for different constants a. *) - let rec mk_proof prf = + let rec mk_proof prf = match prf with | Hyp i -> [ ([i, Int 1] , List.nth hyps i) ] @@ -985,15 +985,15 @@ let mk_proof hyps prf = and prfsr = mk_proof prf2 in (* I take only the pairs for which the elimination is meaningfull *) forall_pairs (pivot v) prfsl prfsr - | And(prf1,prf2) -> - let prfsl1 = mk_proof prf1 + | And(prf1,prf2) -> + let prfsl1 = mk_proof prf1 and prfsl2 = mk_proof prf2 in (* detect trivial redundancies and contradictions *) match normalise_proofs (prfsl1@prfsl2) with | Inr x -> [x] (* This is a contradiction - this should be the end of the proof *) | Inl l -> (* All the vectors are the same *) - let prfs = - List.fold_left (fun acc e -> + let prfs = + List.fold_left (fun acc e -> match acc with | Inr _ -> acc (* I have a contradiction *) | Inl (oleft,oright) -> merge_proof oleft e oright) (Inl(None,None)) l in @@ -1008,5 +1008,5 @@ let mk_proof hyps prf = mk_proof prf -end +end diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index d884f26598..5c45c8f5fa 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -803,7 +803,7 @@ let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with (match q0 with | Pc c -> q0 | Pinj (j', q1) -> Pinj ((pplus XH j'), q1) - | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i' + | PX (p3, p4, p5) -> Pinj (XH, q0)) p')) i' (p0 cO)) (mkPX cO ceqb (pmulI cO cI cmul ceqb (fun x x0 -> @@ -1599,16 +1599,16 @@ let rec zChecker l = function (match op4 with | NonStrict -> if is_pol_Z0 (padd1 e1 e2) - then + then let rec label pfs lb ub = - + match pfs with - | + | [] -> if z_gt_dec lb ub then true else false - | + | pf1 :: rsr -> (&&) (zChecker diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index a0158b1567..ec06fa58bb 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -14,25 +14,25 @@ let debug = false -let finally f rst = - try +let finally f rst = + try let res = f () in rst () ; res - with x -> - (try rst () + with x -> + (try rst () with _ -> raise x ); raise x -let map_option f x = +let map_option f x = match x with | None -> None | Some v -> Some (f v) let from_option = function | None -> failwith "from_option" - | Some v -> v + | Some v -> v -let rec try_any l x = +let rec try_any l x = match l with | [] -> None | (f,s)::l -> match f x with @@ -40,20 +40,20 @@ let rec try_any l x = | x -> x let iteri f l = - let rec xiter i l = + let rec xiter i l = match l with | [] -> () | e::l -> f i e ; xiter (i+1) l in xiter 0 l let mapi f l = - let rec xmap i l = + let rec xmap i l = match l with | [] -> [] | e::l -> (f i e)::xmap (i+1) l in xmap 0 l -let rec map3 f l1 l2 l3 = +let rec map3 f l1 l2 l3 = match l1 , l2 ,l3 with | [] , [] , [] -> [] | e1::l1 , e2::l2 , e3::l3 -> (f e1 e2 e3)::(map3 f l1 l2 l3) @@ -61,14 +61,14 @@ let rec map3 f l1 l2 l3 = -let rec is_sublist l1 l2 = +let rec is_sublist l1 l2 = match l1 ,l2 with | [] ,_ -> true | e::l1', [] -> false - | e::l1' , e'::l2' -> + | e::l1' , e'::l2' -> if e = e' then is_sublist l1' l2' else is_sublist l1 l2' - + let list_try_find f = @@ -85,16 +85,16 @@ let rec list_fold_right_elements f l = | x::l -> f x (aux l) in aux l -let interval n m = +let interval n m = let rec interval_n (l,m) = if n > m then l else interval_n (m::l,pred m) - in + in interval_n ([],m) open Num open Big_int -let ppcm x y = +let ppcm x y = let g = gcd_big_int x y in let x' = div_big_int x g in let y' = div_big_int y g in @@ -115,26 +115,26 @@ let rec ppcm_list c l = | [] -> c | e::l -> ppcm_list (ppcm c (denominator e)) l -let rec rec_gcd_list c l = +let rec rec_gcd_list c l = match l with | [] -> c | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l -let rec gcd_list l = +let rec gcd_list l = let res = rec_gcd_list zero_big_int l in - if compare_big_int res zero_big_int = 0 + if compare_big_int res zero_big_int = 0 then unit_big_int else res - - - -let rats_to_ints l = + + + +let rats_to_ints l = let c = ppcm_list unit_big_int l in - List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) + List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) (denominator x))) l - + (* Nasty reordering of lists - useful to trim certificate down *) let mapi f l = - let rec xmapi i l = + let rec xmapi i l = match l with | [] -> [] | e::l -> (f e i)::(xmapi (i+1) l) in @@ -146,11 +146,11 @@ let concatMapi f l = List.rev (mapi (fun e i -> (i,f e)) l) (* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) let assoc_pos j l = (mapi (fun e i -> e,i+j) l, j + (List.length l)) -let assoc_pos_assoc l = +let assoc_pos_assoc l = let rec xpos i l = match l with | [] -> [] - | (x,l) ::rst -> let (l',j) = assoc_pos i l in + | (x,l) ::rst -> let (l',j) = assoc_pos i l in (x,l')::(xpos j rst) in xpos 0 l @@ -159,7 +159,7 @@ let filter_pos f l = let rec xfilter l = match l with | [] -> [] - | (x,e)::l -> + | (x,e)::l -> if List.exists (fun ee -> List.mem ee f) (List.map snd e) then (x,e)::(xfilter l) else xfilter l in @@ -169,11 +169,11 @@ let select_pos lpos l = let rec xselect i lpos l = match lpos with | [] -> [] - | j::rpos -> + | j::rpos -> match l with | [] -> failwith "select_pos" - | e::l -> - if i = j + | e::l -> + if i = j then e:: (xselect (i+1) rpos l) else xselect (i+1) lpos l in xselect 0 lpos l @@ -188,7 +188,7 @@ struct | S n -> (nat n) + 1 - let rec positive p = + let rec positive p = match p with | XH -> 1 | XI p -> 1+ 2*(positive p) @@ -208,7 +208,7 @@ struct | XO i -> 2*(index i) - let z x = + let z x = match x with | Z0 -> 0 | Zpos p -> (positive p) @@ -223,7 +223,7 @@ struct | XO p -> (mult_int_big_int 2 (positive_big_int p)) - let z_big_int x = + let z_big_int x = match x with | Z0 -> zero_big_int | Zpos p -> (positive_big_int p) @@ -232,9 +232,9 @@ struct let num x = Num.Big_int (z_big_int x) - let q_to_num {qnum = x ; qden = y} = + let q_to_num {qnum = x ; qden = y} = Big_int (z_big_int x) // (Big_int (z_big_int (Zpos y))) - + end @@ -252,8 +252,8 @@ struct else if n land 1 = 1 then XI (positive (n lsr 1)) else XO (positive (n lsr 1)) - let n nt = - if nt < 0 + let n nt = + if nt < 0 then assert false else if nt = 0 then N0 else Npos (positive nt) @@ -264,47 +264,47 @@ struct else XO (index (n lsr 1)) - let idx n = + let idx n = (*a.k.a path_of_int *) (* returns the list of digits of n in reverse order with initial 1 removed *) let rec digits_of_int n = - if n=1 then [] + if n=1 then [] else (n mod 2 = 1)::(digits_of_int (n lsr 1)) in - List.fold_right + List.fold_right (fun b c -> (if b then XI c else XO c)) (List.rev (digits_of_int n)) (XH) - let z x = + let z x = match compare x 0 with | 0 -> Z0 | 1 -> Zpos (positive x) | _ -> (* this should be -1 *) - Zneg (positive (-x)) + Zneg (positive (-x)) open Big_int - let positive_big_int n = - let two = big_int_of_int 2 in - let rec _pos n = + let positive_big_int n = + let two = big_int_of_int 2 in + let rec _pos n = if eq_big_int n unit_big_int then XH else let (q,m) = quomod_big_int n two in - if eq_big_int unit_big_int m + if eq_big_int unit_big_int m then XI (_pos q) else XO (_pos q) in _pos n - let bigint x = + let bigint x = match sign_big_int x with | 0 -> Z0 | 1 -> Zpos (positive_big_int x) | _ -> Zneg (positive_big_int (minus_big_int x)) - let q n = - {Micromega.qnum = bigint (numerator n) ; + let q n = + {Micromega.qnum = bigint (numerator n) ; Micromega.qden = positive_big_int (denominator n)} end @@ -312,23 +312,23 @@ end module Cmp = struct - let rec compare_lexical l = + let rec compare_lexical l = match l with | [] -> 0 (* Equal *) - | f::l -> + | f::l -> let cmp = f () in if cmp = 0 then compare_lexical l else cmp - let rec compare_list cmp l1 l2 = + let rec compare_list cmp l1 l2 = match l1 , l2 with | [] , [] -> 0 | [] , _ -> -1 | _ , [] -> 1 - | e1::l1 , e2::l2 -> + | e1::l1 , e2::l2 -> let c = cmp e1 e2 in if c = 0 then compare_list cmp l1 l2 else c - - let hash_list hash l = + + let hash_list hash l = let rec _hash_list l h = match l with | [] -> h lxor (Hashtbl.hash []) @@ -373,21 +373,21 @@ let command exe_path args vl = let outch = Unix.out_channel_of_descr stdin_write in output_value outch vl ; flush outch ; - + (* Wait for its completion *) let _pid,status = Unix.waitpid [] pid in - finally - (fun () -> + finally + (fun () -> (* Recover the result *) match status with - | Unix.WEXITED 0 -> - let inch = Unix.in_channel_of_descr stdout_read in + | Unix.WEXITED 0 -> + let inch = Unix.in_channel_of_descr stdout_read in begin try Marshal.from_channel inch with x -> failwith (Printf.sprintf "command \"%s\" exited %s" exe_path (Printexc.to_string x)) end | Unix.WEXITED i -> failwith (Printf.sprintf "command \"%s\" exited %i" exe_path i) | Unix.WSIGNALED i -> failwith (Printf.sprintf "command \"%s\" killed %i" exe_path i) | Unix.WSTOPPED i -> failwith (Printf.sprintf "command \"%s\" stopped %i" exe_path i)) - (fun () -> + (fun () -> (* Cleanup *) List.iter (fun x -> try Unix.close x with _ -> ()) [stdin_read; stdin_write; stdout_read ; stdout_write ; stderr_read; stderr_write] ) diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 87c9d1bbeb..f17e1c35bd 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -13,13 +13,13 @@ (************************************************************************) -module type PHashtable = +module type PHashtable = sig type 'a t - type key + type key val create : int -> string -> 'a t - (** [create i f] creates an empty persistent table + (** [create i f] creates an empty persistent table with initial size i associated with file [f] *) @@ -31,7 +31,7 @@ module type PHashtable = val find : 'a t -> key -> 'a (** find has the specification of Hashtable.find *) - + val add : 'a t -> key -> 'a -> unit (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. (and writes the binding to the file associated with [tbl].) @@ -50,7 +50,7 @@ module type PHashtable = open Hashtbl -module PHashtable(Key:HashedType) : PHashtable with type key = Key.t = +module PHashtable(Key:HashedType) : PHashtable with type key = Key.t = struct type key = Key.t @@ -66,27 +66,27 @@ struct type mode = Closed | Open - type 'a t = - { + type 'a t = + { outch : out_channel ; - mutable status : mode ; + mutable status : mode ; htbl : 'a Table.t } -let create i f = - { - outch = open_out_bin f ; - status = Open ; +let create i f = + { + outch = open_out_bin f ; + status = Open ; htbl = Table.create i } -let finally f rst = - try +let finally f rst = + try let res = f () in rst () ; res - with x -> - (try rst () + with x -> + (try rst () with _ -> raise x ); raise x @@ -94,80 +94,80 @@ let finally f rst = let read_key_elem inch = try Some (Marshal.from_channel inch) - with + with | End_of_file -> None | _ -> raise InvalidTableFormat - -let open_in f = + +let open_in f = let flags = [Open_rdonly;Open_binary;Open_creat] in let inch = open_in_gen flags 0o666 f in let htbl = Table.create 10 in - let rec xload () = + let rec xload () = match read_key_elem inch with | None -> () - | Some (key,elem) -> - Table.add htbl key elem ; + | Some (key,elem) -> + Table.add htbl key elem ; xload () in - try + try finally (fun () -> xload () ) (fun () -> close_in inch) ; { outch = begin let flags = [Open_append;Open_binary;Open_creat] in - open_out_gen flags 0o666 f + open_out_gen flags 0o666 f end ; status = Open ; htbl = htbl } - with InvalidTableFormat -> + with InvalidTableFormat -> (* Try to keep as many entries as possible *) begin let flags = [Open_wronly; Open_trunc;Open_binary;Open_creat] in let outch = open_out_gen flags 0o666 f in - Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; + Table.iter (fun k e -> Marshal.to_channel outch (k,e) [Marshal.No_sharing]) htbl; { outch = outch ; - status = Open ; + status = Open ; htbl = htbl } end -let close t = +let close t = let {outch = outch ; status = status ; htbl = tbl} = t in match t.status with | Closed -> () (* don't do it twice *) - | Open -> - close_out outch ; + | Open -> + close_out outch ; Table.clear tbl ; t.status <- Closed -let add t k e = +let add t k e = let {outch = outch ; status = status ; htbl = tbl} = t in if status = Closed then raise UnboundTable else begin - Table.add tbl k e ; + Table.add tbl k e ; Marshal.to_channel outch (k,e) [Marshal.No_sharing] end -let find t k = +let find t k = let {outch = outch ; status = status ; htbl = tbl} = t in if status = Closed then raise UnboundTable else let res = Table.find tbl k in - res + res -let memo cache f = +let memo cache f = let tbl = lazy (open_in cache) in - fun x -> + fun x -> let tbl = Lazy.force tbl in - try + try find tbl x with - Not_found -> + Not_found -> let res = f x in add tbl x res ; res diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index 87e55c9e17..2512dee92d 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -318,16 +318,16 @@ let string_of_vname (v:vname): string = (v: string);; let rec string_of_term t = match t with Opp t1 -> "(- " ^ string_of_term t1 ^ ")" -| Add (t1, t2) -> +| Add (t1, t2) -> "(" ^ (string_of_term t1) ^ " + " ^ (string_of_term t2) ^ ")" -| Sub (t1, t2) -> +| Sub (t1, t2) -> "(" ^ (string_of_term t1) ^ " - " ^ (string_of_term t2) ^ ")" -| Mul (t1, t2) -> +| Mul (t1, t2) -> "(" ^ (string_of_term t1) ^ " * " ^ (string_of_term t2) ^ ")" | Inv t1 -> "(/ " ^ string_of_term t1 ^ ")" -| Div (t1, t2) -> +| Div (t1, t2) -> "(" ^ (string_of_term t1) ^ " / " ^ (string_of_term t2) ^ ")" -| Pow (t1, n1) -> +| Pow (t1, n1) -> "(" ^ (string_of_term t1) ^ " ^ " ^ (string_of_int n1) ^ ")" | Zero -> "0" | Var v -> "x" ^ (string_of_vname v) @@ -384,11 +384,11 @@ let print_poly m = Format.print_string(string_of_poly m);; (* ------------------------------------------------------------------------- *) let rec poly_of_term t = match t with - Zero -> poly_0 + Zero -> poly_0 | Const n -> poly_const n | Var x -> poly_var x | Opp t1 -> poly_neg (poly_of_term t1) -| Inv t1 -> +| Inv t1 -> let p = poly_of_term t1 in if poly_isconst p then poly_const(Int 1 // eval undefined p) else failwith "poly_of_term: inverse of non-constant polyomial" diff --git a/plugins/micromega/sos.mli b/plugins/micromega/sos.mli index 42e22ffec2..e38caba06c 100644 --- a/plugins/micromega/sos.mli +++ b/plugins/micromega/sos.mli @@ -24,7 +24,7 @@ val poly_of_term : term -> poly val term_of_poly : poly -> term -val term_of_sos : positivstellensatz * (Num.num * poly) list -> +val term_of_sos : positivstellensatz * (Num.num * poly) list -> positivstellensatz val string_of_poly : poly -> string diff --git a/plugins/micromega/sos_lib.ml b/plugins/micromega/sos_lib.ml index a9228365ec..baf90d4daa 100644 --- a/plugins/micromega/sos_lib.ml +++ b/plugins/micromega/sos_lib.ml @@ -606,16 +606,16 @@ let rec deepen f n = exception TooDeep -let deepen_until limit f n = +let deepen_until limit f n = match compare limit 0 with | 0 -> raise TooDeep | -1 -> deepen f n - | _ -> + | _ -> let rec d_until f n = - try(* if !debugging - then (print_string "Searching with depth limit "; + try(* if !debugging + then (print_string "Searching with depth limit "; print_int n; print_newline()) ;*) f n - with Failure x -> + with Failure x -> (*if !debugging then (Printf.printf "solver error : %s\n" x) ; *) if n = limit then raise TooDeep else d_until f (n + 1) in d_until f n diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v index fe8fcc9249..56a854d6f8 100644 --- a/plugins/omega/OmegaLemmas.v +++ b/plugins/omega/OmegaLemmas.v @@ -31,7 +31,7 @@ Qed. Theorem Zred_factor3 : forall n m:Z, n * m + n = n * (1 + m). Proof. intros x y; pattern x at 2 in |- *; rewrite <- (Zmult_1_r x); - rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; + rewrite <- Zmult_plus_distr_r; rewrite Zplus_comm; trivial with arith. Qed. @@ -53,7 +53,7 @@ Qed. (** Other specific variants of theorems dedicated for the Omega tactic *) Lemma new_var : forall x : Z, exists y : Z, x = y. -intros x; exists x; trivial with arith. +intros x; exists x; trivial with arith. Qed. Lemma OMEGA1 : forall x y : Z, x = y -> 0 <= x -> 0 <= y. @@ -62,7 +62,7 @@ Qed. Lemma OMEGA2 : forall x y : Z, 0 <= x -> 0 <= y -> 0 <= x + y. exact Zplus_le_0_compat. -Qed. +Qed. Lemma OMEGA3 : forall x y k : Z, k > 0 -> x = y * k -> x = 0 -> y = 0. @@ -82,11 +82,11 @@ unfold not in |- *; intros x y z H1 H2 H3; cut (y > 0); [ rewrite H3; unfold Zgt in |- *; simpl in |- *; discriminate | apply Zle_gt_trans with x; [ pattern x at 1 in |- *; rewrite <- (Zplus_0_l x); - apply Zplus_le_compat_r; rewrite Zmult_comm; + apply Zplus_le_compat_r; rewrite Zmult_comm; generalize H4; unfold Zgt in |- *; case y; [ simpl in |- *; intros H7; discriminate H7 | intros p H7; rewrite <- (Zmult_0_r (Zpos p)); - unfold Zle in |- *; rewrite Zcompare_mult_compat; + unfold Zle in |- *; rewrite Zcompare_mult_compat; exact H6 | simpl in |- *; intros p H7; discriminate H7 ] | assumption ] ] @@ -116,7 +116,7 @@ Lemma OMEGA8 : forall x y : Z, 0 <= x -> 0 <= y -> x = - y -> x = 0. intros x y H1 H2 H3; elim (Zle_lt_or_eq 0 x H1); [ intros H4; absurd (0 < x); [ change (0 >= x) in |- *; apply Zle_ge; apply Zplus_le_reg_l with y; - rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r; + rewrite H3; rewrite Zplus_opp_r; rewrite Zplus_0_r; assumption | assumption ] | intros H4; rewrite H4; trivial with arith ]. @@ -143,7 +143,7 @@ Lemma OMEGA11 : (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2). intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; trivial with arith. Qed. @@ -152,7 +152,7 @@ Lemma OMEGA12 : l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2). intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; rewrite Zplus_permute; trivial with arith. Qed. @@ -166,7 +166,7 @@ intros; rewrite Zplus_assoc; rewrite (Zplus_comm (v * Zpos x) l1); rewrite Zplus_opp_r; rewrite Zmult_0_r; rewrite Zplus_0_r; trivial with arith. Qed. - + Lemma OMEGA14 : forall (v l1 l2 : Z) (x : positive), v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2. @@ -188,14 +188,14 @@ Qed. Lemma OMEGA16 : forall v c l k : Z, (v * c + l) * k = v * (c * k) + l * k. intros; repeat rewrite Zmult_plus_distr_l || rewrite Zmult_plus_distr_r; - repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; + repeat rewrite Zmult_assoc; repeat elim Zplus_assoc; trivial with arith. Qed. Lemma OMEGA17 : forall x y z : Z, Zne x 0 -> y = 0 -> Zne (x + y * z) 0. unfold Zne, not in |- *; intros x y z H1 H2 H3; apply H1; - apply Zplus_reg_l with (y * z); rewrite Zplus_comm; + apply Zplus_reg_l with (y * z); rewrite Zplus_comm; rewrite H3; rewrite H2; auto with arith. Qed. @@ -213,7 +213,7 @@ unfold Zne in |- *; intros x H; elim (Zle_or_lt 0 x); rewrite <- Zsucc_pred; apply Zlt_le_succ; assumption | intros H2; absurd (x = 0); auto with arith ] | intros H1; right; rewrite <- Zopp_eq_mult_neg_1; rewrite Zplus_comm; - apply Zle_left; apply Zsucc_le_reg; simpl in |- *; + apply Zle_left; apply Zsucc_le_reg; simpl in |- *; apply Zlt_le_succ; auto with arith ]. Qed. @@ -229,7 +229,7 @@ Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop) Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p). -Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) +Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop) (H : P (n + m + p)) := eq_ind_r P H (Zplus_assoc n m p). Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop) @@ -257,7 +257,7 @@ Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop) (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x). -Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) +Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop) (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x). Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop) @@ -272,18 +272,18 @@ Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop) Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) := eq_ind_r P H (Zopp_involutive x). -Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) +Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop) (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y). Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop) (H : P (n * p + m * p)) := eq_ind_r P H (Zmult_plus_distr_l n m p). -Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) +Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop) (H : P (x * - y)) := eq_ind_r P H (Zmult_opp_comm x y). Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop) (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p). -Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) +Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop) (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x). Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop) @@ -295,8 +295,8 @@ Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop) Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop) (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z). -Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) +Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop) (H : P y) := eq_ind_r P H (Zred_factor5 x y). -Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) +Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop) (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x). diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 47e22a97f3..a5a085a99e 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -5,16 +5,16 @@ Open Local Scope Z_scope. (** * zify: the Z-ification tactic *) -(* This tactic searches for nat and N and positive elements in the goal and - translates everything into Z. It is meant as a pre-processor for +(* This tactic searches for nat and N and positive elements in the goal and + translates everything into Z. It is meant as a pre-processor for (r)omega; for instance a positivity hypothesis is added whenever - a multiplication is encountered - an atom is encountered (that is a variable or an unknown construct) Recognized relations (can be handled as deeply as allowed by setoid rewrite): - { eq, le, lt, ge, gt } on { Z, positive, N, nat } - - Recognized operations: + + Recognized operations: - on Z: Zmin, Zmax, Zabs, Zsgn are translated in term of <= < = - on nat: + * - S O pred min max nat_of_P nat_of_N Zabs_nat - on positive: Zneg Zpos xI xO xH + * - Psucc Ppred Pmin Pmax P_of_succ_nat @@ -26,31 +26,31 @@ Open Local Scope Z_scope. (** I) translation of Zmax, Zmin, Zabs, Zsgn into recognized equations *) -Ltac zify_unop_core t thm a := +Ltac zify_unop_core t thm a := (* Let's introduce the specification theorem for t *) - let H:= fresh "H" in assert (H:=thm a); + let H:= fresh "H" in assert (H:=thm a); (* Then we replace (t a) everywhere with a fresh variable *) let z := fresh "z" in set (z:=t a) in *; clearbody z. -Ltac zify_unop_var_or_term t thm a := +Ltac zify_unop_var_or_term t thm a := (* If a is a variable, no need for aliasing *) - let za := fresh "z" in + let za := fresh "z" in (rename a into za; rename za into a; zify_unop_core t thm a) || (* Otherwise, a is a complex term: we alias it. *) (remember a as za; zify_unop_core t thm za). -Ltac zify_unop t thm a := +Ltac zify_unop t thm a := (* if a is a scalar, we can simply reduce the unop *) - let isz := isZcst a in - match isz with + let isz := isZcst a in + match isz with | true => simpl (t a) in * | _ => zify_unop_var_or_term t thm a end. -Ltac zify_unop_nored t thm a := +Ltac zify_unop_nored t thm a := (* in this version, we don't try to reduce the unop (that can be (Zplus x)) *) - let isz := isZcst a in - match isz with + let isz := isZcst a in + match isz with | true => zify_unop_core t thm a | _ => zify_unop_var_or_term t thm a end. @@ -58,20 +58,20 @@ Ltac zify_unop_nored t thm a := Ltac zify_binop t thm a b:= (* works as zify_unop, except that we should be careful when dealing with b, since it can be equal to a *) - let isza := isZcst a in - match isza with + let isza := isZcst a in + match isza with | true => zify_unop (t a) (thm a) b - | _ => - let za := fresh "z" in + | _ => + let za := fresh "z" in (rename a into za; rename za into a; zify_unop_nored (t a) (thm a) b) || - (remember a as za; match goal with + (remember a as za; match goal with | H : za = b |- _ => zify_unop_nored (t za) (thm za) za | _ => zify_unop_nored (t za) (thm za) b end) end. -Ltac zify_op_1 := - match goal with +Ltac zify_op_1 := + match goal with | |- context [ Zmax ?a ?b ] => zify_binop Zmax Zmax_spec a b | H : context [ Zmax ?a ?b ] |- _ => zify_binop Zmax Zmax_spec a b | |- context [ Zmin ?a ?b ] => zify_binop Zmin Zmin_spec a b @@ -93,13 +93,13 @@ Ltac zify_op := repeat zify_op_1. Definition Z_of_nat' := Z_of_nat. -Ltac hide_Z_of_nat t := - let z := fresh "z" in set (z:=Z_of_nat t) in *; - change Z_of_nat with Z_of_nat' in z; +Ltac hide_Z_of_nat t := + let z := fresh "z" in set (z:=Z_of_nat t) in *; + change Z_of_nat with Z_of_nat' in z; unfold z in *; clear z. -Ltac zify_nat_rel := - match goal with +Ltac zify_nat_rel := + match goal with (* I: equalities *) | H : (@eq nat ?a ?b) |- _ => generalize (inj_eq _ _ H); clear H; intro H | |- (@eq nat ?a ?b) => apply (inj_eq_rev a b) @@ -127,8 +127,8 @@ Ltac zify_nat_rel := | |- context [ ge ?a ?b ] => rewrite (inj_ge_iff a b) end. -Ltac zify_nat_op := - match goal with +Ltac zify_nat_op := + match goal with (* misc type conversions: positive/N/Z to nat *) | H : context [ Z_of_nat (nat_of_P ?a) ] |- _ => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) in H | |- context [ Z_of_nat (nat_of_P ?a) ] => rewrite <- (Zpos_eq_Z_of_nat_o_nat_of_P a) @@ -158,11 +158,11 @@ Ltac zify_nat_op := | |- context [ Z_of_nat (pred ?a) ] => rewrite (pred_of_minus a) (* mult -> Zmult and a positivity hypothesis *) - | H : context [ Z_of_nat (mult ?a ?b) ] |- _ => - let H:= fresh "H" in + | H : context [ Z_of_nat (mult ?a ?b) ] |- _ => + let H:= fresh "H" in assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * - | |- context [ Z_of_nat (mult ?a ?b) ] => - let H:= fresh "H" in + | |- context [ Z_of_nat (mult ?a ?b) ] => + let H:= fresh "H" in assert (H:=Zle_0_nat (mult a b)); rewrite (inj_mult a b) in * (* O -> Z0 *) @@ -170,29 +170,29 @@ Ltac zify_nat_op := | |- context [ Z_of_nat O ] => simpl (Z_of_nat O) (* S -> number or Zsucc *) - | H : context [ Z_of_nat (S ?a) ] |- _ => - let isnat := isnatcst a in - match isnat with + | H : context [ Z_of_nat (S ?a) ] |- _ => + let isnat := isnatcst a in + match isnat with | true => simpl (Z_of_nat (S a)) in H | _ => rewrite (inj_S a) in H end - | |- context [ Z_of_nat (S ?a) ] => - let isnat := isnatcst a in - match isnat with + | |- context [ Z_of_nat (S ?a) ] => + let isnat := isnatcst a in + match isnat with | true => simpl (Z_of_nat (S a)) | _ => rewrite (inj_S a) end - (* atoms of type nat : we add a positivity condition (if not already there) *) - | H : context [ Z_of_nat ?a ] |- _ => - match goal with + (* atoms of type nat : we add a positivity condition (if not already there) *) + | H : context [ Z_of_nat ?a ] |- _ => + match goal with | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a | H' : 0 <= Z_of_nat' a |- _ => fail | _ => let H:= fresh "H" in assert (H:=Zle_0_nat a); hide_Z_of_nat a end - | |- context [ Z_of_nat ?a ] => - match goal with + | |- context [ Z_of_nat ?a ] => + match goal with | H' : 0 <= Z_of_nat a |- _ => hide_Z_of_nat a | H' : 0 <= Z_of_nat' a |- _ => fail | _ => let H:= fresh "H" in @@ -205,18 +205,18 @@ Ltac zify_nat := repeat zify_nat_rel; repeat zify_nat_op; unfold Z_of_nat' in *. -(* III) conversion from positive to Z *) +(* III) conversion from positive to Z *) Definition Zpos' := Zpos. Definition Zneg' := Zneg. -Ltac hide_Zpos t := - let z := fresh "z" in set (z:=Zpos t) in *; - change Zpos with Zpos' in z; +Ltac hide_Zpos t := + let z := fresh "z" in set (z:=Zpos t) in *; + change Zpos with Zpos' in z; unfold z in *; clear z. -Ltac zify_positive_rel := - match goal with +Ltac zify_positive_rel := + match goal with (* I: equalities *) | H : (@eq positive ?a ?b) |- _ => generalize (Zpos_eq _ _ H); clear H; intro H | |- (@eq positive ?a ?b) => apply (Zpos_eq_rev a b) @@ -236,18 +236,18 @@ Ltac zify_positive_rel := | |- context [ (?a>=?b)%positive ] => change (a>=b)%positive with (Zpos a>=Zpos b) end. -Ltac zify_positive_op := - match goal with +Ltac zify_positive_op := + match goal with (* Zneg -> -Zpos (except for numbers) *) - | H : context [ Zneg ?a ] |- _ => - let isp := isPcst a in - match isp with + | H : context [ Zneg ?a ] |- _ => + let isp := isPcst a in + match isp with | true => change (Zneg a) with (Zneg' a) in H | _ => change (Zneg a) with (- Zpos a) in H end - | |- context [ Zneg ?a ] => - let isp := isPcst a in - match isp with + | |- context [ Zneg ?a ] => + let isp := isPcst a in + match isp with | true => change (Zneg a) with (Zneg' a) | _ => change (Zneg a) with (- Zpos a) end @@ -272,45 +272,45 @@ Ltac zify_positive_op := | H : context [ Zpos (Pminus ?a ?b) ] |- _ => rewrite (Zpos_minus a b) in H | |- context [ Zpos (Pminus ?a ?b) ] => rewrite (Zpos_minus a b) - (* Psucc -> Zsucc *) + (* Psucc -> Zsucc *) | H : context [ Zpos (Psucc ?a) ] |- _ => rewrite (Zpos_succ_morphism a) in H | |- context [ Zpos (Psucc ?a) ] => rewrite (Zpos_succ_morphism a) (* Ppred -> Pminus ... -1 -> Zmax 1 (Zminus ... - 1) *) | H : context [ Zpos (Ppred ?a) ] |- _ => rewrite (Ppred_minus a) in H | |- context [ Zpos (Ppred ?a) ] => rewrite (Ppred_minus a) - + (* Pmult -> Zmult and a positivity hypothesis *) - | H : context [ Zpos (Pmult ?a ?b) ] |- _ => - let H:= fresh "H" in + | H : context [ Zpos (Pmult ?a ?b) ] |- _ => + let H:= fresh "H" in assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * - | |- context [ Zpos (Pmult ?a ?b) ] => - let H:= fresh "H" in + | |- context [ Zpos (Pmult ?a ?b) ] => + let H:= fresh "H" in assert (H:=Zgt_pos_0 (Pmult a b)); rewrite (Zpos_mult_morphism a b) in * (* xO *) - | H : context [ Zpos (xO ?a) ] |- _ => - let isp := isPcst a in - match isp with + | H : context [ Zpos (xO ?a) ] |- _ => + let isp := isPcst a in + match isp with | true => change (Zpos (xO a)) with (Zpos' (xO a)) in H | _ => rewrite (Zpos_xO a) in H end - | |- context [ Zpos (xO ?a) ] => - let isp := isPcst a in - match isp with + | |- context [ Zpos (xO ?a) ] => + let isp := isPcst a in + match isp with | true => change (Zpos (xO a)) with (Zpos' (xO a)) | _ => rewrite (Zpos_xO a) end - (* xI *) - | H : context [ Zpos (xI ?a) ] |- _ => - let isp := isPcst a in - match isp with + (* xI *) + | H : context [ Zpos (xI ?a) ] |- _ => + let isp := isPcst a in + match isp with | true => change (Zpos (xI a)) with (Zpos' (xI a)) in H | _ => rewrite (Zpos_xI a) in H end - | |- context [ Zpos (xI ?a) ] => - let isp := isPcst a in - match isp with + | |- context [ Zpos (xI ?a) ] => + let isp := isPcst a in + match isp with | true => change (Zpos (xI a)) with (Zpos' (xI a)) | _ => rewrite (Zpos_xI a) end @@ -320,38 +320,38 @@ Ltac zify_positive_op := | |- context [ Zpos xH ] => hide_Zpos xH (* atoms of type positive : we add a positivity condition (if not already there) *) - | H : context [ Zpos ?a ] |- _ => - match goal with + | H : context [ Zpos ?a ] |- _ => + match goal with | H' : Zpos a > 0 |- _ => hide_Zpos a | H' : Zpos' a > 0 |- _ => fail | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a end - | |- context [ Zpos ?a ] => - match goal with + | |- context [ Zpos ?a ] => + match goal with | H' : Zpos a > 0 |- _ => hide_Zpos a | H' : Zpos' a > 0 |- _ => fail | _ => let H:= fresh "H" in assert (H:=Zgt_pos_0 a); hide_Zpos a end end. -Ltac zify_positive := +Ltac zify_positive := repeat zify_positive_rel; repeat zify_positive_op; unfold Zpos',Zneg' in *. -(* IV) conversion from N to Z *) +(* IV) conversion from N to Z *) Definition Z_of_N' := Z_of_N. -Ltac hide_Z_of_N t := - let z := fresh "z" in set (z:=Z_of_N t) in *; - change Z_of_N with Z_of_N' in z; +Ltac hide_Z_of_N t := + let z := fresh "z" in set (z:=Z_of_N t) in *; + change Z_of_N with Z_of_N' in z; unfold z in *; clear z. -Ltac zify_N_rel := - match goal with +Ltac zify_N_rel := + match goal with (* I: equalities *) | H : (@eq N ?a ?b) |- _ => generalize (Z_of_N_eq _ _ H); clear H; intro H | |- (@eq N ?a ?b) => apply (Z_of_N_eq_rev a b) @@ -378,9 +378,9 @@ Ltac zify_N_rel := | H : context [ (?a>=?b)%N ] |- _ => rewrite (Z_of_N_ge_iff a b) in H | |- context [ (?a>=?b)%N ] => rewrite (Z_of_N_ge_iff a b) end. - -Ltac zify_N_op := - match goal with + +Ltac zify_N_op := + match goal with (* misc type conversions: nat to positive *) | H : context [ Z_of_N (N_of_nat ?a) ] |- _ => rewrite (Z_of_N_of_nat a) in H | |- context [ Z_of_N (N_of_nat ?a) ] => rewrite (Z_of_N_of_nat a) @@ -407,27 +407,27 @@ Ltac zify_N_op := | H : context [ Z_of_N (Nminus ?a ?b) ] |- _ => rewrite (Z_of_N_minus a b) in H | |- context [ Z_of_N (Nminus ?a ?b) ] => rewrite (Z_of_N_minus a b) - (* Nsucc -> Zsucc *) + (* Nsucc -> Zsucc *) | H : context [ Z_of_N (Nsucc ?a) ] |- _ => rewrite (Z_of_N_succ a) in H | |- context [ Z_of_N (Nsucc ?a) ] => rewrite (Z_of_N_succ a) - + (* Nmult -> Zmult and a positivity hypothesis *) - | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ => - let H:= fresh "H" in + | H : context [ Z_of_N (Nmult ?a ?b) ] |- _ => + let H:= fresh "H" in assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in * - | |- context [ Z_of_N (Nmult ?a ?b) ] => - let H:= fresh "H" in + | |- context [ Z_of_N (Nmult ?a ?b) ] => + let H:= fresh "H" in assert (H:=Z_of_N_le_0 (Nmult a b)); rewrite (Z_of_N_mult a b) in * - (* atoms of type N : we add a positivity condition (if not already there) *) - | H : context [ Z_of_N ?a ] |- _ => - match goal with + (* atoms of type N : we add a positivity condition (if not already there) *) + | H : context [ Z_of_N ?a ] |- _ => + match goal with | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a | H' : 0 <= Z_of_N' a |- _ => fail | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a end - | |- context [ Z_of_N ?a ] => - match goal with + | |- context [ Z_of_N ?a ] => + match goal with | H' : 0 <= Z_of_N a |- _ => hide_Z_of_N a | H' : 0 <= Z_of_N' a |- _ => fail | _ => let H:= fresh "H" in assert (H:=Z_of_N_le_0 a); hide_Z_of_N a @@ -440,6 +440,6 @@ Ltac zify_N := repeat zify_N_rel; repeat zify_N_op; unfold Z_of_N' in *. (** The complete Z-ification tactic *) -Ltac zify := +Ltac zify := repeat progress (zify_nat; zify_positive; zify_N); zify_op. diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 075188f54d..e037ee8bff 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -58,7 +58,7 @@ let write f x = f:=x open Goptions let _ = - declare_bool_option + declare_bool_option { optsync = false; optname = "Omega system time displaying flag"; optkey = ["Omega";"System"]; @@ -66,7 +66,7 @@ let _ = optwrite = write display_system_flag } let _ = - declare_bool_option + declare_bool_option { optsync = false; optname = "Omega action display flag"; optkey = ["Omega";"Action"]; @@ -74,7 +74,7 @@ let _ = optwrite = write display_action_flag } let _ = - declare_bool_option + declare_bool_option { optsync = false; optname = "Omega old style flag"; optkey = ["Omega";"OldStyle"]; @@ -89,16 +89,16 @@ let elim_time = timing "Elim " let simpl_time = timing "Simpl " let generalize_time = timing "Generalize" -let new_identifier = - let cpt = ref 0 in +let new_identifier = + let cpt = ref 0 in (fun () -> let s = "Omega" ^ string_of_int !cpt in incr cpt; id_of_string s) -let new_identifier_state = - let cpt = ref 0 in +let new_identifier_state = + let cpt = ref 0 in (fun () -> let s = make_ident "State" (Some !cpt) in incr cpt; s) -let new_identifier_var = - let cpt = ref 0 in +let new_identifier_var = + let cpt = ref 0 in (fun () -> let s = "Zvar" ^ string_of_int !cpt in incr cpt; id_of_string s) let new_id = @@ -115,17 +115,17 @@ let display_var i = Printf.sprintf "X%d" i let intern_id,unintern_id = let cpt = ref 0 in let table = Hashtbl.create 7 and co_table = Hashtbl.create 7 in - (fun (name : identifier) -> - try Hashtbl.find table name with Not_found -> + (fun (name : identifier) -> + try Hashtbl.find table name with Not_found -> let idx = !cpt in - Hashtbl.add table name idx; + Hashtbl.add table name idx; Hashtbl.add co_table idx name; incr cpt; idx), - (fun idx -> - try Hashtbl.find co_table idx with Not_found -> + (fun idx -> + try Hashtbl.find co_table idx with Not_found -> let v = new_var () in Hashtbl.add table v idx; Hashtbl.add co_table idx v; v) - + let mk_then = tclTHENLIST let exists_tac c = constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [c]) @@ -134,10 +134,10 @@ let generalize_tac t = generalize_time (generalize t) let elim t = elim_time (simplest_elim t) let exact t = exact_time (Tactics.refine t) let unfold s = Tactics.unfold_in_concl [all_occurrences, Lazy.force s] - + let rev_assoc k = let rec loop = function - | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l + | [] -> raise Not_found | (v,k')::_ when k = k' -> v | _ :: l -> loop l in loop @@ -347,15 +347,15 @@ let mk_eq_rel t1 t2 = mkApp (build_coq_eq (), let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) let mk_integer n = - let rec loop n = - if n =? one then Lazy.force coq_xH else + let rec loop n = + if n =? one then Lazy.force coq_xH else mkApp((if n mod two =? zero then Lazy.force coq_xO else Lazy.force coq_xI), [| loop (n/two) |]) in - if n =? zero then Lazy.force coq_Z0 + if n =? zero then Lazy.force coq_Z0 else mkApp ((if n >? zero then Lazy.force coq_Zpos else Lazy.force coq_Zneg), [| loop (abs n) |]) - + type omega_constant = | Zplus | Zmult | Zminus | Zsucc | Zopp | Plus | Mult | Minus | Pred | S | O @@ -371,7 +371,7 @@ type omega_proposition = | Keq of constr * constr * constr | Kn -type result = +type result = | Kvar of identifier | Kapp of omega_constant * constr list | Kimp of constr * constr @@ -442,18 +442,18 @@ let recognize_number t = | f, [t] when f = Lazy.force coq_xI -> one + two * loop t | f, [t] when f = Lazy.force coq_xO -> two * loop t | f, [] when f = Lazy.force coq_xH -> one - | _ -> failwith "not a number" + | _ -> failwith "not a number" in - match decompose_app t with + match decompose_app t with | f, [t] when f = Lazy.force coq_Zpos -> loop t | f, [t] when f = Lazy.force coq_Zneg -> neg (loop t) | f, [] when f = Lazy.force coq_Z0 -> zero | _ -> failwith "not a number" - + type constr_path = | P_APP of int (* Abstraction and product *) - | P_BODY + | P_BODY | P_TYPE (* Case *) | P_BRANCH of int @@ -461,8 +461,8 @@ type constr_path = | P_ARG let context operation path (t : constr) = - let rec loop i p0 t = - match (p0,kind_of_term t) with + let rec loop i p0 t = + match (p0,kind_of_term t) with | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) | ([], _) -> operation i t | ((P_APP n :: p), App (f,v)) -> @@ -493,9 +493,9 @@ let context operation path (t : constr) = (mkLambda (n,loop i p t,c)) | ((P_TYPE :: p), LetIn (n,b,t,c)) -> (mkLetIn (n,b,loop i p t,c)) - | (p, _) -> + | (p, _) -> ppnl (Printer.pr_lconstr t); - failwith ("abstract_path " ^ string_of_int(List.length p)) + failwith ("abstract_path " ^ string_of_int(List.length p)) in loop 1 path t @@ -514,9 +514,9 @@ let occurence path (t : constr) = | ((P_TYPE :: p), Prod (n,term,c)) -> loop p term | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term - | (p, _) -> + | (p, _) -> ppnl (Printer.pr_lconstr t); - failwith ("occurence " ^ string_of_int(List.length p)) + failwith ("occurence " ^ string_of_int(List.length p)) in loop path t @@ -539,13 +539,13 @@ type oformula = | Oz of bigint | Oufo of constr -let rec oprint = function - | Oplus(t1,t2) -> - print_string "("; oprint t1; print_string "+"; +let rec oprint = function + | Oplus(t1,t2) -> + print_string "("; oprint t1; print_string "+"; oprint t2; print_string ")" | Oinv t -> print_string "~"; oprint t - | Otimes (t1,t2) -> - print_string "("; oprint t1; print_string "*"; + | Otimes (t1,t2) -> + print_string "("; oprint t1; print_string "*"; oprint t2; print_string ")" | Oatom s -> print_string (string_of_id s) | Oz i -> print_string (string_of_bigint i) @@ -567,92 +567,92 @@ let rec val_of = function | Oplus(t1,t2) -> mkApp (Lazy.force coq_Zplus, [| val_of t1; val_of t2 |]) | Oufo c -> c -let compile name kind = +let compile name kind = let rec loop accu = function | Oplus(Otimes(Oatom v,Oz n),r) -> loop ({v=intern_id v; c=n} :: accu) r | Oz n -> let id = new_id () in tag_hypothesis name id; {kind = kind; body = List.rev accu; constant = n; id = id} - | _ -> anomaly "compile_equation" + | _ -> anomaly "compile_equation" in loop [] -let rec decompile af = +let rec decompile af = let rec loop = function - | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) - | [] -> Oz af.constant + | ({v=v; c=n}::r) -> Oplus(Otimes(Oatom (unintern_id v),Oz n),loop r) + | [] -> Oz af.constant in loop af.body let mkNewMeta () = mkMeta (Evarutil.new_meta()) -let clever_rewrite_base_poly typ p result theorem gl = +let clever_rewrite_base_poly typ p result theorem gl = let full = pf_concl gl in let (abstracted,occ) = abstract_path typ (List.rev p) full in - let t = + let t = applist (mkLambda - (Name (id_of_string "P"), + (Name (id_of_string "P"), mkArrow typ mkProp, mkLambda (Name (id_of_string "H"), applist (mkRel 1,[result]), - mkApp (Lazy.force coq_eq_ind_r, + mkApp (Lazy.force coq_eq_ind_r, [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), - [abstracted]) + [abstracted]) in exact (applist(t,[mkNewMeta()])) gl -let clever_rewrite_base p result theorem gl = +let clever_rewrite_base p result theorem gl = clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl -let clever_rewrite_base_nat p result theorem gl = +let clever_rewrite_base_nat p result theorem gl = clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl -let clever_rewrite_gen p result (t,args) = - let theorem = applist(t, args) in +let clever_rewrite_gen p result (t,args) = + let theorem = applist(t, args) in clever_rewrite_base p result theorem -let clever_rewrite_gen_nat p result (t,args) = - let theorem = applist(t, args) in +let clever_rewrite_gen_nat p result (t,args) = + let theorem = applist(t, args) in clever_rewrite_base_nat p result theorem -let clever_rewrite p vpath t gl = +let clever_rewrite p vpath t gl = let full = pf_concl gl in let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in let vargs = List.map (fun p -> occurence p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in exact (applist(t',[mkNewMeta()])) gl -let rec shuffle p (t1,t2) = +let rec shuffle p (t1,t2) = match t1,t2 with | Oplus(l1,r1), Oplus(l2,r2) -> - if weight l1 > weight l2 then + if weight l1 > weight l2 then let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in - (clever_rewrite p [[P_APP 1;P_APP 1]; + (clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: tac, Oplus(l1,t')) - else + else let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in (clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_permute) :: tac, Oplus(l2,t')) - | Oplus(l1,r1), t2 -> + | Oplus(l1,r1), t2 -> if weight l1 > weight t2 then let (tac,t') = shuffle (P_APP 2 :: p) (r1,t2) in clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) - :: tac, + :: tac, Oplus(l1, t') - else - [clever_rewrite p [[P_APP 1];[P_APP 2]] + else + [clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) - | t1,Oplus(l2,r2) -> + | t1,Oplus(l2,r2) -> if weight l2 > weight t1 then let (tac,t') = shuffle (P_APP 2 :: p) (t1,r2) in clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] @@ -664,11 +664,11 @@ let rec shuffle p (t1,t2) = [focused_simpl p], Oz(Bigint.add t1 t2) | t1,t2 -> if weight t1 < weight t2 then - [clever_rewrite p [[P_APP 1];[P_APP 2]] + [clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zplus_comm)], Oplus(t2,t1) else [],Oplus(t1,t2) - + let rec shuffle_mult p_init k1 e1 k2 e2 = let rec loop p = function | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> @@ -681,13 +681,13 @@ let rec shuffle_mult p_init k1 e1 k2 e2 = [P_APP 2; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA10) + (Lazy.force coq_fast_OMEGA10) in - if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then - let tac' = + if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then + let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in - tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: + tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: loop p (l1,l2) else tac :: loop (P_APP 2 :: p) (l1,l2) else if v1 > v2 then @@ -706,7 +706,7 @@ let rec shuffle_mult p_init k1 e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) (l1',l2) - | ({c=c1;v=v1}::l1), [] -> + | ({c=c1;v=v1}::l1), [] -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; @@ -714,7 +714,7 @@ let rec shuffle_mult p_init k1 e1 k2 e2 = [P_APP 1; P_APP 2]] (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) (l1,[]) - | [],({c=c2;v=v2}::l2) -> + | [],({c=c2;v=v2}::l2) -> clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; @@ -722,10 +722,10 @@ let rec shuffle_mult p_init k1 e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) ([],l2) - | [],[] -> [focused_simpl p_init] + | [],[] -> [focused_simpl p_init] in loop p_init (e1,e2) - + let rec shuffle_mult_right p_init e1 k2 e2 = let rec loop p = function | (({c=c1;v=v1}::l1) as l1'),(({c=c2;v=v2}::l2) as l2') -> @@ -738,14 +738,14 @@ let rec shuffle_mult_right p_init e1 k2 e2 = [P_APP 1; P_APP 2]; [P_APP 2; P_APP 1; P_APP 2]; [P_APP 2; P_APP 2]] - (Lazy.force coq_fast_OMEGA15) + (Lazy.force coq_fast_OMEGA15) in - if Bigint.add c1 (Bigint.mult k2 c2) =? zero then - let tac' = + if Bigint.add c1 (Bigint.mult k2 c2) =? zero then + let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] - (Lazy.force coq_fast_Zred_factor5) + (Lazy.force coq_fast_Zred_factor5) in - tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: + tac :: focused_simpl (P_APP 1::P_APP 2:: p) :: tac' :: loop p (l1,l2) else tac :: loop (P_APP 2 :: p) (l1,l2) else if v1 > v2 then @@ -760,11 +760,11 @@ let rec shuffle_mult_right p_init e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) (l1',l2) - | ({c=c1;v=v1}::l1), [] -> + | ({c=c1;v=v1}::l1), [] -> clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: loop (P_APP 2 :: p) (l1,[]) - | [],({c=c2;v=v2}::l2) -> + | [],({c=c2;v=v2}::l2) -> clever_rewrite p [[P_APP 2; P_APP 1; P_APP 1; P_APP 1]; [P_APP 2; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1]; @@ -772,89 +772,89 @@ let rec shuffle_mult_right p_init e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA12) :: loop (P_APP 2 :: p) ([],l2) - | [],[] -> [focused_simpl p_init] + | [],[] -> [focused_simpl p_init] in loop p_init (e1,e2) -let rec shuffle_cancel p = function +let rec shuffle_cancel p = function | [] -> [focused_simpl p] | ({c=c1}::l1) -> - let tac = + let tac = clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 2]; - [P_APP 2; P_APP 2]; + [P_APP 2; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2; P_APP 1]] - (if c1 >? zero then - (Lazy.force coq_fast_OMEGA13) - else - (Lazy.force coq_fast_OMEGA14)) + (if c1 >? zero then + (Lazy.force coq_fast_OMEGA13) + else + (Lazy.force coq_fast_OMEGA14)) in tac :: shuffle_cancel p l1 - + let rec scalar p n = function - | Oplus(t1,t2) -> - let tac1,t1' = scalar (P_APP 1 :: p) n t1 and + | Oplus(t1,t2) -> + let tac1,t1' = scalar (P_APP 1 :: p) n t1 and tac2,t2' = scalar (P_APP 2 :: p) n t2 in clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_Zmult_plus_distr_l) :: + (Lazy.force coq_fast_Zmult_plus_distr_l) :: (tac1 @ tac2), Oplus(t1',t2') | Oinv t -> - [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zmult_opp_comm); focused_simpl (P_APP 2 :: p)], Otimes(t,Oz(neg n)) - | Otimes(t1,Oz x) -> + | Otimes(t1,Oz x) -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zmult_assoc_reverse); - focused_simpl (P_APP 2 :: p)], + focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (n*x)) | Otimes(t1,t2) -> error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> [], Otimes(t,Oz n) | Oz i -> [focused_simpl p],Oz(n*i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zmult, [| mk_integer n; c |])) - -let rec scalar_norm p_init = + +let rec scalar_norm p_init = let rec loop p = function | [] -> [focused_simpl p_init] - | (_::l) -> + | (_::l) -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1];[P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 2];[P_APP 2]] - (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l + (Lazy.force coq_fast_OMEGA16) :: loop (P_APP 2 :: p) l in loop p_init let rec norm_add p_init = let rec loop p = function | [] -> [focused_simpl p_init] - | _:: l -> + | _:: l -> clever_rewrite p [[P_APP 1;P_APP 1]; [P_APP 1; P_APP 2];[P_APP 2]] (Lazy.force coq_fast_Zplus_assoc_reverse) :: - loop (P_APP 2 :: p) l + loop (P_APP 2 :: p) l in loop p_init let rec scalar_norm_add p_init = let rec loop p = function | [] -> [focused_simpl p_init] - | _ :: l -> + | _ :: l -> clever_rewrite p [[P_APP 1; P_APP 1; P_APP 1; P_APP 1]; [P_APP 1; P_APP 1; P_APP 1; P_APP 2]; [P_APP 1; P_APP 1; P_APP 2]; [P_APP 2]; [P_APP 1; P_APP 2]] - (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l + (Lazy.force coq_fast_OMEGA11) :: loop (P_APP 2 :: p) l in loop p_init let rec negate p = function - | Oplus(t1,t2) -> - let tac1,t1' = negate (P_APP 1 :: p) t1 and + | Oplus(t1,t2) -> + let tac1,t1' = negate (P_APP 1 :: p) t1 and tac2,t2' = negate (P_APP 2 :: p) t2 in clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] - (Lazy.force coq_fast_Zopp_plus_distr) :: + (Lazy.force coq_fast_Zopp_plus_distr) :: (tac1 @ tac2), Oplus(t1',t2') | Oinv t -> [clever_rewrite p [[P_APP 1;P_APP 1]] (Lazy.force coq_fast_Zopp_involutive)], t - | Otimes(t1,Oz x) -> + | Otimes(t1,Oz x) -> [clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zopp_mult_distr_r); focused_simpl (P_APP 2 :: p)], Otimes(t1,Oz (neg x)) @@ -864,13 +864,13 @@ let rec negate p = function [clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1)], r | Oz i -> [focused_simpl p],Oz(neg i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) - -let rec transform p t = + +let rec transform p t = let default isnat t' = - try + try let v,th,_ = find_constr t' in [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - with _ -> + with _ -> let v = new_identifier_var () and th = new_identifier () in hide_constr t' v th isnat; @@ -878,12 +878,12 @@ let rec transform p t = in try match destructurate_term t with | Kapp(Zplus,[t1;t2]) -> - let tac1,t1' = transform (P_APP 1 :: p) t1 + let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in let tac,t' = shuffle p (t1',t2') in tac1 @ tac2 @ tac, t' | Kapp(Zminus,[t1;t2]) -> - let tac,t = + let tac,t = transform p (mkApp (Lazy.force coq_Zplus, [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in @@ -893,18 +893,18 @@ let rec transform p t = [| t1; mk_integer one |])) in unfold sp_Zsucc :: tac,t | Kapp(Zmult,[t1;t2]) -> - let tac1,t1' = transform (P_APP 1 :: p) t1 + let tac1,t1' = transform (P_APP 1 :: p) t1 and tac2,t2' = transform (P_APP 2 :: p) t2 in begin match t1',t2' with | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' | (Oz n,_) -> - let sym = - clever_rewrite p [[P_APP 1];[P_APP 2]] + let sym = + clever_rewrite p [[P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zmult_comm) in let tac,t' = scalar p n t2' in tac1 @ tac2 @ (sym :: tac),t' | _ -> default false t end - | Kapp((Zpos|Zneg|Z0),_) -> + | Kapp((Zpos|Zneg|Z0),_) -> (try ([],Oz(recognize_number t)) with _ -> default false t) | Kvar s -> [],Oatom s | Kapp(Zopp,[t]) -> @@ -914,28 +914,28 @@ let rec transform p t = | Kapp(Z_of_nat,[t']) -> default true t' | _ -> default false t with e when catchable_exception e -> default false t - + let shrink_pair p f1 f2 = match f1,f2 with - | Oatom v,Oatom _ -> + | Oatom v,Oatom _ -> let r = Otimes(Oatom v,Oz two) in clever_rewrite p [[P_APP 1]] (Lazy.force coq_fast_Zred_factor1), r - | Oatom v, Otimes(_,c2) -> + | Oatom v, Otimes(_,c2) -> let r = Otimes(Oatom v,Oplus(c2,Oz one)) in - clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] + clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zred_factor2), r - | Otimes (v1,c1),Oatom v -> + | Otimes (v1,c1),Oatom v -> let r = Otimes(Oatom v,Oplus(c1,Oz one)) in clever_rewrite p [[P_APP 2];[P_APP 1;P_APP 2]] (Lazy.force coq_fast_Zred_factor3), r | Otimes (Oatom v,c1),Otimes (v2,c2) -> let r = Otimes(Oatom v,Oplus(c1,c2)) in - clever_rewrite p + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 1;P_APP 2];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zred_factor4),r - | t1,t2 -> - begin - oprint t1; print_newline (); oprint t2; print_newline (); + | t1,t2 -> + begin + oprint t1; print_newline (); oprint t2; print_newline (); flush Pervasives.stdout; error "shrink.1" end @@ -948,7 +948,7 @@ let reduce_factor p = function let rec compute = function | Oz n -> n | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) - | _ -> error "condense.1" + | _ -> error "condense.1" in [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) | t -> oprint t; error "reduce_factor.1" @@ -957,31 +957,31 @@ let rec condense p = function | Oplus(f1,(Oplus(f2,r) as t)) -> if weight f1 = weight f2 then begin let shrink_tac,t = shrink_pair (P_APP 1 :: p) f1 f2 in - let assoc_tac = - clever_rewrite p + let assoc_tac = + clever_rewrite p [[P_APP 1];[P_APP 2;P_APP 1];[P_APP 2;P_APP 2]] (Lazy.force coq_fast_Zplus_assoc) in let tac_list,t' = condense p (Oplus(t,r)) in (assoc_tac :: shrink_tac :: tac_list), t' end else begin let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) t in - (tac @ tac'), Oplus(f,t') + let tac',t' = condense (P_APP 2 :: p) t in + (tac @ tac'), Oplus(f,t') end - | Oplus(f1,Oz n) -> + | Oplus(f1,Oz n) -> let tac,f1' = reduce_factor (P_APP 1 :: p) f1 in tac,Oplus(f1',Oz n) - | Oplus(f1,f2) -> + | Oplus(f1,f2) -> if weight f1 = weight f2 then begin let tac_shrink,t = shrink_pair p f1 f2 in let tac,t' = condense p t in tac_shrink :: tac,t' end else begin let tac,f = reduce_factor (P_APP 1 :: p) f1 in - let tac',t' = condense (P_APP 2 :: p) f2 in - (tac @ tac'),Oplus(f,t') + let tac',t' = condense (P_APP 2 :: p) f2 in + (tac @ tac'),Oplus(f,t') end | Oz _ as t -> [],t - | t -> + | t -> let tac,t' = reduce_factor p t in let final = Oplus(t',Oz zero) in let tac' = clever_rewrite p [[]] (Lazy.force coq_fast_Zred_factor6) in @@ -990,99 +990,99 @@ let rec condense p = function let rec clear_zero p = function | Oplus(Otimes(Oatom v,Oz n),r) when n =? zero -> let tac = - clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] + clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in let tac',t = clear_zero p r in tac :: tac',t - | Oplus(f,r) -> + | Oplus(f,r) -> let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) | t -> [],t -let replay_history tactic_normalisation = +let replay_history tactic_normalisation = let aux = id_of_string "auxiliary" in let aux1 = id_of_string "auxiliary_1" in let aux2 = id_of_string "auxiliary_2" in let izero = mk_integer zero in let rec loop t = match t with - | HYP e :: l -> - begin - try - tclTHEN - (List.assoc (hyp_of_tag e.id) tactic_normalisation) + | HYP e :: l -> + begin + try + tclTHEN + (List.assoc (hyp_of_tag e.id) tactic_normalisation) (loop l) with Not_found -> loop l end | NEGATE_CONTRADICT (e2,e1,b) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in - let id1 = hyp_of_tag e1.id + let eq1 = decompile e1 + and eq2 = decompile e2 in + let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2.id in let k = if b then negone else one in let p_initial = [P_APP 1;P_TYPE] in let tac= shuffle_mult_right p_initial e1.body k e2.body in tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_OMEGA17, [| + (generalize_tac + [mkApp (Lazy.force coq_OMEGA17, [| val_of eq1; val_of eq2; - mk_integer k; + mk_integer k; mkVar id1; mkVar id2 |])]); (mk_then tac); (intros_using [aux]); (resolve_id aux); reflexivity ] - | CONTRADICTION (e1,e2) :: l -> - let eq1 = decompile e1 - and eq2 = decompile e2 in + | CONTRADICTION (e1,e2) :: l -> + let eq1 = decompile e1 + and eq2 = decompile e2 in let p_initial = [P_APP 2;P_TYPE] in let tac = shuffle_cancel p_initial e1.body in let solve_le = - let not_sup_sup = mkApp (build_coq_eq (), [| - Lazy.force coq_comparison; + let not_sup_sup = mkApp (build_coq_eq (), [| + Lazy.force coq_comparison; Lazy.force coq_Gt; Lazy.force coq_Gt |]) in - tclTHENS + tclTHENS (tclTHENLIST [ (unfold sp_Zle); (simpl_in_concl); intro; (absurd not_sup_sup) ]) - [ assumption ; reflexivity ] + [ assumption ; reflexivity ] in let theorem = - mkApp (Lazy.force coq_OMEGA2, [| - val_of eq1; val_of eq2; + mkApp (Lazy.force coq_OMEGA2, [| + val_of eq1; val_of eq2; mkVar (hyp_of_tag e1.id); mkVar (hyp_of_tag e2.id) |]) in tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) (solve_le) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> let id = hyp_of_tag e1.id in - let eq1 = val_of(decompile e1) + let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in - let kk = mk_integer k + let kk = mk_integer k and dd = mk_integer d in let rhs = mk_plus (mk_times eq2 kk) dd in let state_eg = mk_eq eq1 rhs in let tac = scalar_norm_add [P_APP 3] e2.body in - tclTHENS - (cut state_eg) + tclTHENS + (cut state_eg) [ tclTHENS (tclTHENLIST [ (intros_using [aux]); - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_OMEGA1, [| eq1; rhs; mkVar aux; mkVar id |])]); (clear [aux;id]); (intros_using [id]); (cut (mk_gt kk dd)) ]) - [ tclTHENS - (cut (mk_gt kk izero)) + [ tclTHENS + (cut (mk_gt kk izero)) [ tclTHENLIST [ (intros_using [aux1; aux2]); - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_Zmult_le_approx, [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); (clear [aux1;aux2;id]); @@ -1095,23 +1095,23 @@ let replay_history tactic_normalisation = tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] ]; tclTHEN (mk_then tac) reflexivity ] - + | NOT_EXACT_DIVIDE (e1,k) :: l -> let c = floor_div e1.constant k in let d = Bigint.sub e1.constant (Bigint.mult c k) in - let e2 = {id=e1.id; kind=EQUA;constant = c; + let e2 = {id=e1.id; kind=EQUA;constant = c; body = map_eq_linear (fun c -> c / k) e1.body } in let eq2 = val_of(decompile e2) in - let kk = mk_integer k + let kk = mk_integer k and dd = mk_integer d in let tac = scalar_norm_add [P_APP 2] e2.body in - tclTHENS - (cut (mk_gt dd izero)) - [ tclTHENS (cut (mk_gt kk dd)) + tclTHENS + (cut (mk_gt dd izero)) + [ tclTHENS (cut (mk_gt kk dd)) [tclTHENLIST [ (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA4, + (generalize_tac + [mkApp (Lazy.force coq_OMEGA4, [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); (clear [aux1;aux2]); (unfold sp_not); @@ -1121,7 +1121,7 @@ let replay_history tactic_normalisation = assumption ] ; tclTHENLIST [ (unfold sp_Zgt); - simpl_in_concl; + simpl_in_concl; reflexivity ] ]; tclTHENLIST [ (unfold sp_Zgt); @@ -1130,18 +1130,18 @@ let replay_history tactic_normalisation = | EXACT_DIVIDE (e1,k) :: l -> let id = hyp_of_tag e1.id in let e2 = map_eq_afine (fun c -> c / k) e1 in - let eq1 = val_of(decompile e1) + let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in let kk = mk_integer k in let state_eq = mk_eq eq1 (mk_times eq2 kk) in if e1.kind = DISE then let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS - (cut state_eq) + tclTHENS + (cut state_eq) [tclTHENLIST [ (intros_using [aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA18, + (generalize_tac + [mkApp (Lazy.force coq_OMEGA18, [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); (clear [aux1;id]); (intros_using [id]); @@ -1149,14 +1149,14 @@ let replay_history tactic_normalisation = tclTHEN (mk_then tac) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in - tclTHENS (cut state_eq) + tclTHENS (cut state_eq) [ - tclTHENS - (cut (mk_gt kk izero)) + tclTHENS + (cut (mk_gt kk izero)) [tclTHENLIST [ (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA3, + (generalize_tac + [mkApp (Lazy.force coq_OMEGA3, [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); (clear [aux1;aux2;id]); (intros_using [id]); @@ -1169,35 +1169,35 @@ let replay_history tactic_normalisation = | (MERGE_EQ(e3,e1,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id + let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2 in - let eq1 = val_of(decompile e1) + let eq1 = val_of(decompile e1) and eq2 = val_of (decompile (negate_eq e1)) in - let tac = - clever_rewrite [P_APP 3] [[P_APP 1]] + let tac = + clever_rewrite [P_APP 3] [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: - scalar_norm [P_APP 3] e1.body + scalar_norm [P_APP 3] e1.body in - tclTHENS - (cut (mk_eq eq1 (mk_inv eq2))) + tclTHENS + (cut (mk_eq eq1 (mk_inv eq2))) [tclTHENLIST [ (intros_using [aux]); - (generalize_tac [mkApp (Lazy.force coq_OMEGA8, + (generalize_tac [mkApp (Lazy.force coq_OMEGA8, [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); (clear [id1;id2;aux]); (intros_using [id]); (loop l) ]; tclTHEN (mk_then tac) reflexivity] - + | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> - let id = new_identifier () + let id = new_identifier () and id2 = hyp_of_tag orig.id in tag_hypothesis id e.id; - let eq1 = val_of(decompile def) + let eq1 = val_of(decompile def) and eq2 = val_of(decompile orig) in let vid = unintern_id v in let theorem = - mkApp (build_coq_ex (), [| + mkApp (build_coq_ex (), [| Lazy.force coq_Z; mkLambda (Name vid, @@ -1206,20 +1206,20 @@ let replay_history tactic_normalisation = in let mm = mk_integer m in let p_initial = [P_APP 2;P_TYPE] in - let tac = - clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) + let tac = + clever_rewrite (P_APP 1 :: P_APP 1 :: P_APP 2 :: p_initial) [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: shuffle_mult_right p_initial orig.body m ({c= negone;v= v}::def.body) in - tclTHENS - (cut theorem) + tclTHENS + (cut theorem) [tclTHENLIST [ (intros_using [aux]); (elim_id aux); (clear [aux]); (intros_using [vid; aux]); (generalize_tac - [mkApp (Lazy.force coq_OMEGA9, + [mkApp (Lazy.force coq_OMEGA9, [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); (mk_then tac); (clear [aux]); @@ -1227,36 +1227,36 @@ let replay_history tactic_normalisation = (loop l) ]; tclTHEN (exists_tac (inj_open eq1)) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> - let id1 = new_identifier () + let id1 = new_identifier () and id2 = new_identifier () in tag_hypothesis id1 e1; tag_hypothesis id2 e2; let id = hyp_of_tag e.id in let tac1 = norm_add [P_APP 2;P_TYPE] e.body in let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in let eq = val_of(decompile e) in - tclTHENS + tclTHENS (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) [tclTHENLIST [ (mk_then tac1); (intros_using [id1]); (loop act1) ]; tclTHENLIST [ (mk_then tac2); (intros_using [id2]); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; - let id1 = hyp_of_tag e1.id + let id1 = hyp_of_tag e1.id and id2 = hyp_of_tag e2.id in - let eq1 = val_of(decompile e1) + let eq1 = val_of(decompile e1) and eq2 = val_of(decompile e2) in if k1 =? one & e2.kind = EQUA then let tac_thm = match e1.kind with - | EQUA -> Lazy.force coq_OMEGA5 - | INEQ -> Lazy.force coq_OMEGA6 - | DISE -> Lazy.force coq_OMEGA20 + | EQUA -> Lazy.force coq_OMEGA5 + | INEQ -> Lazy.force coq_OMEGA6 + | DISE -> Lazy.force coq_OMEGA20 in let kk = mk_integer k2 in let p_initial = if e1.kind=DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in let tac = shuffle_mult_right p_initial e1.body k2 e2.body in - tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); (mk_then tac); @@ -1264,18 +1264,18 @@ let replay_history tactic_normalisation = (loop l) ] else - let kk1 = mk_integer k1 + let kk1 = mk_integer k1 and kk2 = mk_integer k2 in let p_initial = [P_APP 2;P_TYPE] in let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in - tclTHENS (cut (mk_gt kk1 izero)) - [tclTHENS - (cut (mk_gt kk2 izero)) + tclTHENS (cut (mk_gt kk1 izero)) + [tclTHENS + (cut (mk_gt kk2 izero)) [tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac - [mkApp (Lazy.force coq_OMEGA7, [| - eq1;eq2;kk1;kk2; + [mkApp (Lazy.force coq_OMEGA7, [| + eq1;eq2;kk1;kk2; mkVar aux1;mkVar aux2; mkVar id1;mkVar id2 |])]); (clear [aux1;aux2]); @@ -1288,11 +1288,11 @@ let replay_history tactic_normalisation = reflexivity ] ]; tclTHENLIST [ (unfold sp_Zgt); - simpl_in_concl; + simpl_in_concl; reflexivity ] ] - | CONSTANT_NOT_NUL(e,k) :: l -> + | CONSTANT_NOT_NUL(e,k) :: l -> tclTHEN (generalize_tac [mkVar (hyp_of_tag e)]) Equality.discrConcl - | CONSTANT_NUL(e) :: l -> + | CONSTANT_NUL(e) :: l -> tclTHEN (resolve_id (hyp_of_tag e)) reflexivity | CONSTANT_NEG(e,k) :: l -> tclTHENLIST [ @@ -1302,43 +1302,43 @@ let replay_history tactic_normalisation = (unfold sp_not); (intros_using [aux]); (resolve_id aux); - reflexivity + reflexivity ] - | _ -> tclIDTAC + | _ -> tclIDTAC in loop let normalize p_initial t = let (tac,t') = transform p_initial t in let (tac',t'') = condense p_initial t' in - let (tac'',t''') = clear_zero p_initial t'' in + let (tac'',t''') = clear_zero p_initial t'' in tac @ tac' @ tac'' , t''' - + let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = let p_initial = [P_APP pos ;P_TYPE] in let (tac,t') = normalize p_initial t in - let shift_left = - tclTHEN + let shift_left = + tclTHEN (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]) (tclTRY (clear [id])) in if tac <> [] then - let id' = new_identifier () in + let id' = new_identifier () in ((id',(tclTHENLIST [ (shift_left); (mk_then tac); (intros_using [id']) ])) :: tactic, compile id' flag t' :: defs) - else + else (tactic,defs) - + let destructure_omega gl tac_def (id,c) = - if atompart_of_id id = "State" then + if atompart_of_id id = "State" then tac_def else try match destructurate_prop c with - | Kapp(Eq,[typ;t1;t2]) + | Kapp(Eq,[typ;t1;t2]) when destructurate_type (pf_nf gl typ) = Kapp(Z,[]) -> let t = mk_plus t1 (mk_inv t2) in - normalize_equation + normalize_equation id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def | Kapp(Zne,[t1;t2]) -> let t = mk_plus t1 (mk_inv t2) in @@ -1369,10 +1369,10 @@ let reintroduce id = let coq_omega gl = clear_tables (); - let tactic_normalisation, system = + let tactic_normalisation, system = List.fold_left (destructure_omega gl) ([],[]) (pf_hyps_types gl) in - let prelude,sys = - List.fold_left + let prelude,sys = + List.fold_left (fun (tac,sys) (t,(v,th,b)) -> if b then let id = new_identifier () in @@ -1385,8 +1385,8 @@ let coq_omega gl = (clear [id]); (intros_using [th;id]); tac ]), - {kind = INEQ; - body = [{v=intern_id v; c=one}]; + {kind = INEQ; + body = [{v=intern_id v; c=one}]; constant = zero; id = i} :: sys else (tclTHENLIST [ @@ -1399,17 +1399,17 @@ let coq_omega gl = let system = system @ sys in if !display_system_flag then display_system display_var system; if !old_style_flag then begin - try + try let _ = simplify (new_id,new_var_num,display_var) false system in tclIDTAC gl - with UNSOLVABLE -> + with UNSOLVABLE -> let _,path = depend [] [] (history ()) in if !display_action_flag then display_action display_var path; - (tclTHEN prelude (replay_history tactic_normalisation path)) gl - end else begin + (tclTHEN prelude (replay_history tactic_normalisation path)) gl + end else begin try let path = simplify_strong (new_id,new_var_num,display_var) system in - if !display_action_flag then display_action display_var path; + if !display_action_flag then display_action display_var path; (tclTHEN prelude (replay_history tactic_normalisation path)) gl with NO_CONTRADICTION -> error "Omega can't solve this system" end @@ -1417,10 +1417,10 @@ let coq_omega gl = let coq_omega = solver_time coq_omega let nat_inject gl = - let rec explore p t = + let rec explore p t = try match destructurate_term t with | Kapp(Plus,[t1;t2]) -> - tclTHENLIST [ + tclTHENLIST [ (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_plus),[t1;t2])); (explore (P_APP 1 :: p) t1); @@ -1436,61 +1436,61 @@ let nat_inject gl = | Kapp(Minus,[t1;t2]) -> let id = new_identifier () in tclTHENS - (tclTHEN - (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) - (intros_using [id])) + (tclTHEN + (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) + (intros_using [id])) [ tclTHENLIST [ - (clever_rewrite_gen p + (clever_rewrite_gen p (mk_minus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ]; - (tclTHEN + (tclTHEN (clever_rewrite_gen p (mk_integer zero) ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])) (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) ] | Kapp(S,[t']) -> let rec is_number t = - try match destructurate_term t with + try match destructurate_term t with Kapp(S,[t]) -> is_number t | Kapp(O,[]) -> true | _ -> false - with e when catchable_exception e -> false + with e when catchable_exception e -> false in let rec loop p t = - try match destructurate_term t with + try match destructurate_term t with Kapp(S,[t]) -> - (tclTHEN - (clever_rewrite_gen p + (tclTHEN + (clever_rewrite_gen p (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) - ((Lazy.force coq_inj_S),[t])) + ((Lazy.force coq_inj_S),[t])) (loop (P_APP 1 :: p) t)) - | _ -> explore p t - with e when catchable_exception e -> explore p t + | _ -> explore p t + with e when catchable_exception e -> explore p t in if is_number t' then focused_simpl p else loop p t | Kapp(Pred,[t]) -> - let t_minus_one = - mkApp (Lazy.force coq_minus, [| t; + let t_minus_one = + mkApp (Lazy.force coq_minus, [| t; mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in tclTHEN - (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one + (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one ((Lazy.force coq_pred_of_minus),[t])) - (explore p t_minus_one) + (explore p t_minus_one) | Kapp(O,[]) -> focused_simpl p - | _ -> tclIDTAC - with e when catchable_exception e -> tclIDTAC - + | _ -> tclIDTAC + with e when catchable_exception e -> tclIDTAC + and loop = function | [] -> tclIDTAC - | (i,t)::lit -> - begin try match destructurate_prop t with + | (i,t)::lit -> + begin try match destructurate_prop t with Kapp(Le,[t1;t2]) -> tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); @@ -1499,7 +1499,7 @@ let nat_inject gl = ] | Kapp(Lt,[t1;t2]) -> tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); @@ -1508,7 +1508,7 @@ let nat_inject gl = ] | Kapp(Ge,[t1;t2]) -> tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); (explore [P_APP 2; P_TYPE] t2); @@ -1536,7 +1536,7 @@ let nat_inject gl = | Kapp(Eq,[typ;t1;t2]) -> if pf_conv_x gl typ (Lazy.force coq_nat) then tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); (explore [P_APP 2; P_TYPE] t1); (explore [P_APP 3; P_TYPE] t2); @@ -1545,32 +1545,32 @@ let nat_inject gl = ] else loop lit | _ -> loop lit - with e when catchable_exception e -> loop lit end + with e when catchable_exception e -> loop lit end in loop (List.rev (pf_hyps_types gl)) gl - + let rec decidability gl t = match destructurate_prop t with - | Kapp(Or,[t1;t2]) -> + | Kapp(Or,[t1;t2]) -> mkApp (Lazy.force coq_dec_or, [| t1; t2; decidability gl t1; decidability gl t2 |]) - | Kapp(And,[t1;t2]) -> + | Kapp(And,[t1;t2]) -> mkApp (Lazy.force coq_dec_and, [| t1; t2; decidability gl t1; decidability gl t2 |]) - | Kapp(Iff,[t1;t2]) -> + | Kapp(Iff,[t1;t2]) -> mkApp (Lazy.force coq_dec_iff, [| t1; t2; decidability gl t1; decidability gl t2 |]) - | Kimp(t1,t2) -> + | Kimp(t1,t2) -> mkApp (Lazy.force coq_dec_imp, [| t1; t2; decidability gl t1; decidability gl t2 |]) - | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; + | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |]) - | Kapp(Eq,[typ;t1;t2]) -> + | Kapp(Eq,[typ;t1;t2]) -> begin match destructurate_type (pf_nf gl typ) with | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) - | _ -> errorlabstrm "decidability" - (str "Omega: Can't solve a goal with equality on " ++ + | _ -> errorlabstrm "decidability" + (str "Omega: Can't solve a goal with equality on " ++ Printer.pr_lconstr typ) end | Kapp(Zne,[t1;t2]) -> mkApp (Lazy.force coq_dec_Zne, [| t1;t2 |]) @@ -1584,7 +1584,7 @@ let rec decidability gl t = | Kapp(Gt, [t1;t2]) -> mkApp (Lazy.force coq_dec_gt, [| t1;t2 |]) | Kapp(False,[]) -> Lazy.force coq_dec_False | Kapp(True,[]) -> Lazy.force coq_dec_True - | Kapp(Other t,_::_) -> error + | Kapp(Other t,_::_) -> error ("Omega: Unrecognized predicate or connective: "^t) | Kapp(Other t,[]) -> error ("Omega: Unrecognized atomic proposition: "^t) | Kvar _ -> error "Omega: Can't solve a goal with proposition variables" @@ -1595,7 +1595,7 @@ let onClearedName id tac = (* so renaming may be necessary *) tclTHEN (tclTRY (clear [id])) - (fun gl -> + (fun gl -> let id = fresh_id [] id gl in tclTHEN (introduction id) (tac id) gl) @@ -1607,7 +1607,7 @@ let destructure_hyps gl = | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> - (tclTHENS + (tclTHENS (elim_id i) [ onClearedName i (fun i -> (loop ((i,None,t1)::lit))); onClearedName i (fun i -> (loop ((i,None,t2)::lit))) ]) @@ -1615,7 +1615,7 @@ let destructure_hyps gl = tclTHENLIST [ (elim_id i); (tclTRY (clear [i])); - (fun gl -> + (fun gl -> let i1 = fresh_id [] (add_suffix i "_left") gl in let i2 = fresh_id [] (add_suffix i "_right") gl in tclTHENLIST [ @@ -1627,7 +1627,7 @@ let destructure_hyps gl = tclTHENLIST [ (elim_id i); (tclTRY (clear [i])); - (fun gl -> + (fun gl -> let i1 = fresh_id [] (add_suffix i "_left") gl in let i2 = fresh_id [] (add_suffix i "_right") gl in tclTHENLIST [ @@ -1661,16 +1661,16 @@ let destructure_hyps gl = ] else loop lit - | Kapp(Not,[t]) -> - begin match destructurate_prop t with - Kapp(Or,[t1;t2]) -> + | Kapp(Not,[t]) -> + begin match destructurate_prop t with + Kapp(Or,[t1;t2]) -> tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,mk_and (mk_not t1) (mk_not t2)):: lit)))) ] - | Kapp(And,[t1;t2]) -> + | Kapp(And,[t1;t2]) -> tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_and, [| t1; t2; @@ -1690,8 +1690,8 @@ let destructure_hyps gl = ] | Kimp(t1,t2) -> tclTHENLIST [ - (generalize_tac - [mkApp (Lazy.force coq_not_imp, [| t1; t2; + (generalize_tac + [mkApp (Lazy.force coq_not_imp, [| t1; t2; decidability gl t1;mkVar i |])]); (onClearedName i (fun i -> (loop ((i,None,mk_and t1 (mk_not t2)) :: lit)))) @@ -1717,7 +1717,7 @@ let destructure_hyps gl = ] | Kapp(Zlt, [t1;t2]) -> tclTHENLIST [ - (generalize_tac + (generalize_tac [mkApp (Lazy.force coq_Znot_lt_ge, [| t1;t2;mkVar i|])]); (onClearedName i (fun _ -> loop lit)) ] @@ -1752,33 +1752,33 @@ let destructure_hyps gl = (onClearedName i (fun _ -> loop lit)) ] | Kapp(Eq,[typ;t1;t2]) -> - if !old_style_flag then begin + if !old_style_flag then begin match destructurate_type (pf_nf gl typ) with - | Kapp(Nat,_) -> + | Kapp(Nat,_) -> tclTHENLIST [ - (simplest_elim + (simplest_elim (mkApp (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | Kapp(Z,_) -> tclTHENLIST [ - (simplest_elim + (simplest_elim (mkApp (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | _ -> loop lit - end else begin + end else begin match destructurate_type (pf_nf gl typ) with - | Kapp(Nat,_) -> - (tclTHEN + | Kapp(Nat,_) -> + (tclTHEN (convert_hyp_no_check (i,body, (mkApp (Lazy.force coq_neq, [| t1;t2|])))) (loop lit)) | Kapp(Z,_) -> - (tclTHEN + (tclTHEN (convert_hyp_no_check (i,body, (mkApp (Lazy.force coq_Zne, [| t1;t2|])))) @@ -1786,10 +1786,10 @@ let destructure_hyps gl = | _ -> loop lit end | _ -> loop lit - end - | _ -> loop lit + end + | _ -> loop lit with e when catchable_exception e -> loop lit - end + end in loop (pf_hyps gl) gl @@ -1798,19 +1798,19 @@ let destructure_goal gl = let rec loop t = match destructurate_prop t with | Kapp(Not,[t]) -> - (tclTHEN - (tclTHEN (unfold sp_not) intro) + (tclTHEN + (tclTHEN (unfold sp_not) intro) destructure_hyps) | Kimp(a,b) -> (tclTHEN intro (loop b)) | Kapp(False,[]) -> destructure_hyps | _ -> - (tclTHEN + (tclTHEN (tclTHEN - (Tactics.refine + (Tactics.refine (mkApp (Lazy.force coq_dec_not_not, [| t; decidability gl t; mkNewMeta () |]))) - intro) - (destructure_hyps)) + intro) + (destructure_hyps)) in (loop concl) gl @@ -1818,7 +1818,7 @@ let destructure_goal = all_time (destructure_goal) let omega_solver gl = Coqlib.check_required_library ["Coq";"omega";"Omega"]; - let result = destructure_goal gl in - (* if !display_time_flag then begin text_time (); + let result = destructure_goal gl in + (* if !display_time_flag then begin text_time (); flush Pervasives.stdout end; *) result diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index a69f8ef745..3bfdce7fdc 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -20,16 +20,16 @@ open Coq_omega open Refiner -let omega_tactic l = - let tacs = List.map - (function +let omega_tactic l = + let tacs = List.map + (function | "nat" -> Tacinterp.interp <:tactic> | "positive" -> Tacinterp.interp <:tactic> | "N" -> Tacinterp.interp <:tactic> | "Z" -> Tacinterp.interp <:tactic> | s -> Util.error ("No Omega knowledge base for type "^s)) (Util.list_uniquize (List.sort compare l)) - in + in tclTHEN (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) omega_solver @@ -40,7 +40,7 @@ TACTIC EXTEND omega END TACTIC EXTEND omega' -| [ "omega" "with" ne_ident_list(l) ] -> +| [ "omega" "with" ne_ident_list(l) ] -> [ omega_tactic (List.map Names.string_of_id l) ] | [ "omega" "with" "*" ] -> [ omega_tactic ["nat";"positive";"N";"Z"] ] END diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index fd774c16d0..11ab9c0394 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -85,13 +85,13 @@ type linear = coeff list type eqn_kind = EQUA | INEQ | DISE -type afine = { +type afine = { (* a number uniquely identifying the equation *) - id: int ; + id: int ; (* a boolean true for an eq, false for an ineq (Sigma a_i x_i >= 0) *) - kind: eqn_kind; + kind: eqn_kind; (* the variables and their coefficient *) - body: coeff list; + body: coeff list; (* a constant *) constant: bigint } @@ -108,7 +108,7 @@ type action = | FORGET_C of int | EXACT_DIVIDE of afine * bigint | SUM of int * (bigint * afine) * (bigint * afine) - | STATE of state_action + | STATE of state_action | HYP of afine | FORGET of int * int | FORGET_I of int * int @@ -126,22 +126,22 @@ exception UNSOLVABLE exception NO_CONTRADICTION let display_eq print_var (l,e) = - let _ = - List.fold_left + let _ = + List.fold_left (fun not_first f -> - print_string + print_string (if f.c ? zero then + if e >? zero then Printf.printf "+ %s " (string_of_bigint e) - else if e accu + one in List.fold_left action_length zero l -let operator_of_eq = function +let operator_of_eq = function | EQUA -> "=" | DISE -> "!=" | INEQ -> ">=" let kind_of = function | EQUA -> "equation" | DISE -> "disequation" | INEQ -> "inequation" -let display_system print_var l = - List.iter - (fun { kind=b; body=e; constant=c; id=id} -> +let display_system print_var l = + List.iter + (fun { kind=b; body=e; constant=c; id=id} -> Printf.printf "E%d: " id; display_eq print_var (e,c); Printf.printf "%s 0\n" (operator_of_eq b)) l; print_string "------------------------\n\n" -let display_inequations print_var l = +let display_inequations print_var l = List.iter (fun e -> display_eq print_var e;print_string ">= 0\n") l; print_string "------------------------\n\n" @@ -175,7 +175,7 @@ let sbi = string_of_bigint let rec display_action print_var = function | act :: l -> begin match act with | DIVIDE_AND_APPROX (e1,e2,k,d) -> - Printf.printf + Printf.printf "Inequation E%d is divided by %s and the constant coefficient is \ rounded by substracting %s.\n" e1.id (sbi k) (sbi d) | NOT_EXACT_DIVIDE (e,k) -> @@ -187,28 +187,28 @@ let rec display_action print_var = function "Equation E%d is divided by the pgcd \ %s of its coefficients.\n" e.id (sbi k) | WEAKEN (e,k) -> - Printf.printf + Printf.printf "To ensure a solution in the dark shadow \ the equation E%d is weakened by %s.\n" e (sbi k) - | SUM (e,(c1,e1),(c2,e2)) -> + | SUM (e,(c1,e1),(c2,e2)) -> Printf.printf - "We state %s E%d = %s %s E%d + %s %s E%d.\n" + "We state %s E%d = %s %s E%d + %s %s E%d.\n" (kind_of e1.kind) e (sbi c1) (kind_of e1.kind) e1.id (sbi c2) (kind_of e2.kind) e2.id | STATE { st_new_eq = e } -> - Printf.printf "We define a new equation E%d: " e.id; - display_eq print_var (e.body,e.constant); + Printf.printf "We define a new equation E%d: " e.id; + display_eq print_var (e.body,e.constant); print_string (operator_of_eq e.kind); print_string " 0" - | HYP e -> - Printf.printf "We define E%d: " e.id; - display_eq print_var (e.body,e.constant); + | HYP e -> + Printf.printf "We define E%d: " e.id; + display_eq print_var (e.body,e.constant); print_string (operator_of_eq e.kind); print_string " 0\n" | FORGET_C e -> Printf.printf "E%d is trivially satisfiable.\n" e | FORGET (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 | FORGET_I (e1,e2) -> Printf.printf "E%d subsumes E%d.\n" e1 e2 | MERGE_EQ (e,e1,e2) -> Printf.printf "E%d and E%d can be merged into E%d.\n" e1.id e2 e - | CONTRADICTION (e1,e2) -> + | CONTRADICTION (e1,e2) -> Printf.printf "Equations E%d and E%d imply a contradiction on their \ constant factors.\n" e1.id e2.id @@ -216,20 +216,20 @@ let rec display_action print_var = function Printf.printf "Equations E%d and E%d state that their body is at the same time equal and different\n" e1.id e2.id - | CONSTANT_NOT_NUL (e,k) -> + | CONSTANT_NOT_NUL (e,k) -> Printf.printf "Equation E%d states %s = 0.\n" e (sbi k) - | CONSTANT_NEG(e,k) -> + | CONSTANT_NEG(e,k) -> Printf.printf "Equation E%d states %s >= 0.\n" e (sbi k) | CONSTANT_NUL e -> Printf.printf "Inequation E%d states 0 != 0.\n" e - | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> + | SPLIT_INEQ (e,(e1,l1),(e2,l2)) -> Printf.printf "Equation E%d is split in E%d and E%d\n\n" e.id e1 e2; display_action print_var l1; print_newline (); display_action print_var l2; print_newline () end; display_action print_var l - | [] -> + | [] -> flush stdout let default_print_var v = Printf.sprintf "X%d" v (* For debugging *) @@ -245,38 +245,38 @@ let nf_linear = Sort.list (fun x y -> x.v > y.v) let nf ((b : bool),(e,(x : int))) = (b,(nf_linear e,x)) -let map_eq_linear f = +let map_eq_linear f = let rec loop = function | x :: l -> let c = f x.c in if c=?zero then loop l else {v=x.v; c=c} :: loop l - | [] -> [] + | [] -> [] in loop -let map_eq_afine f e = - { id = e.id; kind = e.kind; body = map_eq_linear f e.body; +let map_eq_afine f e = + { id = e.id; kind = e.kind; body = map_eq_linear f e.body; constant = f e.constant } let negate_eq = map_eq_afine (fun x -> neg x) -let rec sum p0 p1 = match (p0,p1) with +let rec sum p0 p1 = match (p0,p1) with | ([], l) -> l | (l, []) -> l - | (((x1::l1) as l1'), ((x2::l2) as l2')) -> + | (((x1::l1) as l1'), ((x2::l2) as l2')) -> if x1.v = x2.v then let c = x1.c + x2.c in if c =? zero then sum l1 l2 else {v=x1.v;c=c} :: sum l1 l2 - else if x1.v > x2.v then + else if x1.v > x2.v then x1 :: sum l1 l2' - else + else x2 :: sum l1' l2 -let sum_afine new_eq_id eq1 eq2 = +let sum_afine new_eq_id eq1 eq2 = { kind = eq1.kind; id = new_eq_id (); body = sum eq1.body eq2.body; constant = eq1.constant + eq2.constant } exception FACTOR1 let rec chop_factor_1 = function - | x :: l -> + | x :: l -> if abs x.c =? one then x,l else let (c',l') = chop_factor_1 l in (c',x::l') | [] -> raise FACTOR1 @@ -287,7 +287,7 @@ let rec chop_var v = function | [] -> raise CHOPVAR let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = - if e = [] then begin + if e = [] then begin match eq_flag with | EQUA -> if x =? zero then [] else begin @@ -310,7 +310,7 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = end else if gcd <> one then begin let c = floor_div x gcd in let d = x - c * gcd in - let new_eq = {id=id; kind=eq_flag; constant=c; + let new_eq = {id=id; kind=eq_flag; constant=c; body=map_eq_linear (fun c -> c / gcd) e} in add_event (if eq_flag=EQUA or eq_flag = DISE then EXACT_DIVIDE(eq,gcd) else DIVIDE_AND_APPROX(eq,new_eq,gcd,d)); @@ -320,15 +320,15 @@ let normalize ({id=id; kind=eq_flag; body=e; constant =x} as eq) = let eliminate_with_in new_eq_id {v=v;c=c_unite} eq2 ({body=e1; constant=c1} as eq1) = try - let (f,_) = chop_var v e1 in - let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c + let (f,_) = chop_var v e1 in + let coeff = if c_unite=?one then neg f.c else if c_unite=? negone then f.c else failwith "eliminate_with_in" in let res = sum_afine new_eq_id eq1 (map_eq_afine (fun c -> c * coeff) eq2) in add_event (SUM (res.id,(one,eq1),(coeff,eq2))); res with CHOPVAR -> eq1 let omega_mod a b = a - b * floor_div (two * a + b) (two * b) -let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = +let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = let e = original.body in let sigma = new_var_id () in let smallest,var = @@ -339,7 +339,7 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = let m = smallest + one in let new_eq = { constant = omega_mod original.constant m; - body = {c= neg m;v=sigma} :: + body = {c= neg m;v=sigma} :: map_eq_linear (fun a -> omega_mod a m) original.body; id = new_eq_id (); kind = EQUA } in let definition = @@ -351,11 +351,11 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = st_orig = original; st_coef = m; st_var = sigma}); let new_eq = List.hd (normalize new_eq) in let eliminated_var, def = chop_var var new_eq.body in - let other_equations = + let other_equations = Util.list_map_append - (fun e -> + (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l1 in - let inequations = + let inequations = Util.list_map_append (fun e -> normalize (eliminate_with_in new_eq_id eliminated_var new_eq e)) l2 in @@ -364,7 +364,7 @@ let banerjee_step (new_eq_id,new_var_id,print_var) original l1 l2 = add_event (EXACT_DIVIDE (original',m)); List.hd (normalize mod_original),other_equations,inequations -let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = +let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e,other,ineqs) = if !debug then display_system print_var (e::other); try let v,def = chop_factor_1 e.body in @@ -377,22 +377,22 @@ let rec eliminate_one_equation ((new_eq_id,new_var_id,print_var) as new_ids) (e, let rec banerjee ((_,_,print_var) as new_ids) (sys_eq,sys_ineq) = let rec fst_eq_1 = function - (eq::l) -> + (eq::l) -> if List.exists (fun x -> abs x.c =? one) eq.body then eq,l else let (eq',l') = fst_eq_1 l in (eq',eq::l') | [] -> raise Not_found in match sys_eq with [] -> if !debug then display_system print_var sys_ineq; sys_ineq - | (e1::rest) -> + | (e1::rest) -> let eq,other = try fst_eq_1 sys_eq with Not_found -> (e1,rest) in - if eq.body = [] then + if eq.body = [] then if eq.constant =? zero then begin add_event (FORGET_C eq.id); banerjee new_ids (other,sys_ineq) end else begin add_event (CONSTANT_NOT_NUL(eq.id,eq.constant)); raise UNSOLVABLE end else - banerjee new_ids + banerjee new_ids (eliminate_one_equation new_ids (eq,other,sys_ineq)) type kind = INVERTED | NORMAL @@ -403,37 +403,37 @@ let redundancy_elimination new_eq_id system = | e -> e,NORMAL in let table = Hashtbl.create 7 in List.iter - (fun e -> + (fun e -> let ({body=ne} as nx) ,kind = normal e in if ne = [] then if nx.constant + match optnormal with + Some v -> let kept = - if v.constant Some nx,optinvert end else begin - match optinvert with + match optinvert with Some v -> let _kept = - if v.constant >? nx.constant + if v.constant >? nx.constant then begin add_event (FORGET_I (v.id,nx.id));v end else begin add_event (FORGET_I (nx.id,v.id));nx end in (optnormal,Some(if v.constant >? nx.constant then v else nx)) | None -> optnormal,Some nx end in begin match final with - (Some high, Some low) -> + (Some high, Some low) -> if high.constant - Hashtbl.add table ne + Hashtbl.add table ne (if kind = NORMAL then (Some nx,None) else (None,Some nx))) system; let accu_eq = ref [] in let accu_ineq = ref [] in Hashtbl.iter - (fun p0 p1 -> match (p0,p1) with + (fun p0 p1 -> match (p0,p1) with | (e, (Some x, Some y)) when x.constant =? y.constant -> let id=new_eq_id () in add_event (MERGE_EQ(id,x,y.id)); push {id=id; kind=EQUA; body=x.body; constant=x.constant} accu_eq | (e, (optnorm,optinvert)) -> - begin match optnorm with + begin match optnorm with Some x -> push x accu_ineq | _ -> () end; - begin match optinvert with + begin match optinvert with Some x -> push (negate_eq x) accu_ineq | _ -> () end) table; !accu_eq,!accu_ineq @@ -465,7 +465,7 @@ exception SOLVED_SYSTEM let select_variable system = let table = Hashtbl.create 7 in - let push v c= + let push v c= try let r = Hashtbl.find table v in r := max !r (abs c) with Not_found -> Hashtbl.add table v (ref (abs c)) in List.iter (fun {body=l} -> List.iter (fun f -> push f.v f.c) l) system; @@ -480,7 +480,7 @@ let select_variable system = !vmin let classify v system = - List.fold_left + List.fold_left (fun (not_occ,below,over) eq -> try let f,eq' = chop_var v eq.body in if f.c >=? zero then (not_occ,((f.c,eq) :: below),over) @@ -493,18 +493,18 @@ let product new_eq_id dark_shadow low high = (fun accu (a,eq1) -> List.fold_left (fun accu (b,eq2) -> - let eq = + let eq = sum_afine new_eq_id (map_eq_afine (fun c -> c * b) eq1) (map_eq_afine (fun c -> c * a) eq2) in add_event(SUM(eq.id,(b,eq1),(a,eq2))); match normalize eq with | [eq] -> let final_eq = - if dark_shadow then + if dark_shadow then let delta = (a - one) * (b - one) in add_event(WEAKEN(eq.id,delta)); - {id = eq.id; kind=INEQ; body = eq.body; - constant = eq.constant - delta} + {id = eq.id; kind=INEQ; body = eq.body; + constant = eq.constant - delta} else eq in final_eq :: accu | (e::_) -> failwith "Product dardk" @@ -519,7 +519,7 @@ let fourier_motzkin (new_eq_id,_,print_var) dark_shadow system = if !debug then display_system print_var expanded; expanded let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = - if List.exists (fun e -> e.kind = DISE) system then + if List.exists (fun e -> e.kind = DISE) system then failwith "disequation in simplify"; clear_history (); List.iter (fun e -> add_event (HYP e)) system; @@ -528,23 +528,23 @@ let simplify ((new_eq_id,new_var_id,print_var) as new_ids) dark_shadow system = let simp_eq,simp_ineq = redundancy_elimination new_eq_id ineqs in let system = (eqs @ simp_eq,simp_ineq) in let rec loop1a system = - let sys_ineq = banerjee new_ids system in - loop1b sys_ineq + let sys_ineq = banerjee new_ids system in + loop1b sys_ineq and loop1b sys_ineq = let simp_eq,simp_ineq = redundancy_elimination new_eq_id sys_ineq in - if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) + if simp_eq = [] then simp_ineq else loop1a (simp_eq,simp_ineq) in let rec loop2 system = try let expanded = fourier_motzkin new_ids dark_shadow system in loop2 (loop1b expanded) with SOLVED_SYSTEM -> - if !debug then display_system print_var system; system + if !debug then display_system print_var system; system in loop2 (loop1a system) let rec depend relie_on accu = function - | act :: l -> + | act :: l -> begin match act with | DIVIDE_AND_APPROX (e,_,_,_) -> if List.mem e.id relie_on then depend relie_on (act::accu) l @@ -555,40 +555,40 @@ let rec depend relie_on accu = function | WEAKEN (e,_) -> if List.mem e relie_on then depend relie_on (act::accu) l else depend relie_on accu l - | SUM (e,(_,e1),(_,e2)) -> - if List.mem e relie_on then + | SUM (e,(_,e1),(_,e2)) -> + if List.mem e relie_on then depend (e1.id::e2.id::relie_on) (act::accu) l - else + else depend relie_on accu l | STATE {st_new_eq=e;st_orig=o} -> if List.mem e.id relie_on then depend (o.id::relie_on) (act::accu) l else depend relie_on accu l - | HYP e -> + | HYP e -> if List.mem e.id relie_on then depend relie_on (act::accu) l else depend relie_on accu l | FORGET_C _ -> depend relie_on accu l | FORGET _ -> depend relie_on accu l | FORGET_I _ -> depend relie_on accu l | MERGE_EQ (e,e1,e2) -> - if List.mem e relie_on then + if List.mem e relie_on then depend (e1.id::e2::relie_on) (act::accu) l - else + else depend relie_on accu l | NOT_EXACT_DIVIDE (e,_) -> depend (e.id::relie_on) (act::accu) l - | CONTRADICTION (e1,e2) -> + | CONTRADICTION (e1,e2) -> depend (e1.id::e2.id::relie_on) (act::accu) l | CONSTANT_NOT_NUL (e,_) -> depend (e::relie_on) (act::accu) l | CONSTANT_NEG (e,_) -> depend (e::relie_on) (act::accu) l | CONSTANT_NUL e -> depend (e::relie_on) (act::accu) l - | NEGATE_CONTRADICT (e1,e2,_) -> + | NEGATE_CONTRADICT (e1,e2,_) -> depend (e1.id::e2.id::relie_on) (act::accu) l | SPLIT_INEQ _ -> failwith "depend" end | [] -> relie_on, accu (* -let depend relie_on accu trace = - Printf.printf "Longueur de la trace initiale : %d\n" +let depend relie_on accu trace = + Printf.printf "Longueur de la trace initiale : %d\n" (trace_length trace + trace_length accu); let rel',trace' = depend relie_on accu trace in Printf.printf "Longueur de la trace simplifiée : %d\n" (trace_length trace'); @@ -598,20 +598,20 @@ let depend relie_on accu trace = let solve (new_eq_id,new_eq_var,print_var) system = try let _ = simplify new_eq_id false system in failwith "no contradiction" with UNSOLVABLE -> display_action print_var (snd (depend [] [] (history ()))) - + let negation (eqs,ineqs) = let diseq,_ = List.partition (fun e -> e.kind = DISE) ineqs in let normal = function | ({body=f::_} as e) when f.c negate_eq e, INVERTED | e -> e,NORMAL in let table = Hashtbl.create 7 in - List.iter (fun e -> + List.iter (fun e -> let {body=ne;constant=c} ,kind = normal e in Hashtbl.add table (ne,c) (kind,e)) diseq; List.iter (fun e -> assert (e.kind = EQUA); let {body=ne;constant=c},kind = normal e in - try + try let (kind',e') = Hashtbl.find table (ne,c) in add_event (NEGATE_CONTRADICT (e,e',kind=kind')); raise UNSOLVABLE @@ -625,39 +625,39 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = (* Initial simplification phase *) let rec loop1a system = negation system; - let sys_ineq = banerjee new_ids system in - loop1b sys_ineq + let sys_ineq = banerjee new_ids system in + loop1b sys_ineq and loop1b sys_ineq = let dise,ine = List.partition (fun e -> e.kind = DISE) sys_ineq in let simp_eq,simp_ineq = redundancy_elimination new_eq_id ine in if simp_eq = [] then dise @ simp_ineq - else loop1a (simp_eq,dise @ simp_ineq) + else loop1a (simp_eq,dise @ simp_ineq) in let rec loop2 system = try let expanded = fourier_motzkin new_ids false system in loop2 (loop1b expanded) - with SOLVED_SYSTEM -> if !debug then display_system print_var system; system + with SOLVED_SYSTEM -> if !debug then display_system print_var system; system in - let rec explode_diseq = function + let rec explode_diseq = function | (de::diseq,ineqs,expl_map) -> - let id1 = new_eq_id () + let id1 = new_eq_id () and id2 = new_eq_id () in - let e1 = + let e1 = {id = id1; kind=INEQ; body = de.body; constant = de.constant -one} in - let e2 = - {id = id2; kind=INEQ; body = map_eq_linear neg de.body; + let e2 = + {id = id2; kind=INEQ; body = map_eq_linear neg de.body; constant = neg de.constant - one} in let new_sys = - List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) - ineqs @ - List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) - ineqs + List.map (fun (what,sys) -> ((de.id,id1,true)::what, e1::sys)) + ineqs @ + List.map (fun (what,sys) -> ((de.id,id2,false)::what,e2::sys)) + ineqs in explode_diseq (diseq,new_sys,(de.id,(de,id1,id2))::expl_map) - | ([],ineqs,expl_map) -> ineqs,expl_map + | ([],ineqs,expl_map) -> ineqs,expl_map in - try + try let system = Util.list_map_append normalize system in let eqs,ineqs = List.partition (fun e -> e.kind=EQUA) system in let dise,ine = List.partition (fun e -> e.kind = DISE) ineqs in @@ -669,45 +669,45 @@ let simplify_strong ((new_eq_id,new_var_id,print_var) as new_ids) system = let sys_exploded,explode_map = explode_diseq (diseq,[[],ineq],[]) in let all_solutions = List.map - (fun (decomp,sys) -> + (fun (decomp,sys) -> clear_history (); try let _ = loop2 sys in raise NO_CONTRADICTION - with UNSOLVABLE -> + with UNSOLVABLE -> let relie_on,path = depend [] [] (history ()) in let dc,_ = List.partition (fun (_,id,_) -> List.mem id relie_on) decomp in let red = List.map (fun (x,_,_) -> x) dc in (red,relie_on,decomp,path)) - sys_exploded + sys_exploded in - let max_count sys = + let max_count sys = let tbl = Hashtbl.create 7 in - let augment x = - try incr (Hashtbl.find tbl x) + let augment x = + try incr (Hashtbl.find tbl x) with Not_found -> Hashtbl.add tbl x (ref 1) in let eq = ref (-1) and c = ref 0 in - List.iter (function + List.iter (function | ([],r_on,_,path) -> raise (FULL_SOLUTION (path,r_on)) | (l,_,_,_) -> List.iter augment l) sys; Hashtbl.iter (fun x v -> if !v > !c then begin eq := x; c := !v end) tbl; - !eq + !eq in - let rec solve systems = - try - let id = max_count systems in - let rec sign = function - | ((id',_,b)::l) -> if id=id' then b else sign l + let rec solve systems = + try + let id = max_count systems in + let rec sign = function + | ((id',_,b)::l) -> if id=id' then b else sign l | [] -> failwith "solve" in let s1,s2 = List.partition (fun (_,_,decomp,_) -> sign decomp) systems in - let s1' = + let s1' = List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s1 in - let s2' = + let s2' = List.map (fun (dep,ro,dc,pa) -> (Util.list_except id dep,ro,dc,pa)) s2 in - let (r1,relie1) = solve s1' + let (r1,relie1) = solve s1' and (r2,relie2) = solve s2' in let (eq,id1,id2) = List.assoc id explode_map in [SPLIT_INEQ(eq,(id1,r1),(id2, r2))], eq.id :: Util.list_union relie1 relie2 - with FULL_SOLUTION (x0,x1) -> (x0,x1) + with FULL_SOLUTION (x0,x1) -> (x0,x1) in let act,relie_on = solve all_solutions in snd(depend relie_on act first_segment) diff --git a/plugins/ring/LegacyArithRing.v b/plugins/ring/LegacyArithRing.v index 959d66c749..231b5fbb0f 100644 --- a/plugins/ring/LegacyArithRing.v +++ b/plugins/ring/LegacyArithRing.v @@ -73,14 +73,14 @@ Ltac rewrite_S_to_plus := match goal with | |- (?X1 = ?X2) => try - let t1 := + let t1 := (**) (**) rewrite_S_to_plus_term X1 with t2 := rewrite_S_to_plus_term X2 in change (t1 = t2) in |- * | |- (?X1 = ?X2) => try - let t1 := + let t1 := (**) (**) rewrite_S_to_plus_term X1 with t2 := rewrite_S_to_plus_term X2 in diff --git a/plugins/ring/LegacyRing_theory.v b/plugins/ring/LegacyRing_theory.v index 79f6976bd2..30d29515f0 100644 --- a/plugins/ring/LegacyRing_theory.v +++ b/plugins/ring/LegacyRing_theory.v @@ -19,8 +19,8 @@ Variable Aplus : A -> A -> A. Variable Amult : A -> A -> A. Variable Aone : A. Variable Azero : A. -(* There is also a "weakly decidable" equality on A. That means - that if (A_eq x y)=true then x=y but x=y can arise when +(* There is also a "weakly decidable" equality on A. That means + that if (A_eq x y)=true then x=y but x=y can arise when (A_eq x y)=false. On an abstract ring the function [x,y:A]false is a good choice. The proof of A_eq_prop is in this case easy. *) Variable Aeq : A -> A -> bool. @@ -30,7 +30,7 @@ Infix "*" := Amult (at level 40, left associativity). Notation "0" := Azero. Notation "1" := Aone. -Record Semi_Ring_Theory : Prop := +Record Semi_Ring_Theory : Prop := {SR_plus_comm : forall n m:A, n + m = m + n; SR_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; SR_mult_comm : forall n m:A, n * m = m * n; @@ -49,7 +49,7 @@ Let plus_assoc := SR_plus_assoc T. Let mult_comm := SR_mult_comm T. Let mult_assoc := SR_mult_assoc T. Let plus_zero_left := SR_plus_zero_left T. -Let mult_one_left := SR_mult_one_left T. +Let mult_one_left := SR_mult_one_left T. Let mult_zero_left := SR_mult_zero_left T. Let distr_left := SR_distr_left T. (*Let plus_reg_left := SR_plus_reg_left T.*) @@ -58,7 +58,7 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left mult_one_left mult_zero_left distr_left (*plus_reg_left*). (* Lemmas whose form is x=y are also provided in form y=x because Auto does - not symmetry *) + not symmetry *) Lemma SR_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). symmetry in |- *; eauto. Qed. @@ -150,7 +150,7 @@ Notation "0" := Azero. Notation "1" := Aone. Notation "- x" := (Aopp x). -Record Ring_Theory : Prop := +Record Ring_Theory : Prop := {Th_plus_comm : forall n m:A, n + m = m + n; Th_plus_assoc : forall n m p:A, n + (m + p) = n + m + p; Th_mult_comm : forall n m:A, n * m = m * n; @@ -168,7 +168,7 @@ Let plus_assoc := Th_plus_assoc T. Let mult_comm := Th_mult_comm T. Let mult_assoc := Th_mult_assoc T. Let plus_zero_left := Th_plus_zero_left T. -Let mult_one_left := Th_mult_one_left T. +Let mult_one_left := Th_mult_one_left T. Let opp_def := Th_opp_def T. Let distr_left := Th_distr_left T. @@ -176,7 +176,7 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left mult_one_left opp_def distr_left. (* Lemmas whose form is x=y are also provided in form y=x because Auto does - not symmetry *) + not symmetry *) Lemma Th_mult_assoc2 : forall n m p:A, n * m * p = n * (m * p). symmetry in |- *; eauto. Qed. @@ -331,7 +331,7 @@ Qed. Lemma Th_plus_reg_right : forall n m p:A, m + n = p + n -> m = p. intros. -eapply Th_plus_reg_left with n. +eapply Th_plus_reg_left with n. rewrite (plus_comm n m). rewrite (plus_comm n p). auto. @@ -354,7 +354,7 @@ Hint Resolve Th_mult_zero_left (*Th_plus_reg_left*): core. Unset Implicit Arguments. Definition Semi_Ring_Theory_of : - forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A) + forall (A:Type) (Aplus Amult:A -> A -> A) (Aone Azero:A) (Aopp:A -> A) (Aeq:A -> A -> bool), Ring_Theory Aplus Amult Aone Azero Aopp Aeq -> Semi_Ring_Theory Aplus Amult Aone Azero Aeq. diff --git a/plugins/ring/Ring_abstract.v b/plugins/ring/Ring_abstract.v index 9b85fb85e0..2a9df21b33 100644 --- a/plugins/ring/Ring_abstract.v +++ b/plugins/ring/Ring_abstract.v @@ -164,7 +164,7 @@ Lemma abstract_varlist_insert_ok : trivial. simpl in |- *; intros. - elim (varlist_lt l v); simpl in |- *. + elim (varlist_lt l v); simpl in |- *. eauto. rewrite iacs_aux_ok. rewrite H; auto. @@ -175,7 +175,7 @@ Lemma abstract_sum_merge_ok : forall x y:abstract_sum, interp_acs (abstract_sum_merge x y) = Aplus (interp_acs x) (interp_acs y). -Proof. +Proof. simple induction x. trivial. simple induction y; intros. @@ -240,13 +240,13 @@ End abstract_semi_rings. Section abstract_rings. (* In abstract polynomials there is no constants other - than 0 and 1. An abstract ring is a ring whose operations plus, + than 0 and 1. An abstract ring is a ring whose operations plus, and mult are not functions but constructors. In other words, when c1 and c2 are closed, (plus c1 c2) doesn't reduce to a closed term. "closed" mean here "without plus and mult". *) (* this section is not parametrized by a (semi-)ring. - Nevertheless, they are two different types for semi-rings and rings + Nevertheless, they are two different types for semi-rings and rings and there will be 2 correction theorems *) Inductive apolynomial : Type := @@ -488,7 +488,7 @@ Lemma signed_sum_merge_ok : intro Heq; rewrite (Heq I). rewrite H. repeat rewrite isacs_aux_ok. - rewrite (Th_plus_permute T). + rewrite (Th_plus_permute T). repeat rewrite (Th_plus_assoc T). rewrite (Th_plus_comm T (Aopp (interp_vl Amult Aone Azero vm v0)) @@ -509,7 +509,7 @@ Lemma signed_sum_merge_ok : intro Heq; rewrite (Heq I). rewrite H. repeat rewrite isacs_aux_ok. - rewrite (Th_plus_permute T). + rewrite (Th_plus_permute T). repeat rewrite (Th_plus_assoc T). rewrite (Th_opp_def T). rewrite (Th_plus_zero_left T). @@ -701,6 +701,6 @@ Proof. intros. rewrite signed_sum_opp_ok. rewrite H; reflexivity. -Qed. +Qed. End abstract_rings. diff --git a/plugins/ring/Ring_normalize.v b/plugins/ring/Ring_normalize.v index ad1cc5cf10..7aeee21857 100644 --- a/plugins/ring/Ring_normalize.v +++ b/plugins/ring/Ring_normalize.v @@ -39,11 +39,11 @@ Variable Aeq : A -> A -> bool. (* Normal abtract Polynomials *) (******************************************) (* DEFINITIONS : -- A varlist is a sorted product of one or more variables : x, x*y*z +- A varlist is a sorted product of one or more variables : x, x*y*z - A monom is a constant, a varlist or the product of a constant by a varlist variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. -- A canonical sum is either a monom or an ordered sum of monoms - (the order on monoms is defined later) +- A canonical sum is either a monom or an ordered sum of monoms + (the order on monoms is defined later) - A normal polynomial it either a constant or a canonical sum or a constant plus a canonical sum *) @@ -61,14 +61,14 @@ Inductive canonical_sum : Type := (* Order on monoms *) -(* That's the lexicographic order on varlist, extended by : - - A constant is less than every monom +(* That's the lexicographic order on varlist, extended by : + - A constant is less than every monom - The relation between two varlist is preserved by multiplication by a constant. - Examples : + Examples : 3 < x < y - x*y < x*y*y*z + x*y < x*y*y*z 2*x*y < x*y*y*z x*y < 54*x*y*y*z 4*x*y < 59*x*y*y*z @@ -214,7 +214,7 @@ Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : end. (* Computes c0*l0*s *) -Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) +Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) (s:canonical_sum) {struct s} : canonical_sum := match s with | Cons_monom c l t => @@ -225,7 +225,7 @@ Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) | Nil_monom => Nil_monom end. -(* returns the product of two canonical sums *) +(* returns the product of two canonical sums *) Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : canonical_sum := match s1 with @@ -282,7 +282,7 @@ Definition spolynomial_simplify (x:spolynomial) := Variable vm : varmap A. -(* Interpretation of list of variables +(* Interpretation of list of variables * [x1; ... ; xn ] is interpreted as (find v x1)* ... *(find v xn) * The unbound variables are mapped to 0. Normally this case sould * never occur. Since we want only to prove correctness theorems, which form @@ -608,7 +608,7 @@ repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). +repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). @@ -620,7 +620,7 @@ repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). +repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). reflexivity. @@ -639,7 +639,7 @@ repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). +repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T a (interp_vl l) (interp_vl v)). @@ -651,7 +651,7 @@ repeat rewrite ics_aux_ok. repeat rewrite interp_m_ok. rewrite H. rewrite varlist_merge_ok. -repeat rewrite (SR_distr_right T). +repeat rewrite (SR_distr_right T). repeat rewrite <- (SR_mult_assoc T). repeat rewrite <- (SR_plus_assoc T). rewrite (SR_mult_permute T c (interp_vl l) (interp_vl v)). diff --git a/plugins/ring/Setoid_ring_normalize.v b/plugins/ring/Setoid_ring_normalize.v index ce23d05af0..9b4c46fe92 100644 --- a/plugins/ring/Setoid_ring_normalize.v +++ b/plugins/ring/Setoid_ring_normalize.v @@ -13,7 +13,7 @@ Require Import Quote. Set Implicit Arguments. Unset Boxed Definitions. - + Lemma index_eq_prop : forall n m:index, Is_true (index_eq n m) -> n = m. Proof. simple induction n; simple induction m; simpl in |- *; @@ -75,11 +75,11 @@ Section semi_setoid_rings. (* Normal abtract Polynomials *) (******************************************) (* DEFINITIONS : -- A varlist is a sorted product of one or more variables : x, x*y*z +- A varlist is a sorted product of one or more variables : x, x*y*z - A monom is a constant, a varlist or the product of a constant by a varlist variables. 2*x*y, x*y*z, 3 are monoms : 2*3, x*3*y, 4*x*3 are NOT. -- A canonical sum is either a monom or an ordered sum of monoms - (the order on monoms is defined later) +- A canonical sum is either a monom or an ordered sum of monoms + (the order on monoms is defined later) - A normal polynomial it either a constant or a canonical sum or a constant plus a canonical sum *) @@ -97,14 +97,14 @@ Inductive canonical_sum : Type := (* Order on monoms *) -(* That's the lexicographic order on varlist, extended by : - - A constant is less than every monom +(* That's the lexicographic order on varlist, extended by : + - A constant is less than every monom - The relation between two varlist is preserved by multiplication by a constant. - Examples : + Examples : 3 < x < y - x*y < x*y*y*z + x*y < x*y*y*z 2*x*y < x*y*y*z x*y < 54*x*y*y*z 4*x*y < 59*x*y*y*z @@ -250,7 +250,7 @@ Fixpoint canonical_sum_scalar2 (l0:varlist) (s:canonical_sum) {struct s} : end. (* Computes c0*l0*s *) -Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) +Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) (s:canonical_sum) {struct s} : canonical_sum := match s with | Cons_monom c l t => @@ -261,7 +261,7 @@ Fixpoint canonical_sum_scalar3 (c0:A) (l0:varlist) | Nil_monom => Nil_monom end. -(* returns the product of two canonical sums *) +(* returns the product of two canonical sums *) Fixpoint canonical_sum_prod (s1 s2:canonical_sum) {struct s1} : canonical_sum := match s1 with @@ -540,7 +540,7 @@ rewrite end) c0)). rewrite H0. rewrite (ics_aux_ok (interp_m a v) c); - rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *; + rewrite (ics_aux_ok (interp_m a0 v0) c0); simpl in |- *; auto. generalize (varlist_eq_prop v v0). diff --git a/plugins/ring/Setoid_ring_theory.v b/plugins/ring/Setoid_ring_theory.v index f50a2f30a4..2c2314affe 100644 --- a/plugins/ring/Setoid_ring_theory.v +++ b/plugins/ring/Setoid_ring_theory.v @@ -57,7 +57,7 @@ Qed. Section Theory_of_semi_setoid_rings. -Record Semi_Setoid_Ring_Theory : Prop := +Record Semi_Setoid_Ring_Theory : Prop := {SSR_plus_comm : forall n m:A, n + m == m + n; SSR_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; SSR_mult_comm : forall n m:A, n * m == m * n; @@ -76,7 +76,7 @@ Let plus_assoc := SSR_plus_assoc T. Let mult_comm := SSR_mult_comm T. Let mult_assoc := SSR_mult_assoc T. Let plus_zero_left := SSR_plus_zero_left T. -Let mult_one_left := SSR_mult_one_left T. +Let mult_one_left := SSR_mult_one_left T. Let mult_zero_left := SSR_mult_zero_left T. Let distr_left := SSR_distr_left T. Let plus_reg_left := SSR_plus_reg_left T. @@ -90,7 +90,7 @@ Hint Resolve plus_comm plus_assoc mult_comm mult_assoc plus_zero_left Hint Immediate equiv_sym. (* Lemmas whose form is x=y are also provided in form y=x because - Auto does not symmetry *) + Auto does not symmetry *) Lemma SSR_mult_assoc2 : forall n m p:A, n * m * p == n * (m * p). auto. Qed. @@ -174,7 +174,7 @@ End Theory_of_semi_setoid_rings. Section Theory_of_setoid_rings. -Record Setoid_Ring_Theory : Prop := +Record Setoid_Ring_Theory : Prop := {STh_plus_comm : forall n m:A, n + m == m + n; STh_plus_assoc : forall n m p:A, n + (m + p) == n + m + p; STh_mult_comm : forall n m:A, n * m == m * n; @@ -192,7 +192,7 @@ Let plus_assoc := STh_plus_assoc T. Let mult_comm := STh_mult_comm T. Let mult_assoc := STh_mult_assoc T. Let plus_zero_left := STh_plus_zero_left T. -Let mult_one_left := STh_mult_one_left T. +Let mult_one_left := STh_mult_one_left T. Let opp_def := STh_opp_def T. Let distr_left := STh_distr_left T. Let equiv_refl := Seq_refl A Aequiv S. diff --git a/plugins/ring/g_ring.ml4 b/plugins/ring/g_ring.ml4 index 5ca1bfced5..d766e34454 100644 --- a/plugins/ring/g_ring.ml4 +++ b/plugins/ring/g_ring.ml4 @@ -20,13 +20,13 @@ END (* The vernac commands "Add Ring" and co *) -let cset_of_constrarg_list l = +let cset_of_constrarg_list l = List.fold_right ConstrSet.add (List.map constr_of l) ConstrSet.empty VERNAC COMMAND EXTEND AddRing - [ "Add" "Legacy" "Ring" + [ "Add" "Legacy" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) - constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] + constr(aopp) constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory true false false (constr_of a) None @@ -41,9 +41,9 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Legacy" "Semi" "Ring" +| [ "Add" "Legacy" "Semi" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) constr(azero) - constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] + constr(aeq) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory false false false (constr_of a) None @@ -58,9 +58,9 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Legacy" "Abstract" "Ring" +| [ "Add" "Legacy" "Abstract" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) - constr(azero) constr(aopp) constr(aeq) constr(t) ] + constr(azero) constr(aopp) constr(aeq) constr(t) ] -> [ add_theory true true false (constr_of a) None @@ -75,9 +75,9 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) ConstrSet.empty ] -| [ "Add" "Legacy" "Abstract" "Semi" "Ring" +| [ "Add" "Legacy" "Abstract" "Semi" "Ring" constr(a) constr(aplus) constr(amult) constr(aone) - constr(azero) constr(aeq) constr(t) ] + constr(azero) constr(aeq) constr(t) ] -> [ add_theory false true false (constr_of a) None @@ -93,9 +93,9 @@ VERNAC COMMAND EXTEND AddRing ConstrSet.empty ] | [ "Add" "Legacy" "Setoid" "Ring" - constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) + constr(a) constr(aequiv) constr(asetth) constr(aplus) constr(amult) constr(aone) constr(azero) constr(aopp) constr(aeq) constr(pm) - constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] + constr(mm) constr(om) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory true false true (constr_of a) (Some (constr_of aequiv)) @@ -113,10 +113,10 @@ VERNAC COMMAND EXTEND AddRing (constr_of t) (cset_of_constrarg_list l) ] -| [ "Add" "Legacy" "Semi" "Setoid" "Ring" +| [ "Add" "Legacy" "Semi" "Setoid" "Ring" constr(a) constr(aequiv) constr(asetth) constr(aplus) - constr(amult) constr(aone) constr(azero) constr(aeq) - constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] + constr(amult) constr(aone) constr(azero) constr(aeq) + constr(pm) constr(mm) constr(t) "[" ne_constr_list(l) "]" ] -> [ add_theory false false true (constr_of a) (Some (constr_of aequiv)) diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml index 2ed20b2bbe..bf3b8ef6f8 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -30,7 +30,7 @@ open Libobject open Closure open Tacred open Tactics -open Pattern +open Pattern open Hiddentac open Nametab open Quote @@ -96,13 +96,13 @@ let coq_SetPopp = lazy (ring_constant "SetPopp") let coq_interp_setsp = lazy (ring_constant "interp_setsp") let coq_interp_setp = lazy (ring_constant "interp_setp") let coq_interp_setcs = lazy (ring_constant "interp_setcs") -let coq_setspolynomial_simplify = +let coq_setspolynomial_simplify = lazy (ring_constant "setspolynomial_simplify") -let coq_setpolynomial_simplify = +let coq_setpolynomial_simplify = lazy (ring_constant "setpolynomial_simplify") -let coq_setspolynomial_simplify_ok = +let coq_setspolynomial_simplify_ok = lazy (ring_constant "setspolynomial_simplify_ok") -let coq_setpolynomial_simplify_ok = +let coq_setpolynomial_simplify_ok = lazy (ring_constant "setpolynomial_simplify_ok") (* Ring abstract *) @@ -123,9 +123,9 @@ let coq_interp_acs = lazy (ring_constant "interp_acs") let coq_interp_sacs = lazy (ring_constant "interp_sacs") let coq_aspolynomial_normalize = lazy (ring_constant "aspolynomial_normalize") let coq_apolynomial_normalize = lazy (ring_constant "apolynomial_normalize") -let coq_aspolynomial_normalize_ok = +let coq_aspolynomial_normalize_ok = lazy (ring_constant "aspolynomial_normalize_ok") -let coq_apolynomial_normalize_ok = +let coq_apolynomial_normalize_ok = lazy (ring_constant "apolynomial_normalize_ok") (* Logic --> to be found in Coqlib *) @@ -135,8 +135,8 @@ let mkLApp(fc,v) = mkApp(Lazy.force fc, v) (*********** Useful types and functions ************) -module OperSet = - Set.Make (struct +module OperSet = + Set.Make (struct type t = global_reference let compare = (Pervasives.compare : t->t->int) end) @@ -166,7 +166,7 @@ type theory = (* Must be empty for an abstract ring *) } -(* Theories are stored in a table which is synchronised with the Reset +(* Theories are stored in a table which is synchronised with the Reset mechanism. *) module Cmap = Map.Make(struct type t = constr let compare = compare end) @@ -177,7 +177,7 @@ let theories_map_add (c,t) = theories_map := Cmap.add c t !theories_map let theories_map_find c = Cmap.find c !theories_map let theories_map_mem c = Cmap.mem c !theories_map -let _ = +let _ = Summary.declare_summary "tactic-ring-table" { Summary.freeze_function = (fun () -> !theories_map); Summary.unfreeze_function = (fun t -> theories_map := t); @@ -188,23 +188,23 @@ let _ = between theories and environement objects. *) -let subst_morph subst morph = +let subst_morph subst morph = let plusm' = subst_mps subst morph.plusm in let multm' = subst_mps subst morph.multm in let oppm' = Option.smartmap (subst_mps subst) morph.oppm in - if plusm' == morph.plusm - && multm' == morph.multm - && oppm' == morph.oppm then + if plusm' == morph.plusm + && multm' == morph.multm + && oppm' == morph.oppm then morph else { plusm = plusm' ; multm = multm' ; oppm = oppm' ; } - -let subst_set subst cset = + +let subst_set subst cset = let same = ref true in - let copy_subst c newset = + let copy_subst c newset = let c' = subst_mps subst c in if not (c' == c) then same := false; ConstrSet.add c' newset @@ -212,21 +212,21 @@ let subst_set subst cset = let cset' = ConstrSet.fold copy_subst cset ConstrSet.empty in if !same then cset else cset' -let subst_theory subst th = +let subst_theory subst th = let th_equiv' = Option.smartmap (subst_mps subst) th.th_equiv in let th_setoid_th' = Option.smartmap (subst_mps subst) th.th_setoid_th in let th_morph' = Option.smartmap (subst_morph subst) th.th_morph in - let th_a' = subst_mps subst th.th_a in + let th_a' = subst_mps subst th.th_a in let th_plus' = subst_mps subst th.th_plus in let th_mult' = subst_mps subst th.th_mult in let th_one' = subst_mps subst th.th_one in let th_zero' = subst_mps subst th.th_zero in let th_opp' = Option.smartmap (subst_mps subst) th.th_opp in let th_eq' = subst_mps subst th.th_eq in - let th_t' = subst_mps subst th.th_t in + let th_t' = subst_mps subst th.th_t in let th_closed' = subst_set subst th.th_closed in - if th_equiv' == th.th_equiv - && th_setoid_th' == th.th_setoid_th + if th_equiv' == th.th_equiv + && th_setoid_th' == th.th_setoid_th && th_morph' == th.th_morph && th_a' == th.th_a && th_plus' == th.th_plus @@ -236,29 +236,29 @@ let subst_theory subst th = && th_opp' == th.th_opp && th_eq' == th.th_eq && th_t' == th.th_t - && th_closed' == th.th_closed - then - th + && th_closed' == th.th_closed + then + th else - { th_ring = th.th_ring ; + { th_ring = th.th_ring ; th_abstract = th.th_abstract ; - th_setoid = th.th_setoid ; + th_setoid = th.th_setoid ; th_equiv = th_equiv' ; th_setoid_th = th_setoid_th' ; th_morph = th_morph' ; - th_a = th_a' ; + th_a = th_a' ; th_plus = th_plus' ; th_mult = th_mult' ; th_one = th_one' ; th_zero = th_zero' ; - th_opp = th_opp' ; + th_opp = th_opp' ; th_eq = th_eq' ; - th_t = th_t' ; - th_closed = th_closed' ; + th_t = th_t' ; + th_closed = th_closed' ; } -let subst_th (_,subst,(c,th as obj)) = +let subst_th (_,subst,(c,th as obj)) = let c' = subst_mps subst c in let th' = subst_theory subst th in if c' == c && th' == th then obj else @@ -280,21 +280,21 @@ let (theory_to_obj, obj_to_theory) = (* But only one theory can be declared for a given Set *) let guess_theory a = - try + try theories_map_find a - with Not_found -> - errorlabstrm "Ring" + with Not_found -> + errorlabstrm "Ring" (str "No Declared Ring Theory for " ++ pr_lconstr a ++ fnl () ++ str "Use Add [Semi] Ring to declare it") (* Looks up an option *) -let unbox = function +let unbox = function | Some w -> w | None -> anomaly "Ring : Not in case of a setoid ring." -(* Protects the convertibility test against undue exceptions when using it +(* Protects the convertibility test against undue exceptions when using it with untyped terms *) let safe_pf_conv_x gl c1 c2 = try pf_conv_x gl c1 c2 with _ -> false @@ -320,8 +320,8 @@ let states_compatibility_for env plus mult opp morphs = | Some opp, Some compat -> check opp compat | _,_ -> assert false) -let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = - if theories_map_mem a then errorlabstrm "Add Semi Ring" +let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus amult aone azero aopp aeq t cset = + if theories_map_mem a then errorlabstrm "Add Semi Ring" (str "A (Semi-)(Setoid-)Ring Structure is already declared for " ++ pr_lconstr a); let env = Global.env () in @@ -332,10 +332,10 @@ let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus not (implement_theory env (unbox asetth) coq_Setoid_Theory [| a; (unbox aequiv) |]) || not (states_compatibility_for env aplus amult aopp (unbox amorph)) - )) then + )) then errorlabstrm "addring" (str "Not a valid Setoid-Ring theory"); if (not want_ring & want_setoid & ( - not (implement_theory env t coq_Semi_Setoid_Ring_Theory + not (implement_theory env t coq_Semi_Setoid_Ring_Theory [| a; (unbox aequiv); aplus; amult; aone; azero; aeq|]) || not (implement_theory env (unbox asetth) coq_Setoid_Theory [| a; (unbox aequiv) |]) || @@ -348,10 +348,10 @@ let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus errorlabstrm "addring" (str "Not a valid Ring theory"); if (not want_ring & not want_setoid & not (implement_theory env t coq_Semi_Ring_Theory - [| a; aplus; amult; aone; azero; aeq |])) then + [| a; aplus; amult; aone; azero; aeq |])) then errorlabstrm "addring" (str "Not a valid Semi-Ring theory"); Lib.add_anonymous_leaf - (theory_to_obj + (theory_to_obj (a, { th_ring = want_ring; th_abstract = want_abstract; th_setoid = want_setoid; @@ -374,9 +374,9 @@ let add_theory want_ring want_abstract want_setoid a aequiv asetth amorph aplus gl : goal sigma th : semi-ring theory (concrete) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -386,43 +386,43 @@ let build_spolynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - (* aux creates the spolynom p by a recursive destructuration of c + (* aux creates the spolynom p by a recursive destructuration of c and builds the varmap with side-effects *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_SPplus, [|th.th_a; aux c1; aux c2 |]) | App (binop,[|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_SPmult, [|th.th_a; aux c1; aux c2 |]) | _ when closed_under th.th_closed c -> mkLApp(coq_SPconst, [|th.th_a; c |]) - | _ -> - try Hashtbl.find varhash c - with Not_found -> + | _ -> + try Hashtbl.find varhash c + with Not_found -> let newvar = mkLApp(coq_SPvar, [|th.th_a; (path_of_int !counter) |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; newvar end - in + in let lp = List.map aux lc in let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in - List.map - (fun p -> + List.map + (fun p -> (mkLApp (coq_interp_sp, [|th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), mkLApp (coq_interp_cs, [|th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl - (mkLApp (coq_spolynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; + pf_reduce cbv_betadeltaiota gl + (mkLApp (coq_spolynomial_simplify, + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; th.th_eq; p|])) |]), mkLApp (coq_spolynomial_simplify_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; th.th_eq; v; th.th_t; p |]))) lp @@ -430,9 +430,9 @@ let build_spolynom gl th lc = gl : goal sigma th : ring theory (concrete) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -442,8 +442,8 @@ let build_polynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_Pplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> @@ -459,12 +459,12 @@ let build_polynom gl th lc = mkLApp(coq_Popp, [|th.th_a; aux c1|]) | _ when closed_under th.th_closed c -> mkLApp(coq_Pconst, [|th.th_a; c |]) - | _ -> - try Hashtbl.find varhash c - with Not_found -> + | _ -> + try Hashtbl.find varhash c + with Not_found -> let newvar = mkLApp(coq_Pvar, [|th.th_a; (path_of_int !counter) |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; @@ -473,20 +473,20 @@ let build_polynom gl th lc = in let lp = List.map aux lc in let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in - List.map - (fun p -> + List.map + (fun p -> (mkLApp(coq_interp_p, [| th.th_a; th.th_plus; th.th_mult; th.th_zero; (unbox th.th_opp); v; p |])), mkLApp(coq_interp_cs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl + pf_reduce cbv_betadeltaiota gl (mkLApp(coq_polynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; p |])) |]), mkLApp(coq_polynomial_simplify_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; v; th.th_t; p |])) lp @@ -494,9 +494,9 @@ let build_polynom gl th lc = gl : goal sigma th : semi-ring theory (abstract) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -506,41 +506,41 @@ let build_aspolynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - (* aux creates the aspolynom p by a recursive destructuration of c + (* aux creates the aspolynom p by a recursive destructuration of c and builds the varmap with side-effects *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_ASPplus, [| aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_ASPmult, [| aux c1; aux c2 |]) | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_ASP0 | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_ASP1 - | _ -> - try Hashtbl.find varhash c - with Not_found -> + | _ -> + try Hashtbl.find varhash c + with Not_found -> let newvar = mkLApp(coq_ASPvar, [|(path_of_int !counter) |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; newvar end - in + in let lp = List.map aux lc in let v = btree_of_array (Array.of_list (List.rev !varlist)) th.th_a in - List.map - (fun p -> + List.map + (fun p -> (mkLApp(coq_interp_asp, - [| th.th_a; th.th_plus; th.th_mult; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; p |]), mkLApp(coq_interp_acs, - [| th.th_a; th.th_plus; th.th_mult; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl + pf_reduce cbv_betadeltaiota gl (mkLApp(coq_aspolynomial_normalize,[|p|])) |]), mkLApp(coq_spolynomial_simplify_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; th.th_eq; v; th.th_t; p |]))) lp @@ -548,9 +548,9 @@ let build_aspolynom gl th lc = gl : goal sigma th : ring theory (abstract) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -560,14 +560,14 @@ let build_apolynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_APplus, [| aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_APmult, [| aux c1; aux c2 |]) (* The special case of Zminus *) - | App (binop, [|c1; c2|]) + | App (binop, [|c1; c2|]) when safe_pf_conv_x gl c (mkApp(th.th_plus, [|c1; mkApp(unbox th.th_opp,[|c2|]) |])) -> mkLApp(coq_APplus, @@ -576,12 +576,12 @@ let build_apolynom gl th lc = mkLApp(coq_APopp, [| aux c1 |]) | _ when safe_pf_conv_x gl c th.th_zero -> Lazy.force coq_AP0 | _ when safe_pf_conv_x gl c th.th_one -> Lazy.force coq_AP1 - | _ -> - try Hashtbl.find varhash c - with Not_found -> + | _ -> + try Hashtbl.find varhash c + with Not_found -> let newvar = mkLApp(coq_APvar, [| path_of_int !counter |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; @@ -590,28 +590,28 @@ let build_apolynom gl th lc = in let lp = List.map aux lc in let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in - List.map - (fun p -> + List.map + (fun p -> (mkLApp(coq_interp_ap, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); v; p |]), mkLApp(coq_interp_sacs, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; (unbox th.th_opp); v; - pf_reduce cbv_betadeltaiota gl + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; (unbox th.th_opp); v; + pf_reduce cbv_betadeltaiota gl (mkLApp(coq_apolynomial_normalize, [|p|])) |]), mkLApp(coq_apolynomial_normalize_ok, - [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; v; th.th_t; p |]))) lp - + (* gl : goal sigma th : setoid ring theory (concrete) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -621,8 +621,8 @@ let build_setpolynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_SetPplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> @@ -638,12 +638,12 @@ let build_setpolynom gl th lc = mkLApp(coq_SetPopp, [| th.th_a; aux c1 |]) | _ when closed_under th.th_closed c -> mkLApp(coq_SetPconst, [| th.th_a; c |]) - | _ -> - try Hashtbl.find varhash c - with Not_found -> + | _ -> + try Hashtbl.find varhash c + with Not_found -> let newvar = mkLApp(coq_SetPvar, [| th.th_a; path_of_int !counter |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; @@ -652,17 +652,17 @@ let build_setpolynom gl th lc = in let lp = List.map aux lc in let v = (btree_of_array (Array.of_list (List.rev !varlist)) th.th_a) in - List.map - (fun p -> + List.map + (fun p -> (mkLApp(coq_interp_setp, [| th.th_a; th.th_plus; th.th_mult; th.th_zero; (unbox th.th_opp); v; p |]), mkLApp(coq_interp_setcs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl + pf_reduce cbv_betadeltaiota gl (mkLApp(coq_setpolynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; (unbox th.th_opp); th.th_eq; p |])) |]), mkLApp(coq_setpolynomial_simplify_ok, [| th.th_a; (unbox th.th_equiv); th.th_plus; @@ -676,9 +676,9 @@ let build_setpolynom gl th lc = gl : goal sigma th : semi setoid ring theory (concrete) cl : constr list [c1; c2; ...] - -Builds - - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] + +Builds + - a list of tuples [(c1, c'1, c''1, c'1_eq_c''1); ... ] where c'i is convertible with ci and c'i_eq_c''i is a proof of equality of c'i and c''i @@ -688,20 +688,20 @@ let build_setspolynom gl th lc = let varhash = (Hashtbl.create 17 : (constr, constr) Hashtbl.t) in let varlist = ref ([] : constr list) in (* list of variables *) let counter = ref 1 in (* number of variables created + 1 *) - let rec aux c = - match (kind_of_term (strip_outer_cast c)) with + let rec aux c = + match (kind_of_term (strip_outer_cast c)) with | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_plus -> mkLApp(coq_SetSPplus, [|th.th_a; aux c1; aux c2 |]) | App (binop, [|c1; c2|]) when safe_pf_conv_x gl binop th.th_mult -> mkLApp(coq_SetSPmult, [| th.th_a; aux c1; aux c2 |]) | _ when closed_under th.th_closed c -> mkLApp(coq_SetSPconst, [| th.th_a; c |]) - | _ -> + | _ -> try Hashtbl.find varhash c with Not_found -> let newvar = mkLApp(coq_SetSPvar, [|th.th_a; path_of_int !counter |]) in - begin + begin incr counter; varlist := c :: !varlist; Hashtbl.add varhash c newvar; @@ -716,10 +716,10 @@ let build_setspolynom gl th lc = [| th.th_a; th.th_plus; th.th_mult; th.th_zero; v; p |]), mkLApp(coq_interp_setcs, [| th.th_a; th.th_plus; th.th_mult; th.th_one; th.th_zero; v; - pf_reduce cbv_betadeltaiota gl + pf_reduce cbv_betadeltaiota gl (mkLApp(coq_setspolynomial_simplify, - [| th.th_a; th.th_plus; th.th_mult; - th.th_one; th.th_zero; + [| th.th_a; th.th_plus; th.th_mult; + th.th_one; th.th_zero; th.th_eq; p |])) |]), mkLApp(coq_setspolynomial_simplify_ok, [| th.th_a; (unbox th.th_equiv); th.th_plus; @@ -737,12 +737,12 @@ module SectionPathSet = (* Avec l'uniformisation des red_kind, on perd ici sur la structure SectionPathSet; peut-être faudra-t-il la déplacer dans Closure *) -let constants_to_unfold = +let constants_to_unfold = (* List.fold_right SectionPathSet.add *) - let transform s = + let transform s = let sp = path_of_string s in let dir, id = repr_path sp in - Libnames.encode_con dir id + Libnames.encode_con dir id in List.map transform [ "Coq.ring.Ring_normalize.interp_cs"; @@ -772,9 +772,9 @@ let polynom_unfold_tac = let flags = (mkflags(fBETA::fIOTA::(List.map fCONST constants_to_unfold))) in reduct_in_concl (cbv_norm_flags flags,DEFAULTcast) - + let polynom_unfold_tac_in_term gl = - let flags = + let flags = (mkflags(fBETA::fIOTA::fZETA::(List.map fCONST constants_to_unfold))) in cbv_norm_flags flags (pf_env gl) (project gl) @@ -783,7 +783,7 @@ let polynom_unfold_tac_in_term gl = (* th : theory associated to t *) (* op : clause (None for conclusion or Some id for hypothesis id) *) (* gl : goal *) -(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) +(* Does the rewriting c_i -> (interp R RC v (polynomial_simplify p_i)) where the ring R, the Ring theory RC, the varmap v and the polynomials p_i are guessed and such that c_i = (interp R RC v p_i) *) let raw_polynom th op lc gl = @@ -791,7 +791,7 @@ let raw_polynom th op lc gl = after t in the list. This is to avoid that the normalization of t' modifies t in a non-desired way *) let lc = sort_subterm gl lc in - let ltriplets = + let ltriplets = if th.th_setoid then if th.th_ring then build_setpolynom gl th lc @@ -802,23 +802,23 @@ let raw_polynom th op lc gl = then build_apolynom gl th lc else build_polynom gl th lc else - if th.th_abstract + if th.th_abstract then build_aspolynom gl th lc - else build_spolynom gl th lc in - let polynom_tac = + else build_spolynom gl th lc in + let polynom_tac = List.fold_right2 (fun ci (c'i, c''i, c'i_eq_c''i) tac -> - let c'''i = - if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i + let c'''i = + if !term_quality then polynom_unfold_tac_in_term gl c''i else c''i in - if !term_quality && safe_pf_conv_x gl c'''i ci then + if !term_quality && safe_pf_conv_x gl c'''i ci then tac (* convertible terms *) else if th.th_setoid then - (tclORELSE + (tclORELSE (tclORELSE (h_exact c'i_eq_c''i) - (h_exact (mkLApp(coq_seq_sym, + (h_exact (mkLApp(coq_seq_sym, [| th.th_a; (unbox th.th_equiv); (unbox th.th_setoid_th); c'''i; ci; c'i_eq_c''i |])))) @@ -826,7 +826,7 @@ let raw_polynom th op lc gl = (tclORELSE (Equality.general_rewrite true Termops.all_occurrences c'i_eq_c''i) - (Equality.general_rewrite false + (Equality.general_rewrite false Termops.all_occurrences c'i_eq_c''i)) [tac])) else @@ -835,13 +835,13 @@ let raw_polynom th op lc gl = (h_exact c'i_eq_c''i) (h_exact (mkApp(build_coq_eq_sym (), [|th.th_a; c'''i; ci; c'i_eq_c''i |])))) - (tclTHENS - (elim_type + (tclTHENS + (elim_type (mkApp(build_coq_eq (), [|th.th_a; c'''i; ci |]))) [ tac; h_exact c'i_eq_c''i ])) ) - lc ltriplets polynom_unfold_tac + lc ltriplets polynom_unfold_tac in polynom_tac gl @@ -864,19 +864,19 @@ let guess_eq_tac th = th.th_plus |]))) reflexivity))))) -let guess_equiv_tac th = +let guess_equiv_tac th = (tclORELSE (apply (mkLApp(coq_seq_refl, [| th.th_a; (unbox th.th_equiv); (unbox th.th_setoid_th)|]))) - (tclTHEN + (tclTHEN polynom_unfold_tac - (tclREPEAT - (tclORELSE + (tclREPEAT + (tclORELSE (apply (unbox th.th_morph).plusm) (apply (unbox th.th_morph).multm))))) let match_with_equiv c = match (kind_of_term c) with - | App (e,a) -> + | App (e,a) -> if (List.mem e []) (* (Setoid_replace.equiv_list ())) *) then Some (decompose_app c) else None @@ -884,18 +884,18 @@ let match_with_equiv c = match (kind_of_term c) with let polynom lc gl = Coqlib.check_required_library ["Coq";"ring";"LegacyRing"]; - match lc with + match lc with (* If no argument is given, try to recognize either an equality or - a declared relation with arguments c1 ... cn, + a declared relation with arguments c1 ... cn, do "Ring c1 c2 ... cn" and then try to apply the simplification theorems declared for the relation *) | [] -> - (try + (try match Hipattern.match_with_equation (pf_concl gl) with | _,_,Hipattern.PolymorphicLeibnizEq (t,c1,c2) -> let th = guess_theory t in (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl - | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2) + | _,_,Hipattern.HeterogenousEq (t1,c1,t2,c2) when safe_pf_conv_x gl t1 t2 -> let th = guess_theory t1 in (tclTHEN (raw_polynom th None [c1;c2]) (guess_eq_tac th)) gl @@ -905,22 +905,22 @@ let polynom lc gl = | Some (equiv, c1::args) -> let t = (pf_type_of gl c1) in let th = (guess_theory t) in - if List.exists + if List.exists (fun c2 -> not (safe_pf_conv_x gl t (pf_type_of gl c2))) args - then + then errorlabstrm "Ring :" (str" All terms must have the same type"); - (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl - | _ -> errorlabstrm "polynom :" + (tclTHEN (raw_polynom th None (c1::args)) (guess_equiv_tac th)) gl + | _ -> errorlabstrm "polynom :" (str" This goal is not an equality nor a setoid equivalence"))) (* Elsewhere, guess the theory, check that all terms have the same type and apply raw_polynom *) - | c :: lc' -> - let t = pf_type_of gl c in - let th = guess_theory t in - if List.exists + | c :: lc' -> + let t = pf_type_of gl c in + let th = guess_theory t in + if List.exists (fun c1 -> not (safe_pf_conv_x gl t (pf_type_of gl c1))) lc' - then + then errorlabstrm "Ring :" (str" All terms must have the same type"); (tclTHEN (raw_polynom th None lc) polynom_unfold_tac) gl diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 12176d661d..a97f43d087 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -12,19 +12,19 @@ Delimit Scope Int_scope with I. (* Abstract Integers. *) -Module Type Int. +Module Type Int. - Parameter int : Set. + Parameter int : Set. - Parameter zero : int. - Parameter one : int. - Parameter plus : int -> int -> int. + Parameter zero : int. + Parameter one : int. + Parameter plus : int -> int -> int. Parameter opp : int -> int. - Parameter minus : int -> int -> int. + Parameter minus : int -> int -> int. Parameter mult : int -> int -> int. Notation "0" := zero : Int_scope. - Notation "1" := one : Int_scope. + Notation "1" := one : Int_scope. Infix "+" := plus : Int_scope. Infix "-" := minus : Int_scope. Infix "*" := mult : Int_scope. @@ -57,17 +57,17 @@ Module Type Int. Axiom lt_0_1 : 0<1. Axiom plus_le_compat : forall i j k l, i<=j -> k<=l -> i+k<=j+l. Axiom opp_le_compat : forall i j, i<=j -> (-j)<=(-i). - Axiom mult_lt_compat_l : + Axiom mult_lt_compat_l : forall i j k, 0 < k -> i < j -> k*i int -> comparison. Infix "?=" := compare (at level 70, no associativity) : Int_scope. Axiom compare_Eq : forall i j, compare i j = Eq <-> i=j. Axiom compare_Lt : forall i j, compare i j = Lt <-> i i>j. - (* Up to here, these requirements could be fulfilled + (* Up to here, these requirements could be fulfilled by any totally ordered ring. Let's now be int-specific: *) Axiom le_lt_int : forall x y, x x<=y+-(1). @@ -83,9 +83,9 @@ Module Z_as_Int <: Int. Open Scope Z_scope. - Definition int := Z. - Definition zero := 0. - Definition one := 1. + Definition int := Z. + Definition zero := 0. + Definition one := 1. Definition plus := Zplus. Definition opp := Zopp. Definition minus := Zminus. @@ -154,32 +154,32 @@ Module Z_as_Int <: Int. apply Zlt_succ. Qed. -End Z_as_Int. +End Z_as_Int. -Module IntProperties (I:Int). +Module IntProperties (I:Int). Import I. - + (* Primo, some consequences of being a ring theory... *) - + Definition two := 1+1. - Notation "2" := two : Int_scope. + Notation "2" := two : Int_scope. (* Aliases for properties packed in the ring record. *) Definition plus_assoc := ring.(Radd_assoc). Definition plus_comm := ring.(Radd_comm). Definition plus_0_l := ring.(Radd_0_l). - Definition mult_assoc := ring.(Rmul_assoc). + Definition mult_assoc := ring.(Rmul_assoc). Definition mult_comm := ring.(Rmul_comm). Definition mult_1_l := ring.(Rmul_1_l). Definition mult_plus_distr_r := ring.(Rdistr_l). Definition opp_def := ring.(Ropp_def). Definition minus_def := ring.(Rsub_def). - Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l + Opaque plus_assoc plus_comm plus_0_l mult_assoc mult_comm mult_1_l mult_plus_distr_r opp_def minus_def. (* More facts about plus *) @@ -188,7 +188,7 @@ Module IntProperties (I:Int). Proof. intros; rewrite plus_comm; apply plus_0_l. Qed. Lemma plus_0_r_reverse : forall x, x = x+0. - Proof. intros; symmetry; apply plus_0_r. Qed. + Proof. intros; symmetry; apply plus_0_r. Qed. Lemma plus_assoc_reverse : forall x y z, x+y+z = x+(y+z). Proof. intros; symmetry; apply plus_assoc. Qed. @@ -197,14 +197,14 @@ Module IntProperties (I:Int). Proof. intros; do 2 rewrite plus_assoc; f_equal; apply plus_comm. Qed. Lemma plus_reg_l : forall x y z, x+y = x+z -> y = z. - Proof. + Proof. intros. rewrite (plus_0_r_reverse y), (plus_0_r_reverse z), <-(opp_def x). - now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. + now rewrite plus_permute, plus_assoc, H, <- plus_assoc, plus_permute. Qed. - (* More facts about mult *) - + (* More facts about mult *) + Lemma mult_assoc_reverse : forall x y z, x*y*z = x*(y*z). Proof. intros; symmetry; apply mult_assoc. Qed. @@ -216,7 +216,7 @@ Module IntProperties (I:Int). Qed. Lemma mult_0_l : forall x, 0*x = 0. - Proof. + Proof. intros. generalize (mult_plus_distr_r 0 1 x). rewrite plus_0_l, mult_1_l, plus_comm; intros. @@ -224,7 +224,7 @@ Module IntProperties (I:Int). rewrite <- H. apply plus_0_r_reverse. Qed. - + (* More facts about opp *) @@ -269,7 +269,7 @@ Module IntProperties (I:Int). rewrite <- mult_opp_comm. apply plus_reg_l with (x*y). now rewrite opp_def, <-mult_plus_distr_r, opp_def, mult_0_l. - Qed. + Qed. Lemma egal_left : forall n m, n=m -> n+-m = 0. Proof. intros; subst; apply opp_def. Qed. @@ -287,7 +287,7 @@ Module IntProperties (I:Int). Proof. symmetry; rewrite mult_comm; apply mult_1_l. Qed. Lemma red_factor1 : forall n, n+n = n*2. - Proof. + Proof. intros; unfold two. now rewrite mult_comm, mult_plus_distr_r, mult_1_l. Qed. @@ -302,10 +302,10 @@ Module IntProperties (I:Int). Proof. intros; now rewrite plus_comm, red_factor2. Qed. Lemma red_factor4 : forall n m p, n*m + n*p = n*(m+p). - Proof. + Proof. intros; now rewrite mult_plus_distr_l. Qed. - + Lemma red_factor5 : forall n m , n * 0 + m = m. Proof. intros; now rewrite mult_comm, mult_0_l, plus_0_l. Qed. @@ -368,7 +368,7 @@ Module IntProperties (I:Int). Qed. - (* Secondo, some results about order (and equality) *) + (* Secondo, some results about order (and equality) *) Lemma lt_irrefl : forall n, ~ n i=j. Proof. intros. @@ -471,7 +471,7 @@ Module IntProperties (I:Int). Proof. intros; now rewrite <- bgt_iff. Qed. Lemma bgt_false : forall i j, bgt i j = false -> i<=j. - Proof. + Proof. intros. rewrite le_lt_iff, <-gt_lt_iff, <-bgt_iff; intro H'; now rewrite H' in H. Qed. @@ -498,7 +498,7 @@ Module IntProperties (I:Int). destruct (lt_eq_lt_dec p m) as [[H|H]|H]; subst; auto. generalize (lt_trans _ _ _ H C); intuition. Qed. - + (* order and operations *) Lemma le_0_neg : forall n, 0 <= n <-> -n <= 0. @@ -582,7 +582,7 @@ Module IntProperties (I:Int). Lemma mult_integral : forall n m, n * m = 0 -> n = 0 \/ m = 0. Proof. intros. - destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; + destruct (lt_eq_lt_dec n 0) as [[Hn|Hn]|Hn]; auto; destruct (lt_eq_lt_dec m 0) as [[Hm|Hm]|Hm]; auto; elimtype False. rewrite lt_0_neg' in Hn. @@ -611,7 +611,7 @@ Module IntProperties (I:Int). exact (lt_irrefl 0). Qed. - Lemma mult_le_compat : + Lemma mult_le_compat : forall i j k l, i<=j -> k<=l -> 0<=i -> 0<=k -> i*k<=j*l. Proof. intros. @@ -624,9 +624,9 @@ Module IntProperties (I:Int). generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. rewrite (mult_comm i), (mult_comm j). - destruct (le_is_lt_or_eq _ _ H0); + destruct (le_is_lt_or_eq _ _ H0); [ | subst; do 2 rewrite mult_0_l; apply le_refl]. - destruct (le_is_lt_or_eq _ _ H); + destruct (le_is_lt_or_eq _ _ H); [ | subst; apply le_refl]. apply lt_le_weak. apply mult_lt_compat_l; auto. @@ -634,9 +634,9 @@ Module IntProperties (I:Int). subst i. rewrite mult_0_l. generalize (le_trans _ _ _ H2 H0); clear H0 H1 H2; intros. - destruct (le_is_lt_or_eq _ _ H); + destruct (le_is_lt_or_eq _ _ H); [ | subst; rewrite mult_0_l; apply le_refl]. - destruct (le_is_lt_or_eq _ _ H0); + destruct (le_is_lt_or_eq _ _ H0); [ | subst; rewrite mult_comm, mult_0_l; apply le_refl]. apply lt_le_weak. apply mult_lt_0_compat; auto. @@ -766,7 +766,7 @@ Module IntProperties (I:Int). apply plus_lt_compat; auto. apply mult_lt_0_compat; auto. apply lt_trans with x; auto. - Qed. + Qed. Lemma OMEGA19 : forall x, x<>0 -> 0 <= x + -(1) \/ 0 <= x * -(1) + -(1). Proof. @@ -781,7 +781,7 @@ Module IntProperties (I:Int). apply opp_lt_compat; auto. Qed. - Lemma mult_le_approx : + Lemma mult_le_approx : forall n m p, n > 0 -> n > p -> 0 <= m * n + p -> 0 <= m. Proof. intros n m p. @@ -850,7 +850,7 @@ Module IntOmega (I:Int). Import I. Module IP:=IntProperties(I). Import IP. - + (* \subsubsection{Definition of reified integer expressions} Terms are either: \begin{itemize} @@ -903,7 +903,7 @@ Inductive proposition : Set := | Tprop : nat -> proposition. (* Definition of goals as a list of hypothesis *) -Notation hyps := (list proposition). +Notation hyps := (list proposition). (* Definition of lists of subgoals (set of open goals) *) Notation lhyps := (list hyps). @@ -930,7 +930,7 @@ Inductive t_fusion : Set := | F_right : t_fusion. (* \subsubsection{Rewriting steps to normalize terms} *) -Inductive step : Set := +Inductive step : Set := (* apply the rewriting steps to both subterms of an operation *) | C_DO_BOTH : step -> step -> step (* apply the rewriting step to the first branch *) @@ -938,9 +938,9 @@ Inductive step : Set := (* apply the rewriting step to the second branch *) | C_RIGHT : step -> step (* apply two steps consecutively to a term *) - | C_SEQ : step -> step -> step + | C_SEQ : step -> step -> step (* empty step *) - | C_NOP : step + | C_NOP : step (* the following operations correspond to actual rewriting *) | C_OPP_PLUS : step | C_OPP_OPP : step @@ -990,8 +990,8 @@ Inductive t_omega : Set := | O_STATE : int -> step -> nat -> nat -> t_omega -> t_omega. (* \subsubsection{Rules for normalizing the hypothesis} *) -(* These rules indicate how to normalize useful propositions - of each useful hypothesis before the decomposition of hypothesis. +(* These rules indicate how to normalize useful propositions + of each useful hypothesis before the decomposition of hypothesis. The rules include the inversion phase for negation removal. *) Inductive p_step : Set := @@ -1001,19 +1001,19 @@ Inductive p_step : Set := | P_STEP : step -> p_step | P_NOP : p_step. -(* List of normalizations to perform : with a constructor of type - [p_step] allowing to visit both left and right branches, we would be - able to restrict to only one normalization by hypothesis. - And since all hypothesis are useful (otherwise they wouldn't be included), +(* List of normalizations to perform : with a constructor of type + [p_step] allowing to visit both left and right branches, we would be + able to restrict to only one normalization by hypothesis. + And since all hypothesis are useful (otherwise they wouldn't be included), we would be able to replace [h_step] by a simple list. *) Inductive h_step : Set := pair_step : nat -> p_step -> h_step. (* \subsubsection{Rules for decomposing the hypothesis} *) -(* This type allows to navigate in the logical constructors that - form the predicats of the hypothesis in order to decompose them. - This allows in particular to extract one hypothesis from a +(* This type allows to navigate in the logical constructors that + form the predicats of the hypothesis in order to decompose them. + This allows in particular to extract one hypothesis from a conjonction with possibly the right level of negations. *) Inductive direction : Set := @@ -1022,8 +1022,8 @@ Inductive direction : Set := | D_mono : direction. (* This type allows to extract useful components from hypothesis, either - hypothesis generated by splitting a disjonction, or equations. - The last constructor indicates how to solve the obtained system + hypothesis generated by splitting a disjonction, or equations. + The last constructor indicates how to solve the obtained system via the use of the trace type of Omega [t_omega] *) Inductive e_step : Set := @@ -1032,10 +1032,10 @@ Inductive e_step : Set := | E_SOLVE : t_omega -> e_step. (* \subsection{Efficient decidable equality} *) -(* For each reified data-type, we define an efficient equality test. +(* For each reified data-type, we define an efficient equality test. It is not the one produced by [Decide Equality]. - - Then we prove two theorem allowing to eliminate such equalities : + + Then we prove two theorem allowing to eliminate such equalities : \begin{verbatim} (t1,t2: typ) (eq_typ t1 t2) = true -> t1 = t2. (t1,t2: typ) (eq_typ t1 t2) = false -> ~ t1 = t2. @@ -1056,21 +1056,21 @@ Fixpoint eq_term (t1 t2 : term) {struct t2} : bool := | _, _ => false end. -Close Scope romega_scope. +Close Scope romega_scope. Theorem eq_term_true : forall t1 t2 : term, eq_term t1 t2 = true -> t1 = t2. Proof. simple induction t1; intros until t2; case t2; simpl in *; - try (intros; discriminate; fail); + try (intros; discriminate; fail); [ intros; elim beq_true with (1 := H); trivial | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); + elim H with (1 := H4); elim H0 with (1 := H5); trivial | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); + elim H with (1 := H4); elim H0 with (1 := H5); trivial | intros t21 t22 H3; elim andb_prop with (1 := H3); intros H4 H5; - elim H with (1 := H4); elim H0 with (1 := H5); + elim H with (1 := H4); elim H0 with (1 := H5); trivial | intros t21 H3; elim H with (1 := H3); trivial | intros; elim beq_nat_true with (1 := H); trivial ]. @@ -1083,7 +1083,7 @@ Theorem eq_term_false : Proof. simple induction t1; [ intros z t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; - intros; elim beq_false with (1 := H); simplify_eq H0; + intros; elim beq_false with (1 := H); simplify_eq H0; auto | intros t11 H1 t12 H2 t2; case t2; try trivial_case; simpl in |- *; intros t21 t22 H3; unfold not in |- *; intro H4; @@ -1101,21 +1101,21 @@ Proof. [ elim H1 with (1 := H5); simplify_eq H4; auto | elim H2 with (1 := H5); simplify_eq H4; auto ] | intros t11 H1 t2; case t2; try trivial_case; simpl in |- *; intros t21 H3; - unfold not in |- *; intro H4; elim H1 with (1 := H3); + unfold not in |- *; intro H4; elim H1 with (1 := H3); simplify_eq H4; auto | intros n t2; case t2; try trivial_case; simpl in |- *; unfold not in |- *; - intros; elim beq_nat_false with (1 := H); simplify_eq H0; + intros; elim beq_nat_false with (1 := H); simplify_eq H0; auto ]. Qed. -(* \subsubsection{Tactiques pour éliminer ces tests} +(* \subsubsection{Tactiques pour éliminer ces tests} - Si on se contente de faire un [Case (eq_typ t1 t2)] on perd + Si on se contente de faire un [Case (eq_typ t1 t2)] on perd totalement dans chaque branche le fait que [t1=t2] ou [~t1=t2]. Initialement, les développements avaient été réalisés avec les tests rendus par [Decide Equality], c'est à dire un test rendant - des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un + des termes du type [{t1=t2}+{~t1=t2}]. Faire une élimination sur un tel test préserve bien l'information voulue mais calculatoirement de telles fonctions sont trop lentes. *) @@ -1132,8 +1132,8 @@ Ltac elim_beq t1 t2 := [ generalize (beq_true t1 t2 Aux); clear Aux | generalize (beq_false t1 t2 Aux); clear Aux ]. -Ltac elim_bgt t1 t2 := - pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux; +Ltac elim_bgt t1 t2 := + pattern (bgt t1 t2) in |- *; apply bool_eq_ind; intro Aux; [ generalize (bgt_true t1 t2 Aux); clear Aux | generalize (bgt_false t1 t2 Aux); clear Aux ]. @@ -1151,7 +1151,7 @@ Fixpoint interp_term (env : list int) (t : term) {struct t} : int := | [n]%term => nth n env 0 end. -(* \subsubsection{Interprétation des prédicats} *) +(* \subsubsection{Interprétation des prédicats} *) Fixpoint interp_proposition (envp : list Prop) (env : list int) (p : proposition) {struct p} : Prop := @@ -1179,7 +1179,7 @@ Fixpoint interp_proposition (envp : list Prop) (env : list int) Interprétation sous forme d'une conjonction d'hypothèses plus faciles à manipuler individuellement *) -Fixpoint interp_hyps (envp : list Prop) (env : list int) +Fixpoint interp_hyps (envp : list Prop) (env : list int) (l : hyps) {struct l} : Prop := match l with | nil => True @@ -1191,7 +1191,7 @@ Fixpoint interp_hyps (envp : list Prop) (env : list int) [Generalize] et qu'une conjonction est forcément lourde (répétition des types dans les conjonctions intermédiaires) *) -Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) +Fixpoint interp_goal_concl (c : proposition) (envp : list Prop) (env : list int) (l : hyps) {struct l} : Prop := match l with | nil => interp_proposition envp env c @@ -1219,7 +1219,7 @@ Theorem hyps_to_goal : Proof. simple induction l; simpl in |- *; [ auto | intros; apply H; elim H1; auto ]. Qed. - + (* \subsection{Manipulations sur les hypothèses} *) (* \subsubsection{Définitions de base de stabilité pour la réflexion} *) @@ -1228,7 +1228,7 @@ Definition term_stable (f : term -> term) := forall (e : list int) (t : term), interp_term e t = interp_term e (f t). (* Une opération est valide sur une hypothèse, si l'hypothèse implique le - résultat de l'opération. \emph{Attention : cela ne concerne que des + résultat de l'opération. \emph{Attention : cela ne concerne que des opérations sur les hypothèses et non sur les buts (contravariance)}. On définit la validité pour une opération prenant une ou deux propositions en argument (cela suffit pour omega). *) @@ -1242,15 +1242,15 @@ Definition valid2 (f : proposition -> proposition -> proposition) := interp_proposition ep e p1 -> interp_proposition ep e p2 -> interp_proposition ep e (f p1 p2). -(* Dans cette notion de validité, la fonction prend directement une - liste de propositions et rend une nouvelle liste de proposition. +(* Dans cette notion de validité, la fonction prend directement une + liste de propositions et rend une nouvelle liste de proposition. On reste contravariant *) Definition valid_hyps (f : hyps -> hyps) := forall (ep : list Prop) (e : list int) (lp : hyps), interp_hyps ep e lp -> interp_hyps ep e (f lp). -(* Enfin ce théorème élimine la contravariance et nous ramène à une +(* Enfin ce théorème élimine la contravariance et nous ramène à une opération sur les buts *) Theorem valid_goal : @@ -1264,14 +1264,14 @@ Qed. (* \subsubsection{Généralisation a des listes de buts (disjonctions)} *) -Fixpoint interp_list_hyps (envp : list Prop) (env : list int) +Fixpoint interp_list_hyps (envp : list Prop) (env : list int) (l : lhyps) {struct l} : Prop := match l with | nil => False | h :: l' => interp_hyps envp env h \/ interp_list_hyps envp env l' end. -Fixpoint interp_list_goal (envp : list Prop) (env : list int) +Fixpoint interp_list_goal (envp : list Prop) (env : list int) (l : lhyps) {struct l} : Prop := match l with | nil => True @@ -1311,10 +1311,10 @@ Theorem goal_valid : forall f : hyps -> lhyps, valid_list_hyps f -> valid_list_goal f. Proof. unfold valid_list_goal in |- *; intros f H ep e lp H1; apply goal_to_hyps; - intro H2; apply list_hyps_to_goal with (1 := H1); + intro H2; apply list_hyps_to_goal with (1 := H1); apply (H ep e lp); assumption. Qed. - + Theorem append_valid : forall (ep : list Prop) (e : list int) (l1 l2 : lhyps), interp_list_hyps ep e l1 \/ interp_list_hyps ep e l2 -> @@ -1345,7 +1345,7 @@ Proof. | intros; simpl in |- *; apply H; elim H1; auto ] ]. Qed. -(* Appliquer une opération (valide) sur deux hypothèses extraites de +(* Appliquer une opération (valide) sur deux hypothèses extraites de la liste et ajouter le résultat à la liste. *) Definition apply_oper_2 (i j : nat) (f : proposition -> proposition -> proposition) (l : hyps) := @@ -1361,7 +1361,7 @@ Qed. (* Modifier une hypothèse par application d'une opération valide *) -Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) +Fixpoint apply_oper_1 (i : nat) (f : proposition -> proposition) (l : hyps) {struct i} : hyps := match l with | nil => nil (A:=proposition) @@ -1390,7 +1390,7 @@ Qed. (* \subsubsection{Manipulations de termes} *) (* Les fonctions suivantes permettent d'appliquer une fonction de réécriture sur un sous terme du terme principal. Avec la composition, - cela permet de construire des réécritures complexes proches des + cela permet de construire des réécritures complexes proches des tactiques de conversion *) Definition apply_left (f : term -> term) (t : term) := @@ -1415,7 +1415,7 @@ Definition apply_both (f g : term -> term) (t : term) := | x => x end. -(* Les théorèmes suivants montrent la stabilité (conditionnée) des +(* Les théorèmes suivants montrent la stabilité (conditionnée) des fonctions. *) Theorem apply_left_stable : @@ -1448,21 +1448,21 @@ Proof. Qed. (* \subsection{Les règles de réécriture} *) -(* Chacune des règles de réécriture est accompagnée par sa preuve de - stabilité. Toutes ces preuves ont la même forme : il faut analyser +(* Chacune des règles de réécriture est accompagnée par sa preuve de + stabilité. Toutes ces preuves ont la même forme : il faut analyser suivant la forme du terme (élimination de chaque Case). On a besoin d'une - élimination uniquement dans les cas d'utilisation d'égalité décidable. + élimination uniquement dans les cas d'utilisation d'égalité décidable. Cette tactique itère la décomposition des Case. Elle est constituée de deux fonctions s'appelant mutuellement : - \begin{itemize} + \begin{itemize} \item une fonction d'enrobage qui lance la recherche sur le but, \item une fonction récursive qui décompose ce but. Quand elle a trouvé un - Case, elle l'élimine. - \end{itemize} + Case, elle l'élimine. + \end{itemize} Les motifs sur les cas sont très imparfaits et dans certains cas, il semble que cela ne marche pas. On aimerait plutot un motif de la - forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on + forme [ Case (?1 :: T) of _ end ] permettant de s'assurer que l'on utilise le bon type. Chaque élimination introduit correctement exactement le nombre d'hypothèses @@ -1520,15 +1520,15 @@ Ltac loop t := | [x]%term => _ end => destruct X1; auto; Simplify | (if beq ?X1 ?X2 then _ else _) => - let H := fresh "H" in + let H := fresh "H" in elim_beq X1 X2; intro H; try (rewrite H in *; clear H); simpl in |- *; auto; Simplify | (if bgt ?X1 ?X2 then _ else _) => - let H := fresh "H" in + let H := fresh "H" in elim_bgt X1 X2; intro H; simpl in |- *; auto; Simplify | (if eq_term ?X1 ?X2 then _ else _) => - let H := fresh "H" in - elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); + let H := fresh "H" in + elim_eq_term X1 X2; intro H; try (rewrite H in *; clear H); simpl in |- *; auto; Simplify | (if _ && _ then _ else _) => rewrite andb_if; Simplify | (if negb _ then _ else _) => rewrite negb_if; Simplify @@ -1617,7 +1617,7 @@ Qed. Definition T_OMEGA10 (t : term) := match t with | ((v * Tint c1 + l1) * Tint k1 + (v' * Tint c2 + l2) * Tint k2)%term => - if eq_term v v' + if eq_term v v' then (v * Tint (c1 * k1 + c2 * k2)%I + (l1 * Tint k1 + l2 * Tint k2))%term else t | _ => t @@ -1650,12 +1650,12 @@ Definition T_OMEGA12 (t : term) := Theorem T_OMEGA12_stable : term_stable T_OMEGA12. Proof. prove_stable T_OMEGA12 OMEGA12. -Qed. +Qed. Definition T_OMEGA13 (t : term) := match t with | (v * Tint x + l1 + (v' * Tint x' + l2))%term => - if eq_term v v' && beq x (-x') + if eq_term v v' && beq x (-x') then (l1+l2)%term else t | _ => t @@ -1670,7 +1670,7 @@ Qed. Definition T_OMEGA15 (t : term) := match t with | (v * Tint c1 + l1 + (v' * Tint c2 + l2) * Tint k2)%term => - if eq_term v v' + if eq_term v v' then (v * Tint (c1 + c2 * k2)%I + (l1 + l2 * Tint k2))%term else t | _ => t @@ -1792,9 +1792,9 @@ Qed. Definition Tred_factor1 (t : term) := match t with | (x + y)%term => - if eq_term x y + if eq_term x y then (x * Tint 2)%term - else t + else t | _ => t end. @@ -1806,7 +1806,7 @@ Qed. Definition Tred_factor2 (t : term) := match t with | (x + y * Tint k)%term => - if eq_term x y + if eq_term x y then (x * Tint (1 + k))%term else t | _ => t @@ -1820,7 +1820,7 @@ Qed. Definition Tred_factor3 (t : term) := match t with | (x * Tint k + y)%term => - if eq_term x y + if eq_term x y then (x * Tint (1 + k))%term else t | _ => t @@ -1835,7 +1835,7 @@ Qed. Definition Tred_factor4 (t : term) := match t with | (x * Tint k1 + y * Tint k2)%term => - if eq_term x y + if eq_term x y then (x * Tint (k1 + k2))%term else t | _ => t @@ -1919,13 +1919,13 @@ Proof. | intros; auto | intros; auto | intros; auto - | intros; auto ])); intros t0 H0; simpl in |- *; + | intros; auto ])); intros t0 H0; simpl in |- *; rewrite H0; case (reduce t0); intros; auto. Qed. (* \subsubsection{Fusions} \paragraph{Fusion de deux équations} *) -(* On donne une somme de deux équations qui sont supposées normalisées. +(* On donne une somme de deux équations qui sont supposées normalisées. Cette fonction prend une trace de fusion en argument et transforme le terme en une équation normalisée. C'est une version très simplifiée du moteur de réécriture [rewrite]. *) @@ -1941,7 +1941,7 @@ Fixpoint fusion (trace : list t_fusion) (t : term) {struct trace} : term := | F_right => apply_right (fusion trace') (T_OMEGA12 t) end end. - + Theorem fusion_stable : forall t : list t_fusion, term_stable (fusion t). Proof. simple induction t; simpl in |- *; @@ -1985,7 +1985,7 @@ Proof. unfold term_stable, fusion_cancel in |- *; intros trace e; elim trace; [ exact (reduce_stable e) | intros n H t; elim H; exact (T_OMEGA13_stable e t) ]. -Qed. +Qed. (* \subsubsection{Opérations affines sur une équation} *) (* \paragraph{Multiplication scalaire et somme d'une constante} *) @@ -2004,7 +2004,7 @@ Proof. | intros n H e t; elim apply_right_stable; [ exact (T_OMEGA11_stable e t) | exact H ] ]. Qed. - + (* \paragraph{Multiplication scalaire} *) Fixpoint scalar_norm (trace : nat) (t : term) {struct trace} : term := match trace with @@ -2101,8 +2101,8 @@ Proof. | exact Tmult_comm_stable ]. Qed. -(* \subsection{tactiques de résolution d'un but omega normalisé} - Trace de la procédure +(* \subsection{tactiques de résolution d'un but omega normalisé} + Trace de la procédure \subsubsection{Tactiques générant une contradiction} \paragraph{[O_CONSTANT_NOT_NUL]} *) @@ -2117,17 +2117,17 @@ Theorem constant_not_nul_valid : forall i : nat, valid_hyps (constant_not_nul i). Proof. unfold valid_hyps, constant_not_nul in |- *; intros; - generalize (nth_valid ep e i lp); Simplify; simpl in |- *. - - elim_beq i1 i0; auto; simpl in |- *; intros H1 H2; + generalize (nth_valid ep e i lp); Simplify; simpl in |- *. + + elim_beq i1 i0; auto; simpl in |- *; intros H1 H2; elim H1; symmetry in |- *; auto. -Qed. +Qed. (* \paragraph{[O_CONSTANT_NEG]} *) Definition constant_neg (i : nat) (h : hyps) := match nth_hyps i h with - | LeqTerm (Tint Nul) (Tint Neg) => + | LeqTerm (Tint Nul) (Tint Neg) => if bgt Nul Neg then absurd else h | _ => h end. @@ -2140,14 +2140,14 @@ Proof. Qed. (* \paragraph{[NOT_EXACT_DIVIDE]} *) -Definition not_exact_divide (k1 k2 : int) (body : term) +Definition not_exact_divide (k1 k2 : int) (body : term) (t i : nat) (l : hyps) := match nth_hyps i l with | EqTerm (Tint Nul) b => - if beq Nul 0 && - eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && - bgt k2 0 && - bgt k1 k2 + if beq Nul 0 && + eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && + bgt k2 0 && + bgt k1 k2 then absurd else l | _ => l @@ -2161,7 +2161,7 @@ Proof. generalize (nth_valid ep e i lp); Simplify. rewrite (scalar_norm_add_stable t e), <-H1. do 2 rewrite <- scalar_norm_add_stable; simpl in *; intros. - absurd (interp_term e body * k1 + k2 = 0); + absurd (interp_term e body * k1 + k2 = 0); [ now apply OMEGA4 | symmetry; auto ]. Qed. @@ -2173,8 +2173,8 @@ Definition contradiction (t i j : nat) (l : hyps) := match nth_hyps j l with | LeqTerm (Tint Nul') b2 => match fusion_cancel t (b1 + b2)%term with - | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k - then absurd + | Tint k => if beq Nul 0 && beq Nul' 0 && bgt 0 k + then absurd else l | _ => l end @@ -2188,16 +2188,16 @@ Theorem contradiction_valid : Proof. unfold valid_hyps, contradiction in |- *; intros t i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; + case (nth_hyps i l); auto; intros t1 t2; case t1; + auto; case (nth_hyps j l); + auto; intros t3 t4; case t3; auto; simpl in |- *; intros z z' H1 H2; generalize (refl_equal (interp_term e (fusion_cancel t (t2 + t4)%term))); pattern (fusion_cancel t (t2 + t4)%term) at 2 3 in |- *; - case (fusion_cancel t (t2 + t4)%term); simpl in |- *; + case (fusion_cancel t (t2 + t4)%term); simpl in |- *; auto; intro k; elim (fusion_cancel_stable t); simpl in |- *. Simplify; intro H3. - generalize (OMEGA2 _ _ H2 H1); rewrite H3. + generalize (OMEGA2 _ _ H2 H1); rewrite H3. rewrite gt_lt_iff in H0; rewrite le_lt_iff; intuition. Qed. @@ -2208,17 +2208,17 @@ Definition negate_contradict (i1 i2 : nat) (h : hyps) := | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with | NeqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 - then absurd + if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 + then absurd else h | _ => h end | NeqTerm (Tint Nul) b1 => match nth_hyps i2 h with | EqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 - then absurd - else h + if beq Nul 0 && beq Nul' 0 && eq_term b1 b2 + then absurd + else h | _ => h end | _ => h @@ -2229,7 +2229,7 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := | EqTerm (Tint Nul) b1 => match nth_hyps i2 h with | NeqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && + if beq Nul 0 && beq Nul' 0 && eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then absurd else h @@ -2238,7 +2238,7 @@ Definition negate_contradict_inv (t i1 i2 : nat) (h : hyps) := | NeqTerm (Tint Nul) b1 => match nth_hyps i2 h with | EqTerm (Tint Nul') b2 => - if beq Nul 0 && beq Nul' 0 && + if beq Nul 0 && beq Nul' 0 && eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then absurd else h @@ -2252,9 +2252,9 @@ Theorem negate_contradict_valid : Proof. unfold valid_hyps, negate_contradict in |- *; intros i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; + case (nth_hyps i l); auto; intros t1 t2; case t1; + auto; intros z; auto; case (nth_hyps j l); + auto; intros t3 t4; case t3; auto; intros z'; auto; simpl in |- *; intros H1 H2; Simplify. Qed. @@ -2263,15 +2263,15 @@ Theorem negate_contradict_inv_valid : Proof. unfold valid_hyps, negate_contradict_inv in |- *; intros t i j ep e l H; generalize (nth_valid _ _ i _ H); generalize (nth_valid _ _ j _ H); - case (nth_hyps i l); auto; intros t1 t2; case t1; - auto; intros z; auto; case (nth_hyps j l); - auto; intros t3 t4; case t3; auto; intros z'; - auto; simpl in |- *; intros H1 H2; Simplify; + case (nth_hyps i l); auto; intros t1 t2; case t1; + auto; intros z; auto; case (nth_hyps j l); + auto; intros t3 t4; case t3; auto; intros z'; + auto; simpl in |- *; intros H1 H2; Simplify; [ rewrite <- scalar_norm_stable in H2; simpl in *; elim (mult_integral (interp_term e t4) (-(1))); intuition; elim minus_one_neq_zero; auto - | + | elim H2; clear H2; rewrite <- scalar_norm_stable; simpl in *; now rewrite <- H1, mult_0_l @@ -2282,7 +2282,7 @@ Qed. (* \paragraph{[O_SUM]} C'est une oper2 valide mais elle traite plusieurs cas à la fois (suivant les opérateurs de comparaison des deux arguments) d'où une - preuve un peu compliquée. On utilise quelques lemmes qui sont des + preuve un peu compliquée. On utilise quelques lemmes qui sont des généralisations des théorèmes utilisés par OMEGA. *) Definition sum (k1 k2 : int) (trace : list t_fusion) @@ -2291,11 +2291,11 @@ Definition sum (k1 k2 : int) (trace : list t_fusion) | EqTerm (Tint Null) b1 => match prop2 with | EqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 + if beq Null 0 && beq Null' 0 then EqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | LeqTerm (Tint Null') b2 => - if beq Null 0 && beq Null' 0 && bgt k2 0 + if beq Null 0 && beq Null' 0 && bgt k2 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm @@ -2305,18 +2305,18 @@ Definition sum (k1 k2 : int) (trace : list t_fusion) if beq Null 0 && bgt k1 0 then match prop2 with | EqTerm (Tint Null') b2 => - if beq Null' 0 then + if beq Null' 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) - else TrueTerm + else TrueTerm | LeqTerm (Tint Null') b2 => - if beq Null' 0 && bgt k2 0 + if beq Null' 0 && bgt k2 0 then LeqTerm (Tint 0) (fusion trace (b1 * Tint k1 + b2 * Tint k2)%term) else TrueTerm | _ => TrueTerm end - else TrueTerm + else TrueTerm | NeqTerm (Tint Null) b1 => match prop2 with | EqTerm (Tint Null') b2 => @@ -2334,7 +2334,7 @@ Theorem sum_valid : forall (k1 k2 : int) (t : list t_fusion), valid2 (sum k1 k2 t). Proof. unfold valid2 in |- *; intros k1 k2 t ep e p1 p2; unfold sum in |- *; - Simplify; simpl in |- *; auto; try elim (fusion_stable t); + Simplify; simpl in |- *; auto; try elim (fusion_stable t); simpl in |- *; intros; [ apply sum1; assumption | apply sum2; try assumption; apply sum4; assumption @@ -2350,13 +2350,13 @@ Definition exact_divide (k : int) (body : term) (t : nat) (prop : proposition) := match prop with | EqTerm (Tint Null) b => - if beq Null 0 && - eq_term (scalar_norm t (body * Tint k)%term) b && - negb (beq k 0) + if beq Null 0 && + eq_term (scalar_norm t (body * Tint k)%term) b && + negb (beq k 0) then EqTerm (Tint 0) body else TrueTerm | NeqTerm (Tint Null) b => - if beq Null 0 && + if beq Null 0 && eq_term (scalar_norm t (body * Tint k)%term) b && negb (beq k 0) then NeqTerm (Tint 0) body @@ -2367,8 +2367,8 @@ Definition exact_divide (k : int) (body : term) (t : nat) Theorem exact_divide_valid : forall (k : int) (t : term) (n : nat), valid1 (exact_divide k t n). Proof. - unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; - Simplify; simpl; auto; subst; + unfold valid1, exact_divide in |- *; intros k1 k2 t ep e p1; + Simplify; simpl; auto; subst; rewrite <- scalar_norm_stable; simpl; intros; [ destruct (mult_integral _ _ (sym_eq H0)); intuition | contradict H0; rewrite <- H0, mult_0_l; auto @@ -2380,15 +2380,15 @@ Qed. La preuve reprend le schéma de la précédente mais on est sur une opération de type valid1 et non sur une opération terminale. *) -Definition divide_and_approx (k1 k2 : int) (body : term) +Definition divide_and_approx (k1 k2 : int) (body : term) (t : nat) (prop : proposition) := match prop with | LeqTerm (Tint Null) b => - if beq Null 0 && + if beq Null 0 && eq_term (scalar_norm_add t (body * Tint k1 + Tint k2)%term) b && - bgt k1 0 && - bgt k1 k2 - then LeqTerm (Tint 0) body + bgt k1 0 && + bgt k1 k2 + then LeqTerm (Tint 0) body else prop | _ => prop end. @@ -2411,7 +2411,7 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) := match prop2 with | LeqTerm (Tint Null') b2 => if beq Null 0 && beq Null' 0 && - eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) + eq_term b1 (scalar_norm t (b2 * Tint (-(1)))%term) then EqTerm (Tint 0) b1 else TrueTerm | _ => TrueTerm @@ -2422,7 +2422,7 @@ Definition merge_eq (t : nat) (prop1 prop2 : proposition) := Theorem merge_eq_valid : forall n : nat, valid2 (merge_eq n). Proof. unfold valid2, merge_eq in |- *; intros n ep e p1 p2; Simplify; simpl in |- *; - auto; elim (scalar_norm_stable n e); simpl in |- *; + auto; elim (scalar_norm_stable n e); simpl in |- *; intros; symmetry in |- *; apply OMEGA8 with (2 := H0); [ assumption | elim opp_eq_mult_neg_1; trivial ]. Qed. @@ -2433,8 +2433,8 @@ Qed. Definition constant_nul (i : nat) (h : hyps) := match nth_hyps i h with - | NeqTerm (Tint Null) (Tint Null') => - if beq Null Null' then absurd else h + | NeqTerm (Tint Null) (Tint Null') => + if beq Null Null' then absurd else h | _ => h end. @@ -2452,7 +2452,7 @@ Definition state (m : int) (s : step) (prop1 prop2 : proposition) := | EqTerm (Tint Null) b1 => match prop2 with | EqTerm b2 b3 => - if beq Null 0 + if beq Null 0 then EqTerm (Tint 0) (rewrite s (b1 + (- b3 + b2) * Tint m)%term) else TrueTerm | _ => TrueTerm @@ -2463,20 +2463,20 @@ Definition state (m : int) (s : step) (prop1 prop2 : proposition) := Theorem state_valid : forall (m : int) (s : step), valid2 (state m s). Proof. unfold valid2 in |- *; intros m s ep e p1 p2; unfold state in |- *; Simplify; - simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; + simpl in |- *; auto; elim (rewrite_stable s e); simpl in |- *; intros H1 H2; elim H1. now rewrite H2, plus_opp_l, plus_0_l, mult_0_l. Qed. (* \subsubsection{Tactiques générant plusieurs but} - \paragraph{[O_SPLIT_INEQ]} + \paragraph{[O_SPLIT_INEQ]} La seule pour le moment (tant que la normalisation n'est pas réfléchie). *) -Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) +Definition split_ineq (i t : nat) (f1 f2 : hyps -> lhyps) (l : hyps) := match nth_hyps i l with | NeqTerm (Tint Null) b1 => - if beq Null 0 then + if beq Null 0 then f1 (LeqTerm (Tint 0) (add_norm t (b1 + Tint (-(1)))%term) :: l) ++ f2 (LeqTerm (Tint 0) @@ -2491,8 +2491,8 @@ Theorem split_ineq_valid : valid_list_hyps f2 -> valid_list_hyps (split_ineq i t f1 f2). Proof. unfold valid_list_hyps, split_ineq in |- *; intros i t f1 f2 H1 H2 ep e lp H; - generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); - simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; + generalize (nth_valid _ _ i _ H); case (nth_hyps i lp); + simpl in |- *; auto; intros t1 t2; case t1; simpl in |- *; auto; intros z; simpl in |- *; auto; intro H3. Simplify. apply append_valid; elim (OMEGA19 (interp_term e t2)); @@ -2580,7 +2580,7 @@ Proof. Qed. -(* \subsection{Les opérations globales sur le but} +(* \subsection{Les opérations globales sur le but} \subsubsection{Normalisation} *) Definition move_right (s : step) (p : proposition) := @@ -2615,7 +2615,7 @@ Proof. apply move_right_valid. Qed. -Fixpoint do_normalize_list (l : list step) (i : nat) +Fixpoint do_normalize_list (l : list step) (i : nat) (h : hyps) {struct l} : hyps := match l with | s :: l' => do_normalize_list l' (S i) (do_normalize i s h) @@ -2659,7 +2659,7 @@ Proof. Qed. (* A simple decidability checker : if the proposition belongs to the - simple grammar describe below then it is decidable. Proof is by + simple grammar describe below then it is decidable. Proof is by induction and uses well known theorem about arithmetic and propositional calculus *) @@ -2703,7 +2703,7 @@ Qed. (* An interpretation function for a complete goal with an explicit conclusion. We use an intermediate fixpoint. *) -Fixpoint interp_full_goal (envp : list Prop) (env : list int) +Fixpoint interp_full_goal (envp : list Prop) (env : list int) (c : proposition) (l : hyps) {struct l} : Prop := match l with | nil => interp_proposition envp env c @@ -2711,7 +2711,7 @@ Fixpoint interp_full_goal (envp : list Prop) (env : list int) interp_proposition envp env p' -> interp_full_goal envp env c l' end. -Definition interp_full (ep : list Prop) (e : list int) +Definition interp_full (ep : list Prop) (e : list int) (lc : hyps * proposition) : Prop := match lc with | (l, c) => interp_full_goal ep e c l @@ -2729,7 +2729,7 @@ Proof. Qed. (* Push the conclusion in the list of hypothesis using a double negation - If the decidability cannot be "proven", then just forget about the + If the decidability cannot be "proven", then just forget about the conclusion (equivalent of replacing it with false) *) Definition to_contradict (lc : hyps * proposition) := @@ -2765,16 +2765,16 @@ Fixpoint map_cons (A : Set) (x : A) (l : list (list A)) {struct l} : | l :: ll => (x :: l) :: map_cons A x ll end. -(* This function breaks up a list of hypothesis in a list of simpler +(* This function breaks up a list of hypothesis in a list of simpler list of hypothesis that together implie the original one. The goal - of all this is to transform the goal in a list of solvable problems. + of all this is to transform the goal in a list of solvable problems. Note that : - we need a way to drive the analysis as some hypotheis may not - require a split. + require a split. - this procedure must be perfectly mimicked by the ML part otherwise hypothesis will get desynchronised and this will be a mess. *) - + Fixpoint destructure_hyps (nn : nat) (ll : hyps) {struct nn} : lhyps := match nn with | O => ll :: nil @@ -2834,7 +2834,7 @@ Proof. (simpl in |- *; intros; apply map_cons_val; simpl in |- *; elim H0; auto); [ simpl in |- *; intros p1 (H1, H2); - pattern (decidability p1) in |- *; apply bool_eq_ind; + pattern (decidability p1) in |- *; apply bool_eq_ind; intro H3; [ apply H; simpl in |- *; split; [ apply not_not; auto | assumption ] @@ -2842,7 +2842,7 @@ Proof. | simpl in |- *; intros p1 p2 (H1, H2); apply H; simpl in |- *; elim not_or with (1 := H1); auto | simpl in |- *; intros p1 p2 (H1, H2); - pattern (decidability p1) in |- *; apply bool_eq_ind; + pattern (decidability p1) in |- *; apply bool_eq_ind; intro H3; [ apply append_valid; elim not_and with (2 := H1); [ intro; left; apply H; simpl in |- *; auto @@ -2850,11 +2850,11 @@ Proof. | auto ] | auto ] ] | simpl in |- *; intros p1 p2 (H1, H2); apply append_valid; - (elim H1; intro H3; simpl in |- *; [ left | right ]); + (elim H1; intro H3; simpl in |- *; [ left | right ]); apply H; simpl in |- *; auto | simpl in |- *; intros; apply H; simpl in |- *; tauto | simpl in |- *; intros p1 p2 (H1, H2); - pattern (decidability p1) in |- *; apply bool_eq_ind; + pattern (decidability p1) in |- *; apply bool_eq_ind; intro H3; [ apply append_valid; elim imp_simp with (2 := H1); [ intro H4; left; simpl in |- *; apply H; simpl in |- *; auto @@ -2867,7 +2867,7 @@ Definition prop_stable (f : proposition -> proposition) := forall (ep : list Prop) (e : list int) (p : proposition), interp_proposition ep e p <-> interp_proposition ep e (f p). -Definition p_apply_left (f : proposition -> proposition) +Definition p_apply_left (f : proposition -> proposition) (p : proposition) := match p with | Timp x y => Timp (f x) y @@ -2907,7 +2907,7 @@ Proof. | intros p1 p2; elim (H ep e p2); tauto ]). Qed. -Definition p_invert (f : proposition -> proposition) +Definition p_invert (f : proposition -> proposition) (p : proposition) := match p with | EqTerm x y => Tnot (f (NeqTerm x y)) @@ -2960,7 +2960,7 @@ Proof. | case p; simpl in |- *; intros; auto; generalize H; elim (rewrite_stable s); simpl in |- *; intro H1; [ rewrite (plus_0_r_reverse (interp_term e t0)); rewrite H1; - rewrite plus_permute; rewrite plus_opp_r; + rewrite plus_permute; rewrite plus_opp_r; rewrite plus_0_r; trivial | apply (fun a b => plus_le_reg_r a b (- interp_term e t)); rewrite plus_opp_r; assumption @@ -3037,7 +3037,7 @@ Fixpoint extract_hyp_pos (s : list direction) (p : proposition) {struct s} : end | _ => p end - + with extract_hyp_neg (s : list direction) (p : proposition) {struct s} : proposition := match s with @@ -3087,7 +3087,7 @@ Proof. (apply H2; tauto) || (pattern (decidability p0) in |- *; apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e p0 H3); - unfold decidable in |- *; intro H4; apply H1; + unfold decidable in |- *; intro H4; apply H1; tauto | intro; tauto ]) ]. Qed. @@ -3103,8 +3103,8 @@ Fixpoint decompose_solve (s : e_step) (h : hyps) {struct s} : lhyps := decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (Tnot y :: h) else h :: nil - | Timp x y => - if decidability x then + | Timp x y => + if decidability x then decompose_solve s1 (Tnot x :: h) ++ decompose_solve s2 (y :: h) else h::nil | _ => h :: nil @@ -3130,11 +3130,11 @@ Proof. | simpl in |- *; auto ] | intros p1 p2 H2; apply append_valid; simpl in |- *; elim H2; [ intros H3; left; apply H; simpl in |- *; auto - | intros H3; right; apply H0; simpl in |- *; auto ] + | intros H3; right; apply H0; simpl in |- *; auto ] | intros p1 p2 H2; pattern (decidability p1) in |- *; apply bool_eq_ind; [ intro H3; generalize (decidable_correct ep e1 p1 H3); intro H4; - apply append_valid; elim H4; intro H5; + apply append_valid; elim H4; intro H5; [ right; apply H0; simpl in |- *; tauto | left; apply H; simpl in |- *; tauto ] | simpl in |- *; auto ] ] @@ -3172,7 +3172,7 @@ Theorem do_reduce_lhyps : interp_list_goal envp env (reduce_lhyps l) -> interp_list_goal envp env l. Proof. intros envp env l H; apply list_goal_to_hyps; intro H1; - apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; + apply list_hyps_to_goal with (1 := H); apply reduce_lhyps_valid; assumption. Qed. @@ -3193,12 +3193,12 @@ Proof. | simpl in |- *; tauto ]. Qed. -Definition omega_tactic (t1 : e_step) (t2 : list h_step) +Definition omega_tactic (t1 : e_step) (t2 : list h_step) (c : proposition) (l : hyps) := reduce_lhyps (decompose_solve t1 (normalize_hyps t2 (concl_to_hyp c :: l))). Theorem do_omega : - forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) + forall (t1 : e_step) (t2 : list h_step) (envp : list Prop) (env : list int) (c : proposition) (l : hyps), interp_list_goal envp env (omega_tactic t1 t2 c l) -> interp_goal_concl c envp env l. @@ -3210,7 +3210,7 @@ Qed. End IntOmega. -(* For now, the above modular construction is instanciated on Z, +(* For now, the above modular construction is instanciated on Z, in order to retrieve the initial ROmega. *) Module ZOmega := IntOmega(Z_as_Int). diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 1caa5db1c5..2978d699e1 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -9,7 +9,7 @@ let module_refl_name = "ReflOmegaCore" let module_refl_path = ["Coq"; "romega"; module_refl_name] -type result = +type result = Kvar of string | Kapp of string * Term.constr list | Kimp of Term.constr * Term.constr @@ -38,10 +38,10 @@ let destructurate t = exception Destruct -let dest_const_apply t = - let f,args = Term.decompose_app t in - let ref = - match Term.kind_of_term f with +let dest_const_apply t = + let f,args = Term.decompose_app t in + let ref = + match Term.kind_of_term f with | Term.Const sp -> Libnames.ConstRef sp | Term.Construct csp -> Libnames.ConstructRef csp | Term.Ind isp -> Libnames.IndRef isp @@ -165,15 +165,15 @@ let coq_do_omega = lazy (constant "do_omega") (* \subsection{Construction d'expressions} *) -let do_left t = +let do_left t = if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop else Term.mkApp (Lazy.force coq_c_do_left, [|t |] ) -let do_right t = +let do_right t = if t = Lazy.force coq_c_nop then Lazy.force coq_c_nop else Term.mkApp (Lazy.force coq_c_do_right, [|t |]) -let do_both t1 t2 = +let do_both t1 t2 = if t1 = Lazy.force coq_c_nop then do_right t2 else if t2 = Lazy.force coq_c_nop then do_left t1 else Term.mkApp (Lazy.force coq_c_do_both , [|t1; t2 |]) @@ -182,7 +182,7 @@ let do_seq t1 t2 = if t1 = Lazy.force coq_c_nop then t2 else if t2 = Lazy.force coq_c_nop then t1 else Term.mkApp (Lazy.force coq_c_do_seq, [|t1; t2 |]) - + let rec do_list = function | [] -> Lazy.force coq_c_nop | [x] -> x @@ -206,7 +206,7 @@ let mk_list typ l = let rec loop = function | [] -> Term.mkApp (Lazy.force coq_nil, [|typ|]) - | (step :: l) -> + | (step :: l) -> Term.mkApp (Lazy.force coq_cons, [|typ; step; loop l |]) in loop l @@ -215,16 +215,16 @@ let mk_plist l = mk_list Term.mkProp l let mk_shuffle_list l = mk_list (Lazy.force coq_t_fusion) l -type parse_term = - | Tplus of Term.constr * Term.constr +type parse_term = + | Tplus of Term.constr * Term.constr | Tmult of Term.constr * Term.constr | Tminus of Term.constr * Term.constr | Topp of Term.constr | Tsucc of Term.constr | Tnum of Bigint.bigint - | Tother + | Tother -type parse_rel = +type parse_rel = | Req of Term.constr * Term.constr | Rne of Term.constr * Term.constr | Rlt of Term.constr * Term.constr @@ -240,12 +240,12 @@ type parse_rel = | Riff of Term.constr * Term.constr | Rother -let parse_logic_rel c = +let parse_logic_rel c = try match destructurate c with | Kapp("True",[]) -> Rtrue | Kapp("False",[]) -> Rfalse | Kapp("not",[t]) -> Rnot t - | Kapp("or",[t1;t2]) -> Ror (t1,t2) + | Kapp("or",[t1;t2]) -> Ror (t1,t2) | Kapp("and",[t1;t2]) -> Rand (t1,t2) | Kimp(t1,t2) -> Rimp (t1,t2) | Kapp("iff",[t1;t2]) -> Riff (t1,t2) @@ -255,7 +255,7 @@ let parse_logic_rel c = module type Int = sig val typ : Term.constr Lazy.t - val plus : Term.constr Lazy.t + val plus : Term.constr Lazy.t val mult : Term.constr Lazy.t val opp : Term.constr Lazy.t val minus : Term.constr Lazy.t @@ -264,10 +264,10 @@ module type Int = sig val parse_term : Term.constr -> parse_term val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel (* check whether t is built only with numbers and + * - *) - val is_scalar : Term.constr -> bool + val is_scalar : Term.constr -> bool end -module Z : Int = struct +module Z : Int = struct let typ = lazy (constant "Z") let plus = lazy (constant "Zplus") @@ -297,16 +297,16 @@ let recognize t = | "Z0",[] -> Bigint.zero | _ -> failwith "not a number";; -let rec mk_positive n = - if n=Bigint.one then Lazy.force coq_xH +let rec mk_positive n = + if n=Bigint.one then Lazy.force coq_xH else let (q,r) = Bigint.euclid n Bigint.two in Term.mkApp ((if r = Bigint.zero then Lazy.force coq_xO else Lazy.force coq_xI), - [| mk_positive q |]) + [| mk_positive q |]) let mk_Z n = - if n = Bigint.zero then Lazy.force coq_Z0 + if n = Bigint.zero then Lazy.force coq_Z0 else if Bigint.is_strictly_pos n then Term.mkApp (Lazy.force coq_Zpos, [| mk_positive n |]) else @@ -314,7 +314,7 @@ let mk_Z n = let mk = mk_Z -let parse_term t = +let parse_term t = try match destructurate t with | Kapp("Zplus",[t1;t2]) -> Tplus (t1,t2) | Kapp("Zminus",[t1;t2]) -> Tminus (t1,t2) @@ -322,21 +322,21 @@ let parse_term t = | Kapp("Zopp",[t]) -> Topp t | Kapp("Zsucc",[t]) -> Tsucc t | Kapp("Zpred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) - | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> + | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> (try Tnum (recognize t) with _ -> Tother) | _ -> Tother with e when Logic.catchable_exception e -> Tother - -let parse_rel gl t = - try match destructurate t with - | Kapp("eq",[typ;t1;t2]) + +let parse_rel gl t = + try match destructurate t with + | Kapp("eq",[typ;t1;t2]) when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2) | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) | Kapp("Zle",[t1;t2]) -> Rle (t1,t2) | Kapp("Zlt",[t1;t2]) -> Rlt (t1,t2) | Kapp("Zge",[t1;t2]) -> Rge (t1,t2) | Kapp("Zgt",[t1;t2]) -> Rgt (t1,t2) - | _ -> parse_logic_rel t + | _ -> parse_logic_rel t with e when Logic.catchable_exception e -> Rother let is_scalar t = diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index 0f00e9184a..b8db71e40a 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -168,7 +168,7 @@ module type Int = val parse_term : Term.constr -> parse_term (* parsing a relation expression, including = < <= >= > *) val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel - (* Is a particular term only made of numbers and + * - ? *) + (* Is a particular term only made of numbers and + * - ? *) val is_scalar : Term.constr -> bool end diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 39b6c2106b..2db86e005b 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -11,23 +11,23 @@ open Refl_omega open Refiner -let romega_tactic l = - let tacs = List.map - (function +let romega_tactic l = + let tacs = List.map + (function | "nat" -> Tacinterp.interp <:tactic> | "positive" -> Tacinterp.interp <:tactic> | "N" -> Tacinterp.interp <:tactic> | "Z" -> Tacinterp.interp <:tactic> | s -> Util.error ("No ROmega knowledge base for type "^s)) (Util.list_uniquize (List.sort compare l)) - in + in tclTHEN (tclREPEAT (tclPROGRESS (tclTHENLIST tacs))) - (tclTHEN - (* because of the contradiction process in (r)omega, + (tclTHEN + (* because of the contradiction process in (r)omega, we'd better leave as little as possible in the conclusion, for an easier decidability argument. *) - Tactics.intros + Tactics.intros total_reflexive_omega_tactic) @@ -36,7 +36,7 @@ TACTIC EXTEND romega END TACTIC EXTEND romega' -| [ "romega" "with" ne_ident_list(l) ] -> +| [ "romega" "with" ne_ident_list(l) ] -> [ romega_tactic (List.map Names.string_of_id l) ] | [ "romega" "with" "*" ] -> [ romega_tactic ["nat";"positive";"N";"Z"] ] END diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index fc4f7a8f09..570bb1877e 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -28,7 +28,7 @@ let mkApp = Term.mkApp (* \section{Types} \subsection{How to walk in a term} To represent how to get to a proposition. Only choice points are - kept (branch to choose in a disjunction and identifier of the disjunctive + kept (branch to choose in a disjunction and identifier of the disjunctive connector) *) type direction = Left of int | Right of int @@ -58,11 +58,11 @@ type oformula = (* Operators for comparison recognized by Omega *) type comparaison = Eq | Leq | Geq | Gt | Lt | Neq -(* Type des prédicats réifiés (fragment de calcul propositionnel. Les +(* Type des prédicats réifiés (fragment de calcul propositionnel. Les * quantifications sont externes au langage) *) -type oproposition = +type oproposition = Pequa of Term.constr * oequation - | Ptrue + | Ptrue | Pfalse | Pnot of oproposition | Por of int * oproposition * oproposition @@ -77,16 +77,16 @@ and oequation = { e_right: oformula; (* formule brute droite *) e_trace: Term.constr; (* tactique de normalisation *) e_origin: occurence; (* l'hypothèse dont vient le terme *) - e_negated: bool; (* vrai si apparait en position nié + e_negated: bool; (* vrai si apparait en position nié après normalisation *) - e_depends: direction list; (* liste des points de disjonction dont - dépend l'accès à l'équation avec la + e_depends: direction list; (* liste des points de disjonction dont + dépend l'accès à l'équation avec la direction (branche) pour y accéder *) e_omega: afine (* la fonction normalisée *) - } + } -(* \subsection{Proof context} - This environment codes +(* \subsection{Proof context} + This environment codes \begin{itemize} \item the terms and propositions that are given as parameters of the reified proof (and are represented as variables in the @@ -101,7 +101,7 @@ type environment = { mutable props : Term.constr list; (* Les variables introduites par omega *) mutable om_vars : (oformula * int) list; - (* Traduction des indices utilisés ici en les indices finaux utilisés par + (* Traduction des indices utilisés ici en les indices finaux utilisés par * la tactique Omega après dénombrement des variables utiles *) real_indices : (int,int) Hashtbl.t; mutable cnt_connectors : int; @@ -119,7 +119,7 @@ type solution = { s_trace : action list } (* Arbre de solution résolvant complètement un ensemble de systèmes *) -type solution_tree = +type solution_tree = Leaf of solution (* un noeud interne représente un point de branchement correspondant à l'élimination d'un connecteur générant plusieurs buts @@ -130,37 +130,37 @@ type solution_tree = (* Représentation de l'environnement extrait du but initial sous forme de chemins pour extraire des equations ou d'hypothèses *) -type context_content = +type context_content = CCHyp of occurence | CCEqua of int (* \section{Specific utility functions to handle base types} *) -(* Nom arbitraire de l'hypothèse codant la négation du but final *) +(* Nom arbitraire de l'hypothèse codant la négation du but final *) let id_concl = Names.id_of_string "__goal__" (* Initialisation de l'environnement de réification de la tactique *) let new_environment () = { - terms = []; props = []; om_vars = []; cnt_connectors = 0; + terms = []; props = []; om_vars = []; cnt_connectors = 0; real_indices = Hashtbl.create 7; equations = Hashtbl.create 7; constructors = Hashtbl.create 7; } (* Génération d'un nom d'équation *) -let new_connector_id env = +let new_connector_id env = env.cnt_connectors <- succ env.cnt_connectors; env.cnt_connectors (* Calcul de la branche complémentaire *) let barre = function Left x -> Right x | Right x -> Left x (* Identifiant associé à une branche *) -let indice = function Left x | Right x -> x +let indice = function Left x | Right x -> x (* Affichage de l'environnement de réification (termes et propositions) *) -let print_env_reification env = +let print_env_reification env = let rec loop c i = function [] -> Printf.printf " ===============================\n\n" - | t :: l -> + | t :: l -> Printf.printf " (%c%02d) := " c i; Pp.ppnl (Printer.pr_lconstr t); Pp.flush_all (); @@ -173,16 +173,16 @@ let print_env_reification env = (* \subsection{Gestion des environnements de variable pour Omega} *) (* generation d'identifiant d'equation pour Omega *) -let new_omega_eq, rst_omega_eq = - let cpt = ref 0 in - (function () -> incr cpt; !cpt), +let new_omega_eq, rst_omega_eq = + let cpt = ref 0 in + (function () -> incr cpt; !cpt), (function () -> cpt:=0) (* generation d'identifiant de variable pour Omega *) -let new_omega_var, rst_omega_var = - let cpt = ref 0 in - (function () -> incr cpt; !cpt), +let new_omega_var, rst_omega_var = + let cpt = ref 0 in + (function () -> incr cpt; !cpt), (function () -> cpt:=0) (* Affichage des variables d'un système *) @@ -195,8 +195,8 @@ let display_omega_var i = Printf.sprintf "OV%d" i let intern_omega env t = begin try List.assoc t env.om_vars - with Not_found -> - let v = new_omega_var () in + with Not_found -> + let v = new_omega_var () in env.om_vars <- (t,v) :: env.om_vars; v end @@ -207,14 +207,14 @@ let intern_omega_force env t v = env.om_vars <- (t,v) :: env.om_vars (* Récupère le terme associé à une variable *) let unintern_omega env id = - let rec loop = function - [] -> failwith "unintern" + let rec loop = function + [] -> failwith "unintern" | ((t,j)::l) -> if id = j then t else loop l in loop env.om_vars -(* \subsection{Gestion des environnements de variable pour la réflexion} +(* \subsection{Gestion des environnements de variable pour la réflexion} Gestion des environnements de traduction entre termes des constructions - non réifiés et variables des termes reifies. Attention il s'agit de + non réifiés et variables des termes reifies. Attention il s'agit de l'environnement initial contenant tout. Il faudra le réduire après calcul des variables utiles. *) @@ -224,7 +224,7 @@ let add_reified_atom t env = let i = List.length env.terms in env.terms <- env.terms @ [t]; i -let get_reified_atom env = +let get_reified_atom env = try List.nth env.terms with _ -> failwith "get_reified_atom" (* \subsection{Gestion de l'environnement de proposition pour Omega} *) @@ -245,33 +245,33 @@ let add_equation env e = with Not_found -> Hashtbl.add env.equations id e (* accès a une equation *) -let get_equation env id = +let get_equation env id = try Hashtbl.find env.equations id with e -> Printf.printf "Omega Equation %d non trouvée\n" id; raise e (* Affichage des termes réifiés *) -let rec oprint ch = function +let rec oprint ch = function | Oint n -> Printf.fprintf ch "%s" (Bigint.to_string n) - | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 - | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 - | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 + | Oplus (t1,t2) -> Printf.fprintf ch "(%a + %a)" oprint t1 oprint t2 + | Omult (t1,t2) -> Printf.fprintf ch "(%a * %a)" oprint t1 oprint t2 + | Ominus(t1,t2) -> Printf.fprintf ch "(%a - %a)" oprint t1 oprint t2 | Oopp t1 ->Printf.fprintf ch "~ %a" oprint t1 | Oatom n -> Printf.fprintf ch "V%02d" n | Oufo x -> Printf.fprintf ch "?" let rec pprint ch = function Pequa (_,{ e_comp=comp; e_left=t1; e_right=t2 }) -> - let connector = - match comp with + let connector = + match comp with Eq -> "=" | Leq -> "<=" | Geq -> ">=" | Gt -> ">" | Lt -> "<" | Neq -> "!=" in - Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 + Printf.fprintf ch "%a %s %a" oprint t1 connector oprint t2 | Ptrue -> Printf.fprintf ch "TT" | Pfalse -> Printf.fprintf ch "FF" | Pnot t -> Printf.fprintf ch "not(%a)" pprint t - | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 - | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 - | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 + | Por (_,t1,t2) -> Printf.fprintf ch "(%a or %a)" pprint t1 pprint t2 + | Pand(_,t1,t2) -> Printf.fprintf ch "(%a and %a)" pprint t1 pprint t2 + | Pimp(_,t1,t2) -> Printf.fprintf ch "(%a => %a)" pprint t1 pprint t2 | Pprop c -> Printf.fprintf ch "Prop" let rec weight env = function @@ -287,21 +287,21 @@ let rec weight env = function (* \subsection{Oformula vers Omega} *) -let omega_of_oformula env kind = +let omega_of_oformula env kind = let rec loop accu = function - | Oplus(Omult(v,Oint n),r) -> + | Oplus(Omult(v,Oint n),r) -> loop ({v=intern_omega env v; c=n} :: accu) r | Oint n -> let id = new_omega_eq () in (*i tag_equation name id; i*) - {kind = kind; body = List.rev accu; + {kind = kind; body = List.rev accu; constant = n; id = id} | t -> print_string "CO"; oprint stdout t; failwith "compile_equation" in loop [] (* \subsection{Omega vers Oformula} *) -let rec oformula_of_omega env af = +let rec oformula_of_omega env af = let rec loop = function | ({v=v; c=n}::r) -> Oplus(Omult(unintern_omega env v,Oint n),loop r) @@ -330,8 +330,8 @@ let rec coq_of_formula env t = let reified_of_atom env i = try Hashtbl.find env.real_indices i - with Not_found -> - Printf.printf "Atome %d non trouvé\n" i; + with Not_found -> + Printf.printf "Atome %d non trouvé\n" i; Hashtbl.iter (fun k v -> Printf.printf "%d -> %d\n" k v) env.real_indices; raise Not_found @@ -352,55 +352,55 @@ let reified_of_formula env f = begin try reified_of_formula env f with e -> oprint stderr f; raise e end let rec reified_of_proposition env = function - Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> + Pequa (_,{ e_comp=Eq; e_left=t1; e_right=t2 }) -> app coq_p_eq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> + | Pequa (_,{ e_comp=Leq; e_left=t1; e_right=t2 }) -> app coq_p_leq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> + | Pequa(_,{ e_comp=Geq; e_left=t1; e_right=t2 }) -> app coq_p_geq [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> + | Pequa(_,{ e_comp=Gt; e_left=t1; e_right=t2 }) -> app coq_p_gt [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> + | Pequa(_,{ e_comp=Lt; e_left=t1; e_right=t2 }) -> app coq_p_lt [| reified_of_formula env t1; reified_of_formula env t2 |] - | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> + | Pequa(_,{ e_comp=Neq; e_left=t1; e_right=t2 }) -> app coq_p_neq [| reified_of_formula env t1; reified_of_formula env t2 |] | Ptrue -> Lazy.force coq_p_true | Pfalse -> Lazy.force coq_p_false - | Pnot t -> + | Pnot t -> app coq_p_not [| reified_of_proposition env t |] - | Por (_,t1,t2) -> + | Por (_,t1,t2) -> app coq_p_or [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pand(_,t1,t2) -> + | Pand(_,t1,t2) -> app coq_p_and [| reified_of_proposition env t1; reified_of_proposition env t2 |] - | Pimp(_,t1,t2) -> + | Pimp(_,t1,t2) -> app coq_p_imp [| reified_of_proposition env t1; reified_of_proposition env t2 |] | Pprop t -> app coq_p_prop [| mk_nat (add_prop env t) |] let reified_of_proposition env f = - begin try reified_of_proposition env f + begin try reified_of_proposition env f with e -> pprint stderr f; raise e end (* \subsection{Omega vers COQ réifié} *) -let reified_of_omega env body constant = - let coeff_constant = +let reified_of_omega env body constant = + let coeff_constant = app coq_t_int [| Z.mk constant |] in let mk_coeff {c=c; v=v} t = - let coef = - app coq_t_mult - [| reified_of_formula env (unintern_omega env v); + let coef = + app coq_t_mult + [| reified_of_formula env (unintern_omega env v); app coq_t_int [| Z.mk c |] |] in app coq_t_plus [|coef; t |] in List.fold_right mk_coeff body coeff_constant -let reified_of_omega env body c = - begin try - reified_of_omega env body c - with e -> - display_eq display_omega_var (body,c); raise e +let reified_of_omega env body c = + begin try + reified_of_omega env body c + with e -> + display_eq display_omega_var (body,c); raise e end (* \section{Opérations sur les équations} @@ -423,13 +423,13 @@ let rec vars_of_formula = function | Oufo _ -> [] let rec vars_of_equations = function - | [] -> [] - | e::l -> + | [] -> [] + | e::l -> (vars_of_formula e.e_left) @@ (vars_of_formula e.e_right) @@ (vars_of_equations l) -let rec vars_of_prop = function +let rec vars_of_prop = function | Pequa(_,e) -> vars_of_equations [e] | Pnot p -> vars_of_prop p | Por(_,p1,p2) -> (vars_of_prop p1) @@ (vars_of_prop p2) @@ -440,16 +440,16 @@ let rec vars_of_prop = function (* \subsection{Multiplication par un scalaire} *) let rec scalar n = function - Oplus(t1,t2) -> - let tac1,t1' = scalar n t1 and + Oplus(t1,t2) -> + let tac1,t1' = scalar n t1 and tac2,t2' = scalar n t2 in - do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], + do_list [Lazy.force coq_c_mult_plus_distr; do_both tac1 tac2], Oplus(t1',t2') | Oopp t -> do_list [Lazy.force coq_c_mult_opp_left], Omult(t,Oint(Bigint.neg n)) - | Omult(t1,Oint x) -> + | Omult(t1,Oint x) -> do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x)) - | Omult(t1,t2) -> + | Omult(t1,t2) -> Util.error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> do_list [], Omult(t,Oint n) | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i) @@ -459,16 +459,16 @@ let rec scalar n = function (* \subsection{Propagation de l'inversion} *) let rec negate = function - Oplus(t1,t2) -> - let tac1,t1' = negate t1 and + Oplus(t1,t2) -> + let tac1,t1' = negate t1 and tac2,t2' = negate t2 in do_list [Lazy.force coq_c_opp_plus ; (do_both tac1 tac2)], Oplus(t1',t2') | Oopp t -> do_list [Lazy.force coq_c_opp_opp], t - | Omult(t1,Oint x) -> + | Omult(t1,Oint x) -> do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x)) - | Omult(t1,t2) -> + | Omult(t1,t2) -> Util.error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone)) @@ -493,29 +493,29 @@ let rec shuffle_path k1 e1 k2 e2 = Lazy.force coq_f_left :: loop(l1,l2')) else ( Lazy.force coq_f_right :: loop(l1',l2)) - | ({c=c1;v=v1}::l1), [] -> + | ({c=c1;v=v1}::l1), [] -> Lazy.force coq_f_left :: loop(l1,[]) - | [],({c=c2;v=v2}::l2) -> + | [],({c=c2;v=v2}::l2) -> Lazy.force coq_f_right :: loop([],l2) | [],[] -> flush stdout; [] in mk_shuffle_list (loop (e1,e2)) (* \subsubsection{Version sans coefficients} *) -let rec shuffle env (t1,t2) = +let rec shuffle env (t1,t2) = match t1,t2 with Oplus(l1,r1), Oplus(l2,r2) -> - if weight env l1 > weight env l2 then + if weight env l1 > weight env l2 then let l_action,t' = shuffle env (r1,t2) in do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action], Oplus(l1,t') - else + else let l_action,t' = shuffle env (t1,r2) in do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') - | Oplus(l1,r1), t2 -> + | Oplus(l1,r1), t2 -> if weight env l1 > weight env t2 then let (l_action,t') = shuffle env (r1,t2) in do_list [Lazy.force coq_c_plus_assoc_r;do_right l_action],Oplus(l1, t') else do_list [Lazy.force coq_c_plus_comm], Oplus(t2,t1) - | t1,Oplus(l2,r2) -> + | t1,Oplus(l2,r2) -> if weight env l2 > weight env t1 then let (l_action,t') = shuffle env (t1,r2) in do_list [Lazy.force coq_c_plus_permute;do_right l_action], Oplus(l2,t') @@ -531,16 +531,16 @@ let rec shuffle env (t1,t2) = let shrink_pair f1 f2 = begin match f1,f2 with - Oatom v,Oatom _ -> + Oatom v,Oatom _ -> Lazy.force coq_c_red1, Omult(Oatom v,Oint two) - | Oatom v, Omult(_,c2) -> + | Oatom v, Omult(_,c2) -> Lazy.force coq_c_red2, Omult(Oatom v,Oplus(c2,Oint one)) - | Omult (v1,c1),Oatom v -> + | Omult (v1,c1),Oatom v -> Lazy.force coq_c_red3, Omult(Oatom v,Oplus(c1,Oint one)) | Omult (Oatom v,c1),Omult (v2,c2) -> Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2)) - | t1,t2 -> - oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); + | t1,t2 -> + oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); flush Pervasives.stdout; Util.error "shrink.1" end @@ -554,7 +554,7 @@ let reduce_factor = function | Omult(Oatom v,c) -> let rec compute = function Oint n -> n - | Oplus(t1,t2) -> compute t1 + compute t2 + | Oplus(t1,t2) -> compute t1 + compute t2 | _ -> Util.error "condense.1" in [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) | t -> Util.error "reduce_factor.1" @@ -570,24 +570,24 @@ let rec condense env = function assoc_tac :: do_left (do_list [shrink_tac]) :: tac_list, t' end else begin let tac,f = reduce_factor f1 in - let tac',t' = condense env t in - [do_both (do_list tac) (do_list tac')], Oplus(f,t') + let tac',t' = condense env t in + [do_both (do_list tac) (do_list tac')], Oplus(f,t') end - | Oplus(f1,Oint n) -> - let tac,f1' = reduce_factor f1 in + | Oplus(f1,Oint n) -> + let tac,f1' = reduce_factor f1 in [do_left (do_list tac)],Oplus(f1',Oint n) - | Oplus(f1,f2) -> + | Oplus(f1,f2) -> if weight env f1 = weight env f2 then begin let tac_shrink,t = shrink_pair f1 f2 in let tac,t' = condense env t in tac_shrink :: tac,t' end else begin let tac,f = reduce_factor f1 in - let tac',t' = condense env f2 in - [do_both (do_list tac) (do_list tac')],Oplus(f,t') + let tac',t' = condense env f2 in + [do_both (do_list tac) (do_list tac')],Oplus(f,t') end | (Oint _ as t)-> [],t - | t -> + | t -> let tac,t' = reduce_factor t in let final = Oplus(t',Oint zero) in tac @ [Lazy.force coq_c_red6], final @@ -598,8 +598,8 @@ let rec clear_zero = function Oplus(Omult(Oatom v,Oint n),r) when n=zero -> let tac',t = clear_zero r in Lazy.force coq_c_red5 :: tac',t - | Oplus(f,r) -> - let tac,t = clear_zero r in + | Oplus(f,r) -> + let tac,t = clear_zero r in (if tac = [] then [] else [do_right (do_list tac)]),Oplus(f,t) | t -> [],t;; @@ -641,14 +641,14 @@ let normalize_linear_term env t = (* Cette fonction reproduit très exactement le comportement de [p_invert] *) let negate_oper = function Eq -> Neq | Neq -> Eq | Leq -> Gt | Geq -> Lt | Lt -> Geq | Gt -> Leq - -let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = + +let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = let mk_step t1 t2 f kind = let t = f t1 t2 in let trace, oterm = normalize_linear_term env t in - let equa = omega_of_oformula env kind oterm in - { e_comp = oper; e_left = t1; e_right = t2; - e_negated = negated; e_depends = depends; + let equa = omega_of_oformula env kind oterm in + { e_comp = oper; e_left = t1; e_right = t2; + e_negated = negated; e_depends = depends; e_origin = { o_hyp = origin; o_path = List.rev path }; e_trace = trace; e_omega = equa } in try match (if negated then (negate_oper oper) else oper) with @@ -660,36 +660,36 @@ let normalize_equation env (negated,depends,origin,path) (oper,t1,t2) = mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o2,Oint negone),Oopp o1)) INEQ | Gt -> - mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) + mk_step t1 t2 (fun o1 o2 -> Oplus (Oplus(o1,Oint negone),Oopp o2)) INEQ with e when Logic.catchable_exception e -> raise e (* \section{Compilation des hypothèses} *) let rec oformula_of_constr env t = - match Z.parse_term t with + match Z.parse_term t with | Tplus (t1,t2) -> binop env (fun x y -> Oplus(x,y)) t1 t2 | Tminus (t1,t2) -> binop env (fun x y -> Ominus(x,y)) t1 t2 - | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> + | Tmult (t1,t2) when Z.is_scalar t1 || Z.is_scalar t2 -> binop env (fun x y -> Omult(x,y)) t1 t2 | Topp t -> Oopp(oformula_of_constr env t) | Tsucc t -> Oplus(oformula_of_constr env t, Oint one) | Tnum n -> Oint n | _ -> Oatom (add_reified_atom t env) -and binop env c t1 t2 = +and binop env c t1 t2 = let t1' = oformula_of_constr env t1 in let t2' = oformula_of_constr env t2 in c t1' t2' -and binprop env (neg2,depends,origin,path) +and binprop env (neg2,depends,origin,path) add_to_depends neg1 gl c t1 t2 = let i = new_connector_id env in let depends1 = if add_to_depends then Left i::depends else depends in let depends2 = if add_to_depends then Right i::depends else depends in if add_to_depends then Hashtbl.add env.constructors i {o_hyp = origin; o_path = List.rev path}; - let t1' = + let t1' = oproposition_of_constr env (neg1,depends1,origin,O_left::path) gl t1 in let t2' = oproposition_of_constr env (neg2,depends2,origin,O_right::path) gl t2 in @@ -704,31 +704,31 @@ and mk_equation env ctxt c connector t1 t2 = add_equation env omega; Pequa (c,omega) -and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = - match Z.parse_rel gl c with +and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = + match Z.parse_rel gl c with | Req (t1,t2) -> mk_equation env ctxt c Eq t1 t2 | Rne (t1,t2) -> mk_equation env ctxt c Neq t1 t2 | Rle (t1,t2) -> mk_equation env ctxt c Leq t1 t2 | Rlt (t1,t2) -> mk_equation env ctxt c Lt t1 t2 | Rge (t1,t2) -> mk_equation env ctxt c Geq t1 t2 | Rgt (t1,t2) -> mk_equation env ctxt c Gt t1 t2 - | Rtrue -> Ptrue + | Rtrue -> Ptrue | Rfalse -> Pfalse - | Rnot t -> - let t' = - oproposition_of_constr - env (not negated, depends, origin,(O_mono::path)) gl t in + | Rnot t -> + let t' = + oproposition_of_constr + env (not negated, depends, origin,(O_mono::path)) gl t in Pnot t' - | Ror (t1,t2) -> + | Ror (t1,t2) -> binprop env ctxt (not negated) negated gl (fun i x y -> Por(i,x,y)) t1 t2 - | Rand (t1,t2) -> + | Rand (t1,t2) -> binprop env ctxt negated negated gl (fun i x y -> Pand(i,x,y)) t1 t2 | Rimp (t1,t2) -> - binprop env ctxt (not negated) (not negated) gl + binprop env ctxt (not negated) (not negated) gl (fun i x y -> Pimp(i,x,y)) t1 t2 | Riff (t1,t2) -> - binprop env ctxt negated negated gl + binprop env ctxt negated negated gl (fun i x y -> Pand(i,x,y)) (Term.mkArrow t1 t2) (Term.mkArrow t2 t1) | _ -> Pprop c @@ -751,30 +751,30 @@ let reify_gl env gl = Printf.printf "\n" end; (i,t') :: loop lhyps - | [] -> - if !debug then print_env_reification env; + | [] -> + if !debug then print_env_reification env; [] in let t_lhyps = loop (Tacmach.pf_hyps_types gl) in - (id_concl,t_concl) :: t_lhyps + (id_concl,t_concl) :: t_lhyps let rec destructurate_pos_hyp orig list_equations list_depends = function | Pequa (_,e) -> [e :: list_equations] | Ptrue | Pfalse | Pprop _ -> [list_equations] | Pnot t -> destructurate_neg_hyp orig list_equations list_depends t - | Por (i,t1,t2) -> - let s1 = + | Por (i,t1,t2) -> + let s1 = destructurate_pos_hyp orig list_equations (i::list_depends) t1 in - let s2 = + let s2 = destructurate_pos_hyp orig list_equations (i::list_depends) t2 in s1 @ s2 - | Pand(i,t1,t2) -> + | Pand(i,t1,t2) -> let list_s1 = destructurate_pos_hyp orig list_equations (list_depends) t1 in - let rec loop = function + let rec loop = function le1 :: ll -> destructurate_pos_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 - | Pimp(i,t1,t2) -> + | Pimp(i,t1,t2) -> let s1 = destructurate_neg_hyp orig list_equations (i::list_depends) t1 in let s2 = @@ -785,30 +785,30 @@ and destructurate_neg_hyp orig list_equations list_depends = function | Pequa (_,e) -> [e :: list_equations] | Ptrue | Pfalse | Pprop _ -> [list_equations] | Pnot t -> destructurate_pos_hyp orig list_equations list_depends t - | Pand (i,t1,t2) -> + | Pand (i,t1,t2) -> let s1 = destructurate_neg_hyp orig list_equations (i::list_depends) t1 in let s2 = destructurate_neg_hyp orig list_equations (i::list_depends) t2 in s1 @ s2 - | Por(_,t1,t2) -> + | Por(_,t1,t2) -> let list_s1 = destructurate_neg_hyp orig list_equations list_depends t1 in - let rec loop = function + let rec loop = function le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 - | Pimp(_,t1,t2) -> + | Pimp(_,t1,t2) -> let list_s1 = destructurate_pos_hyp orig list_equations list_depends t1 in - let rec loop = function + let rec loop = function le1 :: ll -> destructurate_neg_hyp orig le1 list_depends t2 @ loop ll | [] -> [] in loop list_s1 let destructurate_hyps syst = let rec loop = function - (i,t) :: l -> + (i,t) :: l -> let l_syst1 = destructurate_pos_hyp i [] [] t in let l_syst2 = loop l in list_cartesian (@) l_syst1 l_syst2 @@ -819,23 +819,23 @@ let destructurate_hyps syst = (* Affichage des dépendances de système *) let display_depend = function - Left i -> Printf.printf " L%d" i + Left i -> Printf.printf " L%d" i | Right i -> Printf.printf " R%d" i -let display_systems syst_list = - let display_omega om_e = +let display_systems syst_list = + let display_omega om_e = Printf.printf " E%d : %a %s 0\n" om_e.id - (fun _ -> display_eq display_omega_var) + (fun _ -> display_eq display_omega_var) (om_e.body, om_e.constant) (operator_of_eq om_e.kind) in - let display_equation oformula_eq = + let display_equation oformula_eq = pprint stdout (Pequa (Lazy.force coq_c_nop,oformula_eq)); print_newline (); display_omega oformula_eq.e_omega; - Printf.printf " Depends on:"; + Printf.printf " Depends on:"; List.iter display_depend oformula_eq.e_depends; - Printf.printf "\n Path: %s" + Printf.printf "\n Path: %s" (String.concat "" (List.map (function O_left -> "L" | O_right -> "R" | O_mono -> "M") oformula_eq.e_origin.o_path)); @@ -852,10 +852,10 @@ let display_systems syst_list = calcul des hypothèses *) let rec hyps_used_in_trace = function - | act :: l -> + | act :: l -> begin match act with | HYP e -> [e.id] @@ (hyps_used_in_trace l) - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> + | SPLIT_INEQ (_,(_,act1),(_,act2)) -> hyps_used_in_trace act1 @@ hyps_used_in_trace act2 | _ -> hyps_used_in_trace l end @@ -866,33 +866,33 @@ let rec hyps_used_in_trace = function éviter les créations de variable au vol *) let rec variable_stated_in_trace = function - | act :: l -> + | act :: l -> begin match act with | STATE action -> (*i nlle_equa: afine, def: afine, eq_orig: afine, i*) (*i coef: int, var:int i*) action :: variable_stated_in_trace l - | SPLIT_INEQ (_,(_,act1),(_,act2)) -> + | SPLIT_INEQ (_,(_,act1),(_,act2)) -> variable_stated_in_trace act1 @ variable_stated_in_trace act2 | _ -> variable_stated_in_trace l end | [] -> [] ;; -let add_stated_equations env tree = +let add_stated_equations env tree = (* Il faut trier les variables par ordre d'introduction pour ne pas risquer de définir dans le mauvais ordre *) - let stated_equations = - let cmpvar x y = Pervasives.(-) x.st_var y.st_var in + let stated_equations = + let cmpvar x y = Pervasives.(-) x.st_var y.st_var in let rec loop = function | Tree(_,t1,t2) -> List.merge cmpvar (loop t1) (loop t2) - | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) + | Leaf s -> List.sort cmpvar (variable_stated_in_trace s.s_trace) in loop tree - in - let add_env st = + in + let add_env st = (* On retransforme la définition de v en formule reifiée *) let v_def = oformula_of_omega env st.st_def in - (* Notez que si l'ordre de création des variables n'est pas respecté, + (* Notez que si l'ordre de création des variables n'est pas respecté, * ca va planter *) let coq_v = coq_of_formula env v_def in let v = add_reified_atom coq_v env in @@ -902,33 +902,33 @@ let add_stated_equations env tree = * l'environnement pour le faire correctement *) let term_to_reify = (v_def,Oatom v) in (* enregistre le lien entre la variable omega et la variable Coq *) - intern_omega_force env (Oatom v) st.st_var; + intern_omega_force env (Oatom v) st.st_var; (v, term_to_generalize,term_to_reify,st.st_def.id) in List.map add_env stated_equations -(* Calcule la liste des éclatements à réaliser sur les hypothèses +(* Calcule la liste des éclatements à réaliser sur les hypothèses nécessaires pour extraire une liste d'équations donnée *) -(* PL: experimentally, the result order of the following function seems +(* PL: experimentally, the result order of the following function seems _very_ crucial for efficiency. No idea why. Do not remove the List.rev - or modify the current semantics of Util.list_union (some elements of first + or modify the current semantics of Util.list_union (some elements of first arg, then second arg), unless you know what you're doing. *) let rec get_eclatement env = function - i :: r -> + i :: r -> let l = try (get_equation env i).e_depends with Not_found -> [] in list_union (List.rev l) (get_eclatement env r) | [] -> [] -let select_smaller l = +let select_smaller l = let comp (_,x) (_,y) = Pervasives.(-) (List.length x) (List.length y) in try List.hd (List.sort comp l) with Failure _ -> failwith "select_smaller" let filter_compatible_systems required systems = let rec select = function - (x::l) -> + (x::l) -> if List.mem x required then select l - else if List.mem (barre x) required then failwith "Exit" + else if List.mem (barre x) required then failwith "Exit" else x :: select l | [] -> [] in map_succeed (function (sol,splits) -> (sol,select splits)) systems @@ -938,8 +938,8 @@ let rec equas_of_solution_tree = function | Leaf s -> s.s_equa_deps (* [really_useful_prop] pushes useless props in a new Pprop variable *) -(* Things get shorter, but may also get wrong, since a Prop is considered - to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance +(* Things get shorter, but may also get wrong, since a Prop is considered + to be undecidable in ReflOmegaCore.concl_to_hyp, whereas for instance Pfalse is decidable. So should not be used on conclusion (??) *) let really_useful_prop l_equa c = @@ -953,21 +953,21 @@ let really_useful_prop l_equa c = (* Attention : implications sur le lifting des variables à comprendre ! *) | Pimp(_,t1,t2) -> Term.mkArrow (real_of t1) (real_of t2) | Pprop t -> t in - let rec loop c = - match c with + let rec loop c = + match c with Pequa(_,e) -> if List.mem e.e_omega.id l_equa then Some c else None | Ptrue -> None | Pfalse -> None - | Pnot t1 -> + | Pnot t1 -> begin match loop t1 with None -> None | Some t1' -> Some (Pnot t1') end | Por(i,t1,t2) -> binop (fun (t1,t2) -> Por(i,t1,t2)) t1 t2 | Pand(i,t1,t2) -> binop (fun (t1,t2) -> Pand(i,t1,t2)) t1 t2 | Pimp(i,t1,t2) -> binop (fun (t1,t2) -> Pimp(i,t1,t2)) t1 t2 | Pprop t -> None - and binop f t1 t2 = + and binop f t1 t2 = begin match loop t1, loop t2 with - None, None -> None + None, None -> None | Some t1',Some t2' -> Some (f(t1',t2')) | Some t1',None -> Some (f(t1',Pprop (real_of t2))) | None,Some t2' -> Some (f(Pprop (real_of t1),t2')) @@ -977,36 +977,36 @@ let really_useful_prop l_equa c = | Some t -> t let rec display_solution_tree ch = function - Leaf t -> - output_string ch - (Printf.sprintf "%d[%s]" + Leaf t -> + output_string ch + (Printf.sprintf "%d[%s]" t.s_index (String.concat " " (List.map string_of_int t.s_equa_deps))) - | Tree(i,t1,t2) -> - Printf.fprintf ch "S%d(%a,%a)" i + | Tree(i,t1,t2) -> + Printf.fprintf ch "S%d(%a,%a)" i display_solution_tree t1 display_solution_tree t2 -let rec solve_with_constraints all_solutions path = +let rec solve_with_constraints all_solutions path = let rec build_tree sol buf = function [] -> Leaf sol - | (Left i :: remainder) -> + | (Left i :: remainder) -> Tree(i, - build_tree sol (Left i :: buf) remainder, + build_tree sol (Left i :: buf) remainder, solve_with_constraints all_solutions (List.rev(Right i :: buf))) - | (Right i :: remainder) -> + | (Right i :: remainder) -> Tree(i, solve_with_constraints all_solutions (List.rev (Left i :: buf)), build_tree sol (Right i :: buf) remainder) in let weighted = filter_compatible_systems path all_solutions in let (winner_sol,winner_deps) = - try select_smaller weighted - with e -> - Printf.printf "%d - %d\n" + try select_smaller weighted + with e -> + Printf.printf "%d - %d\n" (List.length weighted) (List.length all_solutions); List.iter display_depend path; raise e in - build_tree winner_sol (List.rev path) winner_deps + build_tree winner_sol (List.rev path) winner_deps -let find_path {o_hyp=id;o_path=p} env = +let find_path {o_hyp=id;o_path=p} env = let rec loop_path = function ([],l) -> Some l | (x1::l1,x2::l2) when x1 = x2 -> loop_path (l1,l2) @@ -1021,8 +1021,8 @@ let find_path {o_hyp=id;o_path=p} env = | [] -> failwith "find_path" in loop_id 0 env -let mk_direction_list l = - let trans = function +let mk_direction_list l = + let trans = function O_left -> coq_d_left | O_right -> coq_d_right | O_mono -> coq_d_mono in mk_list (Lazy.force coq_direction) (List.map (fun d-> Lazy.force(trans d)) l) @@ -1036,33 +1036,33 @@ let get_hyp env_hyp i = let replay_history env env_hyp = let rec loop env_hyp t = match t with - | CONTRADICTION (e1,e2) :: l -> + | CONTRADICTION (e1,e2) :: l -> let trace = mk_nat (List.length e1.body) in mkApp (Lazy.force coq_s_contradiction, - [| trace ; mk_nat (get_hyp env_hyp e1.id); + [| trace ; mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> mkApp (Lazy.force coq_s_div_approx, - [| Z.mk k; Z.mk d; + [| Z.mk k; Z.mk d; reified_of_omega env e2.body e2.constant; - mk_nat (List.length e2.body); + mk_nat (List.length e2.body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id) |]) | NOT_EXACT_DIVIDE (e1,k) :: l -> let e2_constant = floor_div e1.constant k in let d = e1.constant - e2_constant * k in let e2_body = map_eq_linear (fun c -> c / k) e1.body in mkApp (Lazy.force coq_s_not_exact_divide, - [|Z.mk k; Z.mk d; - reified_of_omega env e2_body e2_constant; - mk_nat (List.length e2_body); + [|Z.mk k; Z.mk d; + reified_of_omega env e2_body e2_constant; + mk_nat (List.length e2_body); mk_nat (get_hyp env_hyp e1.id)|]) | EXACT_DIVIDE (e1,k) :: l -> - let e2_body = + let e2_body = map_eq_linear (fun c -> c / k) e1.body in let e2_constant = floor_div e1.constant k in mkApp (Lazy.force coq_s_exact_divide, - [|Z.mk k; - reified_of_omega env e2_body e2_constant; + [|Z.mk k; + reified_of_omega env e2_body e2_constant; mk_nat (List.length e2_body); loop env_hyp l; mk_nat (get_hyp env_hyp e1.id)|]) | (MERGE_EQ(e3,e1,e2)) :: l -> @@ -1072,22 +1072,22 @@ let replay_history env env_hyp = mk_nat n1; mk_nat n2; loop (CCEqua e3:: env_hyp) l |]) | SUM(e3,(k1,e1),(k2,e2)) :: l -> - let n1 = get_hyp env_hyp e1.id + let n1 = get_hyp env_hyp e1.id and n2 = get_hyp env_hyp e2.id in let trace = shuffle_path k1 e1.body k2 e2.body in mkApp (Lazy.force coq_s_sum, [| Z.mk k1; mk_nat n1; Z.mk k2; mk_nat n2; trace; (loop (CCEqua e3 :: env_hyp) l) |]) - | CONSTANT_NOT_NUL(e,k) :: l -> + | CONSTANT_NOT_NUL(e,k) :: l -> mkApp (Lazy.force coq_s_constant_not_nul, [| mk_nat (get_hyp env_hyp e) |]) | CONSTANT_NEG(e,k) :: l -> mkApp (Lazy.force coq_s_constant_neg, [| mk_nat (get_hyp env_hyp e) |]) - | STATE {st_new_eq=new_eq; st_def =def; + | STATE {st_new_eq=new_eq; st_def =def; st_orig=orig; st_coef=m; st_var=sigma } :: l -> - let n1 = get_hyp env_hyp orig.id + let n1 = get_hyp env_hyp orig.id and n2 = get_hyp env_hyp def.id in let v = unintern_omega env sigma in let o_def = oformula_of_omega env def in @@ -1096,26 +1096,26 @@ let replay_history env env_hyp = Oplus (o_orig,Omult (Oplus (Oopp v,o_def), Oint m)) in let trace,_ = normalize_linear_term env body in mkApp (Lazy.force coq_s_state, - [| Z.mk m; trace; mk_nat n1; mk_nat n2; + [| Z.mk m; trace; mk_nat n1; mk_nat n2; loop (CCEqua new_eq.id :: env_hyp) l |]) | HYP _ :: l -> loop env_hyp l | CONSTANT_NUL e :: l -> - mkApp (Lazy.force coq_s_constant_nul, + mkApp (Lazy.force coq_s_constant_nul, [| mk_nat (get_hyp env_hyp e) |]) | NEGATE_CONTRADICT(e1,e2,true) :: l -> - mkApp (Lazy.force coq_s_negate_contradict, + mkApp (Lazy.force coq_s_negate_contradict, [| mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | NEGATE_CONTRADICT(e1,e2,false) :: l -> - mkApp (Lazy.force coq_s_negate_contradict_inv, - [| mk_nat (List.length e2.body); + mkApp (Lazy.force coq_s_negate_contradict_inv, + [| mk_nat (List.length e2.body); mk_nat (get_hyp env_hyp e1.id); mk_nat (get_hyp env_hyp e2.id) |]) | SPLIT_INEQ(e,(e1,l1),(e2,l2)) :: l -> let i = get_hyp env_hyp e.id in let r1 = loop (CCEqua e1 :: env_hyp) l1 in let r2 = loop (CCEqua e2 :: env_hyp) l2 in - mkApp (Lazy.force coq_s_split_ineq, + mkApp (Lazy.force coq_s_split_ineq, [| mk_nat (List.length e.body); mk_nat i; r1 ; r2 |]) | (FORGET_C _ | FORGET _ | FORGET_I _) :: l -> loop env_hyp l @@ -1125,14 +1125,14 @@ let replay_history env env_hyp = let rec decompose_tree env ctxt = function Tree(i,left,right) -> - let org = - try Hashtbl.find env.constructors i + let org = + try Hashtbl.find env.constructors i with Not_found -> failwith (Printf.sprintf "Cannot find constructor %d" i) in let (index,path) = find_path org ctxt in let left_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_left]} in let right_hyp = CCHyp{o_hyp=org.o_hyp;o_path=org.o_path @ [O_right]} in - app coq_e_split + app coq_e_split [| mk_nat index; mk_direction_list path; decompose_tree env (left_hyp::ctxt) left; @@ -1141,15 +1141,15 @@ let rec decompose_tree env ctxt = function decompose_tree_hyps s.s_trace env ctxt s.s_equa_deps and decompose_tree_hyps trace env ctxt = function [] -> app coq_e_solve [| replay_history env ctxt trace |] - | (i::l) -> + | (i::l) -> let equation = - try Hashtbl.find env.equations i + try Hashtbl.find env.equations i with Not_found -> failwith (Printf.sprintf "Cannot find equation %d" i) in let (index,path) = find_path equation.e_origin ctxt in let full_path = if equation.e_negated then path @ [O_mono] else path in - let cont = - decompose_tree_hyps trace env + let cont = + decompose_tree_hyps trace env (CCEqua equation.e_omega.id :: ctxt) l in app coq_e_extract [|mk_nat index; mk_direction_list full_path; @@ -1165,13 +1165,13 @@ de faire rejouer cette solution par la tactique r let resolution env full_reified_goal systems_list = let num = ref 0 in - let solve_system list_eq = + let solve_system list_eq = let index = !num in let system = List.map (fun eq -> eq.e_omega) list_eq in - let trace = - simplify_strong - (new_omega_eq,new_omega_var,display_omega_var) - system in + let trace = + simplify_strong + (new_omega_eq,new_omega_var,display_omega_var) + system in (* calcule les hypotheses utilisées pour la solution *) let vars = hyps_used_in_trace trace in let splits = get_eclatement env vars in @@ -1201,11 +1201,11 @@ let resolution env full_reified_goal systems_list = let l_hyps = id_concl :: list_remove id_concl l_hyps' in let useful_hyps = List.map (fun id -> List.assoc id full_reified_goal) l_hyps in - let useful_vars = + let useful_vars = let really_useful_vars = vars_of_equations equations in - let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in + let concl_vars = vars_of_prop (List.assoc id_concl full_reified_goal) in really_useful_vars @@ concl_vars - in + in (* variables a introduire *) let to_introduce = add_stated_equations env solution_tree in let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in @@ -1217,19 +1217,19 @@ let resolution env full_reified_goal systems_list = let all_vars_env = useful_vars @ stated_vars in let basic_env = let rec loop i = function - var :: l -> - let t = get_reified_atom env var in + var :: l -> + let t = get_reified_atom env var in Hashtbl.add env.real_indices var i; t :: loop (succ i) l | [] -> [] in loop 0 all_vars_env in let env_terms_reified = mk_list (Lazy.force Z.typ) basic_env in (* On peut maintenant généraliser le but : env est a jour *) let l_reified_stated = - List.map (fun (_,_,(l,r),_) -> - app coq_p_eq [| reified_of_formula env l; + List.map (fun (_,_,(l,r),_) -> + app coq_p_eq [| reified_of_formula env l; reified_of_formula env r |]) to_introduce in - let reified_concl = + let reified_concl = match useful_hyps with (Pnot p) :: _ -> reified_of_proposition env p | _ -> reified_of_proposition env Pfalse in @@ -1239,51 +1239,51 @@ let resolution env full_reified_goal systems_list = reified_of_proposition env (really_useful_prop useful_equa_id p)) (List.tl useful_hyps)) in let env_props_reified = mk_plist env.props in - let reified_goal = + let reified_goal = mk_list (Lazy.force coq_proposition) (l_reified_stated @ l_reified_terms) in - let reified = - app coq_interp_sequent + let reified = + app coq_interp_sequent [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in - let normalize_equation e = + let normalize_equation e = let rec loop = function [] -> app (if e.e_negated then coq_p_invert else coq_p_step) [| e.e_trace |] | ((O_left | O_mono) :: l) -> app coq_p_left [| loop l |] | (O_right :: l) -> app coq_p_right [| loop l |] in - let correct_index = - let i = list_index0 e.e_origin.o_hyp l_hyps in - (* PL: it seems that additionnally introduced hyps are in the way during - normalization, hence this index shifting... *) + let correct_index = + let i = list_index0 e.e_origin.o_hyp l_hyps in + (* PL: it seems that additionnally introduced hyps are in the way during + normalization, hence this index shifting... *) if i=0 then 0 else Pervasives.(+) i (List.length to_introduce) - in + in app coq_pair_step [| mk_nat correct_index; loop e.e_origin.o_path |] in let normalization_trace = mk_list (Lazy.force coq_h_step) (List.map normalize_equation equations) in let initial_context = List.map (fun id -> CCHyp{o_hyp=id;o_path=[]}) (List.tl l_hyps) in - let context = + let context = CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in let decompose_tactic = decompose_tree env context solution_tree in - Tactics.generalize + Tactics.generalize (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps)) >> - Tactics.change_in_concl None reified >> + Tactics.change_in_concl None reified >> Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|]) >> show_goal >> Tactics.normalise_vm_in_concl >> - (*i Alternatives to the previous line: - - Normalisation without VM: + (*i Alternatives to the previous line: + - Normalisation without VM: Tactics.normalise_in_concl - - Skip the conversion check and rely directly on the QED: - Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> + - Skip the conversion check and rely directly on the QED: + Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> i*) Tactics.apply (Lazy.force coq_I) -let total_reflexive_omega_tactic gl = +let total_reflexive_omega_tactic gl = Coqlib.check_required_library ["Coq";"romega";"ROmega"]; - rst_omega_eq (); + rst_omega_eq (); rst_omega_var (); try let env = new_environment () in diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index cd0f1afe97..36da9463ba 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -15,7 +15,7 @@ Unset Boxed Definitions. Open Scope positive_scope. -Ltac clean := try (simpl; congruence). +Ltac clean := try (simpl; congruence). Ltac caseq t := generalize (refl_equal t); pattern t at -1; case t. Functional Scheme Pcompare_ind := Induction for Pcompare Sort Prop. @@ -85,7 +85,7 @@ match m, n with | xO mm, xO nn => pos_eq mm nn | xH, xH => true | _, _ => false -end. +end. Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. induction m;simpl;intro n;destruct n;congruence || @@ -120,12 +120,12 @@ Theorem pos_eq_dec_ex : forall m n, fix 1;intros [mm|mm|] [nn|nn|];try (simpl;congruence). simpl;intro e. elim (pos_eq_dec_ex _ _ e). -intros x ex; rewrite ex. +intros x ex; rewrite ex. exists (f_equal xI x). reflexivity. simpl;intro e. elim (pos_eq_dec_ex _ _ e). -intros x ex; rewrite ex. +intros x ex; rewrite ex. exists (f_equal xO x). reflexivity. simpl. @@ -134,7 +134,7 @@ reflexivity. Qed. Fixpoint nat_eq (m n:nat) {struct m}: bool:= -match m, n with +match m, n with O,O => true | S mm,S nn => nat_eq mm nn | _,_ => false @@ -151,14 +151,14 @@ Defined. Fixpoint Lget (A:Set) (n:nat) (l:list A) {struct l}:option A := match l with nil => None -| x::q => +| x::q => match n with O => Some x | S m => Lget A m q end end . Implicit Arguments Lget [A]. -Lemma map_app : forall (A B:Set) (f:A -> B) l m, +Lemma map_app : forall (A B:Set) (f:A -> B) l m, List.map f (l ++ m) = List.map f l ++ List.map f m. induction l. reflexivity. @@ -166,16 +166,16 @@ simpl. intro m ; apply f_equal with (list B);apply IHl. Qed. -Lemma length_map : forall (A B:Set) (f:A -> B) l, +Lemma length_map : forall (A B:Set) (f:A -> B) l, length (List.map f l) = length l. induction l. reflexivity. simpl; apply f_equal with nat;apply IHl. Qed. -Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, -Lget i (List.map f l) = -match Lget i l with Some a => +Lemma Lget_map : forall (A B:Set) (f:A -> B) i l, +Lget i (List.map f l) = +match Lget i l with Some a => Some (f a) | None => None end. induction i;intros [ | x l ] ;trivial. simpl;auto. @@ -190,7 +190,7 @@ reflexivity. auto. Qed. -Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), +Lemma Lget_app_Some : forall (A:Set) l delta i (a: A), Lget i l = Some a -> Lget i (l ++ delta) = Some a. induction l;destruct i;simpl;try congruence;auto. @@ -208,8 +208,8 @@ Inductive Tree : Type := Tempty : Tree | Branch0 : Tree -> Tree -> Tree | Branch1 : A -> Tree -> Tree -> Tree. - -Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := + +Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := match T with Tempty => PNone | Branch0 T1 T2 => @@ -226,7 +226,7 @@ Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := end end. -Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := +Fixpoint Tadd (p:positive) (a:A) (T:Tree) {struct p}: Tree := match T with | Tempty => match p with @@ -253,13 +253,13 @@ Definition mkBranch0 (T1 T2:Tree) := Tempty ,Tempty => Tempty | _,_ => Branch0 T1 T2 end. - + Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree := match T with | Tempty => Tempty - | Branch0 T1 T2 => + | Branch0 T1 T2 => match p with - | xI pp => mkBranch0 T1 (Tremove pp T2) + | xI pp => mkBranch0 T1 (Tremove pp T2) | xO pp => mkBranch0 (Tremove pp T1) T2 | xH => T end @@ -270,8 +270,8 @@ Fixpoint Tremove (p:positive) (T:Tree) {struct p}: Tree := | xH => mkBranch0 T1 T2 end end. - - + + Theorem Tget_Tempty: forall (p : positive), Tget p (Tempty) = PNone. destruct p;reflexivity. Qed. @@ -293,7 +293,7 @@ generalize i;clear i;induction j;destruct T;simpl in H|-*; destruct i;simpl;try rewrite (IHj _ H);try (destruct i;simpl;congruence);reflexivity|| congruence. Qed. -Record Store : Type := +Record Store : Type := mkStore {index:positive;contents:Tree}. Definition empty := mkStore xH Tempty. @@ -317,7 +317,7 @@ intros S W;induction W. unfold empty,index,get,contents;intros;apply Tget_Tempty. unfold index,get,push;simpl contents. intros i e;rewrite Tget_Tadd. -rewrite (Gt_Psucc _ _ e). +rewrite (Gt_Psucc _ _ e). unfold get in IHW. apply IHW;apply Gt_Psucc;assumption. Qed. @@ -336,8 +336,8 @@ apply get_Full_Gt; auto. apply Psucc_Gt. Qed. -Theorem get_push_Full : - forall i a S, Full S -> +Theorem get_push_Full : + forall i a S, Full S -> get i (push a S) = match (i ?= index S) Eq with Eq => PSome a @@ -359,9 +359,9 @@ apply get_Full_Gt;auto. Qed. Lemma Full_push_compat : forall i a S, Full S -> -forall x, get i S = PSome x -> +forall x, get i S = PSome x -> get i (push a S) = PSome x. -intros i a S F x H. +intros i a S F x H. caseq ((i ?= index S) Eq);intro test. rewrite (Pcompare_Eq_eq _ _ test) in H. rewrite (get_Full_Eq _ F) in H;congruence. @@ -372,7 +372,7 @@ assumption. rewrite (get_Full_Gt _ F) in H;congruence. Qed. -Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. +Lemma Full_index_one_empty : forall S, Full S -> index S = 1 -> S=empty. intros [ind cont] F one; inversion F. reflexivity. simpl index in one;assert (h:=Psucc_not_one (index S)). @@ -382,7 +382,7 @@ Qed. Lemma push_not_empty: forall a S, (push a S) <> empty. intros a [ind cont];unfold push,empty. simpl;intro H;injection H; intros _ ; apply Psucc_not_one. -Qed. +Qed. Fixpoint In (x:A) (S:Store) (F:Full S) {struct F}: Prop := match F with @@ -390,7 +390,7 @@ F_empty => False | F_push a SS FF => x=a \/ In x SS FF end. -Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , +Lemma get_In : forall (x:A) (S:Store) (F:Full S) i , get i S = PSome x -> In x S F. induction F. intro i;rewrite get_empty; congruence. @@ -432,7 +432,7 @@ Implicit Arguments F_empty [A]. Implicit Arguments F_push [A]. Implicit Arguments In [A]. -Section Map. +Section Map. Variables A B:Set. @@ -445,8 +445,8 @@ Tempty => Tempty | Branch1 a t1 t2 => Branch1 (f a) (Tmap t1) (Tmap t2) end. -Lemma Tget_Tmap: forall T i, -Tget i (Tmap T)= match Tget i T with PNone => PNone +Lemma Tget_Tmap: forall T i, +Tget i (Tmap T)= match Tget i T with PNone => PNone | PSome a => PSome (f a) end. induction T;intro i;case i;simpl;auto. Defined. @@ -459,13 +459,13 @@ Defined. Definition map (S:Store A) : Store B := mkStore (index S) (Tmap (contents S)). -Lemma get_map: forall i S, -get i (map S)= match get i S with PNone => PNone +Lemma get_map: forall i S, +get i (map S)= match get i S with PNone => PNone | PSome a => PSome (f a) end. destruct S;unfold get,map,contents,index;apply Tget_Tmap. Defined. -Lemma map_push: forall a S, +Lemma map_push: forall a S, map (push a S) = push (f a) (map S). intros a S. case S. @@ -474,7 +474,7 @@ intros;rewrite Tmap_Tadd;reflexivity. Defined. Theorem Full_map : forall S, Full S -> Full (map S). -intros S F. +intros S F. induction F. exact F_empty. rewrite map_push;constructor 2;assumption. diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v index 4b95097e2f..0d1d09c736 100644 --- a/plugins/rtauto/Rtauto.v +++ b/plugins/rtauto/Rtauto.v @@ -23,7 +23,7 @@ Inductive form:Set:= Atom : positive -> form | Arrow : form -> form -> form | Bot -| Conjunct : form -> form -> form +| Conjunct : form -> form -> form | Disjunct : form -> form -> form. Notation "[ n ]":=(Atom n). @@ -39,7 +39,7 @@ match m with xI mm => match n with xI nn => pos_eq mm nn | _ => false end | xO mm => match n with xO nn => pos_eq mm nn | _ => false end | xH => match n with xH => true | _ => false end -end. +end. Theorem pos_eq_refl : forall m n, pos_eq m n = true -> m = n. induction m;simpl;destruct n;congruence || @@ -49,32 +49,32 @@ Qed. Fixpoint form_eq (p q:form) {struct p} :bool := match p with Atom m => match q with Atom n => pos_eq m n | _ => false end -| Arrow p1 p2 => -match q with - Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 +| Arrow p1 p2 => +match q with + Arrow q1 q2 => form_eq p1 q1 && form_eq p2 q2 | _ => false end | Bot => match q with Bot => true | _ => false end -| Conjunct p1 p2 => -match q with - Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false +| Conjunct p1 p2 => +match q with + Conjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 +| _ => false end -| Disjunct p1 p2 => -match q with - Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 -| _ => false +| Disjunct p1 p2 => +match q with + Disjunct q1 q2 => form_eq p1 q1 && form_eq p2 q2 +| _ => false end -end. +end. Theorem form_eq_refl: forall p q, form_eq p q = true -> p = q. induction p;destruct q;simpl;clean. intro h;generalize (pos_eq_refl _ _ h);congruence. caseq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. +intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. caseq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. +intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. caseq (form_eq p1 q1);clean. -intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. +intros e1 e2;generalize (IHp1 _ e1) (IHp2 _ e2);congruence. Qed. Implicit Arguments form_eq_refl [p q]. @@ -102,16 +102,16 @@ end. Require Export BinPos. -Ltac wipe := intros;simpl;constructor. +Ltac wipe := intros;simpl;constructor. -Lemma compose0 : +Lemma compose0 : forall hyps F (A:Prop), - A -> + A -> (interp_ctx hyps F A). induction F;intros A H;simpl;auto. Qed. -Lemma compose1 : +Lemma compose1 : forall hyps F (A B:Prop), (A -> B) -> (interp_ctx hyps F A) -> @@ -120,9 +120,9 @@ induction F;intros A B H;simpl;auto. apply IHF;auto. Qed. -Theorem compose2 : +Theorem compose2 : forall hyps F (A B C:Prop), - (A -> B -> C) -> + (A -> B -> C) -> (interp_ctx hyps F A) -> (interp_ctx hyps F B) -> (interp_ctx hyps F C). @@ -130,10 +130,10 @@ induction F;intros A B C H;simpl;auto. apply IHF;auto. Qed. -Theorem compose3 : +Theorem compose3 : forall hyps F (A B C D:Prop), - (A -> B -> C -> D) -> - (interp_ctx hyps F A) -> + (A -> B -> C -> D) -> + (interp_ctx hyps F A) -> (interp_ctx hyps F B) -> (interp_ctx hyps F C) -> (interp_ctx hyps F D). @@ -148,7 +148,7 @@ induction F;simpl;intros;auto. apply compose1 with ([[a]]-> G);auto. Qed. -Theorem project_In : forall hyps F g, +Theorem project_In : forall hyps F g, In g hyps F -> interp_ctx hyps F [[g]]. induction F;simpl. @@ -158,7 +158,7 @@ subst;apply compose0;simpl;trivial. apply compose1 with [[g]];auto. Qed. -Theorem project : forall hyps F p g, +Theorem project : forall hyps F p g, get p hyps = PSome g-> interp_ctx hyps F [[g]]. intros hyps F p g e; apply project_In. @@ -186,23 +186,23 @@ Notation "hyps \ A" := (push A hyps) (at level 72,left associativity). Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := match P with - Ax i => + Ax i => match get i hyps with PSome F => form_eq F gl | _ => false - end + end | I_Arrow p => match gl with A =>> B => check_proof (hyps \ A) B p - | _ => false - end + | _ => false + end | E_Arrow i j p => match get i hyps,get j hyps with PSome A,PSome (B =>>C) => form_eq A B && check_proof (hyps \ C) (gl) p | _,_ => false end -| D_Arrow i p1 p2 => +| D_Arrow i p1 p2 => match get i hyps with PSome ((A =>>B)=>>C) => (check_proof ( hyps \ B =>> C \ A) B p1) && (check_proof (hyps \ C) gl p2) @@ -219,12 +219,12 @@ Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := check_proof hyps A p1 && check_proof hyps B p2 | _ => false end -| E_And i p => +| E_And i p => match get i hyps with PSome (A //\\ B) => check_proof (hyps \ A \ B) gl p | _=> false end -| D_And i p => +| D_And i p => match get i hyps with PSome (A //\\ B =>> C) => check_proof (hyps \ A=>>B=>>C) gl p | _=> false @@ -245,7 +245,7 @@ Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := check_proof (hyps \ A) gl p1 && check_proof (hyps \ B) gl p2 | _=> false end -| D_Or i p => +| D_Or i p => match get i hyps with PSome (A \\// B =>> C) => (check_proof (hyps \ A=>>C \ B=>>C) gl p) @@ -253,10 +253,10 @@ Fixpoint check_proof (hyps:ctx) (gl:form) (P:proof) {struct P}: bool := end | Cut A p1 p2 => check_proof hyps A p1 && check_proof (hyps \ A) gl p2 -end. +end. -Theorem interp_proof: -forall p hyps F gl, +Theorem interp_proof: +forall p hyps F gl, check_proof hyps gl p = true -> interp_ctx hyps F [[gl]]. induction p;intros hyps F gl. @@ -281,7 +281,7 @@ intros f ef;caseq (get p0 hyps);clean. intros f0 ef0;destruct f0;clean. caseq (form_eq f f0_1);clean. simpl;intros e check_p1. -generalize (project F ef) (project F ef0) +generalize (project F ef) (project F ef0) (IHp (hyps \ f0_2) (F_push f0_2 hyps F) gl check_p1); clear check_p1 IHp p p0 p1 ef ef0. simpl. @@ -297,7 +297,7 @@ destruct f1;clean. caseq (check_proof (hyps \ f1_2 =>> f2 \ f1_1) f1_2 p2);clean. intros check_p1 check_p2. generalize (project F ef) -(IHp1 (hyps \ f1_2 =>> f2 \ f1_1) +(IHp1 (hyps \ f1_2 =>> f2 \ f1_1) (F_push f1_1 (hyps \ f1_2 =>> f2) (F_push (f1_2 =>> f2) hyps F)) f1_2 check_p1) (IHp2 (hyps \ f2) (F_push f2 hyps F) gl check_p2). @@ -331,7 +331,7 @@ simpl;caseq (get p hyps);clean. intros f ef;destruct f;clean. destruct f1;clean. intro H;generalize (project F ef) -(IHp (hyps \ f1_1 =>> f1_2 =>> f2) +(IHp (hyps \ f1_1 =>> f1_2 =>> f2) (F_push (f1_1 =>> f1_2 =>> f2) hyps F) gl H);clear H;simpl. apply compose2;auto. @@ -364,7 +364,7 @@ intros f ef;destruct f;clean. destruct f1;clean. intro check_p0;generalize (project F ef) (IHp (hyps \ f1_1 =>> f2 \ f1_2 =>> f2) -(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) +(F_push (f1_2 =>> f2) (hyps \ f1_1 =>> f2) (F_push (f1_1 =>> f2) hyps F)) gl check_p0);simpl. apply compose2;auto. @@ -372,7 +372,7 @@ apply compose2;auto. Focus 1. simpl;caseq (check_proof hyps f p1);clean. intros check_p1 check_p2; -generalize (IHp1 hyps F f check_p1) +generalize (IHp1 hyps F f check_p1) (IHp2 (hyps\f) (F_push f hyps F) gl check_p2); simpl; apply compose2;auto. Qed. @@ -392,8 +392,8 @@ Parameters A B C D:Prop. Theorem toto:A /\ (B \/ C) -> (A /\ B) \/ (A /\ C). exact (Reflect (empty \ A \ B \ C) ([1] //\\ ([2] \\// [3]) =>> [1] //\\ [2] \\// [1] //\\ [3]) -(I_Arrow (E_And 1 (E_Or 3 - (I_Or_l (I_And (Ax 2) (Ax 4))) +(I_Arrow (E_And 1 (E_Or 3 + (I_Or_l (I_And (Ax 2) (Ax 4))) (I_Or_r (I_And (Ax 2) (Ax 4))))))). Qed. Print toto. diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 1fee72a601..562e2e3bdb 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -9,7 +9,7 @@ (* $Id$ *) open Term -open Util +open Util open Goptions type s_info= @@ -54,12 +54,12 @@ let opt_pruning= optread=(fun () -> !pruning); optwrite=(fun b -> pruning:=b)} -let _ = declare_bool_option opt_pruning +let _ = declare_bool_option opt_pruning type form= Atom of int | Arrow of form * form - | Bot + | Bot | Conjunct of form * form | Disjunct of form * form @@ -67,14 +67,14 @@ type tag=int let decomp_form=function Atom i -> Some (i,[]) - | Arrow (f1,f2) -> Some (-1,[f1;f2]) + | Arrow (f1,f2) -> Some (-1,[f1;f2]) | Bot -> Some (-2,[]) | Conjunct (f1,f2) -> Some (-3,[f1;f2]) | Disjunct (f1,f2) -> Some (-4,[f1;f2]) module Fmap=Map.Make(struct type t=form let compare=compare end) -type sequent = +type sequent = {rev_hyps: form Intmap.t; norev_hyps: form Intmap.t; size:int; @@ -103,14 +103,14 @@ type proof = | E_Or of int*proof*proof | D_Or of int*proof | Pop of int*proof - + type rule = SAx of int - | SI_Arrow + | SI_Arrow | SE_Arrow of int*int | SD_Arrow of int | SE_False of int - | SI_And + | SI_And | SE_And of int | SD_And of int | SI_Or_l @@ -132,9 +132,9 @@ let add_step s sub = | SI_Or_r,[p] -> I_Or_r p | SE_Or i,[p1;p2] -> E_Or(i,p1,p2) | SD_Or i,[p] -> D_Or(i,p) - | _,_ -> anomaly "add_step: wrong arity" - -type 'a with_deps = + | _,_ -> anomaly "add_step: wrong arity" + +type 'a with_deps = {dep_it:'a; dep_goal:bool; dep_hyps:Intset.t} @@ -148,7 +148,7 @@ type slice= changes_goal:bool; creates_hyps:Intset.t} -type state = +type state = Complete of proof | Incomplete of sequent * slice list @@ -164,15 +164,15 @@ let pop n prf = {prf with dep_it = nprf} let rec fill stack proof = - match stack with + match stack with [] -> Complete proof.dep_it | slice::super -> - if + if !pruning && slice.proofs_done=[] && not (slice.changes_goal && proof.dep_goal) && - not (Intset.exists - (fun i -> Intset.mem i proof.dep_hyps) + not (Intset.exists + (fun i -> Intset.mem i proof.dep_hyps) slice.creates_hyps) then begin @@ -181,23 +181,23 @@ let rec fill stack proof = List.length slice.proofs_todo; let created_here=Intset.cardinal slice.creates_hyps in s_info.pruned_hyps<-s_info.pruned_hyps+ - List.fold_left - (fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps) + List.fold_left + (fun sum dseq -> sum + Intset.cardinal dseq.dep_hyps) created_here slice.proofs_todo; fill super (pop (Intset.cardinal slice.creates_hyps) proof) end else let dep_hyps= - Intset.union slice.needs_hyps + Intset.union slice.needs_hyps (Intset.diff proof.dep_hyps slice.creates_hyps) in let dep_goal= - slice.needs_goal || + slice.needs_goal || ((not slice.changes_goal) && proof.dep_goal) in let proofs_done= proof.dep_it::slice.proofs_done in match slice.proofs_todo with [] -> - fill super {dep_it = + fill super {dep_it = add_step slice.step (List.rev proofs_done); dep_goal = dep_goal; dep_hyps = dep_hyps} @@ -214,8 +214,8 @@ let rec fill stack proof = let append stack (step,subgoals) = s_info.created_steps<-s_info.created_steps+1; - match subgoals with - [] -> + match subgoals with + [] -> s_info.branch_successes<-s_info.branch_successes+1; fill stack {dep_it=add_step step.dep_it []; dep_goal=step.dep_goal; @@ -239,10 +239,10 @@ let embed seq= dep_hyps=Intset.empty} let change_goal seq gl= - {seq with + {seq with dep_it={seq.dep_it with gl=gl}; dep_goal=true} - + let add_hyp seqwd f= s_info.created_hyps<-s_info.created_hyps+1; let seq=seqwd.dep_it in @@ -256,71 +256,71 @@ let add_hyp seqwd f= with Not_found -> seq.cnx,seq.right in let nseq= match f with - Bot -> - {seq with + Bot -> + {seq with left=left; right=right; size=num; abs=Some num; cnx=cnx} | Atom _ -> - {seq with + {seq with size=num; left=left; right=right; cnx=cnx} | Conjunct (_,_) | Disjunct (_,_) -> {seq with - rev_hyps=Intmap.add num f seq.rev_hyps; + rev_hyps=Intmap.add num f seq.rev_hyps; size=num; left=left; right=right; cnx=cnx} | Arrow (f1,f2) -> let ncnx,nright= - try - let i = Fmap.find f1 seq.left in + try + let i = Fmap.find f1 seq.left in (i,num,f1,f2)::cnx,right with Not_found -> cnx,(add_one_arrow num f1 f2 right) in match f1 with Conjunct (_,_) | Disjunct (_,_) -> {seq with - rev_hyps=Intmap.add num f seq.rev_hyps; + rev_hyps=Intmap.add num f seq.rev_hyps; size=num; left=left; right=nright; cnx=ncnx} | Arrow(_,_) -> {seq with - norev_hyps=Intmap.add num f seq.norev_hyps; + norev_hyps=Intmap.add num f seq.norev_hyps; size=num; left=left; right=nright; cnx=ncnx} - | _ -> + | _ -> {seq with size=num; left=left; right=nright; cnx=ncnx} in - {seqwd with + {seqwd with dep_it=nseq; dep_hyps=Intset.add num seqwd.dep_hyps} exception Here_is of (int*form) -let choose m= - try +let choose m= + try Intmap.iter (fun i f -> raise (Here_is (i,f))) m; raise Not_found - with + with Here_is (i,f) -> (i,f) let search_or seq= match seq.gl with - Disjunct (f1,f2) -> + Disjunct (f1,f2) -> [{dep_it = SI_Or_l; dep_goal = true; dep_hyps = Intset.empty}, @@ -333,19 +333,19 @@ let search_or seq= let search_norev seq= let goals=ref (search_or seq) in - let add_one i f= + let add_one i f= match f with Arrow (Arrow (f1,f2),f3) -> - let nseq = + let nseq = {seq with norev_hyps=Intmap.remove i seq.norev_hyps} in goals:= ({dep_it=SD_Arrow(i); dep_goal=false; dep_hyps=Intset.singleton i}, - [add_hyp - (add_hyp - (change_goal (embed nseq) f2) - (Arrow(f2,f3))) + [add_hyp + (add_hyp + (change_goal (embed nseq) f2) + (Arrow(f2,f3))) f1; add_hyp (embed nseq) f3]):: !goals | _ -> anomaly "search_no_rev: can't happen" in @@ -353,7 +353,7 @@ let search_norev seq= List.rev !goals let search_in_rev_hyps seq= - try + try let i,f=choose seq.rev_hyps in let make_step step= {dep_it=step; @@ -361,25 +361,25 @@ let search_in_rev_hyps seq= dep_hyps=Intset.singleton i} in let nseq={seq with rev_hyps=Intmap.remove i seq.rev_hyps} in match f with - Conjunct (f1,f2) -> + Conjunct (f1,f2) -> [make_step (SE_And(i)), [add_hyp (add_hyp (embed nseq) f1) f2]] | Disjunct (f1,f2) -> [make_step (SE_Or(i)), [add_hyp (embed nseq) f1;add_hyp (embed nseq) f2]] - | Arrow (Conjunct (f1,f2),f0) -> + | Arrow (Conjunct (f1,f2),f0) -> [make_step (SD_And(i)), [add_hyp (embed nseq) (Arrow (f1,Arrow (f2,f0)))]] | Arrow (Disjunct (f1,f2),f0) -> [make_step (SD_Or(i)), [add_hyp (add_hyp (embed nseq) (Arrow(f1,f0))) (Arrow (f2,f0))]] - | _ -> anomaly "search_in_rev_hyps: can't happen" + | _ -> anomaly "search_in_rev_hyps: can't happen" with Not_found -> search_norev seq - + let search_rev seq= match seq.cnx with - (i,j,f1,f2)::next -> + (i,j,f1,f2)::next -> let nseq= match f1 with Conjunct (_,_) | Disjunct (_,_) -> @@ -394,7 +394,7 @@ let search_rev seq= dep_goal=false; dep_hyps=Intset.add i (Intset.singleton j)}, [add_hyp (embed nseq) f2]] - | [] -> + | [] -> match seq.gl with Arrow (f1,f2) -> [{dep_it=SI_Arrow; @@ -410,19 +410,19 @@ let search_rev seq= let search_all seq= match seq.abs with - Some i -> + Some i -> [{dep_it=SE_False (i); dep_goal=false; dep_hyps=Intset.singleton i},[]] | None -> - try + try let ax = Fmap.find seq.gl seq.left in [{dep_it=SAx (ax); dep_goal=true; dep_hyps=Intset.singleton ax},[]] with Not_found -> search_rev seq -let bare_sequent = embed +let bare_sequent = embed {rev_hyps=Intmap.empty; norev_hyps=Intmap.empty; size=0; @@ -431,7 +431,7 @@ let bare_sequent = embed cnx=[]; abs=None; gl=Bot} - + let init_state hyps gl= let init = change_goal bare_sequent gl in let goal=List.fold_right (fun (_,f,_) seq ->add_hyp seq f) hyps init in @@ -448,12 +448,12 @@ let branching = function let _ = match successors with [] -> s_info.branch_failures<-s_info.branch_failures+1 - | _::next -> + | _::next -> s_info.nd_branching<-s_info.nd_branching+List.length next in List.map (append stack) successors | Complete prf -> anomaly "already succeeded" -open Pp +open Pp let rec pp_form = function @@ -470,13 +470,13 @@ and pp_and = function and pp_atom= function Bot -> str "#" | Atom n -> int n - | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" + | f -> str "(" ++ hv 2 (pp_form f) ++ str ")" let pr_form f = msg (pp_form f) -let pp_intmap map = - let pp=ref (str "") in - Intmap.iter (fun i obj -> pp:= (!pp ++ +let pp_intmap map = + let pp=ref (str "") in + Intmap.iter (fun i obj -> pp:= (!pp ++ pp_form obj ++ cut ())) map; str "{ " ++ v 0 (!pp) ++ str " }" @@ -486,17 +486,17 @@ let pp=ref (str "") in str "[ " ++ !pp ++ str "]" let pp_mapint map = - let pp=ref (str "") in - Fmap.iter (fun obj l -> pp:= (!pp ++ - pp_form obj ++ str " => " ++ - pp_list (fun (i,f) -> pp_form f) l ++ + let pp=ref (str "") in + Fmap.iter (fun obj l -> pp:= (!pp ++ + pp_form obj ++ str " => " ++ + pp_list (fun (i,f) -> pp_form f) l ++ cut ()) ) map; str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close () let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 let pp_gl gl= cut () ++ - str "{ " ++ vb 0 ++ + str "{ " ++ vb 0 ++ begin match gl.abs with None -> str "" @@ -504,38 +504,38 @@ let pp_gl gl= cut () ++ end ++ str "rev =" ++ pp_intmap gl.rev_hyps ++ cut () ++ str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ - str "arrows=" ++ pp_mapint gl.right ++ cut () ++ - str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ + str "arrows=" ++ pp_mapint gl.right ++ cut () ++ + str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ str "goal =" ++ pp_form gl.gl ++ str " }" ++ close () -let pp = +let pp = function Incomplete(gl,ctx) -> msgnl (pp_gl gl) | _ -> msg (str "") -let pp_info () = - let count_info = +let pp_info () = + let count_info = if !pruning then - str "Proof steps : " ++ - int s_info.created_steps ++ str " created / " ++ + str "Proof steps : " ++ + int s_info.created_steps ++ str " created / " ++ int s_info.pruned_steps ++ str " pruned" ++ fnl () ++ - str "Proof branches : " ++ - int s_info.created_branches ++ str " created / " ++ + str "Proof branches : " ++ + int s_info.created_branches ++ str " created / " ++ int s_info.pruned_branches ++ str " pruned" ++ fnl () ++ - str "Hypotheses : " ++ - int s_info.created_hyps ++ str " created / " ++ + str "Hypotheses : " ++ + int s_info.created_hyps ++ str " created / " ++ int s_info.pruned_hyps ++ str " pruned" ++ fnl () else str "Pruning is off" ++ fnl () ++ - str "Proof steps : " ++ + str "Proof steps : " ++ int s_info.created_steps ++ str " created" ++ fnl () ++ - str "Proof branches : " ++ + str "Proof branches : " ++ int s_info.created_branches ++ str " created" ++ fnl () ++ - str "Hypotheses : " ++ + str "Hypotheses : " ++ int s_info.created_hyps ++ str " created" ++ fnl () in msgnl ( str "Proof-search statistics :" ++ fnl () ++ - count_info ++ + count_info ++ str "Branch ends: " ++ int s_info.branch_successes ++ str " successes / " ++ int s_info.branch_failures ++ str " failures" ++ fnl () ++ @@ -543,4 +543,4 @@ let pp_info () = int s_info.nd_branching ++ str " branches") - + diff --git a/plugins/rtauto/proof_search.mli b/plugins/rtauto/proof_search.mli index a0e86b8d6b..e52f6bbdc5 100644 --- a/plugins/rtauto/proof_search.mli +++ b/plugins/rtauto/proof_search.mli @@ -11,10 +11,10 @@ type form= Atom of int | Arrow of form * form - | Bot + | Bot | Conjunct of form * form | Disjunct of form * form - + type proof = Ax of int | I_Arrow of proof diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index b47bbaa93f..23cb07050a 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -18,24 +18,24 @@ open Evd open Tacmach open Proof_search -let force count lazc = incr count;Lazy.force lazc +let force count lazc = incr count;Lazy.force lazc let step_count = ref 0 -let node_count = ref 0 +let node_count = ref 0 -let logic_constant = - Coqlib.gen_constant "refl_tauto" ["Init";"Logic"] +let logic_constant = + Coqlib.gen_constant "refl_tauto" ["Init";"Logic"] let li_False = lazy (destInd (logic_constant "False")) let li_and = lazy (destInd (logic_constant "and")) let li_or = lazy (destInd (logic_constant "or")) let data_constant = - Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"] + Coqlib.gen_constant "refl_tauto" ["Init";"Datatypes"] -let l_true_equals_true = - lazy (mkApp(logic_constant "refl_equal", +let l_true_equals_true = + lazy (mkApp(logic_constant "refl_equal", [|data_constant "bool";data_constant "true"|])) let pos_constant = @@ -45,7 +45,7 @@ let l_xI = lazy (pos_constant "xI") let l_xO = lazy (pos_constant "xO") let l_xH = lazy (pos_constant "xH") -let store_constant = +let store_constant = Coqlib.gen_constant "refl_tauto" ["rtauto";"Bintree"] let l_empty = lazy (store_constant "empty") @@ -103,17 +103,17 @@ let rec make_form atom_env gls term = let normalize=special_nf gls in let cciterm=special_whd gls term in match kind_of_term cciterm with - Prod(_,a,b) -> - if not (dependent (mkRel 1) b) && - Retyping.get_sort_family_of + Prod(_,a,b) -> + if not (dependent (mkRel 1) b) && + Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) a = InProp - then + then let fa=make_form atom_env gls a in let fb=make_form atom_env gls b in Arrow (fa,fb) else make_atom atom_env (normalize term) - | Cast(a,_,_) -> + | Cast(a,_,_) -> make_form atom_env gls a | Ind ind -> if ind = Lazy.force li_False then @@ -122,7 +122,7 @@ let rec make_form atom_env gls term = make_atom atom_env (normalize term) | App(hd,argv) when Array.length argv = 2 -> begin - try + try let ind = destInd hd in if ind = Lazy.force li_and then let fa=make_form atom_env gls argv.(0) in @@ -139,103 +139,103 @@ let rec make_form atom_env gls term = let rec make_hyps atom_env gls lenv = function [] -> [] - | (_,Some body,typ)::rest -> - make_hyps atom_env gls (typ::body::lenv) rest + | (_,Some body,typ)::rest -> + make_hyps atom_env gls (typ::body::lenv) rest | (id,None,typ)::rest -> let hrec= make_hyps atom_env gls (typ::lenv) rest in - if List.exists (dependent (mkVar id)) lenv || - (Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) typ <> InProp) + if List.exists (dependent (mkVar id)) lenv || + (Retyping.get_sort_family_of + (pf_env gls) (Tacmach.project gls) typ <> InProp) then - hrec + hrec else (id,make_form atom_env gls typ)::hrec let rec build_pos n = - if n<=1 then force node_count l_xH - else if n land 1 = 0 then + if n<=1 then force node_count l_xH + else if n land 1 = 0 then mkApp (force node_count l_xO,[|build_pos (n asr 1)|]) - else + else mkApp (force node_count l_xI,[|build_pos (n asr 1)|]) let rec build_form = function Atom n -> mkApp (force node_count l_Atom,[|build_pos n|]) - | Arrow (f1,f2) -> + | Arrow (f1,f2) -> mkApp (force node_count l_Arrow,[|build_form f1;build_form f2|]) | Bot -> force node_count l_Bot - | Conjunct (f1,f2) -> + | Conjunct (f1,f2) -> mkApp (force node_count l_Conjunct,[|build_form f1;build_form f2|]) - | Disjunct (f1,f2) -> + | Disjunct (f1,f2) -> mkApp (force node_count l_Disjunct,[|build_form f1;build_form f2|]) -let rec decal k = function +let rec decal k = function [] -> k - | (start,delta)::rest -> + | (start,delta)::rest -> if k>start then k - delta - else + else decal k rest let add_pop size d pops= match pops with [] -> [size+d,d] - | (_,sum)::_ -> (size+sum,sum+d)::pops + | (_,sum)::_ -> (size+sum,sum+d)::pops -let rec build_proof pops size = +let rec build_proof pops size = function Ax i -> mkApp (force step_count l_Ax, [|build_pos (decal i pops)|]) - | I_Arrow p -> + | I_Arrow p -> mkApp (force step_count l_I_Arrow, [|build_proof pops (size + 1) p|]) - | E_Arrow(i,j,p) -> - mkApp (force step_count l_E_Arrow, + | E_Arrow(i,j,p) -> + mkApp (force step_count l_E_Arrow, [|build_pos (decal i pops); build_pos (decal j pops); build_proof pops (size + 1) p|]) - | D_Arrow(i,p1,p2) -> - mkApp (force step_count l_D_Arrow, + | D_Arrow(i,p1,p2) -> + mkApp (force step_count l_D_Arrow, [|build_pos (decal i pops); build_proof pops (size + 2) p1; build_proof pops (size + 1) p2|]) - | E_False i -> + | E_False i -> mkApp (force step_count l_E_False, [|build_pos (decal i pops)|]) - | I_And(p1,p2) -> - mkApp (force step_count l_I_And, + | I_And(p1,p2) -> + mkApp (force step_count l_I_And, [|build_proof pops size p1; build_proof pops size p2|]) - | E_And(i,p) -> + | E_And(i,p) -> mkApp (force step_count l_E_And, [|build_pos (decal i pops); build_proof pops (size + 2) p|]) - | D_And(i,p) -> + | D_And(i,p) -> mkApp (force step_count l_D_And, [|build_pos (decal i pops); build_proof pops (size + 1) p|]) - | I_Or_l(p) -> + | I_Or_l(p) -> mkApp (force step_count l_I_Or_l, [|build_proof pops size p|]) - | I_Or_r(p) -> + | I_Or_r(p) -> mkApp (force step_count l_I_Or_r, [|build_proof pops size p|]) | E_Or(i,p1,p2) -> - mkApp (force step_count l_E_Or, + mkApp (force step_count l_E_Or, [|build_pos (decal i pops); build_proof pops (size + 1) p1; build_proof pops (size + 1) p2|]) - | D_Or(i,p) -> + | D_Or(i,p) -> mkApp (force step_count l_D_Or, [|build_pos (decal i pops); build_proof pops (size + 2) p|]) | Pop(d,p) -> - build_proof (add_pop size d pops) size p - + build_proof (add_pop size d pops) size p + let build_env gamma= - List.fold_right (fun (p,_) e -> - mkApp(force node_count l_push,[|mkProp;p;e|])) + List.fold_right (fun (p,_) e -> + mkApp(force node_count l_push,[|mkProp;p;e|])) gamma.env (mkApp (force node_count l_empty,[|mkProp|])) open Goptions @@ -249,7 +249,7 @@ let opt_verbose= optread=(fun () -> !verbose); optwrite=(fun b -> verbose:=b)} -let _ = declare_bool_option opt_verbose +let _ = declare_bool_option opt_verbose let check = ref false @@ -260,7 +260,7 @@ let opt_check= optread=(fun () -> !check); optwrite=(fun b -> check:=b)} -let _ = declare_bool_option opt_check +let _ = declare_bool_option opt_check open Pp @@ -269,34 +269,34 @@ let rtauto_tac gls= let gamma={next=1;env=[]} in let gl=gls.it.evar_concl in let _= - if Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) gl <> InProp + if Retyping.get_sort_family_of + (pf_env gls) (Tacmach.project gls) gl <> InProp then errorlabstrm "rtauto" (Pp.str "goal should be in Prop") in let glf=make_form gamma gls gl in - let hyps=make_hyps gamma gls [gl] + let hyps=make_hyps gamma gls [gl] (Environ.named_context_of_val gls.it.evar_hyps) in let formula= - List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in - let search_fun = + List.fold_left (fun gl (_,f)-> Arrow (f,gl)) glf hyps in + let search_fun = if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 then Search.debug_depth_first - else + else Search.depth_first in - let _ = + let _ = begin reset_info (); if !verbose then msgnl (str "Starting proof-search ..."); end in let search_start_time = System.get_time () in - let prf = - try project (search_fun (init_state [] formula)) + let prf = + try project (search_fun (init_state [] formula)) with Not_found -> errorlabstrm "rtauto" (Pp.str "rtauto couldn't find any proof") in let search_end_time = System.get_time () in let _ = if !verbose then begin - msgnl (str "Proof tree found in " ++ + msgnl (str "Proof tree found in " ++ System.fmt_time_difference search_start_time search_end_time); pp_info (); msgnl (str "Building proof term ... ") @@ -312,10 +312,10 @@ let rtauto_tac gls= let build_end_time=System.get_time () in let _ = if !verbose then begin - msgnl (str "Proof term built in " ++ + msgnl (str "Proof term built in " ++ System.fmt_time_difference build_start_time build_end_time ++ fnl () ++ - str "Proof size : " ++ int !step_count ++ + str "Proof size : " ++ int !step_count ++ str " steps" ++ fnl () ++ str "Proof term size : " ++ int (!step_count+ !node_count) ++ str " nodes (constants)" ++ fnl () ++ @@ -323,15 +323,15 @@ let rtauto_tac gls= end in let tac_start_time = System.get_time () in let result= - if !check then + if !check then Tactics.exact_check term gls else Tactics.exact_no_check term gls in let tac_end_time = System.get_time () in - let _ = + let _ = if !check then msgnl (str "Proof term type-checking is on"); if !verbose then - msgnl (str "Internal tactic executed in " ++ + msgnl (str "Internal tactic executed in " ++ System.fmt_time_difference tac_start_time tac_end_time) in result diff --git a/plugins/setoid_ring/ArithRing.v b/plugins/setoid_ring/ArithRing.v index 601cabe003..e5a4c8d179 100644 --- a/plugins/setoid_ring/ArithRing.v +++ b/plugins/setoid_ring/ArithRing.v @@ -16,11 +16,11 @@ Lemma natSRth : semi_ring_theory O (S O) plus mult (@eq nat). Proof. constructor. exact plus_0_l. exact plus_comm. exact plus_assoc. exact mult_1_l. exact mult_0_l. exact mult_comm. exact mult_assoc. - exact mult_plus_distr_r. + exact mult_plus_distr_r. Qed. -Lemma nat_morph_N : - semi_morph 0 1 plus mult (eq (A:=nat)) +Lemma nat_morph_N : + semi_morph 0 1 plus mult (eq (A:=nat)) 0%N 1%N Nplus Nmult Neq_bool nat_of_N. Proof. constructor;trivial. @@ -46,7 +46,7 @@ Ltac natprering := |- context C [S ?p] => match p with O => fail 1 (* avoid replacing 1 with 1+0 ! *) - | p => match isnatcst p with + | p => match isnatcst p with | true => fail 1 | false => let v := Ss_to_add p (S 0) in fold v; natprering diff --git a/plugins/setoid_ring/BinList.v b/plugins/setoid_ring/BinList.v index 5090200429..d403c9efe2 100644 --- a/plugins/setoid_ring/BinList.v +++ b/plugins/setoid_ring/BinList.v @@ -28,17 +28,17 @@ Section MakeBinList. | xH => hd default l | xO p => nth p (jump p l) | xI p => nth p (jump p (tail l)) - end. + end. Lemma jump_tl : forall j l, tail (jump j l) = jump j (tail l). - Proof. + Proof. induction j;simpl;intros. repeat rewrite IHj;trivial. repeat rewrite IHj;trivial. trivial. Qed. - Lemma jump_Psucc : forall j l, + Lemma jump_Psucc : forall j l, (jump (Psucc j) l) = (jump 1 (jump j l)). Proof. induction j;simpl;intros. @@ -47,7 +47,7 @@ Section MakeBinList. trivial. Qed. - Lemma jump_Pplus : forall i j l, + Lemma jump_Pplus : forall i j l, (jump (i + j) l) = (jump i (jump j l)). Proof. induction i;intros. @@ -69,7 +69,7 @@ Section MakeBinList. trivial. Qed. - + Lemma nth_jump : forall p l, nth p (tail l) = hd default (jump p l). Proof. induction p;simpl;intros. diff --git a/plugins/setoid_ring/Field_tac.v b/plugins/setoid_ring/Field_tac.v index 0082eb9afc..7aff8e0cbb 100644 --- a/plugins/setoid_ring/Field_tac.v +++ b/plugins/setoid_ring/Field_tac.v @@ -10,27 +10,27 @@ Require Import Ring_tac BinList Ring_polynom InitialRing. Require Export Field_theory. (* syntaxification *) - Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := + Ltac mkFieldexpr C Cst CstPow radd rmul rsub ropp rdiv rinv rpow t fv := let rec mkP t := let f := match Cst t with | InitialRing.NotConstant => - match t with - | (radd ?t1 ?t2) => + match t with + | (radd ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEadd e1 e2) - | (rmul ?t1 ?t2) => + | (rmul ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEmul e1 e2) - | (rsub ?t1 ?t2) => - fun _ => + | (rsub ?t1 ?t2) => + fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEsub e1 e2) | (ropp ?t1) => fun _ => let e1 := mkP t1 in constr:(FEopp e1) - | (rdiv ?t1 ?t2) => + | (rdiv ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(FEdiv e1 e2) @@ -38,7 +38,7 @@ Require Export Field_theory. fun _ => let e1 := mkP t1 in constr:(FEinv e1) | (rpow ?t1 ?n) => match CstPow n with - | InitialRing.NotConstant => + | InitialRing.NotConstant => fun _ => let p := Find_at t fv in constr:(@FEX C p) @@ -74,7 +74,7 @@ Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := | _ => AddFvTail t fv end | _ => fv - end + end in TFV t fv. (* packaging the field structure *) @@ -83,7 +83,7 @@ Ltac FFV Cst CstPow add mul sub opp div inv pow t fv := Ltac PackField F req Cst_tac Pow_tac L1 L2 L3 L4 cond_ok pre post := let FLD := match type of L1 with - | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv + | context [req (@FEeval ?R ?rO ?radd ?rmul ?rsub ?ropp ?rdiv ?rinv ?C ?phi ?Cpow ?Cp_phi ?rpow _ _) _ ] => (fun proj => proj Cst_tac Pow_tac pre post @@ -245,9 +245,9 @@ Ltac Field_norm_gen f n FLD lH rl := ReflexiveRewriteTactic mkFFV mkFE lemma_tac main_tac fv0 rl; try simpl_PCond FLD. -Ltac Field_simplify_gen f FLD lH rl := +Ltac Field_simplify_gen f FLD lH rl := get_FldPre FLD (); - Field_norm_gen f ring_subst_niter FLD lH rl; + Field_norm_gen f ring_subst_niter FLD lH rl; get_FldPost FLD (). Ltac Field_simplify := @@ -257,14 +257,14 @@ Tactic Notation (at level 0) "field_simplify" constr_list(rl) := let G := Get_goal in field_lookup (PackField Field_simplify) [] rl G. -Tactic Notation (at level 0) +Tactic Notation (at level 0) "field_simplify" "[" constr_list(lH) "]" constr_list(rl) := let G := Get_goal in field_lookup (PackField Field_simplify) [lH] rl G. -Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= +Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= let G := Get_goal in - let t := type of H in + let t := type of H in let g := fresh "goal" in set (g:= G); revert H; @@ -272,10 +272,10 @@ Tactic Notation "field_simplify" constr_list(rl) "in" hyp(H):= intro H; unfold g;clear g. -Tactic Notation "field_simplify" - "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):= +Tactic Notation "field_simplify" + "["constr_list(lH) "]" constr_list(rl) "in" hyp(H):= let G := Get_goal in - let t := type of H in + let t := type of H in let g := fresh "goal" in set (g:= G); revert H; @@ -284,15 +284,15 @@ Tactic Notation "field_simplify" unfold g;clear g. (* -Ltac Field_simplify_in hyp:= +Ltac Field_simplify_in hyp:= Field_simplify_gen ltac:(fun H => rewrite H in hyp). -Tactic Notation (at level 0) +Tactic Notation (at level 0) "field_simplify" constr_list(rl) "in" hyp(h) := let t := type of h in field_lookup (Field_simplify_in h) [] rl t. -Tactic Notation (at level 0) +Tactic Notation (at level 0) "field_simplify" "[" constr_list(lH) "]" constr_list(rl) "in" hyp(h) := let t := type of h in field_lookup (Field_simplify_in h) [lH] rl t. @@ -317,10 +317,10 @@ Ltac Field_Scheme Simpl_tac n lemma FLD lH := pose (vlpe := lpe); let nlemma := fresh "field_lemma" in (assert (nlemma := lemma n fv vlpe fe1 fe2 prh) - || fail "field anomaly:failed to build lemma"); + || fail "field anomaly:failed to build lemma"); ProveLemmaHyps nlemma ltac:(fun ilemma => - apply ilemma + apply ilemma || fail "field anomaly: failed in applying lemma"; [ Simpl_tac | simpl_PCond FLD]); clear nlemma; @@ -333,11 +333,11 @@ Ltac Field_Scheme Simpl_tac n lemma FLD lH := Ltac FIELD FLD lH rl := let Simpl := vm_compute; reflexivity || fail "not a valid field equation" in let lemma := get_L1 FLD in - get_FldPre FLD (); + get_FldPre FLD (); Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; try exact I; get_FldPost FLD(). - + Tactic Notation (at level 0) "field" := let G := Get_goal in field_lookup (PackField FIELD) [] G. @@ -351,15 +351,15 @@ Tactic Notation (at level 0) "field" "[" constr_list(lH) "]" := Ltac FIELD_SIMPL FLD lH rl := let Simpl := (protect_fv "field") in let lemma := get_SimplifyEqLemma FLD in - get_FldPre FLD (); + get_FldPre FLD (); Field_Scheme Simpl Ring_tac.ring_subst_niter lemma FLD lH; get_FldPost FLD (). -Tactic Notation (at level 0) "field_simplify_eq" := +Tactic Notation (at level 0) "field_simplify_eq" := let G := Get_goal in field_lookup (PackField FIELD_SIMPL) [] G. -Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := +Tactic Notation (at level 0) "field_simplify_eq" "[" constr_list(lH) "]" := let G := Get_goal in field_lookup FIELD_SIMPL [lH] G. @@ -372,7 +372,7 @@ Ltac Field_simplify_eq n FLD lH := let mkFE := get_Meta FLD in let lemma := get_L4 FLD in let hyp := fresh "hyp" in - intro hyp; + intro hyp; OnEquationHyp req hyp ltac:(fun t1 t2 => let fv := FV_hypo_tac mkFV req lH in let fv := mkFFV t1 fv in @@ -385,16 +385,16 @@ Ltac Field_simplify_eq n FLD lH := ProveLemmaHyps (lemma n fv lpe fe1 fe2 prh) ltac:(fun ilemma => match type of ilemma with - | req _ _ -> _ -> ?EQ => + | req _ _ -> _ -> ?EQ => let tmp := fresh "tmp" in assert (tmp : EQ); [ apply ilemma; [ exact hyp | simpl_PCond_BEURK FLD] | protect_fv "field" in tmp; revert tmp ]; - clear hyp + clear hyp end)). Ltac FIELD_SIMPL_EQ FLD lH rl := - get_FldPre FLD (); + get_FldPre FLD (); Field_simplify_eq Ring_tac.ring_subst_niter FLD lH; get_FldPost(). @@ -406,15 +406,15 @@ Tactic Notation (at level 0) "field_simplify_eq" "in" hyp(H) := | clear H;intro H]. -Tactic Notation (at level 0) - "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := +Tactic Notation (at level 0) + "field_simplify_eq" "[" constr_list(lH) "]" "in" hyp(H) := let t := type of H in generalize H; field_lookup (PackField FIELD_SIMPL_EQ) [lH] t; [ try exact I |clear H;intro H]. - -(* More generic tactics to build variants of field *) + +(* More generic tactics to build variants of field *) (* This tactic reifies c and pass to F: - the FLD structure gathering all info in the field DB @@ -489,13 +489,13 @@ Ltac reduce_field_expr ope kont FLD fv expr := (* Hack to let a Ltac return a term in the context of a primitive tactic *) Ltac return_term x := generalize (refl_equal x). Ltac get_term := - match goal with + match goal with | |- ?x = _ -> _ => x end. (* Turn an operation on field expressions (FExpr) into a reduction on terms (in the field carrier). Because of field_lookup, - the tactic cannot return a term directly, so it is returned + the tactic cannot return a term directly, so it is returned via the conclusion of the goal (return_term). *) Ltac reduce_field_ope ope c := gen_with_field ltac:(reduce_field_expr ope return_term) c. @@ -526,7 +526,7 @@ Ltac field_elements set ext fspec pspec sspec dspec rk := Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := let get_lemma := match pspec with None => fun x y => x | _ => fun x y => y end in - let simpl_eq_lemma := get_lemma + let simpl_eq_lemma := get_lemma Field_simplify_eq_correct Field_simplify_eq_pow_correct in let simpl_eq_in_lemma := get_lemma Field_simplify_eq_in_correct Field_simplify_eq_pow_in_correct in @@ -538,27 +538,27 @@ Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := | _ => let field_ok1 := constr:(Field_correct set ext_r inv_m afth morph) in match p_spec with - | mkhypo ?pp_spec => + | mkhypo ?pp_spec => let field_ok2 := constr:(field_ok1 _ _ _ pp_spec) in match s_spec with - | mkhypo ?ss_spec => + | mkhypo ?ss_spec => let field_ok3 := constr:(field_ok2 _ ss_spec) in match d_spec with - | mkhypo ?dd_spec => + | mkhypo ?dd_spec => let field_ok := constr:(field_ok3 _ dd_spec) in - let mk_lemma lemma := - constr:(lemma _ _ _ _ _ _ _ _ _ _ - set ext_r inv_m afth - _ _ _ _ _ _ _ _ _ morph - _ _ _ pp_spec _ ss_spec _ dd_spec) in + let mk_lemma lemma := + constr:(lemma _ _ _ _ _ _ _ _ _ _ + set ext_r inv_m afth + _ _ _ _ _ _ _ _ _ morph + _ _ _ pp_spec _ ss_spec _ dd_spec) in let field_simpl_eq_ok := mk_lemma simpl_eq_lemma in let field_simpl_ok := mk_lemma rw_lemma in let field_simpl_eq_in := mk_lemma simpl_eq_in_lemma in - let cond1_ok := + let cond1_ok := constr:(Pcond_simpl_gen set ext_r afth morph pp_spec dd_spec) in - let cond2_ok := + let cond2_ok := constr:(Pcond_simpl_complete set ext_r afth morph pp_spec dd_spec) in - (fun f => + (fun f => f afth ext_r morph field_ok field_simpl_ok field_simpl_eq_ok field_simpl_eq_in cond1_ok cond2_ok) | _ => fail 4 "field: bad coefficiant division specification" @@ -566,6 +566,6 @@ Ltac field_lemmas set ext inv_m fspec pspec sspec dspec rk := | _ => fail 3 "field: bad sign specification" end | _ => fail 2 "field: bad power specification" - end + end | _ => fail 1 "field internal error : field_lemmas, please report" end). diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index fd99f786f5..205bef6d57 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -14,7 +14,7 @@ Set Implicit Arguments. Section MakeFieldPol. -(* Field elements *) +(* Field elements *) Variable R:Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). Variable (rdiv : R -> R -> R) (rinv : R -> R). @@ -30,7 +30,7 @@ Section MakeFieldPol. Variable Rsth : Setoid_Theory R req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable SRinv_ext : forall p q, p == q -> / p == / q. - + (* Field properties *) Record almost_field_theory : Prop := mk_afield { AF_AR : almost_ring_theory rO rI radd rmul rsub ropp req; @@ -47,10 +47,10 @@ Section AlmostField. Let rdiv_def := AFth.(AFdiv_def). Let rinv_l := AFth.(AFinv_l). - (* Coefficients *) + (* Coefficients *) Variable C: Type. Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. + Variable ceqb : C->C->bool. Variable phi : C -> R. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req @@ -65,7 +65,7 @@ case (ceqb c1 c2); auto. Qed. - (* C notations *) + (* C notations *) Notation "x +! y" := (cadd x y) (at level 50). Notation "x *! y " := (cmul x y) (at level 40). Notation "x -! y " := (csub x y) (at level 50). @@ -74,14 +74,14 @@ Qed. Notation "[ x ]" := (phi x) (at level 0). - (* Useful tactics *) + (* Useful tactics *) Add Setoid R req Rsth as R_set1. Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext. exact (Ropp_ext Reqe). Qed. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Add Morphism rinv : rinv_ext. exact SRinv_ext. Qed. - + Let eq_trans := Setoid.Seq_trans _ _ Rsth. Let eq_sym := Setoid.Seq_sym _ _ Rsth. Let eq_refl := Setoid.Seq_refl _ _ Rsth. @@ -90,15 +90,15 @@ Hint Resolve eq_refl rdiv_def rinv_l rI_neq_rO CRmorph.(morph1) . Hint Resolve (Rmul_ext Reqe) (Rmul_ext Reqe) (Radd_ext Reqe) (ARsub_ext Rsth Reqe ARth) (Ropp_ext Reqe) SRinv_ext. Hint Resolve (ARadd_0_l ARth) (ARadd_comm ARth) (ARadd_assoc ARth) - (ARmul_1_l ARth) (ARmul_0_l ARth) + (ARmul_1_l ARth) (ARmul_0_l ARth) (ARmul_comm ARth) (ARmul_assoc ARth) (ARdistr_l ARth) - (ARopp_mul_l ARth) (ARopp_add ARth) + (ARopp_mul_l ARth) (ARopp_add ARth) (ARsub_def ARth) . (* Power coefficients *) Variable Cpow : Set. Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. + Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. (* sign function *) Variable get_sign : C -> option C. @@ -129,11 +129,11 @@ rewrite (ARopp_zero Rsth Reqe ARth) in |- *; ring. Qed. (*************************************************************************** - - Properties of division - + + Properties of division + ***************************************************************************) - + Theorem rdiv_simpl: forall p q, ~ q == 0 -> q * (p / q) == p. intros p q H. rewrite rdiv_def in |- *. @@ -141,7 +141,7 @@ transitivity (/ q * q * p); [ ring | idtac ]. rewrite rinv_l in |- *; auto. Qed. Hint Resolve rdiv_simpl . - + Theorem SRdiv_ext: forall p1 p2, p1 == p2 -> forall q1 q2, q1 == q2 -> p1 / q1 == p2 / q2. intros p1 p2 H q1 q2 H0. @@ -195,7 +195,7 @@ Qed. Theorem rdiv1: forall r, r == r / 1. intros r; transitivity (1 * (r / 1)); auto. Qed. - + Theorem rdiv2: forall r1 r2 r3 r4, ~ r2 == 0 -> @@ -224,7 +224,7 @@ intros r1 r2 r3 r4 r5 H H0. assert (HH1: ~ r2 == 0) by (intros HH; case H; rewrite HH; ring). assert (HH2: ~ r5 == 0) by (intros HH; case H; rewrite HH; ring). assert (HH3: ~ r4 == 0) by (intros HH; case H0; rewrite HH; ring). -assert (HH4: ~ r2 * (r4 * r5) == 0) +assert (HH4: ~ r2 * (r4 * r5) == 0) by complete (repeat apply field_is_integral_domain; trivial). apply rmul_reg_l with (r2 * (r4 * r5)); trivial. rewrite rdiv_simpl in |- *; trivial. @@ -288,7 +288,7 @@ assert (~ r1 / r2 == 0) as Hk. repeat rewrite rinv_l in |- *; auto. Qed. Hint Resolve rdiv6 . - + Theorem rdiv4: forall r1 r2 r3 r4, ~ r2 == 0 -> @@ -385,9 +385,9 @@ transitivity (r1 / r2 * (r4 / r4)). Qed. (*************************************************************************** - - Some equality test - + + Some equality test + ***************************************************************************) Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool := @@ -397,7 +397,7 @@ Fixpoint positive_eq (p1 p2 : positive) {struct p1} : bool := | xI p3, xI p4 => positive_eq p3 p4 | _, _ => false end. - + Theorem positive_eq_correct: forall p1 p2, if positive_eq p1 p2 then p1 = p2 else p1 <> p2. intros p1; elim p1; @@ -411,8 +411,8 @@ generalize (rec p4); case (positive_eq p3 p4); auto. intros H1; apply f_equal with ( f := xO ); auto. intros H1 H2; case H1; injection H2; auto. Qed. - -Definition N_eq n1 n2 := + +Definition N_eq n1 n2 := match n1, n2 with | N0, N0 => true | Npos p1, Npos p2 => positive_eq p1 p2 @@ -438,7 +438,7 @@ Fixpoint PExpr_eq (e1 e2 : PExpr C) {struct e1} : bool := | PEpow e3 n3, PEpow e4 n4 => if N_eq n3 n4 then PExpr_eq e3 e4 else false | _, _ => false end. - + Add Morphism (pow_pos rmul) : pow_morph. intros x y H p;induction p as [p IH| p IH|];simpl;auto;ring[IH]. Qed. @@ -508,10 +508,10 @@ Definition NPEpow x n := | N0 => PEc cI | Npos p => if positive_eq p xH then x else - match x with - | PEc c => - if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p) - | _ => PEpow x n + match x with + | PEc c => + if ceqb c cI then PEc cI else if ceqb c cO then PEc cO else PEc (pow_pos cmul c p) + | _ => PEpow x n end end. @@ -530,7 +530,7 @@ Proof. induction p;simpl;auto;repeat rewrite CRmorph.(morph_mul);ring [IHp]. Qed. -(* mul *) +(* mul *) Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := match x, y with PEc c1, PEc c2 => PEc (cmul c1 c2) @@ -546,7 +546,7 @@ Fixpoint NPEmul (x y : PExpr C) {struct x} : PExpr C := Lemma pow_pos_mul : forall x y p, pow_pos rmul (x * y) p == pow_pos rmul x p * pow_pos rmul y p. induction p;simpl;auto;try ring [IHp]. Qed. - + Theorem NPEmul_correct : forall l e1 e2, NPEeval l (NPEmul e1 e2) == NPEeval l (PEmul e1 e2). induction e1;destruct e2; simpl in |- *;try reflexivity; @@ -581,17 +581,17 @@ destruct e1; destruct e2; simpl in |- *; try reflexivity; try apply ceqb_rect; try (symmetry; apply rsub_0_l); try (symmetry; apply rsub_0_r). apply (morph_sub CRmorph). Qed. - + (* opp *) Definition NPEopp e1 := match e1 with PEc c1 => PEc (copp c1) | _ => PEopp e1 end. - + Theorem NPEopp_correct: forall l e1, NPEeval l (NPEopp e1) == NPEeval l (PEopp e1). intros l e1; case e1; simpl; auto. intros; apply (morph_opp CRmorph). Qed. - + (* simplification *) Fixpoint PExpr_simp (e : PExpr C) : PExpr C := match e with @@ -602,7 +602,7 @@ Fixpoint PExpr_simp (e : PExpr C) : PExpr C := | PEpow e1 n1 => NPEpow (PExpr_simp e1) n1 | _ => e end. - + Theorem PExpr_simp_correct: forall l e, NPEeval l (PExpr_simp e) == NPEeval l e. intros l e; elim e; simpl; auto. @@ -630,9 +630,9 @@ Qed. (**************************************************************************** - - Datastructure - + + Datastructure + ***************************************************************************) (* The input: syntax of a field expression *) @@ -647,7 +647,7 @@ Inductive FExpr : Type := | FEinv: FExpr -> FExpr | FEdiv: FExpr -> FExpr -> FExpr | FEpow: FExpr -> N -> FExpr . - + Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := match pe with | FEc c => phi c @@ -664,7 +664,7 @@ Fixpoint FEeval (l : list R) (pe : FExpr) {struct pe} : R := Strategy expand [FEeval]. (* The result of the normalisation *) - + Record linear : Type := mk_linear { num : PExpr C; denum : PExpr C; @@ -675,7 +675,7 @@ Record linear : Type := mk_linear { Semantics and properties of side condition ***************************************************************************) - + Fixpoint PCond (l : list R) (le : list (PExpr C)) {struct le} : Prop := match le with | nil => True @@ -689,7 +689,7 @@ intros l a l1 H. destruct l1; simpl in H |- *; trivial. destruct H; trivial. Qed. - + Theorem PCond_cons_inv_r : forall l a l1, PCond l (a :: l1) -> PCond l l1. intros l a l1 H. destruct l1; simpl in H |- *; trivial. @@ -703,12 +703,12 @@ intros l l1 l2; elim l1; simpl app in |- *. destruct l2; firstorder. firstorder. Qed. - + Theorem PCond_app_inv_r: forall l l1 l2, PCond l (l1 ++ l2) -> PCond l l2. intros l l1 l2; elim l1; simpl app; auto. intros a l0 H H0; apply H; apply PCond_cons_inv_r with ( 1 := H0 ). Qed. - + (* An unsatisfiable condition: issued when a division by zero is detected *) Definition absurd_PCond := cons (PEc cO) nil. @@ -720,9 +720,9 @@ apply (morph0 CRmorph). Qed. (*************************************************************************** - - Normalisation - + + Normalisation + ***************************************************************************) Fixpoint isIn (e1:PExpr C) (p1:positive) @@ -731,18 +731,18 @@ Fixpoint isIn (e1:PExpr C) (p1:positive) | PEmul e3 e4 => match isIn e1 p1 e3 p2 with | Some (N0, e5) => Some (N0, NPEmul e5 (NPEpow e4 (Npos p2))) - | Some (Npos p, e5) => + | Some (Npos p, e5) => match isIn e1 p e4 p2 with | Some (n, e6) => Some (n, NPEmul e5 e6) | None => Some (Npos p, NPEmul e5 (NPEpow e4 (Npos p2))) end - | None => + | None => match isIn e1 p1 e4 p2 with | Some (n, e5) => Some (n,NPEmul (NPEpow e3 (Npos p2)) e5) | None => None end end - | PEpow e3 N0 => None + | PEpow e3 N0 => None | PEpow e3 (Npos p3) => isIn e1 p1 e3 (Pmult p3 p2) | _ => if PExpr_eq e1 e2 then @@ -751,27 +751,27 @@ Fixpoint isIn (e1:PExpr C) (p1:positive) | Z0 => Some (N0, PEc cI) | Zneg p => Some (N0, NPEpow e2 (Npos p)) end - else None + else None end. - + Definition ZtoN z := match z with Zpos p => Npos p | _ => N0 end. Definition NtoZ n := match n with Npos p => Zpos p | _ => Z0 end. - Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) + Notation pow_pos_plus := (Ring_theory.pow_pos_Pplus _ Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc)). - Lemma isIn_correct_aux : forall l e1 e2 p1 p2, - match + Lemma isIn_correct_aux : forall l e1 e2 p1 p2, + match (if PExpr_eq e1 e2 then match Zminus (Zpos p1) (Zpos p2) with | Zpos p => Some (Npos p, PEc cI) | Z0 => Some (N0, PEc cI) | Zneg p => Some (N0, NPEpow e2 (Npos p)) end - else None) + else None) with - | Some(n, e3) => - NPEeval l (PEpow e2 (Npos p2)) == + | Some(n, e3) => + NPEeval l (PEpow e2 (Npos p2)) == NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ (Zpos p1 > NtoZ n)%Z | _ => True @@ -779,15 +779,15 @@ Fixpoint isIn (e1:PExpr C) (p1:positive) Proof. intros l e1 e2 p1 p2; generalize (PExpr_eq_semi_correct l e1 e2); case (PExpr_eq e1 e2); simpl; auto; intros H. - case_eq ((p1 ?= p2)%positive Eq);intros;simpl. + case_eq ((p1 ?= p2)%positive Eq);intros;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. split. 2:refine (refl_equal _). - rewrite (Pcompare_Eq_eq _ _ H0). + rewrite (Pcompare_Eq_eq _ _ H0). rewrite H by trivial. ring [ (morph1 CRmorph)]. fold (NPEpow e2 (Npos (p2 - p1))). rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite H;trivial. split. 2:refine (refl_equal _). - rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. + rewrite <- pow_pos_plus; rewrite Pplus_minus;auto. apply ZC2;trivial. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite H;trivial. change (ZtoN @@ -801,7 +801,7 @@ Proof. repeat rewrite Zth.(Rsub_def). rewrite (Ring_theory.Ropp_add Zsth Zeqe Zth). rewrite Zplus_assoc. simpl. rewrite Pcompare_refl. simpl. ring [ (morph1 CRmorph)]. - assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). + assert (Zpos p1 > 0 /\ Zpos p2 > 0)%Z. split;refine (refl_equal _). apply Zplus_gt_reg_l with (Zpos p2). rewrite Zplus_minus. change (Zpos p2 + Zpos p1 > 0 + Zpos p1)%Z. apply Zplus_gt_compat_r. refine (refl_equal _). @@ -815,9 +815,9 @@ Qed. Theorem isIn_correct: forall l e1 p1 e2 p2, - match isIn e1 p1 e2 p2 with - | Some(n, e3) => - NPEeval l (PEpow e2 (Npos p2)) == + match isIn e1 p1 e2 p2 with + | Some(n, e3) => + NPEeval l (PEpow e2 (Npos p2)) == NPEeval l (PEmul (PEpow e1 (ZtoN (Zpos p1 - NtoZ n))) e3) /\ (Zpos p1 > NtoZ n)%Z | _ => True @@ -827,7 +827,7 @@ Opaque NPEpow. intros l e1 p1 e2; generalize p1;clear p1;elim e2; intros; try (refine (isIn_correct_aux l e1 _ p1 p2);fail);simpl isIn. generalize (H p1 p2);clear H;destruct (isIn e1 p1 p p2). destruct p3. -destruct n. +destruct n. simpl. rewrite NPEmul_correct. simpl; rewrite NPEpow_correct;simpl. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul;intros (H,H1);split;[ring[H]|trivial]. @@ -838,12 +838,12 @@ destruct n. unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. rewrite pow_pos_mul. rewrite H1;rewrite H3. assert (pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 * - (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == + (pow_pos rmul (NPEeval l e1) p4 * NPEeval l p5) == pow_pos rmul (NPEeval l e1) p4 * pow_pos rmul (NPEeval l e1) (p1 - p4) * NPEeval l p3 *NPEeval l p5) by ring. rewrite H;clear H. rewrite <- pow_pos_plus. rewrite Pplus_minus. split. symmetry;apply ARth.(ARmul_assoc). refine (refl_equal _). trivial. - repeat rewrite pow_th.(rpow_pow_N);simpl. + repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2) (H3,H4). unfold Zgt in H2, H4;simpl in H2,H4. rewrite H4 in H3;simpl in H3. rewrite H2 in H1;simpl in H1. @@ -857,16 +857,16 @@ destruct n. pow_pos rmul (NPEeval l e1) (p1 - p4) * pow_pos rmul (NPEeval l e1) (p4 - p6) * NPEeval l p3 * NPEeval l p5) by ring. rewrite H0;clear H0. rewrite <- pow_pos_plus. - replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. + replace (p1 - p4 + (p4 - p6))%positive with (p1 - p6)%positive. rewrite NPEmul_correct. simpl;ring. - assert + assert (Zpos p1 - Zpos p6 = Zpos p1 - Zpos p4 + (Zpos p4 - Zpos p6))%Z. change ((Zpos p1 - Zpos p6)%Z = (Zpos p1 + (- Zpos p4) + (Zpos p4 +(- Zpos p6)))%Z). rewrite <- Zplus_assoc. rewrite (Zplus_assoc (- Zpos p4)). simpl. rewrite Pcompare_refl. simpl. reflexivity. unfold Zminus, Zopp in H0. simpl in H0. rewrite H2 in H0;rewrite H4 in H0;rewrite H in H0. inversion H0;trivial. - simpl. repeat rewrite pow_th.(rpow_pow_N). + simpl. repeat rewrite pow_th.(rpow_pow_N). intros H1 (H2,H3). unfold Zgt in H3;simpl in H3. rewrite H3 in H2;rewrite H3. rewrite NPEmul_correct;simpl;rewrite NPEpow_correct;simpl. simpl in H2. rewrite pow_th.(rpow_pow_N);simpl. @@ -879,8 +879,8 @@ destruct n. repeat rewrite pow_th.(rpow_pow_N);simpl. rewrite pow_pos_mul. intros (H1, H2);rewrite H1;split. unfold Zgt in H2;simpl in H2;rewrite H2;rewrite H2 in H1. - simpl in H1;ring [H1]. trivial. - trivial. + simpl in H1;ring [H1]. trivial. + trivial. destruct n. trivial. generalize (H p1 (p0*p2)%positive);clear H;destruct (isIn e1 p1 p (p0*p2)). destruct p3. destruct n;simpl. repeat rewrite pow_th.(rpow_pow_N). simpl. @@ -910,18 +910,18 @@ Fixpoint split_aux (e1: PExpr C) (p:positive) (e2:PExpr C) {struct e1}: rsplit : (NPEmul (common r1) (common r2)) (right r2) | PEpow e3 N0 => mk_rsplit (PEc cI) (PEc cI) e2 - | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2 - | _ => + | PEpow e3 (Npos p3) => split_aux e3 (Pmult p3 p) e2 + | _ => match isIn e1 p e2 xH with - | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 end - end. + end. Lemma split_aux_correct_1 : forall l e1 p e2, let res := match isIn e1 p e2 xH with - | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 + | Some (N0,e3) => mk_rsplit (PEc cI) (NPEpow e1 (Npos p)) e3 | Some (Npos q, e3) => mk_rsplit (NPEpow e1 (Npos q)) (NPEpow e1 (Npos (p - q))) e3 | None => mk_rsplit (NPEpow e1 (Npos p)) (PEc cI) e2 end in @@ -932,7 +932,7 @@ Proof. intros. unfold res;clear res; generalize (isIn_correct l e1 p e2 xH). destruct (isIn e1 p e2 1). destruct p0. Opaque NPEpow NPEmul. - destruct n;simpl; + destruct n;simpl; (repeat rewrite NPEmul_correct;simpl; repeat rewrite NPEpow_correct;simpl; repeat rewrite pow_th.(rpow_pow_N);simpl). @@ -945,7 +945,7 @@ Proof. Qed. Theorem split_aux_correct: forall l e1 p e2, - NPEeval l (PEpow e1 (Npos p)) == + NPEeval l (PEpow e1 (Npos p)) == NPEeval l (NPEmul (left (split_aux e1 p e2)) (common (split_aux e1 p e2))) /\ NPEeval l e2 == NPEeval l (NPEmul (right (split_aux e1 p e2)) @@ -953,9 +953,9 @@ Theorem split_aux_correct: forall l e1 p e2, Proof. intros l; induction e1;intros k e2; try refine (split_aux_correct_1 l _ k e2);simpl. generalize (IHe1_1 k e2); clear IHe1_1. -generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. +generalize (IHe1_2 k (rsplit_right (split_aux e1_1 k e2))); clear IHe1_2. simpl. repeat (rewrite NPEmul_correct;simpl). -repeat rewrite pow_th.(rpow_pow_N);simpl. +repeat rewrite pow_th.(rpow_pow_N);simpl. intros (H1,H2) (H3,H4);split. rewrite pow_pos_mul. rewrite H1;rewrite H3. ring. rewrite H4;rewrite H2;ring. @@ -971,7 +971,7 @@ rewrite pow_pos_pow_pos. intros [H1 H2];split;ring [H1 H2]. Qed. Definition split e1 e2 := split_aux e1 xH e2. - + Theorem split_correct_l: forall l e1 e2, NPEeval l e1 == NPEeval l (NPEmul (left (split e1 e2)) (common (split e1 e2))). @@ -987,7 +987,7 @@ Proof. intros l e1 e2; case (split_aux_correct l e1 xH e2);simpl;auto. Qed. -Fixpoint Fnorm (e : FExpr) : linear := +Fixpoint Fnorm (e : FExpr) : linear := match e with | FEc c => mk_linear (PEc c) (PEc cI) nil | FEX x => mk_linear (PEX C x) (PEc cI) nil @@ -999,7 +999,7 @@ Fixpoint Fnorm (e : FExpr) : linear := (NPEadd (NPEmul (num x) (right s)) (NPEmul (num y) (left s))) (NPEmul (left s) (NPEmul (right s) (common s))) (condition x ++ condition y) - + | FEsub e1 e2 => let x := Fnorm e1 in let y := Fnorm e2 in @@ -1050,13 +1050,13 @@ Proof. induction p;simpl. intro Hp;assert (H1 := @rmul_reg_l _ (pow_pos rmul x p * pow_pos rmul x p) 0 H). apply IHp. - rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). + rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). reflexivity. - rewrite H1. ring. rewrite Hp;ring. + rewrite H1. ring. rewrite Hp;ring. intro Hp;apply IHp. rewrite (@rmul_reg_l _ (pow_pos rmul x p) 0 IHp). reflexivity. rewrite Hp;ring. trivial. Qed. - + Theorem Pcond_Fnorm: forall l e, PCond l (condition (Fnorm e)) -> ~ NPEeval l (denum (Fnorm e)) == 0. @@ -1135,9 +1135,9 @@ Hint Resolve Pcond_Fnorm. (*************************************************************************** - - Main theorem - + + Main theorem + ***************************************************************************) Theorem Fnorm_FEeval_PEeval: @@ -1242,8 +1242,8 @@ apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. intro Hp. apply (pow_pos_not_0 Hdiff p). rewrite (@rmul_reg_l (pow_pos rmul r0 p) (pow_pos rmul r0 p) 0). - reflexivity. apply pow_pos_not_0;trivial. ring [Hp]. -rewrite <- rdiv4;trivial. + reflexivity. apply pow_pos_not_0;trivial. ring [Hp]. +rewrite <- rdiv4;trivial. rewrite IHp;reflexivity. apply pow_pos_not_0;trivial. apply pow_pos_not_0;trivial. reflexivity. @@ -1352,11 +1352,11 @@ Theorem Field_simplify_eq_old_correct : Proof. intros l fe1 fe2 nfe1 nfe2 eq1 eq2 Hcrossprod Hcond; subst nfe1 nfe2. apply Fnorm_crossproduct; trivial. -match goal with +match goal with [ |- NPEeval l ?x == NPEeval l ?y] => rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec O nil l I (refl_equal nil) x (refl_equal (Nnorm O nil x))); - rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec + rewrite (ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec O nil l I (refl_equal nil) y (refl_equal (Nnorm O nil y))) end. trivial. @@ -1368,7 +1368,7 @@ Theorem Field_simplify_eq_correct : forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> + forall den, split (denum nfe1) (denum nfe2) = den -> NPphi_dev l (Nnorm n lmp (PEmul (num nfe1) (right den))) == NPphi_dev l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> PCond l (condition nfe1 ++ condition nfe2) -> @@ -1387,14 +1387,14 @@ repeat rewrite (ARmul_assoc ARth) in |- *. rewrite <-( let x := PEmul (num (Fnorm fe1)) (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in -ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l +ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l Hlpe (refl_equal (Nmk_monpol_list lpe)) x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. rewrite <-( let x := (PEmul (num (Fnorm fe2)) (rsplit_left (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in - ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l + ring_rw_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l Hlpe (refl_equal (Nmk_monpol_list lpe)) x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. simpl in Hcrossprod. @@ -1408,7 +1408,7 @@ Theorem Field_simplify_eq_pow_correct : forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> + forall den, split (denum nfe1) (denum nfe2) = den -> NPphi_pow l (Nnorm n lmp (PEmul (num nfe1) (right den))) == NPphi_pow l (Nnorm n lmp (PEmul (num nfe2) (left den))) -> PCond l (condition nfe1 ++ condition nfe2) -> @@ -1427,14 +1427,14 @@ repeat rewrite (ARmul_assoc ARth) in |- *. rewrite <-( let x := PEmul (num (Fnorm fe1)) (rsplit_right (split (denum (Fnorm fe1)) (denum (Fnorm fe2)))) in -ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l +ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l Hlpe (refl_equal (Nmk_monpol_list lpe)) x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. rewrite <-( let x := (PEmul (num (Fnorm fe2)) (rsplit_left (split (denum (Fnorm fe1)) (denum (Fnorm fe2))))) in - ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l + ring_rw_pow_correct Rsth Reqe ARth CRmorph pow_th cdiv_th get_sign_spec n lpe l Hlpe (refl_equal (Nmk_monpol_list lpe)) x (refl_equal (Nnorm n (Nmk_monpol_list lpe) x))) in Hcrossprod. simpl in Hcrossprod. @@ -1448,7 +1448,7 @@ Theorem Field_simplify_eq_pow_in_correct : forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> + forall den, split (denum nfe1) (denum nfe2) = den -> forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> FEeval l fe1 == FEeval l fe2 -> @@ -1461,7 +1461,7 @@ Proof. repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). - apply (@rmul_reg_l (NPEeval l (rsplit_common den))). + apply (@rmul_reg_l (NPEeval l (rsplit_common den))). intro Heq;apply N1. rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. @@ -1498,7 +1498,7 @@ forall n l lpe fe1 fe2, forall lmp, Nmk_monpol_list lpe = lmp -> forall nfe1, Fnorm fe1 = nfe1 -> forall nfe2, Fnorm fe2 = nfe2 -> - forall den, split (denum nfe1) (denum nfe2) = den -> + forall den, split (denum nfe1) (denum nfe2) = den -> forall np1, Nnorm n lmp (PEmul (num nfe1) (right den)) = np1 -> forall np2, Nnorm n lmp (PEmul (num nfe2) (left den)) = np2 -> FEeval l fe1 == FEeval l fe2 -> @@ -1511,7 +1511,7 @@ Proof. repeat (rewrite <- (norm_subst_ok Rsth Reqe ARth CRmorph pow_th);trivial). simpl. assert (N1 := Pcond_Fnorm _ _ (PCond_app_inv_l _ _ _ H7)). assert (N2 := Pcond_Fnorm _ _ (PCond_app_inv_r _ _ _ H7)). - apply (@rmul_reg_l (NPEeval l (rsplit_common den))). + apply (@rmul_reg_l (NPEeval l (rsplit_common den))). intro Heq;apply N1. rewrite (split_correct_l l (denum (Fnorm fe1)) (denum (Fnorm fe2))). rewrite H3. rewrite NPEmul_correct. simpl. ring [Heq]. @@ -1539,7 +1539,7 @@ Proof. rewrite (ARth.(ARmul_comm) (/ NPEeval l (denum (Fnorm fe2)))). repeat rewrite <- (AFth.(AFdiv_def)). repeat rewrite <- Fnorm_FEeval_PEeval;trivial. - apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). + apply (PCond_app_inv_r _ _ _ H7). apply (PCond_app_inv_l _ _ _ H7). Qed. @@ -1576,7 +1576,7 @@ Fixpoint Fcons (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := nil => cons e nil | cons a l1 => if PExpr_eq e a then l else cons a (Fcons e l1) end. - + Theorem PFcons_fcons_inv: forall l a l1, PCond l (Fcons a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. intros l a l1; elim l1; simpl Fcons; auto. @@ -1603,7 +1603,7 @@ Fixpoint Fcons0 (e:PExpr C) (l:list (PExpr C)) {struct l} : list (PExpr C) := if Peq ceqb (Nnorm O nil e) (Nnorm O nil a) then l else cons a (Fcons0 e l1) end. - + Theorem PFcons0_fcons_inv: forall l a l1, PCond l (Fcons0 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. intros l a l1; elim l1; simpl Fcons0; auto. @@ -1620,7 +1620,7 @@ split. generalize (PCond_cons_inv_l _ _ _ H1); simpl; auto. apply H0. generalize (PCond_cons_inv_r _ _ _ H1); simpl; auto. -clear get_sign get_sign_spec. +clear get_sign get_sign_spec. generalize Hp; case l0; simpl; intuition. Qed. @@ -1647,7 +1647,7 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). apply pow_pos_not_0;trivial. Qed. -Definition Pcond_simpl_gen := +Definition Pcond_simpl_gen := fcons_correct _ PFcons00_fcons_inv. @@ -1674,7 +1674,7 @@ Qed. Fixpoint Fcons1 (e:PExpr C) (l:list (PExpr C)) {struct e} : list (PExpr C) := match e with PEmul e1 e2 => Fcons1 e1 (Fcons1 e2 l) - | PEpow e _ => Fcons1 e l + | PEpow e _ => Fcons1 e l | PEopp e => if ceqb (copp cI) cO then absurd_PCond else Fcons1 e l | PEc c => if ceqb c cO then absurd_PCond else l | _ => Fcons0 e l @@ -1710,7 +1710,7 @@ intros l a; elim a; try (intros; apply PFcons0_fcons_inv; auto; fail). Qed. Definition Fcons2 e l := Fcons1 (PExpr_simp e) l. - + Theorem PFcons2_fcons_inv: forall l a l1, PCond l (Fcons2 a l1) -> ~ NPEeval l a == 0 /\ PCond l l1. unfold Fcons2 in |- *; intros l a l1 H; split; @@ -1720,7 +1720,7 @@ transitivity (NPEeval l a); trivial. apply PExpr_simp_correct. Qed. -Definition Pcond_simpl_complete := +Definition Pcond_simpl_complete := fcons_correct _ PFcons2_fcons_inv. End Fcons_simpl. @@ -1751,7 +1751,7 @@ End FieldAndSemiField. End MakeFieldPol. - Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth + Definition SF2AF R (rO rI:R) radd rmul rdiv rinv req Rsth (sf:semi_field_theory rO rI radd rmul rdiv rinv req) := mk_afield _ _ (SRth_ARth Rsth sf.(SF_SR)) diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index e664b3b767..b5384f80b4 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -27,7 +27,7 @@ Definition NotConstant := false. Lemma Zsth : Setoid_Theory Z (@eq Z). Proof (Eqsth Z). - + Lemma Zeqe : ring_eq_ext Zplus Zmult Zopp (@eq Z). Proof (Eq_ext Zplus Zmult Zopp). @@ -65,7 +65,7 @@ Section ZMORPHISM. Fixpoint gen_phiPOS (p:positive) : R := match p with - | xH => 1 + | xH => 1 | xO xH => (1 + 1) | xO p => (1 + 1) * (gen_phiPOS p) | xI xH => 1 + (1 +1) @@ -78,18 +78,18 @@ Section ZMORPHISM. | Z0 => 0 | Zneg p => -(gen_phiPOS1 p) end. - - Definition gen_phiZ z := + + Definition gen_phiZ z := match z with | Zpos p => gen_phiPOS p | Z0 => 0 | Zneg p => -(gen_phiPOS p) end. - Notation "[ x ]" := (gen_phiZ x). + Notation "[ x ]" := (gen_phiZ x). Definition get_signZ z := match z with - | Zneg p => Some (Zpos p) + | Zneg p => Some (Zpos p) | _ => None end. @@ -101,16 +101,16 @@ Section ZMORPHISM. simpl. unfold Zeq_bool. rewrite Zcompare_refl. trivial. Qed. - + Section ALMOST_RING. Variable ARth : almost_ring_theory 0 1 radd rmul rsub ropp req. Add Morphism rsub : rsub_ext3. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. - + Lemma same_gen : forall x, gen_phiPOS1 x == gen_phiPOS x. Proof. - induction x;simpl. + induction x;simpl. rewrite IHx;destruct x;simpl;norm. rewrite IHx;destruct x;simpl;norm. rrefl. @@ -155,28 +155,28 @@ Section ZMORPHISM. Add Morphism rsub : rsub_ext4. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac norm := gen_srewrite Rsth Reqe ARth. Ltac add_push := gen_add_push radd Rsth Reqe ARth. - + (*morphisms are extensionaly equal*) Lemma same_genZ : forall x, [x] == gen_phiZ1 x. Proof. destruct x;simpl; try rewrite (same_gen ARth);rrefl. Qed. - - Lemma gen_Zeqb_ok : forall x y, + + Lemma gen_Zeqb_ok : forall x y, Zeq_bool x y = true -> [x] == [y]. Proof. intros x y H. assert (H1 := Zeq_bool_eq x y H);unfold IDphi in H1. rewrite H1;rrefl. Qed. - + Lemma gen_phiZ1_add_pos_neg : forall x y, gen_phiZ1 match (x ?= y)%positive Eq with | Eq => Z0 | Lt => Zneg (y - x) | Gt => Zpos (x - y) - end + end == gen_phiPOS1 x + -gen_phiPOS1 y. Proof. intros x y. @@ -197,7 +197,7 @@ Section ZMORPHISM. Qed. Lemma match_compOpp : forall x (B:Type) (be bl bg:B), - match CompOpp x with Eq => be | Lt => bl | Gt => bg end + match CompOpp x with Eq => be | Lt => bl | Gt => bg end = match x with Eq => be | Lt => bg | Gt => bl end. Proof. destruct x;simpl;intros;trivial. Qed. @@ -209,7 +209,7 @@ Section ZMORPHISM. apply gen_phiZ1_add_pos_neg. replace Eq with (CompOpp Eq);trivial. rewrite <- Pcompare_antisym;simpl. - rewrite match_compOpp. + rewrite match_compOpp. rewrite (Radd_comm Rth). apply gen_phiZ1_add_pos_neg. rewrite (ARgen_phiPOS_add ARth); norm. @@ -227,11 +227,11 @@ Section ZMORPHISM. Proof. intros;subst;rrefl. Qed. (*proof that [.] satisfies morphism specifications*) - Lemma gen_phiZ_morph : - ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) + Lemma gen_phiZ_morph : + ring_morph 0 1 radd rmul rsub ropp req Z0 (Zpos xH) Zplus Zmult Zminus Zopp Zeq_bool gen_phiZ. - Proof. - assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) + Proof. + assert ( SRmorph : semi_morph 0 1 radd rmul req Z0 (Zpos xH) Zplus Zmult Zeq_bool gen_phiZ). apply mkRmorph;simpl;try rrefl. apply gen_phiZ_add. apply gen_phiZ_mul. apply gen_Zeqb_ok. @@ -251,7 +251,7 @@ Lemma Nth : semi_ring_theory N0 (Npos xH) Nplus Nmult (@eq N). Proof. constructor. exact Nplus_0_l. exact Nplus_comm. exact Nplus_assoc. exact Nmult_1_l. exact Nmult_0_l. exact Nmult_comm. exact Nmult_assoc. - exact Nmult_plus_distr_r. + exact Nmult_plus_distr_r. Qed. Definition Nsub := SRsub Nplus. @@ -260,11 +260,11 @@ Definition Nopp := (@SRopp N). Lemma Neqe : ring_eq_ext Nplus Nmult Nopp (@eq N). Proof (SReqe_Reqe Nseqe). -Lemma Nath : +Lemma Nath : almost_ring_theory N0 (Npos xH) Nplus Nmult Nsub Nopp (@eq N). Proof (SRth_ARth Nsth Nth). - -Definition Neq_bool (x y:N) := + +Definition Neq_bool (x y:N) := match Ncompare x y with | Eq => true | _ => false @@ -273,17 +273,17 @@ Definition Neq_bool (x y:N) := Lemma Neq_bool_ok : forall x y, Neq_bool x y = true -> x = y. Proof. intros x y;unfold Neq_bool. - assert (H:=Ncompare_Eq_eq x y); + assert (H:=Ncompare_Eq_eq x y); destruct (Ncompare x y);intros;try discriminate. - rewrite H;trivial. + rewrite H;trivial. Qed. Lemma Neq_bool_complete : forall x y, Neq_bool x y = true -> x = y. Proof. intros x y;unfold Neq_bool. - assert (H:=Ncompare_Eq_eq x y); + assert (H:=Ncompare_Eq_eq x y); destruct (Ncompare x y);intros;try discriminate. - rewrite H;trivial. + rewrite H;trivial. Qed. (**Same as above : definition of two,extensionaly equal, generic morphisms *) @@ -298,7 +298,7 @@ Section NMORPHISM. Add Setoid R req Rsth as R_setoid4. Ltac rrefl := gen_reflexivity Rsth. Variable SReqe : sring_eq_ext radd rmul req. - Variable SRth : semi_ring_theory 0 1 radd rmul req. + Variable SRth : semi_ring_theory 0 1 radd rmul req. Let ARth := SRth_ARth Rsth SRth. Let Reqe := SReqe_Reqe SReqe. Let ropp := (@SRopp R). @@ -315,15 +315,15 @@ Section NMORPHISM. match x with | N0 => 0 | Npos x => gen_phiPOS1 1 radd rmul x - end. + end. Definition gen_phiN x := match x with | N0 => 0 | Npos x => gen_phiPOS 1 radd rmul x - end. - Notation "[ x ]" := (gen_phiN x). - + end. + Notation "[ x ]" := (gen_phiN x). + Lemma same_genN : forall x, [x] == gen_phiN1 x. Proof. destruct x;simpl. rrefl. @@ -336,7 +336,7 @@ Section NMORPHISM. destruct x;destruct y;simpl;norm. apply (ARgen_phiPOS_add Rsth Reqe ARth). Qed. - + Lemma gen_phiN_mult : forall x y, [x * y] == [x] * [y]. Proof. intros x y;repeat rewrite same_genN. @@ -397,7 +397,7 @@ Fixpoint Nw_is0 (w : Nword) : bool := | nil => true | 0%N :: w' => Nw_is0 w' | _ => false - end. + end. Fixpoint Nweq_bool (w1 w2 : Nword) {struct w1} : bool := match w1, w2 with @@ -559,7 +559,7 @@ induction x; intros. Qed. (* Proof that [.] satisfies morphism specifications *) - Lemma gen_phiNword_morph : + Lemma gen_phiNword_morph : ring_morph 0 1 radd rmul rsub ropp req NwO NwI Nwadd Nwmul Nwsub Nwopp Nweq_bool gen_phiNword. constructor. @@ -585,7 +585,7 @@ Qed. End NWORDMORPHISM. Section GEN_DIV. - + Variables (R : Type) (rO : R) (rI : R) (radd : R -> R -> R) (rmul : R -> R -> R) (rsub : R -> R -> R) (ropp : R -> R) (req : R -> R -> Prop) (C : Type) (cO : C) (cI : C) @@ -595,8 +595,8 @@ Section GEN_DIV. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. Variable morph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. - - (* Useful tactics *) + + (* Useful tactics *) Add Setoid R req Rsth as R_set1. Ltac rrefl := gen_reflexivity Rsth. Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. @@ -605,7 +605,7 @@ Section GEN_DIV. Add Morphism rsub : rsub_ext. exact (ARsub_ext Rsth Reqe ARth). Qed. Ltac rsimpl := gen_srewrite Rsth Reqe ARth. - Definition triv_div x y := + Definition triv_div x y := if ceqb x y then (cI, cO) else (cO, x). @@ -715,7 +715,7 @@ End GEN_DIV. (* A simple tactic recognizing only 0 and 1. The inv_gen_phiX above are only optimisations that directly returns the reifid constant instead of resorting to the constant propagation of the simplification - algorithm. *) + algorithm. *) Ltac inv_gen_phi rO rI cO cI t := match t with | rO => cO @@ -769,10 +769,10 @@ Ltac gen_ring_sign morph sspec := match sspec with | None => match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req Z ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => constr:(@mkhypo (sign_theory copp ceqb get_signZ) get_signZ_th) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceqb ?phi => constr:(mkhypo (@get_sign_None_th C copp ceqb)) | _ => fail 2 "ring anomaly : default_sign_spec" @@ -782,24 +782,24 @@ Ltac gen_ring_sign morph sspec := Ltac default_div_spec set reqe arth morph := match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req Z ?c0 ?c1 Zplus Zmult ?csub ?copp ?ceq_b ?phi => constr:(mkhypo (Ztriv_div_th set phi)) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req N ?c0 ?c1 Nplus Nmult ?csub ?copp ?ceq_b ?phi => - constr:(mkhypo (Ntriv_div_th set phi)) - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + constr:(mkhypo (Ntriv_div_th set phi)) + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => constr:(mkhypo (triv_div_th set reqe arth morph)) - | _ => fail 1 "ring anomaly : default_sign_spec" + | _ => fail 1 "ring anomaly : default_sign_spec" end. Ltac gen_ring_div set reqe arth morph dspec := match dspec with - | None => default_div_spec set reqe arth morph + | None => default_div_spec set reqe arth morph | Some ?t => constr:(t) end. - + Ltac ring_elements set ext rspec pspec sspec dspec rk := let arth := coerce_to_almost_ring set ext rspec in let ext_r := coerce_to_ring_ext ext in @@ -813,10 +813,10 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk := | _ => fail 2 "ring anomaly" end | @Morphism ?m => - match type of m with - | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m - | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => - constr:(SRmorph_Rmorph set m) + match type of m with + | ring_morph _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => m + | @semi_morph _ _ _ _ _ _ _ _ _ _ _ _ _ => + constr:(SRmorph_Rmorph set m) | _ => fail 2 "ring anomaly" end | _ => fail 1 "ill-formed ring kind" @@ -832,27 +832,27 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk := Ltac ring_lemmas set ext rspec pspec sspec dspec rk := let gen_lemma2 := match pspec with - | None => constr:(ring_rw_correct) + | None => constr:(ring_rw_correct) | Some _ => constr:(ring_rw_pow_correct) end in ring_elements set ext rspec pspec sspec dspec rk ltac:(fun arth ext_r morph p_spec s_spec d_spec => match type of morph with - | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req + | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => - let gen_lemma2_0 := - constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth + let gen_lemma2_0 := + constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth C c0 c1 cadd cmul csub copp ceq_b phi morph) in match p_spec with - | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec => + | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec => let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in match d_spec with | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec => let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in match s_spec with - | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec => - let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in - let lemma1 := + | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec => + let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in + let lemma1 := constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in fun f => f arth ext_r morph lemma1 lemma2 | _ => fail 4 "ring: bad sign specification" @@ -878,7 +878,7 @@ Ltac isPcst t := | xO ?p => isPcst p | xH => constr:true (* nat -> positive *) - | P_of_succ_nat ?n => isnatcst n + | P_of_succ_nat ?n => isnatcst n | _ => constr:false end. diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index 60641bcf95..56473adb9c 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -1,5 +1,5 @@ Require Import Nnat. -Require Import ArithRing. +Require Import ArithRing. Require Export Ring Field. Require Import Rdefinitions. Require Import Rpow_def. @@ -99,7 +99,7 @@ rewrite H in |- *; intro. apply (Rlt_asym 0 0); trivial. Qed. -Lemma Zeq_bool_complete : forall x y, +Lemma Zeq_bool_complete : forall x y, InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp x = InitialRing.gen_phiZ 0%R 1%R Rplus Rmult Ropp y -> Zeq_bool x y = true. @@ -114,21 +114,21 @@ Qed. Lemma R_power_theory : power_theory 1%R Rmult (eq (A:=R)) nat_of_N pow. Proof. constructor. destruct n. reflexivity. - simpl. induction p;simpl. + simpl. induction p;simpl. rewrite ZL6. rewrite Rdef_pow_add;rewrite IHp. reflexivity. unfold nat_of_P;simpl;rewrite ZL6;rewrite Rdef_pow_add;rewrite IHp;trivial. rewrite Rmult_comm;apply Rmult_1_l. Qed. -Ltac Rpow_tac t := +Ltac Rpow_tac t := match isnatcst t with | false => constr:(InitialRing.NotConstant) | _ => constr:(N_of_nat t) - end. + end. -Add Field RField : Rfield +Add Field RField : Rfield (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). - + diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index d88470369d..faa83dedc2 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -18,21 +18,21 @@ Open Local Scope positive_scope. Import RingSyntax. Section MakeRingPol. - - (* Ring elements *) + + (* Ring elements *) Variable R:Type. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R->R). Variable req : R -> R -> Prop. - + (* Ring properties *) Variable Rsth : Setoid_Theory R req. Variable Reqe : ring_eq_ext radd rmul ropp req. Variable ARth : almost_ring_theory rO rI radd rmul rsub ropp req. - (* Coefficients *) + (* Coefficients *) Variable C: Type. Variable (cO cI: C) (cadd cmul csub : C->C->C) (copp : C->C). - Variable ceqb : C->C->bool. + Variable ceqb : C->C->bool. Variable phi : C -> R. Variable CRmorph : ring_morph rO rI radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. @@ -40,7 +40,7 @@ Section MakeRingPol. (* Power coefficients *) Variable Cpow : Set. Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. + Variable rpow : R -> Cpow -> R. Variable pow_th : power_theory rI rmul req Cp_phi rpow. (* division is ok *) @@ -54,12 +54,12 @@ Section MakeRingPol. Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "x == y" := (req x y). - (* C notations *) + (* C notations *) Notation "x +! y" := (cadd x y). Notation "x *! y " := (cmul x y). Notation "x -! y " := (csub x y). Notation "-! x" := (copp x). Notation " x ?=! y" := (ceqb x y). Notation "[ x ]" := (phi x). - (* Useful tactics *) + (* Useful tactics *) Add Setoid R req Rsth as R_set1. Ltac rrefl := gen_reflexivity Rsth. Add Morphism radd : radd_ext. exact (Radd_ext Reqe). Qed. @@ -93,20 +93,20 @@ Section MakeRingPol. *) Inductive Pol : Type := - | Pc : C -> Pol - | Pinj : positive -> Pol -> Pol + | Pc : C -> Pol + | Pinj : positive -> Pol -> Pol | PX : Pol -> positive -> Pol -> Pol. Definition P0 := Pc cO. Definition P1 := Pc cI. - - Fixpoint Peq (P P' : Pol) {struct P'} : bool := + + Fixpoint Peq (P P' : Pol) {struct P'} : bool := match P, P' with | Pc c, Pc c' => c ?=! c' - | Pinj j Q, Pinj j' Q' => + | Pinj j Q, Pinj j' Q' => match Pcompare j j' Eq with - | Eq => Peq Q Q' - | _ => false + | Eq => Peq Q Q' + | _ => false end | PX P i Q, PX P' i' Q' => match Pcompare i i' Eq with @@ -119,7 +119,7 @@ Section MakeRingPol. Notation " P ?== P' " := (Peq P P'). Definition mkPinj j P := - match P with + match P with | Pc _ => P | Pinj j' Q => Pinj ((j + j'):positive) Q | _ => Pinj j P @@ -132,7 +132,7 @@ Section MakeRingPol. | xI j => Pinj (xO j) P end. - Definition mkPX P i Q := + Definition mkPX P i Q := match P with | Pc c => if c ?=! cO then mkPinj xH Q else PX P i Q | Pinj _ _ => PX P i Q @@ -142,20 +142,20 @@ Section MakeRingPol. Definition mkXi i := PX P1 i P0. Definition mkX := mkXi 1. - + (** Opposite of addition *) - - Fixpoint Popp (P:Pol) : Pol := + + Fixpoint Popp (P:Pol) : Pol := match P with | Pc c => Pc (-! c) | Pinj j Q => Pinj j (Popp Q) | PX P i Q => PX (Popp P) i (Popp Q) end. - + Notation "-- P" := (Popp P). (** Addition et subtraction *) - + Fixpoint PaddC (P:Pol) (c:C) {struct P} : Pol := match P with | Pc c1 => Pc (c1 +! c) @@ -178,39 +178,39 @@ Section MakeRingPol. Fixpoint PaddI (j:positive) (P:Pol){struct P} : Pol := match P with | Pc c => mkPinj j (PaddC Q c) - | Pinj j' Q' => + | Pinj j' Q' => match ZPminus j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PaddI k Q') end - | PX P i Q' => + | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) | xO j => PX P i (PaddI (Pdouble_minus_one j) Q') | xI j => PX P i (PaddI (xO j) Q') - end + end end. Fixpoint PsubI (j:positive) (P:Pol){struct P} : Pol := match P with | Pc c => mkPinj j (PaddC (--Q) c) - | Pinj j' Q' => + | Pinj j' Q' => match ZPminus j' j with | Zpos k => mkPinj j (Pop (Pinj k Q') Q) | Z0 => mkPinj j (Pop Q' Q) | Zneg k => mkPinj j' (PsubI k Q') end - | PX P i Q' => + | PX P i Q' => match j with | xH => PX P i (Pop Q' Q) | xO j => PX P i (PsubI (Pdouble_minus_one j) Q') | xI j => PX P i (PsubI (xO j) Q') - end + end end. - + Variable P' : Pol. - + Fixpoint PaddX (i':positive) (P:Pol) {struct P} : Pol := match P with | Pc c => PX P' i' P @@ -245,7 +245,7 @@ Section MakeRingPol. end end. - + End PopI. Fixpoint Padd (P P': Pol) {struct P'} : Pol := @@ -255,12 +255,12 @@ Section MakeRingPol. | PX P' i' Q' => match P with | Pc c => PX P' i' (PaddC Q' c) - | Pinj j Q => + | Pinj j Q => match j with | xH => PX P' i' (Padd Q Q') | xO j => PX P' i' (Padd (Pinj (Pdouble_minus_one j) Q) Q') | xI j => PX P' i' (Padd (Pinj (xO j) Q) Q') - end + end | PX P i Q => match ZPminus i i' with | Zpos k => mkPX (Padd (PX P k P0) P') i' (Padd Q Q') @@ -278,12 +278,12 @@ Section MakeRingPol. | PX P' i' Q' => match P with | Pc c => PX (--P') i' (*(--(PsubC Q' c))*) (PaddC (--Q') c) - | Pinj j Q => + | Pinj j Q => match j with | xH => PX (--P') i' (Psub Q Q') | xO j => PX (--P') i' (Psub (Pinj (Pdouble_minus_one j) Q) Q') | xI j => PX (--P') i' (Psub (Pinj (xO j) Q) Q') - end + end | PX P i Q => match ZPminus i i' with | Zpos k => mkPX (Psub (PX P k P0) P') i' (Psub Q Q') @@ -293,8 +293,8 @@ Section MakeRingPol. end end. Notation "P -- P'" := (Psub P P'). - - (** Multiplication *) + + (** Multiplication *) Fixpoint PmulC_aux (P:Pol) (c:C) {struct P} : Pol := match P with @@ -306,14 +306,14 @@ Section MakeRingPol. Definition PmulC P c := if c ?=! cO then P0 else if c ?=! cI then P else PmulC_aux P c. - - Section PmulI. + + Section PmulI. Variable Pmul : Pol -> Pol -> Pol. Variable Q : Pol. Fixpoint PmulI (j:positive) (P:Pol) {struct P} : Pol := match P with | Pc c => mkPinj j (PmulC Q c) - | Pinj j' Q' => + | Pinj j' Q' => match ZPminus j' j with | Zpos k => mkPinj j (Pmul (Pinj k Q') Q) | Z0 => mkPinj j (Pmul Q' Q) @@ -326,7 +326,7 @@ Section MakeRingPol. | xI j' => mkPX (PmulI j P') i' (PmulI (xO j') Q') end end. - + End PmulI. (* A symmetric version of the multiplication *) @@ -338,10 +338,10 @@ Section MakeRingPol. match P with | Pc c => PmulC P'' c | Pinj j Q => - let QQ' := + let QQ' := match j with | xH => Pmul Q Q' - | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' + | xO j => Pmul (Pinj (Pdouble_minus_one j) Q) Q' | xI j => Pmul (Pinj (xO j) Q) Q' end in mkPX (Pmul P P') i' QQ' @@ -352,15 +352,15 @@ Section MakeRingPol. let PP' := Pmul P P' in (mkPX (mkPX PP' i P0 ++ QP') i' P0) ++ mkPX PQ' i QQ' end - end. + end. (* Non symmetric *) -(* +(* Fixpoint Pmul_aux (P P' : Pol) {struct P'} : Pol := match P' with | Pc c' => PmulC P c' | Pinj j' Q' => PmulI Pmul_aux Q' j' P - | PX P' i' Q' => + | PX P' i' Q' => (mkPX (Pmul_aux P P') i' P0) ++ (PmulI Pmul_aux Q' xH P) end. @@ -368,7 +368,7 @@ Section MakeRingPol. match P with | Pc c => PmulC P' c | Pinj j Q => PmulI Pmul_aux Q j P' - | PX P i Q => + | PX P i Q => (mkPX (Pmul_aux P P') i P0) ++ (PmulI Pmul_aux Q xH P') end. *) @@ -378,7 +378,7 @@ Section MakeRingPol. match P with | Pc c => Pc (c *! c) | Pinj j Q => Pinj j (Psquare Q) - | PX P i Q => + | PX P i Q => let twoPQ := Pmul P (mkPinj xH (PmulC Q (cI +! cI))) in let Q2 := Psquare Q in let P2 := Psquare P in @@ -386,10 +386,10 @@ Section MakeRingPol. end. (** Monomial **) - + Inductive Mon: Set := - mon0: Mon - | zmon: positive -> Mon -> Mon + mon0: Mon + | zmon: positive -> Mon -> Mon | vmon: positive -> Mon -> Mon. Fixpoint Mphi(l:list R) (M: Mon) {struct M} : R := @@ -399,7 +399,7 @@ Section MakeRingPol. | vmon i M1 => let x := hd 0 l in let xi := pow_pos rmul x i in - (Mphi (tail l) M1) * xi + (Mphi (tail l) M1) * xi end. Definition mkZmon j M := @@ -409,8 +409,8 @@ Section MakeRingPol. match j with xH => M | _ => mkZmon (Ppred j) M end. Definition mkVmon i M := - match M with - | mon0 => vmon i mon0 + match M with + | mon0 => vmon i mon0 | zmon j m => vmon i (zmon_pred j m) | vmon i' m => vmon (i+i') m end. @@ -462,35 +462,35 @@ Section MakeRingPol. Definition POneSubst (P1: Pol) (cM1: C * Mon) (P2: Pol): option Pol := let (c,M1) := cM1 in let (Q1,R1) := MFactor P1 c M1 in - match R1 with - (Pc c) => if c ?=! cO then None + match R1 with + (Pc c) => if c ?=! cO then None else Some (Padd Q1 (Pmul P2 R1)) | _ => Some (Padd Q1 (Pmul P2 R1)) end. Fixpoint PNSubst1 (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat) {struct n}: Pol := - match POneSubst P1 cM1 P2 with + match POneSubst P1 cM1 P2 with Some P3 => match n with S n1 => PNSubst1 P3 cM1 P2 n1 | _ => P3 end | _ => P1 end. Definition PNSubst (P1: Pol) (cM1: C * Mon) (P2: Pol) (n: nat): option Pol := - match POneSubst P1 cM1 P2 with + match POneSubst P1 cM1 P2 with Some P3 => match n with S n1 => Some (PNSubst1 P3 cM1 P2 n1) | _ => None end | _ => None end. - - Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: + + Fixpoint PSubstL1 (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: Pol := - match LM1 with + match LM1 with cons (M1,P2) LM2 => PSubstL1 (PNSubst1 P1 M1 P2 n) LM2 n | _ => P1 end. Fixpoint PSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (n: nat) {struct LM1}: option Pol := - match LM1 with + match LM1 with cons (M1,P2) LM2 => - match PNSubst P1 M1 P2 n with + match PNSubst P1 M1 P2 n with Some P3 => Some (PSubstL1 P3 LM2 n) | None => PSubstL P1 LM2 n end @@ -498,7 +498,7 @@ Section MakeRingPol. end. Fixpoint PNSubstL (P1: Pol) (LM1: list ((C * Mon) * Pol)) (m n: nat) {struct m}: Pol := - match PSubstL P1 LM1 n with + match PSubstL P1 LM1 n with Some P3 => match m with S m1 => PNSubstL P3 LM1 m1 n | _ => P3 end | _ => P1 end. @@ -509,10 +509,10 @@ Section MakeRingPol. match P with | Pc c => [c] | Pinj j Q => Pphi (jump j l) Q - | PX P i Q => + | PX P i Q => let x := hd 0 l in let xi := pow_pos rmul x i in - (Pphi l P) * xi + (Pphi (tail l) Q) + (Pphi l P) * xi + (Pphi (tail l) Q) end. Reserved Notation "P @ l " (at level 10, no associativity). @@ -546,8 +546,8 @@ Section MakeRingPol. rewrite Psucc_o_double_minus_one_eq_xO;trivial. simpl;trivial. Qed. - - Lemma Peq_ok : forall P P', + + Lemma Peq_ok : forall P P', (P ?== P') = true -> forall l, P@l == P'@ l. Proof. induction P;destruct P';simpl;intros;try discriminate;trivial. @@ -580,10 +580,10 @@ Section MakeRingPol. rewrite <-jump_Pplus;rewrite Pplus_comm;rrefl. Qed. - Let pow_pos_Pplus := + Let pow_pos_Pplus := pow_pos_Pplus rmul Rsth Reqe.(Rmul_ext) ARth.(ARmul_comm) ARth.(ARmul_assoc). - Lemma mkPX_ok : forall l P i Q, + Lemma mkPX_ok : forall l P i Q, (mkPX P i Q)@l == P@l*(pow_pos rmul (hd 0 l) i) + Q@(tail l). Proof. intros l P i Q;unfold mkPX. @@ -616,8 +616,8 @@ Section MakeRingPol. | -! ?x => rewrite ((morph_opp CRmorph) x) end end)); - rsimpl; simpl. - + rsimpl; simpl. + Lemma PaddC_ok : forall c P l, (PaddC P c)@l == P@l + [c]. Proof. induction P;simpl;intros;Esimpl;trivial. @@ -637,7 +637,7 @@ Section MakeRingPol. induction P;simpl;intros;Esimpl;trivial. rewrite IHP1;rewrite IHP2;rsimpl. mul_push ([c]);rrefl. - Qed. + Qed. Lemma PmulC_ok : forall c P l, (PmulC P c)@l == P@l * [c]. Proof. @@ -660,7 +660,7 @@ Section MakeRingPol. Ltac Esimpl2 := Esimpl; repeat (progress ( - match goal with + match goal with | |- context [(PaddC ?P ?c)@?l] => rewrite (PaddC_ok c P l) | |- context [(PsubC ?P ?c)@?l] => rewrite (PsubC_ok c P l) | |- context [(PmulC ?P ?c)@?l] => rewrite (PmulC_ok c P l) @@ -684,7 +684,7 @@ Section MakeRingPol. rewrite IHP2;simpl. rewrite jump_Pdouble_minus_one;rsimpl. rewrite IHP';rsimpl. - destruct P;simpl. + destruct P;simpl. Esimpl2;add_push [c];rrefl. destruct p0;simpl;Esimpl2. rewrite IHP'2;simpl. @@ -699,7 +699,7 @@ Section MakeRingPol. rewrite H;rewrite Pplus_comm. rewrite pow_pos_Pplus;rsimpl. add_push (P3 @ (tail l));rrefl. - assert (forall P k l, + assert (forall P k l, (PaddX Padd P'1 k P) @ l == P@l + P'1@l * pow_pos rmul (hd 0 l) k). induction P;simpl;intros;try apply (ARadd_comm ARth). destruct p2;simpl;try apply (ARadd_comm ARth). @@ -727,7 +727,7 @@ Section MakeRingPol. induction P;simpl;intros. Esimpl2;apply (ARadd_comm ARth). assert (H := ZPminus_spec p p0);destruct (ZPminus p p0). - rewrite H;Esimpl. rewrite IHP';rsimpl. + rewrite H;Esimpl. rewrite IHP';rsimpl. rewrite H;Esimpl. rewrite IHP';Esimpl. rewrite <- jump_Pplus;rewrite Pplus_comm;rrefl. rewrite H;Esimpl. rewrite IHP. @@ -736,8 +736,8 @@ Section MakeRingPol. rewrite IHP2;simpl;rsimpl. rewrite IHP2;simpl. rewrite jump_Pdouble_minus_one;rsimpl. - rewrite IHP';rsimpl. - destruct P;simpl. + rewrite IHP';rsimpl. + destruct P;simpl. repeat rewrite Popp_ok;Esimpl2;rsimpl;add_push [c];try rrefl. destruct p0;simpl;Esimpl2. rewrite IHP'2;simpl;rsimpl;add_push (P'1@l * (pow_pos rmul (hd 0 l) p));trivial. @@ -752,7 +752,7 @@ Section MakeRingPol. rewrite H;rewrite Pplus_comm. rewrite pow_pos_Pplus;rsimpl. add_push (P3 @ (tail l));rrefl. - assert (forall P k l, + assert (forall P k l, (PsubX Psub P'1 k P) @ l == P@l + - P'1@l * pow_pos rmul (hd 0 l) k). induction P;simpl;intros. rewrite Popp_ok;rsimpl;apply (ARadd_comm ARth);trivial. @@ -775,8 +775,8 @@ Section MakeRingPol. Qed. (* Proof for the symmetriv version *) - Lemma PmulI_ok : - forall P', + Lemma PmulI_ok : + forall P', (forall (P : Pol) (l : list R), (Pmul P P') @ l == P @ l * P' @ l) -> forall (P : Pol) (p : positive) (l : list R), (PmulI Pmul P' p P) @ l == P @ l * P' @ (jump p l). @@ -801,8 +801,8 @@ Section MakeRingPol. Qed. (* - Lemma PmulI_ok : - forall P', + Lemma PmulI_ok : + forall P', (forall (P : Pol) (l : list R), (Pmul_aux P P') @ l == P @ l * P' @ l) -> forall (P : Pol) (p : positive) (l : list R), (PmulI Pmul_aux P' p P) @ l == P @ l * P' @ (jump p l). @@ -846,7 +846,7 @@ Section MakeRingPol. Esimpl2. rewrite IHP'1;Esimpl2. assert (match p0 with | xI j => Pinj (xO j) P ** P'2 - | xO j => Pinj (Pdouble_minus_one j) P ** P'2 + | xO j => Pinj (Pdouble_minus_one j) P ** P'2 | 1 => P ** P'2 end @ (tail l) == P @ (jump p0 l) * P'2 @ (tail l)). destruct p0;simpl;rewrite IHP'2;Esimpl. @@ -886,8 +886,8 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. Mphi l (mkZmon j M) == Mphi l (zmon j M). intros M j l; case M; simpl; intros; rsimpl. Qed. - - Lemma zmon_pred_ok : forall M j l, + + Lemma zmon_pred_ok : forall M j l, Mphi (tail l) (zmon_pred j M) == Mphi l (zmon j M). Proof. destruct j; simpl;intros auto; rsimpl. @@ -902,7 +902,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. rewrite Pplus_comm;rewrite pow_pos_Pplus;rsimpl. Qed. - Lemma Mcphi_ok: forall P c l, + Lemma Mcphi_ok: forall P c l, let (Q,R) := CFactor P c in P@l == Q@l + (phi c) * (R@l). Proof. @@ -924,7 +924,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. rewrite (ARadd_comm ARth); rsimpl. Qed. - Lemma Mphi_ok: forall P (cM: C * Mon) l, + Lemma Mphi_ok: forall P (cM: C * Mon) l, let (c,M) := cM in let (Q,R) := MFactor P c M in P@l == Q@l + (phi c) * (Mphi l M) * (R@l). @@ -951,7 +951,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. rewrite (Pcompare_Eq_eq _ _ He). generalize (Hrec (c, M) (jump j l)); case (MFactor P c M); simpl; intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. - generalize (Hrec (c, (zmon (j -i) M)) (jump i l)); + generalize (Hrec (c, (zmon (j -i) M)) (jump i l)); case (MFactor P c (zmon (j -i) M)); simpl. intros P2 Q2 H; repeat rewrite mkPinj_ok; auto. rewrite <- (Pplus_minus _ _ (ZC2 _ _ He)). @@ -973,14 +973,14 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. apply (Radd_ext Reqe); rsimpl. rewrite (ARadd_comm ARth); rsimpl. intros j M1. - generalize (Hrec1 (c,zmon j M1) l); + generalize (Hrec1 (c,zmon j M1) l); case (MFactor P2 c (zmon j M1)). intros R1 S1 H1. - generalize (Hrec2 (c, zmon_pred j M1) (List.tail l)); + generalize (Hrec2 (c, zmon_pred j M1) (List.tail l)); case (MFactor Q2 c (zmon_pred j M1)); simpl. intros R2 S2 H2; rewrite H1; rewrite H2. repeat rewrite mkPX_ok; simpl. - rsimpl. + rsimpl. apply radd_ext; rsimpl. rewrite (ARadd_comm ARth); rsimpl. apply radd_ext; rsimpl. @@ -1002,7 +1002,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. repeat (rewrite <-(ARmul_assoc ARth)). apply rmul_ext; rsimpl. rewrite (ARmul_comm ARth); rsimpl. - generalize (Hrec1 (c, vmon (j - i) M1) l); + generalize (Hrec1 (c, vmon (j - i) M1) l); case (MFactor P2 c (vmon (j - i) M1)); simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. rewrite H; rsimpl; repeat rewrite mkPinj_ok; auto. @@ -1020,7 +1020,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. apply rmul_ext; rsimpl. rewrite <- pow_pos_Pplus. rewrite (Pplus_minus _ _ (ZC2 _ _ He)); rsimpl. - generalize (Hrec1 (c, mkZmon 1 M1) l); + generalize (Hrec1 (c, mkZmon 1 M1) l); case (MFactor P2 c (mkZmon 1 M1)); simpl; intros P3 Q3 H; repeat rewrite mkPinj_ok; auto. rewrite H; rsimpl. @@ -1064,7 +1064,7 @@ Lemma Pmul_ok : forall P P' l, (P**P')@l == P@l * P'@l. rewrite Padd_ok; rewrite PmulC_ok; rsimpl. intros i P5 H; rewrite H. intros HH H1; injection HH; intros; subst; rsimpl. - rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. + rewrite Padd_ok; rewrite PmulI_ok by (intros;apply Pmul_ok). rewrite H1; rsimpl. intros i P5 P6 H1 H2 H3; rewrite H1; rewrite H3. assert (P4 = Q1 ++ P3 ** PX i P5 P6). injection H2; intros; subst;trivial. @@ -1092,18 +1092,18 @@ Proof. injection H2; intros; subst; rsimpl. rewrite Padd_ok. rewrite Pmul_ok; rsimpl. - Qed. + Qed. *) Lemma PNSubst1_ok: forall n P1 M1 P2 l, [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == (PNSubst1 P1 M1 P2 n)@l. Proof. intros n; elim n; simpl; auto. intros P2 M1 P3 l H. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. intros P4 Hrec; rewrite (Hrec P4); auto; rsimpl. intros n1 Hrec P2 M1 P3 l H. - generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); + generalize (fun P4 => @POneSubst_ok P2 M1 P3 P4 l); case (POneSubst P2 M1 P3); [idtac | intros; rsimpl]. intros P4 Hrec1; rewrite (Hrec1 P4); auto; rsimpl. Qed. @@ -1112,15 +1112,15 @@ Proof. PNSubst P1 M1 P2 n = Some P3 -> [fst M1] * Mphi l (snd M1) == P2@l -> P1@l == P3@l. Proof. intros n P2 (cc, M1) P3 l P4; unfold PNSubst. - generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l); + generalize (fun P4 => @POneSubst_ok P2 (cc,M1) P3 P4 l); case (POneSubst P2 (cc,M1) P3); [idtac | intros; discriminate]. - intros P5 H1; case n; try (intros; discriminate). + intros P5 H1; case n; try (intros; discriminate). intros n1 H2; injection H2; intros; subst. rewrite <- PNSubst1_ok; auto. Qed. - Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop := - match LM1 with + Fixpoint MPcond (LM1: list (C * Mon * Pol)) (l: list R) {struct LM1} : Prop := + match LM1 with cons (M1,P2) LM2 => ([fst M1] * Mphi l (snd M1) == P2@l) /\ (MPcond LM2 l) | _ => True end. @@ -1189,7 +1189,7 @@ Proof. Strategy expand [PEeval]. (** Correctness proofs *) - + Lemma mkX_ok : forall p l, nth 0 p l == (mk_X p) @ l. Proof. destruct p;simpl;intros;Esimpl;trivial. @@ -1198,11 +1198,11 @@ Strategy expand [PEeval]. rewrite nth_Pdouble_minus_one;rrefl. Qed. - Ltac Esimpl3 := + Ltac Esimpl3 := repeat match goal with | |- context [(?P1 ++ ?P2)@?l] => rewrite (Padd_ok P2 P1 l) | |- context [(?P1 -- ?P2)@?l] => rewrite (Psub_ok P2 P1 l) - end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). + end;Esimpl2;try rrefl;try apply (ARadd_comm ARth). (* Power using the chinise algorithm *) (*Section POWER. @@ -1213,13 +1213,13 @@ Strategy expand [PEeval]. | xO p => subst_l (Psquare (Ppow_pos P p)) | xI p => subst_l (Pmul P (Psquare (Ppow_pos P p))) end. - + Definition Ppow_N P n := match n with | N0 => P1 | Npos p => Ppow_pos P p end. - + Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> forall P p, (Ppow_pos P p)@l == (pow_pos Pmul P p)@l. Proof. @@ -1228,28 +1228,28 @@ Strategy expand [PEeval]. repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. repeat rewrite Pmul_ok;rewrite Psquare_ok;rewrite IHp;rrefl. Qed. - + Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. Proof. destruct n;simpl. rrefl. apply Ppow_pos_ok. trivial. Qed. - + End POWER. *) Section POWER. Variable subst_l : Pol -> Pol. Fixpoint Ppow_pos (res P:Pol) (p:positive){struct p} : Pol := match p with - | xH => subst_l (Pmul res P) + | xH => subst_l (Pmul res P) | xO p => Ppow_pos (Ppow_pos res P p) P p | xI p => subst_l (Pmul (Ppow_pos (Ppow_pos res P p) P p) P) end. - + Definition Ppow_N P n := match n with | N0 => P1 | Npos p => Ppow_pos P1 P p end. - + Lemma Ppow_pos_ok : forall l, (forall P, subst_l P@l == P@l) -> forall res P p, (Ppow_pos res P p)@l == res@l * (pow_pos Pmul P p)@l. Proof. @@ -1257,11 +1257,11 @@ Section POWER. induction p;simpl;intros;try rewrite subst_l_ok; repeat rewrite Pmul_ok;repeat rewrite IHp. rsimpl. mul_push (P@l);rsimpl. rsimpl. rrefl. Qed. - + Lemma Ppow_N_ok : forall l, (forall P, subst_l P@l == P@l) -> forall P n, (Ppow_N P n)@l == (pow_N P1 Pmul P n)@l. Proof. destruct n;simpl. rrefl. rewrite Ppow_pos_ok by trivial. Esimpl. Qed. - + End POWER. (** Normalization and rewriting *) @@ -1276,86 +1276,86 @@ Section POWER. Fixpoint norm_aux (pe:PExpr) : Pol := match pe with | PEc c => Pc c - | PEX j => mk_X j + | PEX j => mk_X j | PEadd (PEopp pe1) pe2 => Psub (norm_aux pe2) (norm_aux pe1) - | PEadd pe1 (PEopp pe2) => + | PEadd pe1 (PEopp pe2) => Psub (norm_aux pe1) (norm_aux pe2) | PEadd pe1 pe2 => Padd (norm_aux pe1) (norm_aux pe2) | PEsub pe1 pe2 => Psub (norm_aux pe1) (norm_aux pe2) - | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) + | PEmul pe1 pe2 => Pmul (norm_aux pe1) (norm_aux pe2) | PEopp pe1 => Popp (norm_aux pe1) | PEpow pe1 n => Ppow_N (fun p => p) (norm_aux pe1) n end. Definition norm_subst pe := subst_l (norm_aux pe). - (* + (* Fixpoint norm_subst (pe:PExpr) : Pol := match pe with | PEc c => Pc c - | PEX j => subst_l (mk_X j) + | PEX j => subst_l (mk_X j) | PEadd (PEopp pe1) pe2 => Psub (norm_subst pe2) (norm_subst pe1) - | PEadd pe1 (PEopp pe2) => + | PEadd pe1 (PEopp pe2) => Psub (norm_subst pe1) (norm_subst pe2) | PEadd pe1 pe2 => Padd (norm_subst pe1) (norm_subst pe2) | PEsub pe1 pe2 => Psub (norm_subst pe1) (norm_subst pe2) - | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) + | PEmul pe1 pe2 => Pmul_subst (norm_subst pe1) (norm_subst pe2) | PEopp pe1 => Popp (norm_subst pe1) | PEpow pe1 n => Ppow_subst (norm_subst pe1) n end. - Lemma norm_subst_spec : + Lemma norm_subst_spec : forall l pe, MPcond lmp l -> - PEeval l pe == (norm_subst pe)@l. + PEeval l pe == (norm_subst pe)@l. Proof. - intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). + intros;assert (subst_l_ok:forall P, (subst_l P)@l == P@l). unfold subst_l;intros. rewrite <- PNSubstL_ok;trivial. rrefl. assert (Pms_ok:forall P1 P2, (Pmul_subst P1 P2)@l == P1@l*P2@l). intros;unfold Pmul_subst;rewrite subst_l_ok;rewrite Pmul_ok;rrefl. induction pe;simpl;Esimpl3. rewrite subst_l_ok;apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. + rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. rewrite IHpe1;rewrite IHpe2;rrefl. rewrite Pms_ok;rewrite IHpe1;rewrite IHpe2;rrefl. rewrite IHpe;rrefl. unfold Ppow_subst. rewrite Ppow_N_ok. trivial. rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; repeat rewrite Pmul_ok;rrefl. Qed. *) - Lemma norm_aux_spec : + Lemma norm_aux_spec : forall l pe, MPcond lmp l -> - PEeval l pe == (norm_aux pe)@l. + PEeval l pe == (norm_aux pe)@l. Proof. intros. induction pe;simpl;Esimpl3. apply mkX_ok. - rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. + rewrite IHpe1;rewrite IHpe2;destruct pe1;destruct pe2;Esimpl3. rewrite IHpe1;rewrite IHpe2;rrefl. rewrite IHpe1;rewrite IHpe2. rewrite Pmul_ok. rrefl. rewrite IHpe;rrefl. rewrite Ppow_N_ok by (intros;rrefl). rewrite pow_th.(rpow_pow_N). destruct n0;Esimpl3. - induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; + induction p;simpl;try rewrite IHp;try rewrite IHpe;repeat rewrite Pms_ok; repeat rewrite Pmul_ok;rrefl. Qed. - Lemma norm_subst_spec : + Lemma norm_subst_spec : forall l pe, MPcond lmp l -> PEeval l pe == (norm_subst pe)@l. Proof. intros;unfold norm_subst. unfold subst_l;rewrite <- PNSubstL_ok;trivial. apply norm_aux_spec. trivial. - Qed. - + Qed. + End NORM_SUBST_REC. - + Fixpoint interp_PElist (l:list R) (lpe:list (PExpr*PExpr)) {struct lpe} : Prop := match lpe with | nil => True - | (me,pe)::lpe => + | (me,pe)::lpe => match lpe with | nil => PEeval l me == PEeval l pe | _ => PEeval l me == PEeval l pe /\ interp_PElist l lpe @@ -1366,9 +1366,9 @@ Section POWER. match P with | Pc c => if (c ?=! cO) then None else Some (c, mon0) | Pinj j P => - match mon_of_pol P with + match mon_of_pol P with | None => None - | Some (c,m) => Some (c, mkZmon j m) + | Some (c,m) => Some (c, mkZmon j m) end | PX P i Q => if Peq Q P0 then @@ -1384,15 +1384,15 @@ Section POWER. | nil => nil | (me,pe)::lpe => match mon_of_pol (norm_subst 0 nil me) with - | None => mk_monpol_list lpe - | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe + | None => mk_monpol_list lpe + | Some m => (m,norm_subst 0 nil pe):: mk_monpol_list lpe end end. Lemma mon_of_pol_ok : forall P m, mon_of_pol P = Some m -> forall l, [fst m] * Mphi l (snd m) == P@l. Proof. - induction P;simpl;intros;Esimpl. + induction P;simpl;intros;Esimpl. assert (H1 := (morph_eq CRmorph) c cO). destruct (c ?=! cO). discriminate. @@ -1418,14 +1418,14 @@ Section POWER. discriminate. intros;discriminate. Qed. - - Lemma interp_PElist_ok : forall l lpe, + + Lemma interp_PElist_ok : forall l lpe, interp_PElist l lpe -> MPcond (mk_monpol_list lpe) l. Proof. induction lpe;simpl. trivial. destruct a;simpl;intros. assert (HH:=mon_of_pol_ok (norm_subst 0 nil p)); - destruct (mon_of_pol (norm_subst 0 nil p)). + destruct (mon_of_pol (norm_subst 0 nil p)). split. rewrite <- norm_subst_spec by exact I. destruct lpe;try destruct H;rewrite <- H; @@ -1440,7 +1440,7 @@ Section POWER. Proof. intros;apply norm_subst_spec. apply interp_PElist_ok;trivial. Qed. - + Lemma ring_correct : forall n l lpe pe1 pe2, interp_PElist l lpe -> (let lmp := mk_monpol_list lpe in @@ -1448,9 +1448,9 @@ Section POWER. PEeval l pe1 == PEeval l pe2. Proof. simpl;intros. - do 2 (rewrite (norm_subst_ok n l lpe);trivial). + do 2 (rewrite (norm_subst_ok n l lpe);trivial). apply Peq_ok;trivial. - Qed. + Qed. @@ -1467,23 +1467,23 @@ Section POWER. Variable mkopp_pow : R -> positive -> R. (* [mkmult_pow r x p] = r * x^p *) Variable mkmult_pow : R -> R -> positive -> R. - + Fixpoint mkmult_rec (r:R) (lm:list (R*positive)) {struct lm}: R := match lm with | nil => r - | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t + | cons (x,p) t => mkmult_rec (mkmult_pow r x p) t end. Definition mkmult1 lm := match lm with | nil => 1 - | cons (x,p) t => mkmult_rec (mkpow x p) t + | cons (x,p) t => mkmult_rec (mkpow x p) t end. Definition mkmultm1 lm := match lm with | nil => ropp rI - | cons (x,p) t => mkmult_rec (mkopp_pow x p) t + | cons (x,p) t => mkmult_rec (mkopp_pow x p) t end. Definition mkmult_c_pos c lm := @@ -1493,11 +1493,11 @@ Section POWER. Definition mkmult_c c lm := match get_sign c with | None => mkmult_c_pos c lm - | Some c' => + | Some c' => if c' ?=! cI then mkmultm1 (rev' lm) else mkmult_rec [c] (rev' lm) end. - + Definition mkadd_mult rP c lm := match get_sign c with | None => rP + mkmult_c_pos c lm @@ -1505,49 +1505,49 @@ Section POWER. end. Definition add_pow_list (r:R) n l := - match n with + match n with | N0 => l | Npos p => (r,p)::l end. - Fixpoint add_mult_dev + Fixpoint add_mult_dev (rP:R) (P:Pol) (fv:list R) (n:N) (lm:list (R*positive)) {struct P} : R := match P with - | Pc c => + | Pc c => let lm := add_pow_list (hd 0 fv) n lm in mkadd_mult rP c lm - | Pinj j Q => + | Pinj j Q => add_mult_dev rP Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) - | PX P i Q => + | PX P i Q => let rP := add_mult_dev rP P fv (Nplus (Npos i) n) lm in - if Q ?== P0 then rP + if Q ?== P0 then rP else add_mult_dev rP Q (tail fv) N0 (add_pow_list (hd 0 fv) n lm) end. - Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) + Fixpoint mult_dev (P:Pol) (fv : list R) (n:N) (lm:list (R*positive)) {struct P} : R := - (* P@l * (hd 0 l)^n * lm *) + (* P@l * (hd 0 l)^n * lm *) match P with | Pc c => mkmult_c c (add_pow_list (hd 0 fv) n lm) | Pinj j Q => mult_dev Q (jump j fv) N0 (add_pow_list (hd 0 fv) n lm) - | PX P i Q => + | PX P i Q => let rP := mult_dev P fv (Nplus (Npos i) n) lm in - if Q ?== P0 then rP - else + if Q ?== P0 then rP + else let lmq := add_pow_list (hd 0 fv) n lm in add_mult_dev rP Q (tail fv) N0 lmq - end. + end. Definition Pphi_avoid fv P := mult_dev P fv N0 nil. - + Fixpoint r_list_pow (l:list (R*positive)) : R := match l with | nil => rI - | cons (r,p) l => pow_pos rmul r p * r_list_pow l + | cons (r,p) l => pow_pos rmul r p * r_list_pow l end. Hypothesis mkpow_spec : forall r p, mkpow r p == pow_pos rmul r p. - Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). + Hypothesis mkopp_pow_spec : forall r p, mkopp_pow r p == - (pow_pos rmul r p). Hypothesis mkmult_pow_spec : forall r x p, mkmult_pow r x p == r * pow_pos rmul x p. Lemma mkmult_rec_ok : forall lm r, mkmult_rec r lm == r * r_list_pow lm. @@ -1571,7 +1571,7 @@ Section POWER. Lemma r_list_pow_rev : forall l, r_list_pow (rev' l) == r_list_pow l. Proof. - assert + assert (forall l lr : list (R * positive), r_list_pow (rev_append l lr) == r_list_pow lr * r_list_pow l). induction l;intros;simpl;Esimpl. destruct a;rewrite IHl;Esimpl. @@ -1583,7 +1583,7 @@ Section POWER. Proof. intros;unfold mkmult_c_pos;simpl. assert (H := (morph_eq CRmorph) c cI). - rewrite <- r_list_pow_rev; destruct (c ?=! cI). + rewrite <- r_list_pow_rev; destruct (c ?=! cI). rewrite H;trivial;Esimpl. apply mkmult1_ok. apply mkmult_rec_ok. Qed. @@ -1610,16 +1610,16 @@ Qed. rewrite mkmult_c_pos_ok;Esimpl. Qed. - Lemma add_pow_list_ok : + Lemma add_pow_list_ok : forall r n l, r_list_pow (add_pow_list r n l) == pow_N rI rmul r n * r_list_pow l. Proof. destruct n;simpl;intros;Esimpl. Qed. - Lemma add_mult_dev_ok : forall P rP fv n lm, + Lemma add_mult_dev_ok : forall P rP fv n lm, add_mult_dev rP P fv n lm == rP + P@fv*pow_N rI rmul (hd 0 fv) n * r_list_pow lm. Proof. - induction P;simpl;intros. + induction P;simpl;intros. rewrite mkadd_mult_ok. rewrite add_pow_list_ok; Esimpl. rewrite IHP. simpl. rewrite add_pow_list_ok; Esimpl. change (match P3 with @@ -1639,7 +1639,7 @@ Qed. rewrite IHP1. destruct n;simpl;Esimpl;rewrite pow_pos_Pplus;Esimpl. Qed. - Lemma mult_dev_ok : forall P fv n lm, + Lemma mult_dev_ok : forall P fv n lm, mult_dev P fv n lm == P@fv * pow_N rI rmul (hd 0 fv) n * r_list_pow lm. Proof. induction P;simpl;intros;Esimpl. @@ -1669,14 +1669,14 @@ Qed. End EVALUATION. - Definition Pphi_pow := - let mkpow x p := + Definition Pphi_pow := + let mkpow x p := match p with xH => x | _ => rpow x (Cp_phi (Npos p)) end in let mkopp_pow x p := ropp (mkpow x p) in let mkmult_pow r x p := rmul r (mkpow x p) in Pphi_avoid mkpow mkopp_pow mkmult_pow. - Lemma local_mkpow_ok : + Lemma local_mkpow_ok : forall (r : R) (p : positive), match p with | xI _ => rpow r (Cp_phi (Npos p)) @@ -1684,13 +1684,13 @@ Qed. | 1 => r end == pow_pos rmul r p. Proof. intros r p;destruct p;try rewrite pow_th.(rpow_pow_N);reflexivity. Qed. - + Lemma Pphi_pow_ok : forall P fv, Pphi_pow fv P == P@fv. Proof. unfold Pphi_pow;intros;apply Pphi_avoid_ok;intros;try rewrite local_mkpow_ok;rrefl. Qed. - Lemma ring_rw_pow_correct : forall n lH l, + Lemma ring_rw_pow_correct : forall n lH l, interp_PElist l lH -> forall lmp, mk_monpol_list lH = lmp -> forall pe npe, norm_subst n lmp pe = npe -> @@ -1701,22 +1701,22 @@ Qed. apply norm_subst_ok. trivial. Qed. - Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := + Fixpoint mkmult_pow (r x:R) (p: positive) {struct p} : R := match p with - | xH => r*x + | xH => r*x | xO p => mkmult_pow (mkmult_pow r x p) x p | xI p => mkmult_pow (mkmult_pow (r*x) x p) x p end. - + Definition mkpow x p := - match p with + match p with | xH => x | xO p => mkmult_pow x x (Pdouble_minus_one p) | xI p => mkmult_pow x x (xO p) end. - + Definition mkopp_pow x p := - match p with + match p with | xH => -x | xO p => mkmult_pow (-x) x (Pdouble_minus_one p) | xI p => mkmult_pow (-x) x (xO p) @@ -1726,31 +1726,31 @@ Qed. Lemma mkmult_pow_ok : forall p r x, mkmult_pow r x p == r*pow_pos rmul x p. Proof. - induction p;intros;simpl;Esimpl. + induction p;intros;simpl;Esimpl. repeat rewrite IHp;Esimpl. repeat rewrite IHp;Esimpl. Qed. - + Lemma mkpow_ok : forall p x, mkpow x p == pow_pos rmul x p. Proof. destruct p;simpl;intros;Esimpl. repeat rewrite mkmult_pow_ok;Esimpl. rewrite mkmult_pow_ok;Esimpl. - pattern x at 1;replace x with (pow_pos rmul x 1). - rewrite <- pow_pos_Pplus. + pattern x at 1;replace x with (pow_pos rmul x 1). + rewrite <- pow_pos_Pplus. rewrite <- Pplus_one_succ_l. rewrite Psucc_o_double_minus_one_eq_xO. simpl;Esimpl. trivial. Qed. - + Lemma mkopp_pow_ok : forall p x, mkopp_pow x p == - pow_pos rmul x p. Proof. destruct p;simpl;intros;Esimpl. repeat rewrite mkmult_pow_ok;Esimpl. rewrite mkmult_pow_ok;Esimpl. - pattern x at 1;replace x with (pow_pos rmul x 1). - rewrite <- pow_pos_Pplus. + pattern x at 1;replace x with (pow_pos rmul x 1). + rewrite <- pow_pos_Pplus. rewrite <- Pplus_one_succ_l. rewrite Psucc_o_double_minus_one_eq_xO. simpl;Esimpl. @@ -1765,7 +1765,7 @@ Qed. intros;apply mkmult_pow_ok. Qed. - Lemma ring_rw_correct : forall n lH l, + Lemma ring_rw_correct : forall n lH l, interp_PElist l lH -> forall lmp, mk_monpol_list lH = lmp -> forall pe npe, norm_subst n lmp pe = npe -> diff --git a/plugins/setoid_ring/Ring_tac.v b/plugins/setoid_ring/Ring_tac.v index 44e97bda77..e3eb418ad1 100644 --- a/plugins/setoid_ring/Ring_tac.v +++ b/plugins/setoid_ring/Ring_tac.v @@ -6,7 +6,7 @@ Require Import BinList. Require Import InitialRing. Require Import Quote. Declare ML Module "newring_plugin". - + (* adds a definition t' on the normal form of t and an hypothesis id stating that t = t' (tries to produces a proof as small as possible) *) @@ -58,8 +58,8 @@ Ltac OnMainSubgoal H ty := Ltac ProveLemmaHyp lemma := match type of lemma with forall x', ?x = x' -> _ => - (fun kont => - let x' := fresh "res" in + (fun kont => + let x' := fresh "res" in let H := fresh "res_eq" in compute_assertion H x' x; let lemma' := constr:(lemma x' H) in @@ -72,8 +72,8 @@ Ltac ProveLemmaHyp lemma := Ltac ProveLemmaHyps lemma := match type of lemma with forall x', ?x = x' -> _ => - (fun kont => - let x' := fresh "res" in + (fun kont => + let x' := fresh "res" in let H := fresh "res_eq" in compute_assertion H x' x; let lemma' := constr:(lemma x' H) in @@ -134,7 +134,7 @@ Ltac ReflexiveRewriteTactic FV_tac SYN_tac LEMMA_tac MAIN_tac fv terms := (* extend the atom list *) let fv := list_fold_left FV_tac fv terms in - let RW_tac lemma := + let RW_tac lemma := let fcons term CONT_tac := let expr := SYN_tac term fv in (ApplyLemmaThenAndCont lemma expr MAIN_tac CONT_tac) in @@ -154,8 +154,8 @@ Ltac FV_hypo_tac mkFV req lH := list_fold_right FV_hypo_r_tac fv lH. Ltac mkHyp_tac C req Reify lH := - let mkHyp h res := - match h with + let mkHyp h res := + match h with | @mkhypo (req ?r1 ?r2) _ => let pe1 := Reify r1 in let pe2 := Reify r2 in @@ -173,9 +173,9 @@ Ltac proofHyp_tac lH := match l with | nil => constr:(I) | cons ?h nil => get_proof h - | cons ?h ?tl => + | cons ?h ?tl => let l := get_proof h in - let r := bh tl in + let r := bh tl in constr:(conj l r) end in bh lH. @@ -213,22 +213,22 @@ Ltac FV Cst CstPow add mul sub opp pow t fv := in TFV t fv. (* syntaxification of ring expressions *) -Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := +Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := let rec mkP t := let f := match Cst t with | InitialRing.NotConstant => - match t with - | (radd ?t1 ?t2) => + match t with + | (radd ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEadd e1 e2) - | (rmul ?t1 ?t2) => + | (rmul ?t1 ?t2) => fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEmul e1 e2) - | (rsub ?t1 ?t2) => - fun _ => + | (rsub ?t1 ?t2) => + fun _ => let e1 := mkP t1 in let e2 := mkP t2 in constr:(PEsub e1 e2) | (ropp ?t1) => @@ -236,7 +236,7 @@ Ltac mkPolexpr C Cst CstPow radd rmul rsub ropp rpow t fv := let e1 := mkP t1 in constr:(PEopp e1) | (rpow ?t1 ?n) => match CstPow n with - | InitialRing.NotConstant => + | InitialRing.NotConstant => fun _ => let p := Find_at t fv in constr:(PEX C p) | ?c => fun _ => let e1 := mkP t1 in constr:(PEpow e1 c) end @@ -311,7 +311,7 @@ Ltac get_RingHypTac RNG := (* ring tactics *) Definition ring_subst_niter := (10*10*10)%nat. - + Ltac Ring RNG lemma lH := let req := get_Eq RNG in OnEquation req ltac:(fun lhs rhs => @@ -343,7 +343,7 @@ Ltac Ring_norm_gen f RNG lemma lH rl := let mkHyp := get_RingHypTac RNG in let mk_monpol := get_MonPol lemma in let fv := FV_hypo_tac mkFV ltac:(get_Eq RNG) lH in - let lemma_tac fv kont := + let lemma_tac fv kont := let lpe := mkHyp fv lH in let vlpe := fresh "list_hyp" in let vlmp := fresh "list_hyp_norm" in @@ -390,25 +390,25 @@ Ltac Ring_simplify_gen f RNG lH rl := end in let Heq := fresh "Heq" in intros Heq;clear Heq l; - Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl; + Ring_norm_gen f RNG (lemma ring_subst_niter) lH rl; get_Post RNG (). Ltac Ring_simplify := Ring_simplify_gen ltac:(fun H => rewrite H). -Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := +Tactic Notation (at level 0) "ring_simplify" constr_list(rl) := let G := Get_goal in ring_lookup (PackRing Ring_simplify) [] rl G. -Tactic Notation (at level 0) +Tactic Notation (at level 0) "ring_simplify" "[" constr_list(lH) "]" constr_list(rl) := let G := Get_goal in ring_lookup (PackRing Ring_simplify) [lH] rl G. (* MON DIEU QUE C'EST MOCHE !!!!!!!!!!!!! *) -Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= +Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= let G := Get_goal in - let t := type of H in + let t := type of H in let g := fresh "goal" in set (g:= G); generalize H;clear H; @@ -416,10 +416,10 @@ Tactic Notation "ring_simplify" constr_list(rl) "in" hyp(H):= intro H; unfold g;clear g. -Tactic Notation - "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= +Tactic Notation + "ring_simplify" "["constr_list(lH)"]" constr_list(rl) "in" hyp(H):= let G := Get_goal in - let t := type of H in + let t := type of H in let g := fresh "goal" in set (g:= G); generalize H;clear H; diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 531ab3ca5e..b3250a510f 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -39,7 +39,7 @@ Section Power. Notation "x * y " := (rmul x y). Notation "x == y" := (req x y). - Hypothesis mul_ext : + Hypothesis mul_ext : forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 * y1 == x2 * y2. Hypothesis mul_comm : forall x y, x * y == y * x. Hypothesis mul_assoc : forall x y z, x * (y * z) == (x * y) * z. @@ -79,11 +79,11 @@ Section Power. simpl. apply (Seq_refl _ _ Rsth). Qed. - Definition pow_N (x:R) (p:N) := + Definition pow_N (x:R) (p:N) := match p with | N0 => rI | Npos p => pow_pos x p - end. + end. Definition id_phi_N (x:N) : N := x. @@ -109,12 +109,12 @@ Section DEFINITIONS. SRadd_comm : forall n m, n + m == m + n ; SRadd_assoc : forall n m p, n + (m + p) == (n + m) + p; SRmul_1_l : forall n, 1*n == n; - SRmul_0_l : forall n, 0*n == 0; + SRmul_0_l : forall n, 0*n == 0; SRmul_comm : forall n m, n*m == m*n; SRmul_assoc : forall n m p, n*(m*p) == (n*m)*p; SRdistr_l : forall n m p, (n + m)*p == n*p + m*p }. - + (** Almost Ring *) (*Almost ring are no ring : Ropp_def is missing **) Record almost_ring_theory : Prop := mk_art { @@ -129,7 +129,7 @@ Section DEFINITIONS. ARopp_mul_l : forall x y, -(x * y) == -x * y; ARopp_add : forall x y, -(x + y) == -x + -y; ARsub_def : forall x y, x - y == x + -y - }. + }. (** Ring *) Record ring_theory : Prop := mk_rt { @@ -145,7 +145,7 @@ Section DEFINITIONS. }. (** Equality is extensional *) - + Record sring_eq_ext : Prop := mk_seqe { (* SRing operators are compatible with equality *) SRadd_ext : @@ -163,12 +163,12 @@ Section DEFINITIONS. Ropp_ext : forall x1 x2, x1 == x2 -> -x1 == -x2 }. - (** Interpretation morphisms definition*) + (** Interpretation morphisms definition*) Section MORPHISM. Variable C:Type. Variable (cO cI : C) (cadd cmul csub : C->C->C) (copp : C->C). Variable ceqb : C->C->bool. - (* [phi] est un morphisme de [C] dans [R] *) + (* [phi] est un morphisme de [C] dans [R] *) Variable phi : C -> R. Notation "x +! y" := (cadd x y). Notation "x -! y " := (csub x y). Notation "x *! y " := (cmul x y). Notation "-! x" := (copp x). @@ -180,7 +180,7 @@ Section DEFINITIONS. Smorph1 : [cI] == 1; Smorph_add : forall x y, [x +! y] == [x]+[y]; Smorph_mul : forall x y, [x *! y] == [x]*[y]; - Smorph_eq : forall x y, x?=!y = true -> [x] == [y] + Smorph_eq : forall x y, x?=!y = true -> [x] == [y] }. (* for rings*) @@ -191,7 +191,7 @@ Section DEFINITIONS. morph_sub : forall x y, [x -! y] == [x]-[y]; morph_mul : forall x y, [x *! y] == [x]*[y]; morph_opp : forall x, [-!x] == -[x]; - morph_eq : forall x y, x?=!y = true -> [x] == [y] + morph_eq : forall x y, x?=!y = true -> [x] == [y] }. Section SIGN. @@ -213,7 +213,7 @@ Section DEFINITIONS. }. End DIV. - End MORPHISM. + End MORPHISM. (** Identity is a morphism *) Variable Rsth : Setoid_Theory R req. @@ -231,8 +231,8 @@ Section DEFINITIONS. Section POWER. Variable Cpow : Set. Variable Cp_phi : N -> Cpow. - Variable rpow : R -> Cpow -> R. - + Variable rpow : R -> Cpow -> R. + Record power_theory : Prop := mkpow_th { rpow_pow_N : forall r n, req (rpow r (Cp_phi n)) (pow_N rI rmul r n) }. @@ -241,7 +241,7 @@ Section DEFINITIONS. Definition pow_N_th := mkpow_th id_phi_N (pow_N rI rmul) (pow_N_pow_N rI rmul Rsth). - + End DEFINITIONS. @@ -268,7 +268,7 @@ Section ALMOST_RING. Variable Rsth : Setoid_Theory R req. Add Setoid R req Rsth as R_setoid2. Ltac sreflexivity := apply (Seq_refl _ _ Rsth). - + Section SEMI_RING. Variable SReqe : sring_eq_ext radd rmul req. Add Morphism radd : radd_ext1. exact (SRadd_ext SReqe). Qed. @@ -278,7 +278,7 @@ Section ALMOST_RING. (** Every semi ring can be seen as an almost ring, by taking : -x = x and x - y = x + y *) Definition SRopp (x:R) := x. Notation "- x" := (SRopp x). - + Definition SRsub x y := x + -y. Notation "x - y " := (SRsub x y). Lemma SRopp_ext : forall x y, x == y -> -x == -y. @@ -296,7 +296,7 @@ Section ALMOST_RING. Lemma SRopp_add : forall x y, -(x + y) == -x + -y. Proof. intros;sreflexivity. Qed. - + Lemma SRsub_def : forall x y, x - y == x + -y. Proof. intros;sreflexivity. Qed. @@ -306,7 +306,7 @@ Section ALMOST_RING. (SRmul_1_l SRth) (SRmul_0_l SRth) (SRmul_comm SRth) (SRmul_assoc SRth) (SRdistr_l SRth) SRopp_mul_l SRopp_add SRsub_def). - + (** Identity morphism for semi-ring equipped with their almost-ring structure*) Variable reqb : R->R->bool. @@ -337,12 +337,12 @@ Section ALMOST_RING. Qed. End SEMI_RING. - + Variable Reqe : ring_eq_ext radd rmul ropp req. Add Morphism radd : radd_ext2. exact (Radd_ext Reqe). Qed. Add Morphism rmul : rmul_ext2. exact (Rmul_ext Reqe). Qed. Add Morphism ropp : ropp_ext2. exact (Ropp_ext Reqe). Qed. - + Section RING. Variable Rth : ring_theory 0 1 radd rmul rsub ropp req. @@ -368,7 +368,7 @@ Section ALMOST_RING. rewrite (Rth.(Radd_comm) (-x));rewrite (Ropp_def Rth). rewrite Rmul_0_l;rewrite (Radd_0_l Rth);sreflexivity. Qed. - + Lemma Ropp_add : forall x y, -(x + y) == -x + -y. Proof. intros x y;rewrite <- ((Radd_0_l Rth) (-(x+y))). @@ -387,7 +387,7 @@ Section ALMOST_RING. rewrite ((Radd_comm Rth) (-x) 0);rewrite (Radd_0_l Rth). apply (Radd_comm Rth). Qed. - + Lemma Ropp_opp : forall x, - -x == x. Proof. intros x; rewrite <- (Radd_0_l Rth (- -x)). @@ -402,7 +402,7 @@ Section ALMOST_RING. (Rmul_1_l Rth) Rmul_0_l (Rmul_comm Rth) (Rmul_assoc Rth) (Rdistr_l Rth) Ropp_mul_l Ropp_add (Rsub_def Rth)). - (** Every semi morphism between two rings is a morphism*) + (** Every semi morphism between two rings is a morphism*) Variable C : Type. Variable (cO cI : C) (cadd cmul csub: C->C->C) (copp : C -> C). Variable (ceq : C -> C -> Prop) (ceqb : C -> C -> bool). @@ -431,7 +431,7 @@ Section ALMOST_RING. rewrite (Smorph0 Smorph). rewrite (Radd_comm Rth (-[x])). apply (Radd_0_l Rth);sreflexivity. - Qed. + Qed. Lemma Smorph_sub : forall x y, [x -! y] == [x] - [y]. Proof. @@ -439,11 +439,11 @@ Section ALMOST_RING. rewrite (Smorph_add Smorph);rewrite Smorph_opp;sreflexivity. Qed. - Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req + Lemma Smorph_morph : ring_morph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi. Proof (mkmorph 0 1 radd rmul rsub ropp req cO cI cadd cmul csub copp ceqb phi - (Smorph0 Smorph) (Smorph1 Smorph) + (Smorph0 Smorph) (Smorph1 Smorph) (Smorph_add Smorph) Smorph_sub (Smorph_mul Smorph) Smorph_opp (Smorph_eq Smorph)). @@ -462,7 +462,7 @@ Qed. forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2. Proof. intros. - setoid_replace (x1 - y1) with (x1 + -y1). + setoid_replace (x1 - y1) with (x1 + -y1). setoid_replace (x2 - y2) with (x2 + -y2). rewrite H;rewrite H0;sreflexivity. apply (ARsub_def ARth). @@ -483,10 +483,10 @@ Qed. | match goal with | |- context [?z * (?x + ?y)] => rewrite ((ARmul_comm ARth) z (x+y)) end]. - + Lemma ARadd_0_r : forall x, (x + 0) == x. Proof. intros; mrewrite. Qed. - + Lemma ARmul_1_r : forall x, x * 1 == x. Proof. intros;mrewrite. Qed. @@ -495,7 +495,7 @@ Qed. Lemma ARdistr_r : forall x y z, z * (x + y) == z*x + z*y. Proof. - intros;mrewrite. + intros;mrewrite. repeat rewrite (ARth.(ARmul_comm) z);sreflexivity. Qed. @@ -516,7 +516,7 @@ Qed. intros;rewrite <-((ARmul_assoc ARth) x). rewrite ((ARmul_comm ARth) x);sreflexivity. Qed. - + Lemma ARmul_assoc2 : forall x y z, (y * x) * z == (y * z) * x. Proof. intros; repeat rewrite <- (ARmul_assoc ARth); @@ -592,17 +592,17 @@ Ltac gen_srewrite Rsth Reqe ARth := Ltac gen_add_push add Rsth Reqe ARth x := repeat (match goal with - | |- context [add (add ?y x) ?z] => + | |- context [add (add ?y x) ?z] => progress rewrite (ARadd_assoc2 Rsth Reqe ARth x y z) - | |- context [add (add x ?y) ?z] => + | |- context [add (add x ?y) ?z] => progress rewrite (ARadd_assoc1 Rsth ARth x y z) end). Ltac gen_mul_push mul Rsth Reqe ARth x := repeat (match goal with - | |- context [mul (mul ?y x) ?z] => + | |- context [mul (mul ?y x) ?z] => progress rewrite (ARmul_assoc2 Rsth Reqe ARth x y z) - | |- context [mul (mul x ?y) ?z] => + | |- context [mul (mul x ?y) ?z] => progress rewrite (ARmul_assoc1 Rsth ARth x y z) end). diff --git a/plugins/setoid_ring/ZArithRing.v b/plugins/setoid_ring/ZArithRing.v index 942915abf2..4cb5a05a38 100644 --- a/plugins/setoid_ring/ZArithRing.v +++ b/plugins/setoid_ring/ZArithRing.v @@ -21,7 +21,7 @@ Ltac Zcst t := end. Ltac isZpow_coef t := - match t with + match t with | Zpos ?p => isPcst p | Z0 => constr:true | _ => constr:false @@ -41,18 +41,18 @@ Ltac Zpow_tac t := Ltac Zpower_neg := repeat match goal with - | [|- ?G] => - match G with + | [|- ?G] => + match G with | context c [Zpower _ (Zneg _)] => let t := context c [Z0] in change t end - end. + end. Add Ring Zr : Zth (decidable Zeq_bool_eq, constants [Zcst], preprocess [Zpower_neg;unfold Zsucc], power_tac Zpower_theory [Zpow_tac], - (* The two following option are not needed, it is the default chose when the set of + (* The two following option are not needed, it is the default chose when the set of coefficiant is usual ring Z *) div (InitialRing.Ztriv_div_th (@Eqsth Z) (@IDphi Z)), sign get_signZ_th). diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index 14d10e54f6..c6d9bf44a0 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -108,9 +108,9 @@ let protect_tac_in map id = TACTIC EXTEND protect_fv - [ "protect_fv" string(map) "in" ident(id) ] -> + [ "protect_fv" string(map) "in" ident(id) ] -> [ protect_tac_in map id ] -| [ "protect_fv" string(map) ] -> +| [ "protect_fv" string(map) ] -> [ protect_tac map ] END;; @@ -128,8 +128,8 @@ TACTIC EXTEND closed_term END ;; -TACTIC EXTEND echo -| [ "echo" constr(t) ] -> +TACTIC EXTEND echo +| [ "echo" constr(t) ] -> [ Pp.msg (Termops.print_constr t); Tacinterp.eval_tactic (TacId []) ] END;; @@ -159,11 +159,11 @@ let ic c = let ty c = Typing.type_of (Global.env()) Evd.empty c let decl_constant na c = - mkConst(declare_constant (id_of_string na) (DefinitionEntry + mkConst(declare_constant (id_of_string na) (DefinitionEntry { const_entry_body = c; const_entry_type = None; const_entry_opaque = true; - const_entry_boxed = true}, + const_entry_boxed = true}, IsProof Lemma)) (* Calling a global tactic *) @@ -187,7 +187,7 @@ let ltac_record flds = let carg c = TacDynamic(dummy_loc,Pretyping.constr_in c) -let dummy_goal env = +let dummy_goal env = {Evd.it = Evd.make_evar (named_context_val env) mkProp; Evd.sigma = Evd.empty} @@ -228,7 +228,7 @@ let coq_eq = coq_constant "eq" let lapp f args = mkApp(Lazy.force f,args) -let dest_rel0 t = +let dest_rel0 t = match kind_of_term t with | App(f,args) when Array.length args >= 2 -> let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in @@ -321,9 +321,9 @@ let _ = add_map "ring" (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); - pol_cst "Pphi_pow", + pol_cst "Pphi_pow", (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); - (* PEeval: evaluate morphism and polynomial, protect ring + (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) @@ -379,7 +379,7 @@ let find_ring_structure env sigma l = (str"cannot find a declared ring structure for equality"++ spc()++str"\""++pr_constr req++str"\"")) *) -let _ = +let _ = Summary.declare_summary "tactic-new-ring-table" { Summary.freeze_function = (fun () -> !from_carrier,!from_relation,!from_name); @@ -397,11 +397,11 @@ let add_entry (sp,_kn) e = *) from_carrier := Cmap.add e.ring_carrier e !from_carrier; from_relation := Cmap.add e.ring_req e !from_relation; - from_name := Spmap.add sp e !from_name + from_name := Spmap.add sp e !from_name -let subst_th (_,subst,th) = - let c' = subst_mps subst th.ring_carrier in +let subst_th (_,subst,th) = + let c' = subst_mps subst th.ring_carrier in let eq' = subst_mps subst th.ring_req in let set' = subst_mps subst th.ring_setoid in let ext' = subst_mps subst th.ring_ext in @@ -454,11 +454,11 @@ let (theory_to_obj, obj_to_theory) = let setoid_of_relation env a r = let evm = Evd.empty in - try + try lapp coq_mk_Setoid - [|a ; r ; - Rewrite.get_reflexive_proof env evm a r ; - Rewrite.get_symmetric_proof env evm a r ; + [|a ; r ; + Rewrite.get_reflexive_proof env evm a r ; + Rewrite.get_symmetric_proof env evm a r ; Rewrite.get_transitive_proof env evm a r |] with Not_found -> error "cannot find setoid relation" @@ -551,9 +551,9 @@ let ring_equality (r,add,mul,opp,req) = error "ring opposite should be declared as a morphism" in let op_morph = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in - Flags.if_verbose + Flags.if_verbose msgnl - (str"Using setoid \""++pr_constr req++str"\""++spc()++ + (str"Using setoid \""++pr_constr req++str"\""++spc()++ str"and morphisms \""++pr_constr add_m_lem ++ str"\","++spc()++ str"\""++pr_constr mul_m_lem++ str"\""++spc()++str"and \""++pr_constr opp_m_lem++ @@ -562,13 +562,13 @@ let ring_equality (r,add,mul,opp,req) = | None -> (Flags.if_verbose msgnl - (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ + (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ str"and morphisms \""++pr_constr add_m_lem ++ str"\""++spc()++str"and \""++ pr_constr mul_m_lem++str"\""); op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) - + let build_setoid_params r add mul opp req eqth = match eqth with Some th -> th @@ -652,18 +652,18 @@ let make_hyp env c = let make_hyp_list env lH = let carrier = Lazy.force coq_hypo in - List.fold_right + List.fold_right (fun c l -> lapp coq_cons [|carrier; (make_hyp env c); l|]) lH (lapp coq_nil [|carrier|]) -let interp_power env pow = +let interp_power env pow = let carrier = Lazy.force coq_hypo in match pow with - | None -> + | None -> let t = ArgArg(dummy_loc, Lazy.force ltac_inv_morph_nothing) in (TacArg(TacCall(dummy_loc,t,[])), lapp coq_None [|carrier|]) - | Some (tac, spec) -> - let tac = + | Some (tac, spec) -> + let tac = match tac with | CstTac t -> Tacinterp.glob_tactic t | Closed lc -> @@ -674,8 +674,8 @@ let interp_power env pow = let interp_sign env sign = let carrier = Lazy.force coq_hypo in match sign with - | None -> lapp coq_None [|carrier|] - | Some spec -> + | None -> lapp coq_None [|carrier|] + | Some spec -> let spec = make_hyp env (ic spec) in lapp coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) @@ -683,8 +683,8 @@ let interp_sign env sign = let interp_div env div = let carrier = Lazy.force coq_hypo in match div with - | None -> lapp coq_None [|carrier|] - | Some spec -> + | None -> lapp coq_None [|carrier|] + | Some spec -> let spec = make_hyp env (ic spec) in lapp coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) @@ -695,12 +695,12 @@ let add_theory name rth eqth morphth cst_tac (pre,post) power sign div = let sigma = Evd.empty in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in let (sth,ext) = build_setoid_params r add mul opp req eqth in - let (pow_tac, pspec) = interp_power env power in + let (pow_tac, pspec) = interp_power env power in let sspec = interp_sign env sign in let dspec = interp_div env div in let rk = reflect_coeff morphth in let params = - exec_tactic env 5 (zltac "ring_lemmas") + exec_tactic env 5 (zltac "ring_lemmas") (List.map carg[sth;ext;rth;pspec;sspec;dspec;rk]) in let lemma1 = constr_of params.(3) in let lemma2 = constr_of params.(4) in @@ -757,7 +757,7 @@ VERNAC ARGUMENT EXTEND ring_mod | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ] | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ] | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] -> - [ Pow_spec (Closed l, pow_spec) ] + [ Pow_spec (Closed l, pow_spec) ] | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] -> [ Pow_spec (CstTac cst_tac, pow_spec) ] | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ] @@ -780,7 +780,7 @@ let process_ring_mods l = | Const_tac t -> set_once "tactic recognizing constants" cst_tac t | Pre_tac t -> set_once "preprocess tactic" pre t | Post_tac t -> set_once "postprocess tactic" post t - | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) + | Setoid(sth,ext) -> set_once "setoid" set (ic sth,ic ext) | Pow_spec(t,spec) -> set_once "power" power (t,spec) | Sign_spec t -> set_once "sign" sign t | Div_spec t -> set_once "div" div t) l; @@ -797,7 +797,7 @@ END (* The tactics consist then only in a lookup in the ring database and call the appropriate ltac. *) -let make_args_list rl t = +let make_args_list rl t = match rl with | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] | _ -> rl @@ -838,7 +838,7 @@ TACTIC EXTEND ring_lookup END - + (***********************************************************************) let new_field_path = @@ -861,12 +861,12 @@ let _ = add_map "field" (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); - pol_cst "Pphi_pow", + pol_cst "Pphi_pow", (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); - (* PEeval: evaluate morphism and polynomial, protect ring + (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); - (* FEeval: evaluate morphism, protect field + (* FEeval: evaluate morphism, protect field operations and make recursive call on the var map *) my_constant "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; @@ -958,7 +958,7 @@ let find_field_structure env sigma l = (str"cannot find a declared field structure for equality"++ spc()++str"\""++pr_constr req++str"\"")) *) -let _ = +let _ = Summary.declare_summary "tactic-new-field-table" { Summary.freeze_function = (fun () -> !field_from_carrier,!field_from_relation,!field_from_name); @@ -980,10 +980,10 @@ let add_field_entry (sp,_kn) e = *) field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier; field_from_relation := Cmap.add e.field_req e !field_from_relation; - field_from_name := Spmap.add sp e !field_from_name + field_from_name := Spmap.add sp e !field_from_name -let subst_th (_,subst,th) = - let c' = subst_mps subst th.field_carrier in +let subst_th (_,subst,th) = + let c' = subst_mps subst th.field_carrier in let eq' = subst_mps subst th.field_req in let thm1' = subst_mps subst th.field_ok in let thm2' = subst_mps subst th.field_simpl_eq_ok in @@ -1041,7 +1041,7 @@ let field_equality r inv req = with Not_found -> error "field inverse should be declared as a morphism" in inv_m_lem - + let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odiv = check_required_library (cdir@["Field_tac"]); let env = Global.env() in @@ -1051,7 +1051,7 @@ let add_field_theory name fth eqth morphth cst_tac inj (pre,post) power sign odi let (sth,ext) = build_setoid_params r add mul opp req eqth in let eqth = Some(sth,ext) in let _ = add_theory name rth eqth morphth cst_tac (None,None) power sign odiv in - let (pow_tac, pspec) = interp_power env power in + let (pow_tac, pspec) = interp_power env power in let sspec = interp_sign env sign in let dspec = interp_div env odiv in let inv_m = field_equality r inv req in @@ -1112,7 +1112,7 @@ let process_field_mods l = let cst_tac = ref None in let pre = ref None in let post = ref None in - let inj = ref None in + let inj = ref None in let sign = ref None in let power = ref None in let div = ref None in @@ -1131,7 +1131,7 @@ let process_field_mods l = (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) VERNAC COMMAND EXTEND AddSetoidField -| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> +| [ "Add" "Field" ident(id) ":" constr(t) field_mods(l) ] -> [ let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] END @@ -1163,6 +1163,6 @@ let field_lookup (f:glob_tactic_expr) lH rl t gl = TACTIC EXTEND field_lookup -| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> +| [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> [ let (t,l) = list_sep_last lt in field_lookup (fst f) lH l t ] END diff --git a/plugins/subtac/equations.ml4 b/plugins/subtac/equations.ml4 index 5ae15e00a1..ca4445cc2e 100644 --- a/plugins/subtac/equations.ml4 +++ b/plugins/subtac/equations.ml4 @@ -8,7 +8,7 @@ (************************************************************************) (*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4use: "pa_extend.cmo" i*) (* $Id$ *) @@ -40,18 +40,18 @@ type pat = | PInac of constr let coq_inacc = lazy (Coqlib.gen_constant "equations" ["Program";"Equality"] "inaccessible_pattern") - + let mkInac env c = mkApp (Lazy.force coq_inacc, [| Typing.type_of env Evd.empty c ; c |]) - + let rec constr_of_pat ?(inacc=true) env = function | PRel i -> mkRel i - | PCstr (c, p) -> + | PCstr (c, p) -> let c' = mkConstruct c in mkApp (c', Array.of_list (constrs_of_pats ~inacc env p)) - | PInac r -> + | PInac r -> if inacc then try mkInac env r with _ -> r else r - + and constrs_of_pats ?(inacc=true) env l = map (constr_of_pat ~inacc env) l let rec pat_vars = function @@ -59,8 +59,8 @@ let rec pat_vars = function | PCstr (c, p) -> pats_vars p | PInac _ -> Intset.empty -and pats_vars l = - fold_left (fun vars p -> +and pats_vars l = + fold_left (fun vars p -> let pvars = pat_vars p in let inter = Intset.inter pvars vars in if inter = Intset.empty then @@ -70,7 +70,7 @@ and pats_vars l = Intset.empty l let rec pats_of_constrs l = map pat_of_constr l -and pat_of_constr c = +and pat_of_constr c = match kind_of_term c with | Rel i -> PRel i | App (f, [| a ; c |]) when eq_constr f (Lazy.force coq_inacc) -> @@ -95,10 +95,10 @@ let rec pmatch p c = and pmatches pl l = match pl, l with | [], [] -> [] - | hd :: tl, hd' :: tl' -> + | hd :: tl, hd' :: tl' -> pmatch hd hd' @ pmatches tl tl' | _ -> raise Conflict - + let pattern_matches pl l = try Some (pmatches pl l) with Conflict -> None let rec pinclude p c = @@ -108,59 +108,59 @@ let rec pinclude p c = | PInac _, _ -> true | _, PInac _ -> true | _, _ -> false - + and pincludes pl l = match pl, l with | [], [] -> true - | hd :: tl, hd' :: tl' -> + | hd :: tl, hd' :: tl' -> pinclude hd hd' && pincludes tl tl' | _ -> false - + let pattern_includes pl l = pincludes pl l (** Specialize by a substitution. *) let subst_tele s = replace_vars (List.map (fun (id, _, t) -> id, t) s) -let subst_rel_subst k s c = +let subst_rel_subst k s c = let rec aux depth c = match kind_of_term c with - | Rel n -> - let k = n - depth in - if k >= 0 then + | Rel n -> + let k = n - depth in + if k >= 0 then try lift depth (snd (assoc k s)) with Not_found -> c else c | _ -> map_constr_with_binders succ aux depth c in aux k c - + let subst_context s ctx = - let (_, ctx') = fold_right + let (_, ctx') = fold_right (fun (id, b, t) (k, ctx') -> (succ k, (id, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx')) ctx (0, []) in ctx' -let subst_rel_context k cstr ctx = - let (_, ctx') = fold_right +let subst_rel_context k cstr ctx = + let (_, ctx') = fold_right (fun (id, b, t) (k, ctx') -> (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx')) ctx (k, []) in ctx' -let rec lift_pat n k p = +let rec lift_pat n k p = match p with | PRel i -> if i >= k then PRel (i + n) else p | PCstr(c, pl) -> PCstr (c, lift_pats n k pl) | PInac r -> PInac (liftn n k r) - + and lift_pats n k = map (lift_pat n k) -let rec subst_pat env k t p = +let rec subst_pat env k t p = match p with - | PRel i -> + | PRel i -> if i = k then t else if i > k then PRel (pred i) else p @@ -170,9 +170,9 @@ let rec subst_pat env k t p = and subst_pats env k t = map (subst_pat env k t) -let rec specialize s p = +let rec specialize s p = match p with - | PRel i -> + | PRel i -> if mem_assoc i s then let b, t = assoc i s in if b then PInac t @@ -190,10 +190,10 @@ let specialize_patterns = function | s -> specialize_pats s let specialize_rel_context s ctx = - snd (fold_right (fun (n, b, t) (k, ctx) -> + snd (fold_right (fun (n, b, t) (k, ctx) -> (succ k, (n, Option.map (subst_rel_subst k s) b, subst_rel_subst k s t) :: ctx)) ctx (0, [])) - + let lift_contextn n k sign = let rec liftrec k = function | (na,c,t)::sign -> @@ -202,7 +202,7 @@ let lift_contextn n k sign = in liftrec (rel_context_length sign + k) sign -type program = +type program = signature * clause list and signature = identifier * rel_context * constr @@ -211,16 +211,16 @@ and clause = lhs * (constr, int) rhs and lhs = rel_context * identifier * pat list -and ('a, 'b) rhs = +and ('a, 'b) rhs = | Program of 'a | Empty of 'b -type splitting = +type splitting = | Compute of clause | Split of lhs * int * inductive_family * unification_result array * splitting option array - -and unification_result = + +and unification_result = rel_context * int * constr * pat * substitution option and substitution = (int * (bool * constr)) list @@ -236,14 +236,14 @@ let split_solves split prob = | Compute (lhs, rhs) -> lhs = prob | Split (lhs, id, indf, us, ls) -> lhs = prob -let ids_of_constr c = - let rec aux vars c = +let ids_of_constr c = + let rec aux vars c = match kind_of_term c with | Var id -> Idset.add id vars | _ -> fold_constr aux vars c in aux Idset.empty c -let ids_of_constrs = +let ids_of_constrs = fold_left (fun acc x -> Idset.union (ids_of_constr x) acc) Idset.empty let idset_of_list = @@ -252,8 +252,8 @@ let idset_of_list = let intset_of_list = fold_left (fun s x -> Intset.add x s) Intset.empty -let solves split (delta, id, pats as prob) = - split_solves split prob && +let solves split (delta, id, pats as prob) = + split_solves split prob && Intset.equal (pats_vars pats) (intset_of_list (map destRel (rels_of_tele delta))) let check_judgment ctx c t = @@ -261,7 +261,7 @@ let check_judgment ctx c t = let check_context env ctx = fold_right - (fun (_, _, t as decl) env -> + (fun (_, _, t as decl) env -> ignore(Typing.sort_of env Evd.empty t); push_rel decl env) ctx env @@ -270,7 +270,7 @@ let split_context n c = match before with | hd :: tl -> after, hd, tl | [] -> raise (Invalid_argument "split_context") - + let split_tele n (ctx : rel_context) = let rec aux after n l = match n, l with @@ -284,12 +284,12 @@ let rec add_var_subst env subst n c = let t = assoc n subst in if eq_constr t c then subst else unify env subst t c - else + else let rel = mkRel n in if rel = c then subst else if dependent rel c then raise Conflict else (n, c) :: subst - + and unify env subst x y = match kind_of_term x, kind_of_term y with | Rel n, _ -> add_var_subst env subst n y @@ -298,7 +298,7 @@ and unify env subst x y = unify_constrs env subst (Array.to_list l) (Array.to_list l') | _, _ -> if eq_constr x y then subst else raise Conflict -and unify_constrs (env : env) subst l l' = +and unify_constrs (env : env) subst l l' = if List.length l = List.length l' then fold_left2 (unify env) subst l l' else raise Conflict @@ -306,10 +306,10 @@ and unify_constrs (env : env) subst l l' = let fold_rel_context_with_binders f ctx init = snd (List.fold_right (fun decl (depth, acc) -> (succ depth, f depth decl acc)) ctx (0, init)) - + let dependent_rel_context (ctx : rel_context) k = fold_rel_context_with_binders - (fun depth (n,b,t) acc -> + (fun depth (n,b,t) acc -> let r = mkRel (depth + k) in acc || dependent r t || (match b with @@ -319,14 +319,14 @@ let dependent_rel_context (ctx : rel_context) k = let liftn_between n k p c = let rec aux depth c = match kind_of_term c with - | Rel i -> + | Rel i -> if i <= depth then c else if i-depth > p then c else mkRel (i - n) | _ -> map_constr_with_binders succ aux depth c in aux k c - -let liftn_rel_context n k sign = + +let liftn_rel_context n k sign = let rec liftrec k = function | (na,c,t)::sign -> (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) @@ -348,7 +348,7 @@ let reduce_rel_context (ctx : rel_context) (subst : (int * (bool * constr)) list let s = rev s in let s' = map (fun (korig, (b, knew)) -> korig, (b, substl s knew)) subst in s', ctx' - + (* Compute the transitive closure of the dependency relation for a term in a context *) let rec dependencies_of_rel ctx k = @@ -356,12 +356,12 @@ let rec dependencies_of_rel ctx k = let b = Option.map (lift k) b and t = lift k t in let bdeps = match b with Some b -> dependencies_of_term ctx b | None -> Intset.empty in Intset.union (Intset.singleton k) (Intset.union bdeps (dependencies_of_term ctx t)) - + and dependencies_of_term ctx t = let rels = free_rels t in Intset.fold (fun i -> Intset.union (dependencies_of_rel ctx i)) rels Intset.empty -let subst_telescope k cstr ctx = +let subst_telescope k cstr ctx = let (_, ctx') = fold_left (fun (k, ctx') (id, b, t) -> (succ k, (id, Option.map (substnl [cstr] k) b, substnl [cstr] k t) :: ctx')) @@ -374,9 +374,9 @@ let lift_telescope n k sign = (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (succ k) sign) | [] -> [] in liftrec k sign - + type ('a,'b) either = Inl of 'a | Inr of 'b - + let strengthen (ctx : rel_context) (t : constr) : rel_context * rel_context * (int * (int, int) either) list = let rels = dependencies_of_term ctx t in let len = length ctx in @@ -390,7 +390,7 @@ let strengthen (ctx : rel_context) (t : constr) : rel_context * rel_context * (i else aux (succ k) n (subst_telescope 0 mkProp acc) (succ m) (decl :: rest) ((k, Inr m) :: s) ctx' | [] -> rev acc, rev rest, s in aux 1 1 [] 1 [] [] ctx - + let merge_subst (ctx', rest, s) = let lenrest = length rest in map (function (k, Inl x) -> (k, (false, mkRel (x + lenrest))) | (k, Inr x) -> k, (false, mkRel x)) s @@ -412,7 +412,7 @@ let substitute_in_ctx n c ctx = if k = n then rev after @ (name, Some c, t) :: before else aux (succ k) (decl :: after) before in aux 1 [] ctx - + let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) list) (cursubst : (int * (bool * constr)) list) = match cursubst with | [] -> ctx, substacc @@ -423,7 +423,7 @@ let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) lis let t' = lift (-k) t in let ctx' = substitute_in_ctx k t' ctx in reduce_subst ctx' substacc rest - else (* The term refers to variables declared after [k], so we have + else (* The term refers to variables declared after [k], so we have to move these dependencies before [k]. *) let (minctx, ctxrest, subst as str) = strengthen ctx t in match assoc k subst with @@ -439,8 +439,8 @@ let rec reduce_subst (ctx : rel_context) (substacc : (int * (bool * constr)) lis in map substsubst ((k, (b, t)) :: rest) in reduce_subst ctx' (compose_subst s substacc) rest' (* (compose_subst s ((k, (b, t)) :: rest)) *) - - + + let substituted_context (subst : (int * constr) list) (ctx : rel_context) = let _, subst = fold_left (fun (k, s) _ -> @@ -452,7 +452,7 @@ let substituted_context (subst : (int * constr) list) (ctx : rel_context) = in let ctx', subst' = reduce_subst ctx subst subst in reduce_rel_context ctx' subst' - + let unify_type before ty = try let envb = push_rel_context before (Global.env()) in @@ -460,11 +460,11 @@ let unify_type before ty = let ind, params = dest_ind_family indf in let vs = map (Reduction.whd_betadeltaiota envb) args in let cstrs = Inductiveops.arities_of_constructors envb ind in - let cstrs = + let cstrs = Array.mapi (fun i ty -> let ty = prod_applist ty params in let ctx, ty = decompose_prod_assum ty in - let ctx, ids = + let ctx, ids = let ids = ids_of_rel_context ctx in fold_right (fun (n, b, t as decl) (acc, ids) -> match n with Name _ -> (decl :: acc), ids @@ -480,8 +480,8 @@ let unify_type before ty = env', ctx, constr, constrpat, (* params @ *)args) cstrs in - let res = - Array.map (fun (env', ctxc, c, cpat, us) -> + let res = + Array.map (fun (env', ctxc, c, cpat, us) -> let _beforelen = length before and ctxclen = length ctxc in let fullctx = ctxc @ before in try @@ -490,7 +490,7 @@ let unify_type before ty = let subst = unify_constrs fullenv [] vs' us in let subst', ctx' = substituted_context subst fullctx in (ctx', ctxclen, c, cpat, Some subst') - with Conflict -> + with Conflict -> (fullctx, ctxclen, c, cpat, None)) cstrs in Some (res, indf) with Not_found -> (* not an inductive type *) @@ -502,35 +502,35 @@ let rec id_of_rel n l = | n, _ :: tl -> id_of_rel (pred n) tl | _, _ -> raise (Invalid_argument "id_of_rel") -let constrs_of_lhs ?(inacc=true) env (ctx, _, pats) = +let constrs_of_lhs ?(inacc=true) env (ctx, _, pats) = constrs_of_pats ~inacc (push_rel_context ctx env) pats - -let rec valid_splitting (f, delta, t, pats) tree = - split_solves tree (delta, f, pats) && + +let rec valid_splitting (f, delta, t, pats) tree = + split_solves tree (delta, f, pats) && valid_splitting_tree (f, delta, t) tree - + and valid_splitting_tree (f, delta, t) = function - | Compute (lhs, Program rhs) -> - let subst = constrs_of_lhs ~inacc:false (Global.env ()) lhs in + | Compute (lhs, Program rhs) -> + let subst = constrs_of_lhs ~inacc:false (Global.env ()) lhs in ignore(check_judgment (pi1 lhs) rhs (substl subst t)); true - | Compute ((ctx, id, lhs), Empty split) -> + | Compute ((ctx, id, lhs), Empty split) -> let before, (x, _, ty), after = split_context split ctx in - let unify = + let unify = match unify_type before ty with - | Some (unify, _) -> unify + | Some (unify, _) -> unify | None -> assert false in array_for_all (fun (_, _, _, _, x) -> x = None) unify - - | Split ((ctx, id, lhs), rel, indf, unifs, ls) -> + + | Split ((ctx, id, lhs), rel, indf, unifs, ls) -> let before, (id, _, ty), after = split_tele (pred rel) ctx in let unify, indf' = Option.get (unify_type before ty) in assert(indf = indf'); if not (array_exists (fun (_, _, _, _, x) -> x <> None) unify) then false else - let ok, splits = - Array.fold_left (fun (ok, splits as acc) (ctx', ctxlen, cstr, cstrpat, subst) -> + let ok, splits = + Array.fold_left (fun (ok, splits as acc) (ctx', ctxlen, cstr, cstrpat, subst) -> match subst with | None -> acc | Some subst -> @@ -540,23 +540,23 @@ and valid_splitting_tree (f, delta, t) = function (* ignore(check_context env' (subst_context subst before)); *) (* true *) (* in *) - let newdelta = - subst_context subst (subst_rel_context 0 cstr + let newdelta = + subst_context subst (subst_rel_context 0 cstr (lift_contextn ctxlen 0 after)) @ before in let liftpats = lift_pats ctxlen rel lhs in let newpats = specialize_patterns subst (subst_pats (Global.env ()) rel cstrpat liftpats) in (ok, (f, newdelta, newpats) :: splits)) (true, []) unify in - let subst = List.map2 (fun (id, _, _) x -> out_name id, x) delta - (constrs_of_pats ~inacc:false (Global.env ()) lhs) + let subst = List.map2 (fun (id, _, _) x -> out_name id, x) delta + (constrs_of_pats ~inacc:false (Global.env ()) lhs) in let t' = replace_vars subst t in - ok && for_all - (fun (f, delta', pats') -> + ok && for_all + (fun (f, delta', pats') -> array_exists (function None -> false | Some tree -> valid_splitting (f, delta', t', pats') tree) ls) splits - -let valid_tree (f, delta, t) tree = + +let valid_tree (f, delta, t) tree = valid_splitting (f, delta, t, patvars_of_tele delta) tree let is_constructor c = @@ -579,12 +579,12 @@ let find_split (_, _, curpats : lhs) (_, _, patcs : lhs) = and find_split_pats curpats patcs = assert(List.length curpats = List.length patcs); - fold_left2 (fun acc -> + fold_left2 (fun acc -> match acc with | None -> find_split_pat | _ -> fun _ _ -> acc) None curpats patcs in find_split_pats curpats patcs - + open Pp open Termops @@ -595,13 +595,13 @@ let pr_constr_pat env c = | _ -> pr let pr_pat env c = - try + try let patc = constr_of_pat env c in try pr_constr_pat env patc with _ -> str"pr_constr_pat raised an exception" with _ -> str"constr_of_pat raised an exception" - + let pr_context env c = - let pr_decl (id,b,_) = + let pr_decl (id,b,_) = let bstr = match b with Some b -> str ":=" ++ spc () ++ print_constr_env env b | None -> mt() in let idstr = match id with Name id -> pr_id id | Anonymous -> str"_" in idstr ++ bstr @@ -618,18 +618,18 @@ let pr_lhs env (delta, f, patcs) = let pr_rhs env = function | Empty var -> spc () ++ str ":=!" ++ spc () ++ print_constr_env env (mkRel var) | Program rhs -> spc () ++ str ":=" ++ spc () ++ print_constr_env env rhs - + let pr_clause env (lhs, rhs) = - pr_lhs env lhs ++ + pr_lhs env lhs ++ (let env' = push_rel_context (pi1 lhs) env in pr_rhs env' rhs) - + (* let pr_splitting env = function *) (* | Compute cl -> str "Compute " ++ pr_clause env cl *) (* | Split (lhs, n, indf, results, splits) -> *) (* let pr_unification_result (ctx, n, c, pat, subst) = *) - + (* unification_result array * splitting option array *) let pr_clauses env = @@ -637,36 +637,36 @@ let pr_clauses env = let lhs_includes (delta, _, patcs : lhs) (delta', _, patcs' : lhs) = pattern_includes patcs patcs' - + let lhs_matches (delta, _, patcs : lhs) (delta', _, patcs' : lhs) = pattern_matches patcs patcs' let rec split_on env var (delta, f, curpats as lhs) clauses = let before, (id, _, ty), after = split_tele (pred var) delta in - let unify, indf = - match unify_type before ty with + let unify, indf = + match unify_type before ty with | Some r -> r | None -> assert false (* We decided... so it better be inductive *) in let clauses = ref clauses in - let splits = + let splits = Array.map (fun (ctx', ctxlen, cstr, cstrpat, s) -> match s with | None -> None - | Some s -> + | Some s -> (* ctx' |- s cstr, s cstrpat *) let newdelta = - subst_context s (subst_rel_context 0 cstr + subst_context s (subst_rel_context 0 cstr (lift_contextn ctxlen 1 after)) @ ctx' in - let liftpats = + let liftpats = (* delta |- curpats -> before; ctxc; id; after |- liftpats *) - lift_pats ctxlen (succ var) curpats + lift_pats ctxlen (succ var) curpats in let liftpat = (* before; ctxc |- cstrpat -> before; ctxc; after |- liftpat *) lift_pat (pred var) 1 cstrpat in let substpat = (* before; ctxc; after |- liftpats[id:=liftpat] *) - subst_pats env var liftpat liftpats + subst_pats env var liftpat liftpats in let lifts = (* before; ctxc |- s : newdelta -> before; ctxc; after |- lifts : newdelta ; after *) @@ -674,8 +674,8 @@ let rec split_on env var (delta, f, curpats as lhs) clauses = in let newpats = specialize_patterns lifts substpat in let newlhs = (newdelta, f, newpats) in - let matching, rest = - fold_right (fun (lhs, rhs as clause) (matching, rest) -> + let matching, rest = + fold_right (fun (lhs, rhs as clause) (matching, rest) -> if lhs_includes newlhs lhs then (clause :: matching, rest) else (matching, clause :: rest)) @@ -684,11 +684,11 @@ let rec split_on env var (delta, f, curpats as lhs) clauses = clauses := rest; if matching = [] then ( (* Try finding a splittable variable *) - let (id, _) = - fold_right (fun (id, _, ty as decl) (accid, ctx) -> - match accid with + let (id, _) = + fold_right (fun (id, _, ty as decl) (accid, ctx) -> + match accid with | Some _ -> (accid, ctx) - | None -> + | None -> match unify_type ctx ty with | Some (unify, indf) -> if array_for_all (fun (_, _, _, _, x) -> x = None) unify then @@ -696,13 +696,13 @@ let rec split_on env var (delta, f, curpats as lhs) clauses = else (None, decl :: ctx) | None -> (None, decl :: ctx)) newdelta (None, []) - in + in match id with | None -> errorlabstrm "deppat" (str "Non-exhaustive pattern-matching, no clause found for:" ++ fnl () ++ pr_lhs env newlhs) - | Some id -> + | Some id -> Some (Compute (newlhs, Empty (fst (lookup_rel_id (out_name id) newdelta)))) ) else ( let splitting = make_split_aux env newlhs matching in @@ -713,14 +713,14 @@ let rec split_on env var (delta, f, curpats as lhs) clauses = (* errorlabstrm "deppat" *) (* (str "Impossible clauses:" ++ fnl () ++ pr_clauses env !clauses); *) Split (lhs, var, indf, unify, splits) - + and make_split_aux env lhs clauses = - let split = - fold_left (fun acc (lhs', rhs) -> - match acc with + let split = + fold_left (fun acc (lhs', rhs) -> + match acc with | None -> find_split lhs lhs' | _ -> acc) None clauses - in + in match split with | Some var -> split_on env var lhs clauses | None -> @@ -742,7 +742,7 @@ and make_split_aux env lhs clauses = let make_split env (f, delta, t) clauses = make_split_aux env (delta, f, patvars_of_tele delta) clauses - + open Evd open Evarutil @@ -755,18 +755,18 @@ let term_of_tree status isevar env (i, delta, ty) ann tree = (* | Some (loc, i) -> *) (* let (n, t) = lookup_rel_id i delta in *) (* let t' = lift n t in *) - - + + (* in *) let rec aux = function - | Compute ((ctx, _, pats as lhs), Program rhs) -> + | Compute ((ctx, _, pats as lhs), Program rhs) -> let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in let body = it_mkLambda_or_LetIn rhs ctx and typ = it_mkProd_or_LetIn ty' ctx in mkCast(body, DEFAULTcast, typ), typ | Compute ((ctx, _, pats as lhs), Empty split) -> let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in - let split = (Name (id_of_string "split"), + let split = (Name (id_of_string "split"), Some (Class_tactics.coq_nat_of_int (1 + (length ctx - split))), Lazy.force Class_tactics.coq_nat) in @@ -774,25 +774,25 @@ let term_of_tree status isevar env (i, delta, ty) ann tree = let let_ty' = mkLambda_or_LetIn split (lift 1 ty') in let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark (Define true)) let_ty' in term, ty' - - | Split ((ctx, _, pats as lhs), rel, indf, unif, sp) -> + + | Split ((ctx, _, pats as lhs), rel, indf, unif, sp) -> let before, decl, after = split_tele (pred rel) ctx in let ty' = substl (rev (constrs_of_lhs ~inacc:false env lhs)) ty in - let branches = - array_map2 (fun (ctx', ctxlen, cstr, cstrpat, subst) split -> + let branches = + array_map2 (fun (ctx', ctxlen, cstr, cstrpat, subst) split -> match split with | Some s -> aux s - | None -> + | None -> (* dead code, inversion will find a proof of False by splitting on the rel'th hyp *) Class_tactics.coq_nat_of_int rel, Lazy.force Class_tactics.coq_nat) - unif sp + unif sp in let branches_ctx = Array.mapi (fun i (br, brt) -> (id_of_string ("m_" ^ string_of_int i), Some br, brt)) branches in - let n, branches_lets = - Array.fold_left (fun (n, lets) (id, b, t) -> + let n, branches_lets = + Array.fold_left (fun (n, lets) (id, b, t) -> (succ n, (Name id, Option.map (lift n) b, lift n t) :: lets)) (0, []) branches_ctx in @@ -800,18 +800,18 @@ let term_of_tree status isevar env (i, delta, ty) ann tree = let case = let ty = it_mkProd_or_LetIn ty' liftctx in let ty = it_mkLambda_or_LetIn ty branches_lets in - let nbbranches = (Name (id_of_string "branches"), + let nbbranches = (Name (id_of_string "branches"), Some (Class_tactics.coq_nat_of_int (length branches_lets)), Lazy.force Class_tactics.coq_nat) in - let nbdiscr = (Name (id_of_string "target"), + let nbdiscr = (Name (id_of_string "target"), Some (Class_tactics.coq_nat_of_int (length before)), Lazy.force Class_tactics.coq_nat) in let ty = it_mkLambda_or_LetIn (lift 2 ty) [nbbranches;nbdiscr] in let term = e_new_evar isevar env ~src:(dummy_loc, QuestionMark status) ty in term - in + in let casetyp = it_mkProd_or_LetIn ty' ctx in mkCast(case, DEFAULTcast, casetyp), casetyp @@ -829,9 +829,9 @@ let locate_reference qid = | SynDef kn -> true let is_global id = - try + try locate_reference (qualid_of_ident id) - with Not_found -> + with Not_found -> false let is_freevar ids env x = @@ -841,12 +841,12 @@ let is_freevar ids env x = try ignore(Environ.lookup_named x env) ; false with _ -> not (is_global x) with _ -> true - -let ids_of_patc c ?(bound=Idset.empty) l = + +let ids_of_patc c ?(bound=Idset.empty) l = let found id bdvars l = if not (is_freevar bdvars (Global.env ()) (snd id)) then l - else if List.exists (fun (_, id') -> id' = snd id) l then l - else id :: l + else if List.exists (fun (_, id') -> id' = snd id) l then l + else id :: l in let rec aux bdvars l c = match c with | CRef (Ident lid) -> found lid bdvars l @@ -858,11 +858,11 @@ let ids_of_patc c ?(bound=Idset.empty) l = let interp_pats i isevar env impls pat sign recu = let bound = Idset.singleton i in let vars = ids_of_patc pat ~bound [] in - let varsctx, env' = + let varsctx, env' = fold_right (fun (loc, id) (ctx, env) -> let decl = let ty = e_new_evar isevar env ~src:(loc, BinderType (Name id)) (new_Type ()) in - (Name id, None, ty) + (Name id, None, ty) in decl::ctx, push_rel decl env) vars ([], env) @@ -871,7 +871,7 @@ let interp_pats i isevar env impls pat sign recu = let patenv = match recu with None -> env' | Some ty -> push_named (i, None, ty) env' in let patt, _ = interp_constr_evars_impls ~evdref:isevar patenv ~impls:([],[]) pat in match kind_of_term patt with - | App (m, args) -> + | App (m, args) -> if not (eq_constr m (mkRel (succ (length varsctx)))) then user_err_loc (constr_loc pat, "interp_pats", str "Expecting a pattern for " ++ pr_id i) @@ -880,18 +880,18 @@ let interp_pats i isevar env impls pat sign recu = str "Error parsing pattern: unnexpected left-hand side") in isevar := nf_evar_defs !isevar; - (nf_rel_context_evar ( !isevar) varsctx, + (nf_rel_context_evar ( !isevar) varsctx, nf_env_evar ( !isevar) env', rev_map (nf_evar ( !isevar)) pats) - + let interp_eqn i isevar env impls sign arity recu (pats, rhs) = let ctx, env', patcs = interp_pats i isevar env impls pats sign recu in let rhs' = match rhs with - | Program p -> + | Program p -> let ty = nf_isevar !isevar (substl patcs arity) in Program (interp_casted_constr_evars isevar env' ~impls p ty) | Empty lid -> Empty (fst (lookup_rel_id (snd lid) ctx)) - in ((ctx, i, pats_of_constrs (rev patcs)), rhs') + in ((ctx, i, pats_of_constrs (rev patcs)), rhs') open Entries @@ -905,10 +905,10 @@ let contrib_tactics_path = let tactics_tac s = make_kn (MPfile contrib_tactics_path) (make_dirpath []) (mk_label s) - -let equations_tac = lazy - (Tacinterp.eval_tactic - (TacArg(TacCall(dummy_loc, + +let equations_tac = lazy + (Tacinterp.eval_tactic + (TacArg(TacCall(dummy_loc, ArgArg(dummy_loc, tactics_tac "equations"), [])))) let define_by_eqs with_comp i (l,ann) t nt eqs = @@ -918,14 +918,14 @@ let define_by_eqs with_comp i (l,ann) t nt eqs = let arity = interp_type_evars isevar env' t in let sign = nf_rel_context_evar ( !isevar) sign in let arity = nf_evar ( !isevar) arity in - let arity = + let arity = if with_comp then let compid = add_suffix i "_comp" in let ce = { const_entry_body = it_mkLambda_or_LetIn arity sign; const_entry_type = None; const_entry_opaque = false; - const_entry_boxed = false} + const_entry_boxed = false} in let c = Declare.declare_constant compid (DefinitionEntry ce, IsDefinition Definition) @@ -937,8 +937,8 @@ let define_by_eqs with_comp i (l,ann) t nt eqs = let data = Command.compute_interning_datas env Constrintern.Recursive [] [i] [ty] [impls] in let fixdecls = [(Name i, None, ty)] in let fixenv = push_rel_context fixdecls env in - let equations = - States.with_heavy_rollback (fun () -> + let equations = + States.with_heavy_rollback (fun () -> Option.iter (Command.declare_interning_data data) nt; map (interp_eqn i isevar fixenv data sign arity None) eqs) () in @@ -961,21 +961,21 @@ let define_by_eqs with_comp i (l,ann) t nt eqs = let status = (* if is_recursive then Expand else *) Define false in let t, ty = term_of_tree status isevar env' prob ann split in let undef = undefined_evars !isevar in - let t, ty = if is_recursive then + let t, ty = if is_recursive then (it_mkLambda_or_LetIn t fixdecls, it_mkProd_or_LetIn ty fixdecls) else t, ty in - let obls, t', ty' = + let obls, t', ty' = Eterm.eterm_obligations env i !isevar ( undef) 0 ~status t ty in if is_recursive then - ignore(Subtac_obligations.add_mutual_definitions [(i, t', ty', impls, obls)] [] + ignore(Subtac_obligations.add_mutual_definitions [(i, t', ty', impls, obls)] [] ~tactic:(Lazy.force equations_tac) (Command.IsFixpoint [None, CStructRec])) else ignore(Subtac_obligations.add_definition ~implicits:impls i t' ty' ~tactic:(Lazy.force equations_tac) obls) - + module Gram = Pcoq.Gram module Vernac = Pcoq.Vernac_ module Tactic = Pcoq.Tactic @@ -993,7 +993,7 @@ struct end open Rawterm -open DeppatGram +open DeppatGram open Util open Pcoq open Prim @@ -1002,7 +1002,7 @@ open G_vernac GEXTEND Gram GLOBAL: (* deppat_gallina_loc *) deppat_equations binders_let2; - + deppat_equations: [ [ l = LIST1 equation SEP ";" -> l ] ] ; @@ -1020,7 +1020,7 @@ GEXTEND Gram |":="; c = Constr.lconstr -> Program c ] ] ; - + END type 'a deppat_equations_argtype = (equation list, 'a) Genarg.abstract_argument_type @@ -1059,8 +1059,8 @@ VERNAC COMMAND EXTEND Define_equations2 decl_notation(nt) ] -> [ equations false i l t nt eqs ] END - -let rec int_of_coq_nat c = + +let rec int_of_coq_nat c = match kind_of_term c with | App (f, [| arg |]) -> succ (int_of_coq_nat arg) | _ -> 0 @@ -1076,24 +1076,24 @@ let solve_equations_goal destruct_tac tac gl = | _ -> error "Unnexpected goal") | _ -> error "Unnexpected goal" in - let branches, b = + let branches, b = let rec aux n c = if n = 0 then [], c else match kind_of_term c with - | LetIn (Name id, br, brt, b) -> + | LetIn (Name id, br, brt, b) -> let rest, b = aux (pred n) b in (id, br, brt) :: rest, b | _ -> error "Unnexpected goal" in aux brs b - in + in let ids = targetn :: branchesn :: map pi1 branches in let cleantac = tclTHEN (intros_using ids) (thin ids) in let dotac = tclDO (succ targ) intro in - let subtacs = + let subtacs = tclTHENS destruct_tac (map (fun (id, br, brt) -> tclTHEN (letin_tac None (Name id) br (Some brt) onConcl) tac) branches) in tclTHENLIST [cleantac ; dotac ; subtacs] gl - + TACTIC EXTEND solve_equations [ "solve_equations" tactic(destruct) tactic(tac) ] -> [ solve_equations_goal (snd destruct) (snd tac) ] END @@ -1110,7 +1110,7 @@ let specialize_hyp id gl = let evars = ref (create_evar_defs (project gl)) in let rec aux in_eqs acc ty = match kind_of_term ty with - | Prod (_, t, b) -> + | Prod (_, t, b) -> (match kind_of_term t with | App (eq, [| eqty; x; y |]) when eq_constr eq (Lazy.force coq_eq) -> let pt = mkApp (Lazy.force coq_eq, [| eqty; x; x |]) in @@ -1124,14 +1124,14 @@ let specialize_hyp id gl = if e_conv env evars pt t then aux true (mkApp (acc, [| p |])) (subst1 p b) else error "Unconvertible members of an heterogeneous equality" - | _ -> + | _ -> if in_eqs then acc, in_eqs, ty - else + else let e = e_new_evar evars env t in aux false (mkApp (acc, [| e |])) (subst1 e b)) | t -> acc, in_eqs, ty - in - try + in + try let acc, worked, ty = aux false (mkVar id) ty in let ty = Evarutil.nf_isevar !evars ty in if worked then @@ -1140,9 +1140,9 @@ let specialize_hyp id gl = (exact_no_check (Evarutil.nf_isevar !evars acc)) gl else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl with e -> tclFAIL 0 (Cerrors.explain_exn e) gl - + TACTIC EXTEND specialize_hyp -[ "specialize_hypothesis" constr(c) ] -> [ +[ "specialize_hypothesis" constr(c) ] -> [ match kind_of_term c with | Var id -> specialize_hyp id | _ -> tclFAIL 0 (str "Not an hypothesis") ] diff --git a/plugins/subtac/eterm.ml b/plugins/subtac/eterm.ml index d65b520b65..3c947e29cf 100644 --- a/plugins/subtac/eterm.ml +++ b/plugins/subtac/eterm.ml @@ -16,11 +16,11 @@ open Util open Subtac_utils open Proof_type -let trace s = +let trace s = if !Flags.debug then (msgnl s; msgerr s) else () -let succfix (depth, fixrels) = +let succfix (depth, fixrels) = (succ depth, List.map succ fixrels) type oblinfo = @@ -32,41 +32,41 @@ type oblinfo = ev_typ: types; ev_tac: Tacexpr.raw_tactic_expr option; ev_deps: Intset.t } - -(** Substitute evar references in t using De Bruijn indices, + +(** Substitute evar references in t using De Bruijn indices, where n binders were passed through. *) -let subst_evar_constr evs n t = +let subst_evar_constr evs n t = let seen = ref Intset.empty in let transparent = ref Idset.empty in let evar_info id = List.assoc id evs in let rec substrec (depth, fixrels) c = match kind_of_term c with | Evar (k, args) -> - let { ev_name = (id, idstr) ; + let { ev_name = (id, idstr) ; ev_hyps = hyps ; ev_chop = chop } = try evar_info k - with Not_found -> + with Not_found -> anomaly ("eterm: existential variable " ^ string_of_int k ^ " not found") in seen := Intset.add id !seen; - (* Evar arguments are created in inverse order, + (* Evar arguments are created in inverse order, and we must not apply to defined ones (i.e. LetIn's) *) - let args = - let n = match chop with None -> 0 | Some c -> c in + let args = + let n = match chop with None -> 0 | Some c -> c in let (l, r) = list_chop n (List.rev (Array.to_list args)) in List.rev r in let args = let rec aux hyps args acc = match hyps, args with - ((_, None, _) :: tlh), (c :: tla) -> + ((_, None, _) :: tlh), (c :: tla) -> aux tlh tla ((substrec (depth, fixrels) c) :: acc) | ((_, Some _, _) :: tlh), (_ :: tla) -> aux tlh tla acc | [], [] -> acc | _, _ -> acc (*failwith "subst_evars: invalid argument"*) - in aux hyps args [] + in aux hyps args [] in if List.exists (fun x -> match kind_of_term x with Rel n -> List.mem n fixrels | _ -> false) args then transparent := Idset.add idstr !transparent; @@ -74,25 +74,25 @@ let subst_evar_constr evs n t = | Fix _ -> map_constr_with_binders succfix substrec (depth, 1 :: fixrels) c | _ -> map_constr_with_binders succfix substrec (depth, fixrels) c - in + in let t' = substrec (0, []) t in t', !seen, !transparent - -(** Substitute variable references in t using De Bruijn indices, + +(** Substitute variable references in t using De Bruijn indices, where n binders were passed through. *) -let subst_vars acc n t = +let subst_vars acc n t = let var_index id = Util.list_index id acc in let rec substrec depth c = match kind_of_term c with | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) | _ -> map_constr_with_binders succ substrec depth c - in + in substrec 0 t (** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) to a product : forall H1 : t1, ..., forall Hn : tn, concl. Changes evars and hypothesis references to variable references. -*) +*) let etype_of_evar evs hyps concl = let rec aux acc n = function (id, copt, t) :: tl -> @@ -102,13 +102,13 @@ let etype_of_evar evs hyps concl = let s' = Intset.union s s' in let trans' = Idset.union trans trans' in (match copt with - Some c -> + Some c -> let c', s'', trans'' = subst_evar_constr evs n c in let c' = subst_vars acc 0 c' in - mkNamedProd_or_LetIn (id, Some c', t'') rest, - Intset.union s'' s', + mkNamedProd_or_LetIn (id, Some c', t'') rest, + Intset.union s'' s', Idset.union trans'' trans' - | None -> + | None -> mkNamedProd_or_LetIn (id, None, t'') rest, s', trans') | [] -> let t', s, trans = subst_evar_constr evs n concl in @@ -117,25 +117,25 @@ let etype_of_evar evs hyps concl = open Tacticals - -let trunc_named_context n ctx = + +let trunc_named_context n ctx = let len = List.length ctx in list_firstn (len - n) ctx - -let rec chop_product n t = + +let rec chop_product n t = if n = 0 then Some t - else + else match kind_of_term t with | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (Termops.pop b) else None | _ -> None let evar_dependencies evm ev = - let one_step deps = - Intset.fold (fun ev s -> + let one_step deps = + Intset.fold (fun ev s -> let evi = Evd.find evm ev in Intset.union (Evarutil.evars_of_evar_info evi) s) deps deps - in + in let rec aux deps = let deps' = one_step deps in if Intset.equal deps deps' then deps @@ -143,13 +143,13 @@ let evar_dependencies evm ev = in aux (Intset.singleton ev) let sort_dependencies evl = - List.sort (fun (_, _, deps) (_, _, deps') -> + List.sort (fun (_, _, deps) (_, _, deps') -> if Intset.subset deps deps' then (* deps' depends on deps *) -1 else if Intset.subset deps' deps then 1 else Intset.compare deps deps') evl - -let eterm_obligations env name isevars evm fs ?status t ty = + +let eterm_obligations env name isevars evm fs ?status t ty = (* 'Serialize' the evars *) let nc = Environ.named_context env in let nc_len = Sign.named_context_length nc in @@ -157,37 +157,37 @@ let eterm_obligations env name isevars evm fs ?status t ty = let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in let sevl = sort_dependencies evl in let evl = List.map (fun (id, ev, _) -> id, ev) sevl in - let evn = + let evn = let i = ref (-1) in - List.rev_map (fun (id, ev) -> incr i; + List.rev_map (fun (id, ev) -> incr i; (id, (!i, id_of_string (string_of_id name ^ "_obligation_" ^ string_of_int (succ !i))), ev)) evl in - let evts = + let evts = (* Remove existential variables in types and build the corresponding products *) - fold_right + fold_right (fun (id, (n, nstr), ev) l -> let hyps = Evd.evar_filtered_context ev in let hyps = trunc_named_context nc_len hyps in let evtyp, deps, transp = etype_of_evar l hyps ev.evar_concl in - let evtyp, hyps, chop = + let evtyp, hyps, chop = match chop_product fs evtyp with | Some t -> t, trunc_named_context fs hyps, fs | None -> evtyp, hyps, 0 in let loc, k = evar_source id isevars in let status = match k with QuestionMark o -> Some o | _ -> status in - let status, chop = match status with + let status, chop = match status with | Some (Define true as stat) -> - if chop <> fs then Define false, None + if chop <> fs then Define false, None else stat, Some chop | Some s -> s, None | None -> Define true, None in - let tac = match ev.evar_extra with - | Some t -> - if Dyn.tag t = "tactic" then + let tac = match ev.evar_extra with + | Some t -> + if Dyn.tag t = "tactic" then Some (Tacinterp.globTacticIn (Tacinterp.tactic_out t)) else None | None -> None @@ -195,14 +195,14 @@ let eterm_obligations env name isevars evm fs ?status t ty = let info = { ev_name = (n, nstr); ev_hyps = hyps; ev_status = status; ev_chop = chop; ev_loc = loc; ev_typ = evtyp ; ev_deps = deps; ev_tac = tac } - in (id, info) :: l) + in (id, info) :: l) evn [] - in + in let t', _, transparent = (* Substitute evar refs in the term by variables *) - subst_evar_constr evts 0 t + subst_evar_constr evts 0 t in let ty, _, _ = subst_evar_constr evts 0 ty in - let evars = + let evars = List.map (fun (_, info) -> let { ev_name = (_, name); ev_status = status; ev_loc = loc; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info diff --git a/plugins/subtac/eterm.mli b/plugins/subtac/eterm.mli index 413823ffe9..1d1c512662 100644 --- a/plugins/subtac/eterm.mli +++ b/plugins/subtac/eterm.mli @@ -19,12 +19,12 @@ val mkMetas : int -> constr list val evar_dependencies : evar_map -> int -> Intset.t val sort_dependencies : (int * evar_info * Intset.t) list -> (int * evar_info * Intset.t) list - + (* env, id, evars, number of function prototypes to try to clear from evars contexts, object and type *) -val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> - ?status:obligation_definition_status -> constr -> types -> - (identifier * types * loc * obligation_definition_status * Intset.t * +val eterm_obligations : env -> identifier -> evar_defs -> evar_map -> int -> + ?status:obligation_definition_status -> constr -> types -> + (identifier * types * loc * obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array * constr * types (* Obl. name, type as product, location of the original evar, associated tactic, status and dependencies as indexes into the array *) diff --git a/plugins/subtac/g_eterm.ml4 b/plugins/subtac/g_eterm.ml4 index 095e5fafc9..53ce5b8d64 100644 --- a/plugins/subtac/g_eterm.ml4 +++ b/plugins/subtac/g_eterm.ml4 @@ -20,7 +20,7 @@ open Eterm TACTIC EXTEND eterm - [ "eterm" ] -> [ + [ "eterm" ] -> [ (fun gl -> let evm = Tacmach.project gl and t = Tacmach.pf_concl gl in Eterm.etermtac (evm, t) gl) ] diff --git a/plugins/subtac/g_subtac.ml4 b/plugins/subtac/g_subtac.ml4 index a1cbeb710a..098418a7e3 100644 --- a/plugins/subtac/g_subtac.ml4 +++ b/plugins/subtac/g_subtac.ml4 @@ -7,7 +7,7 @@ (************************************************************************) (*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmo" i*) +(*i camlp4use: "pa_extend.cmo" i*) (* @@ -45,7 +45,7 @@ struct end open Rawterm -open SubtacGram +open SubtacGram open Util open Pcoq open Prim @@ -54,14 +54,14 @@ let sigref = mkRefC (Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Init.Spec GEXTEND Gram GLOBAL: subtac_gallina_loc typeclass_constraint Constr.binder subtac_nameopt; - + subtac_gallina_loc: [ [ g = Vernac.gallina -> loc, g | g = Vernac.gallina_ext -> loc, g ] ] ; subtac_nameopt: - [ [ "ofb"; id=Prim.ident -> Some (id) + [ [ "ofb"; id=Prim.ident -> Some (id) | -> None ] ] ; @@ -115,42 +115,42 @@ let admit_obligations e = try_catch_exn Subtac_obligations.admit_obligations e VERNAC COMMAND EXTEND Subtac_Obligations | [ "Obligation" integer(num) "of" ident(name) ":" lconstr(t) ] -> [ subtac_obligation (num, Some name, Some t) ] | [ "Obligation" integer(num) "of" ident(name) ] -> [ subtac_obligation (num, Some name, None) ] -| [ "Obligation" integer(num) ":" lconstr(t) ] -> [ subtac_obligation (num, None, Some t) ] +| [ "Obligation" integer(num) ":" lconstr(t) ] -> [ subtac_obligation (num, None, Some t) ] | [ "Obligation" integer(num) ] -> [ subtac_obligation (num, None, None) ] | [ "Next" "Obligation" "of" ident(name) ] -> [ next_obligation (Some name) ] | [ "Next" "Obligation" ] -> [ next_obligation None ] END VERNAC COMMAND EXTEND Subtac_Solve_Obligation -| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> +| [ "Solve" "Obligation" integer(num) "of" ident(name) "using" tactic(t) ] -> [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> +| [ "Solve" "Obligation" integer(num) "using" tactic(t) ] -> [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] END VERNAC COMMAND EXTEND Subtac_Solve_Obligations -| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> +| [ "Solve" "Obligations" "of" ident(name) "using" tactic(t) ] -> [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" "using" tactic(t) ] -> +| [ "Solve" "Obligations" "using" tactic(t) ] -> [ try_solve_obligations None (Some (Tacinterp.interp t)) ] -| [ "Solve" "Obligations" ] -> +| [ "Solve" "Obligations" ] -> [ try_solve_obligations None None ] END VERNAC COMMAND EXTEND Subtac_Solve_All_Obligations -| [ "Solve" "All" "Obligations" "using" tactic(t) ] -> +| [ "Solve" "All" "Obligations" "using" tactic(t) ] -> [ solve_all_obligations (Some (Tacinterp.interp t)) ] -| [ "Solve" "All" "Obligations" ] -> +| [ "Solve" "All" "Obligations" ] -> [ solve_all_obligations None ] END VERNAC COMMAND EXTEND Subtac_Admit_Obligations -| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] -| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] +| [ "Admit" "Obligations" ] -> [ admit_obligations None ] END VERNAC COMMAND EXTEND Subtac_Set_Solver -| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ +| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ Subtac_obligations.set_default_tactic (Tacinterp.glob_tactic t) ] END diff --git a/plugins/subtac/subtac.ml b/plugins/subtac/subtac.ml index b5e2880134..56134d7086 100644 --- a/plugins/subtac/subtac.ml +++ b/plugins/subtac/subtac.ml @@ -23,7 +23,7 @@ open Typeops open Libnames open Classops open List -open Recordops +open Recordops open Evarutil open Pretype_errors open Rawterm @@ -50,14 +50,14 @@ open Tacinterp open Tacexpr let solve_tccs_in_type env id isevars evm c typ = - if not (evm = Evd.empty) then + if not (evm = Evd.empty) then let stmt_id = Nameops.add_suffix id "_stmt" in let obls, c', t' = eterm_obligations env stmt_id !isevars evm 0 ~status:Expand c typ in match Subtac_obligations.add_definition stmt_id c' typ obls with - | Subtac_obligations.Defined cst -> constant_value (Global.env()) + | Subtac_obligations.Defined cst -> constant_value (Global.env()) (match cst with ConstRef kn -> kn | _ -> assert false) - | _ -> - errorlabstrm "start_proof" + | _ -> + errorlabstrm "start_proof" (str "The statement obligations could not be resolved automatically, " ++ spc () ++ str "write a statement definition first.") else @@ -75,30 +75,30 @@ let start_proof_com env isevars sopt kind (bl,t) hook = next_global_ident_away false (id_of_string "Unnamed_thm") (Pfedit.get_all_proof_names ()) in - let evm, c, typ, imps = - Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None + let evm, c, typ, imps = + Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr t bl) None in let c = solve_tccs_in_type env id isevars evm c typ in - Command.start_proof id kind c (fun loc gr -> + Command.start_proof id kind c (fun loc gr -> Impargs.declare_manual_implicits (loc = Local) gr ~enriching:true imps; hook loc gr) - + let print_subgoals () = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () let start_proof_and_print env isevars idopt k t hook = start_proof_com env isevars idopt k t hook; print_subgoals () - + let _ = Detyping.set_detype_anonymous (fun loc n -> RVar (loc, id_of_string ("Anonymous_REL_" ^ string_of_int n))) - + let assumption_message id = Flags.if_verbose message ((string_of_id id) ^ " is assumed") let declare_assumption env isevars idl is_coe k bl c nl = if not (Pfedit.refining ()) then let id = snd (List.hd idl) in - let evm, c, typ, imps = - Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr c bl) None + let evm, c, typ, imps = + Subtac_pretyping.subtac_process env isevars id [] (Command.generalize_constr_expr c bl) None in let c = solve_tccs_in_type env id isevars evm c typ in List.iter (Command.declare_one_assumption is_coe k c imps false nl) idl @@ -115,9 +115,9 @@ let dump_variable lid = () let vernac_assumption env isevars kind l nl = let global = fst kind = Global in - List.iter (fun (is_coe,(idl,c)) -> + List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then - List.iter (fun lid -> + List.iter (fun lid -> if global then Dumpglob.dump_definition lid (not global) "ax" else dump_variable lid) idl; declare_assumption env isevars idl is_coe kind [] c nl) l @@ -125,7 +125,7 @@ let vernac_assumption env isevars kind l nl = let check_fresh (loc,id) = if Nametab.exists_cci (Lib.make_path id) or is_section_variable id then user_err_loc (loc,"",pr_id id ++ str " already exists") - + let subtac (loc, command) = check_required_library ["Coq";"Init";"Datatypes"]; check_required_library ["Coq";"Init";"Specif"]; @@ -133,25 +133,25 @@ let subtac (loc, command) = let isevars = ref (create_evar_defs Evd.empty) in try match command with - | VernacDefinition (defkind, (_, id as lid), expr, hook) -> + | VernacDefinition (defkind, (_, id as lid), expr, hook) -> check_fresh lid; Dumpglob.dump_definition lid false "def"; (match expr with - | ProveBody (bl, t) -> + | ProveBody (bl, t) -> if Lib.is_modtype () then errorlabstrm "Subtac_command.StartProof" (str "Proof editing mode not supported in module types"); - start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t) + start_proof_and_print env isevars (Some lid) (Global, DefinitionBody Definition) (bl,t) (fun _ _ -> ()) - | DefineBody (bl, _, c, tycon) -> + | DefineBody (bl, _, c, tycon) -> ignore(Subtac_pretyping.subtac_proof defkind hook env isevars id bl c tycon)) - | VernacFixpoint (l, b) -> - List.iter (fun ((lid, _, _, _, _), _) -> + | VernacFixpoint (l, b) -> + List.iter (fun ((lid, _, _, _, _), _) -> check_fresh lid; Dumpglob.dump_definition lid false "fix") l; let _ = trace (str "Building fixpoint") in ignore(Subtac_command.build_recursive l b) - + | VernacStartTheoremProof (thkind, [Some id, (bl, t)], lettop, hook) -> Dumpglob.dump_definition id false "prf"; if not(Pfedit.refining ()) then @@ -163,30 +163,30 @@ let subtac (loc, command) = (str "Proof editing mode not supported in module types"); check_fresh id; start_proof_and_print env isevars (Some id) (Global, Proof thkind) (bl,t) hook - - | VernacAssumption (stre,nl,l) -> + + | VernacAssumption (stre,nl,l) -> vernac_assumption env isevars stre l nl - + | VernacInstance (glob, sup, is, props, pri) -> dump_constraint "inst" is; ignore(Subtac_classes.new_instance ~global:glob sup is props pri) - + | VernacCoFixpoint (l, b) -> - if Dumpglob.dump () then + if Dumpglob.dump () then List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "cofix") l; ignore(Subtac_command.build_corecursive l b) - - (*| VernacEndProof e -> + + (*| VernacEndProof e -> subtac_end_proof e*) | _ -> user_err_loc (loc,"", str ("Invalid Program command")) - with + with | Typing_error e -> msg_warning (str "Type error in Program tactic:"); - let cmds = + let cmds = (match e with | NonFunctionalApp (loc, x, mux, e) -> - str "non functional application of term " ++ + str "non functional application of term " ++ e ++ str " to function " ++ x ++ str " of (mu) type " ++ mux | NonSigma (loc, t) -> str "Term is not of Sigma type: " ++ t @@ -197,10 +197,10 @@ let subtac (loc, command) = str "Term is ill-sorted:" ++ spc () ++ t ) in msg_warning cmds - + | Subtyping_error e -> msg_warning (str "(Program tactic) Subtyping error:"); - let cmds = + let cmds = match e with | UncoercibleInferType (loc, x, y) -> str "Uncoercible terms:" ++ spc () @@ -217,15 +217,15 @@ let subtac (loc, command) = | Cases.PatternMatchingError (env, exn) as e -> debug 2 (Himsg.explain_pattern_matching_error env exn); raise e - + | Type_errors.TypeError (env, exn) as e -> debug 2 (Himsg.explain_type_error env exn); raise e - + | Pretype_errors.PretypeError (env, exn) as e -> debug 2 (Himsg.explain_pretype_error env exn); raise e - + | (Stdpp.Exc_located (loc, Proof_type.LtacLocated (_,e')) | Stdpp.Exc_located (loc, e') as e) -> debug 2 (str "Parsing exception: "); @@ -233,14 +233,14 @@ let subtac (loc, command) = | Type_errors.TypeError (env, exn) -> debug 2 (Himsg.explain_type_error env exn); raise e - + | Pretype_errors.PretypeError (env, exn) -> debug 2 (Himsg.explain_pretype_error env exn); raise e | e'' -> msg_warning (str "Unexpected exception: " ++ Cerrors.explain_exn e''); raise e) - - | e -> + + | e -> msg_warning (str "Uncatched exception: " ++ Cerrors.explain_exn e); raise e diff --git a/plugins/subtac/subtac_cases.ml b/plugins/subtac/subtac_cases.ml index 5f2cb601be..d54bbee4e3 100644 --- a/plugins/subtac/subtac_cases.ml +++ b/plugins/subtac/subtac_cases.ml @@ -45,7 +45,7 @@ let mssg_may_need_inversion () = (* Utils *) let make_anonymous_patvars = - list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) + list_tabulate (fun _ -> PatVar (dummy_loc,Anonymous)) (* Environment management *) let push_rels vars env = List.fold_right push_rel vars env @@ -72,7 +72,7 @@ let mkSpecialLetInJudge j (na,(deppat,nondeppat,d,t)) = | NonDepAlias -> if (not (dependent (mkRel 1) j.uj_type)) or (* A leaf: *) isRel deppat - then + then (* The body of pat is not needed to type j - see *) (* insert_aliases - and both deppat and nondeppat have the *) (* same type, then one can freely substitute one by the other *) @@ -94,7 +94,7 @@ type rhs = } type equation = - { patterns : cases_pattern list; + { patterns : cases_pattern list; rhs : rhs; alias_stack : name list; eqn_loc : loc; @@ -154,7 +154,7 @@ let feed_history arg = function Continuation (n-1, arg :: l, h) | Continuation (n, _, _) -> anomaly ("Bad number of expected remaining patterns: "^(string_of_int n)) - | Result _ -> + | Result _ -> anomaly "Exhausted pattern history" (* This is for non exhaustive error message *) @@ -185,7 +185,7 @@ let rec simplify_history = function let pat = match f with | AliasConstructor pci -> PatCstr (dummy_loc,pci,pargs,Anonymous) - | AliasLeaf -> + | AliasLeaf -> assert (l = []); PatVar (dummy_loc, Anonymous) in feed_history pat rh @@ -203,7 +203,7 @@ let push_history_pattern n current cont = where tomatch is some sequence of "instructions" (t1 ... tn) - and mat is some matrix + and mat is some matrix (p11 ... p1n -> rhs1) ( ... ) (pm1 ... pmn -> rhsm) @@ -263,7 +263,7 @@ let rec find_row_ind = function let inductive_template isevars env tmloc ind = let arsign = get_full_arity_sign env ind in - let hole_source = match tmloc with + let hole_source = match tmloc with | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i)) | None -> fun _ -> (dummy_loc, Evd.InternalHole) in let (_,evarl,_) = @@ -273,7 +273,7 @@ let inductive_template isevars env tmloc ind = | None -> let ty' = substl subst ty in let e = e_new_evar isevars env ~src:(hole_source n) ty' in - (e::subst,e::evarl,n+1) + (e::subst,e::evarl,n+1) | Some b -> (b::subst,evarl,n+1)) arsign ([],[],1) in @@ -293,7 +293,7 @@ let evd_comb2 f isevars x y = let context_of_arsign l = let (x, _) = List.fold_right - (fun c (x, n) -> + (fun c (x, n) -> (lift_rel_context n c @ x, List.length c + n)) l ([], 0) in x @@ -302,11 +302,11 @@ let context_of_arsign l = let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in - let subst, len = + let subst, len = List.fold_left2 (fun (subst, len) (tm, tmtype) sign -> let signlen = List.length sign in match kind_of_term tm with - | Rel n when dependent tm c + | Rel n when dependent tm c && signlen = 1 (* The term to match is not of a dependent type itself *) -> ((n, len) :: subst, len - signlen) | Rel n when signlen > 1 (* The term is of a dependent type, @@ -314,12 +314,12 @@ let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = (match tmtype with | NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *) | IsInd (_, IndType(indf,realargs)) -> - let subst = - if dependent tm c && List.for_all isRel realargs - then (n, 1) :: subst else subst + let subst = + if dependent tm c && List.for_all isRel realargs + then (n, 1) :: subst else subst in List.fold_left - (fun (subst, len) arg -> + (fun (subst, len) arg -> match kind_of_term arg with | Rel n when dependent arg c -> ((n, len) :: subst, pred len) @@ -330,18 +330,18 @@ let prepare_predicate_from_arsign_tycon loc env evm tomatchs arsign c = in let rec predicate lift c = match kind_of_term c with - | Rel n when n > lift -> - (try + | Rel n when n > lift -> + (try (* Make the predicate dependent on the matched variable *) let idx = List.assoc (n - lift) subst in mkRel (idx + lift) - with Not_found -> + with Not_found -> (* A variable that is not matched, lift over the arsign. *) mkRel (n + nar)) | _ -> - map_constr_with_binders succ predicate lift c + map_constr_with_binders succ predicate lift c in - try + try (* The tycon may be ill-typed after abstraction. *) let pred = predicate 0 c in let env' = push_rel_context (context_of_arsign arsign) env in @@ -352,7 +352,7 @@ module Cases_F(Coercion : Coercion.S) : S = struct let inh_coerce_to_ind isevars env ty tyi = let expected_typ = inductive_template isevars env None tyi in - (* devrait être indifférent d'exiger leq ou pas puisque pour + (* devrait être indifférent d'exiger leq ou pas puisque pour un inductif cela doit être égal *) let _ = e_cumul env isevars expected_typ ty in () @@ -395,7 +395,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps) = (* Ideally, we could find a common inductive type to which both the term to match and the patterns coerce *) (* In practice, we coerce the term to match if it is not already an - inductive type and it is not dependent; moreover, we use only + inductive type and it is not dependent; moreover, we use only the first pattern type and forget about the others *) let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in let typ = @@ -479,7 +479,7 @@ let rec adjust_local_defs loc = function | [], [] -> [] | _ -> raise NotAdjustable -let check_and_adjust_constructor env ind cstrs = function +let check_and_adjust_constructor env ind cstrs = function | PatVar _ as pat -> pat | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> (* Check it is constructor of the right type *) @@ -490,7 +490,7 @@ let check_and_adjust_constructor env ind cstrs = function let nb_args_constr = ci.cs_nargs in if List.length args = nb_args_constr then pat else - try + try let args' = adjust_local_defs loc (args, List.rev ci.cs_args) in PatCstr (loc, cstr, args', alias) with NotAdjustable -> @@ -500,7 +500,7 @@ let check_and_adjust_constructor env ind cstrs = function (* Try to insert a coercion *) try Coercion.inh_pattern_coerce_to loc pat ind' ind - with Not_found -> + with Not_found -> error_bad_constructor_loc loc cstr ind let check_all_variables typ mat = @@ -512,14 +512,14 @@ let check_all_variables typ mat = mat let check_unused_pattern env eqn = - if not !(eqn.used) then + if not !(eqn.used) then raise_pattern_matching_error (eqn.eqn_loc, env, UnusedClause eqn.patterns) let set_used_pattern eqn = eqn.used := true let extract_rhs pb = - match pb.mat with + match pb.mat with | [] -> errorlabstrm "build_leaf" (mssg_may_need_inversion()) | eqn::_ -> set_used_pattern eqn; @@ -558,7 +558,7 @@ let dependent_decl a = function let rec find_dependency_list k n = function | [] -> [] - | (used,tdeps,d)::rest -> + | (used,tdeps,d)::rest -> let deps = find_dependency_list k (n+1) rest in if used && dependent_decl (mkRel n) d then list_add_set (List.length rest + 1) (list_union deps tdeps) @@ -579,7 +579,7 @@ let find_dependencies_signature deps_in_rhs typs = (* A Pushed term to match has just been substituted by some constructor t = (ci x1...xn) and the terms x1 ... xn have been added to - match + match - all terms to match and to push (dependent on t by definition) must have (Rel depth) substituted by t and Rel's>depth lifted by n @@ -604,7 +604,7 @@ let regeneralize_index_tomatch n = ::(genrec (depth+1) rest) in genrec 0 -let rec replace_term n c k t = +let rec replace_term n c k t = if t = mkRel (n+k) then lift k c else map_constr_with_binders succ (replace_term n c) k t @@ -652,7 +652,7 @@ let lift_tomatch_stack n = liftn_tomatch_stack n 1 [match y with (S (S x)) => x | x => x end] should be compiled into [match y with O => y | (S n) => match n with O => y | (S x) => x end end] - and [match y with (S (S n)) => n | n => n end] into + and [match y with (S (S n)) => n | n => n end] into [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end] i.e. user names should be preserved and created names should not @@ -667,7 +667,7 @@ let merge_names get_name = List.map2 (merge_name get_name) let get_names env sign eqns = let names1 = list_tabulate (fun _ -> Anonymous) (List.length sign) in (* If any, we prefer names used in pats, from top to bottom *) - let names2 = + let names2 = List.fold_right (fun (pats,eqn) names -> merge_names alias_of_pat pats names) eqns names1 in @@ -681,7 +681,7 @@ let get_names env sign eqns = let na = merge_name (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) - d na + d na in (na::l,(out_name na)::avoid)) ([],allvars) (List.rev sign) names2 in @@ -722,7 +722,7 @@ let build_aliases_context env sigma names allpats pats = let oldallpats = List.map List.tl oldallpats in let decl = (na,Some deppat,t) in let a = (deppat,nondeppat,d,t) in - insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) + insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) newallpats oldallpats (pats,names) | [], [] -> newallpats, sign1, sign2, env | _ -> anomaly "Inconsistent alias and name lists" in @@ -732,7 +732,7 @@ let build_aliases_context env sigma names allpats pats = let insert_aliases_eqn sign eqnnames alias_rest eqn = let thissign = List.map2 (fun na (_,c,t) -> (na,c,t)) eqnnames sign in push_rels_eqn thissign { eqn with alias_stack = alias_rest; } - + let insert_aliases env sigma alias eqns = (* Là, y a une faiblesse, si un alias est utilisé dans un cas par *) @@ -741,7 +741,7 @@ let insert_aliases env sigma alias eqns = let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in (* names2 takes the meet of all needed aliases *) - let names2 = + let names2 = List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in (* Only needed aliases are kept by build_aliases_context *) let eqnsnames, sign1, sign2, env = @@ -753,12 +753,12 @@ let insert_aliases env sigma alias eqns = (* Functions to deal with elimination predicate *) exception Occur -let noccur_between_without_evar n m term = +let noccur_between_without_evar n m term = let rec occur_rec n c = match kind_of_term c with | Rel p -> if n<=p && p () | _ -> iter_constr_with_binders succ occur_rec n c - in + in try occur_rec n term; true with Occur -> false (* Inferring the predicate *) @@ -836,7 +836,7 @@ let rec transpose_args n = let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k -let reloc_operator (k,n) = function OpRel p when p > k -> +let reloc_operator (k,n) = function OpRel p when p > k -> let rec unify_clauses k pv = let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) ( isevars)) p) pv in let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in @@ -894,7 +894,7 @@ let infer_predicate loc env isevars typs cstrs indf = *) (* "TODO4-2" *) (* We skip parameters *) - let cis = + let cis = Array.map (fun cs -> applist (mkConstruct cs.cs_cstr, extended_rel_list 0 cs.cs_args)) @@ -1122,8 +1122,8 @@ let group_equations pb ind current cstrs mat = (fun eqn () -> let rest = remove_current_pattern eqn in let pat = current_pattern eqn in - match check_and_adjust_constructor pb.env ind cstrs pat with - | PatVar (_,name) -> + match check_and_adjust_constructor pb.env ind cstrs pat with + | PatVar (_,name) -> (* This is a default clause that we expand *) for i=1 to Array.length cstrs do let n = cstrs.(i-1).cs_nargs in @@ -1176,10 +1176,10 @@ let build_branch current deps pb eqns const_info = & not (known_dependent pb.pred) & deps = [] then NonDepAlias - else + else DepAlias in - let history = + let history = push_history_pattern const_info.cs_nargs (AliasConstructor const_info.cs_cstr) pb.history in @@ -1204,7 +1204,7 @@ let build_branch current deps pb eqns const_info = find_dependencies_signature (dependencies_in_rhs const_info.cs_nargs eqns) (List.rev typs) in - (* The dependent term to subst in the types of the remaining UnPushed + (* The dependent term to subst in the types of the remaining UnPushed terms is relative to the current context enriched by topushs *) let ci = build_dependent_constructor const_info in @@ -1283,7 +1283,7 @@ and match_current pb tomatch = let brvals = Array.map (fun (v,_) -> v) brs in let brtyps = Array.map (fun (_,t) -> t) brs in let (pred,typ,s) = - find_predicate pb.caseloc pb.env pb.isevars + find_predicate pb.caseloc pb.env pb.isevars pb.pred brtyps cstrs current indt pb.tomatch in let ci = make_case_info pb.env mind pb.casestyle in let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in @@ -1382,10 +1382,10 @@ let oldprepare_predicate_from_tycon loc dep env isevars tomatchs sign c = e_new_evar isevars env ~src:(loc, Evd.CasesType) (Retyping.get_type_of env ( !isevars) c) else - map_constr_with_full_binders push_rel build_skeleton env c + map_constr_with_full_binders push_rel build_skeleton env c in names, build_skeleton env (lift n c) - + (* Here, [pred] is assumed to be in the context built from all *) (* realargs and terms to match *) let build_initial_predicate isdep allnames pred = @@ -1396,7 +1396,7 @@ let build_initial_predicate isdep allnames pred = let names' = if isdep then List.tl names else names in let n' = n + List.length names' in let pred, p, user_p = - if isdep then + if isdep then if dependent (mkRel (nar-n')) pred then pred, 1, 1 else liftn (-1) (nar-n') pred, 0, 1 else pred, 0, 0 in @@ -1414,10 +1414,10 @@ let build_initial_predicate isdep allnames pred = let extract_arity_signature env0 tomatchl tmsign = let get_one_sign n tm (na,t) = match tm with - | NotInd (bo,typ) -> + | NotInd (bo,typ) -> (match t with | None -> [na,Option.map (lift n) bo,lift n typ] - | Some (loc,_,_,_) -> + | Some (loc,_,_,_) -> user_err_loc (loc,"", str "Unexpected type annotation for a term of non inductive type")) | IsInd (_,IndType(indf,realargs)) -> @@ -1448,10 +1448,10 @@ let extract_arity_signature env0 tomatchl tmsign = let extract_arity_signatures env0 tomatchl tmsign = let get_one_sign tm (na,t) = match tm with - | NotInd (bo,typ) -> + | NotInd (bo,typ) -> (match t with | None -> [na,bo,typ] - | Some (loc,_,_,_) -> + | Some (loc,_,_,_) -> user_err_loc (loc,"", str "Unexpected type annotation for a term of non inductive type")) | IsInd (_,IndType(indf,realargs)) -> @@ -1487,19 +1487,19 @@ let inh_conv_coerce_to_tycon loc env isevars j tycon = | None -> j let out_ind = function IsInd (_, IndType(x, y)) -> (x, y) | _ -> assert(false) - -let string_of_name name = + +let string_of_name name = match name with | Anonymous -> "anonymous" | Name n -> string_of_id n - + let id_of_name n = id_of_string (string_of_name n) -let make_prime_id name = +let make_prime_id name = let str = string_of_name name in id_of_string str, id_of_string (str ^ "'") -let prime avoid name = +let prime avoid name = let previd, id = make_prime_id name in previd, next_ident_away_from id avoid @@ -1508,28 +1508,28 @@ let make_prime avoid prevname = avoid := id :: !avoid; previd, id -let eq_id avoid id = +let eq_id avoid id = let hid = id_of_string ("Heq_" ^ string_of_id id) in let hid' = next_ident_away_from hid avoid in hid' let mk_eq typ x y = mkApp (Lazy.force eq_ind, [| typ; x ; y |]) let mk_eq_refl typ x = mkApp (Lazy.force eq_refl, [| typ; x |]) -let mk_JMeq typ x typ' y = +let mk_JMeq typ x typ' y = mkApp (Lazy.force Subtac_utils.jmeq_ind, [| typ; x ; typ'; y |]) let mk_JMeq_refl typ x = mkApp (Lazy.force Subtac_utils.jmeq_refl, [| typ; x |]) - + let hole = RHole (dummy_loc, Evd.QuestionMark (Evd.Define true)) -let constr_of_pat env isevars arsign pat avoid = - let rec typ env (ty, realargs) pat avoid = +let constr_of_pat env isevars arsign pat avoid = + let rec typ env (ty, realargs) pat avoid = match pat with - | PatVar (l,name) -> + | PatVar (l,name) -> let name, avoid = match name with Name n -> name, avoid - | Anonymous -> + | Anonymous -> let previd, id = prime avoid (Name (id_of_string "wildcard")) in - Name id, id :: avoid + Name id, id :: avoid in PatVar (l, name), [name, None, ty] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid | PatCstr (l,((_, i) as cstr),args,alias) -> @@ -1541,11 +1541,11 @@ let constr_of_pat env isevars arsign pat avoid = let ci = cstrs.(i-1) in let nb_args_constr = ci.cs_nargs in assert(nb_args_constr = List.length args); - let patargs, args, sign, env, n, m, avoid = + let patargs, args, sign, env, n, m, avoid = List.fold_right2 (fun (na, c, t) ua (patargs, args, sign, env, n, m, avoid) -> - let pat', sign', arg', typ', argtypargs, n', avoid = - typ env (lift (n - m) t, []) ua avoid + let pat', sign', arg', typ', argtypargs, n', avoid = + typ env (lift (n - m) t, []) ua avoid in let args' = arg' :: List.map (lift n') args in let env' = push_rels sign' env in @@ -1558,7 +1558,7 @@ let constr_of_pat env isevars arsign pat avoid = let cstr = mkConstruct ci.cs_cstr in let app = applistc cstr (List.map (lift (List.length sign)) params) in let app = applistc app args in - let apptype = Retyping.get_type_of env ( !isevars) app in + let apptype = Retyping.get_type_of env ( !isevars) app in let IndType (indf, realargs) = find_rectype env ( !isevars) apptype in match alias with Anonymous -> @@ -1573,38 +1573,38 @@ let constr_of_pat env isevars arsign pat avoid = let eq_t = mk_eq (lift (succ m) ty) (mkRel 1) (* alias *) (lift 1 app) (* aliased term *) - in + in let neq = eq_id avoid id in (Name neq, Some (mkRel 0), eq_t) :: sign, 2, neq :: avoid with Reduction.NotConvertible -> sign, 1, avoid in (* Mark the equality as a hole *) pat', sign, lift i app, lift i apptype, realargs, n + i, avoid - in - let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in + in + let pat', sign, patc, patty, args, z, avoid = typ env (pi3 (List.hd arsign), List.tl arsign) pat avoid in pat', (sign, patc, (pi3 (List.hd arsign), args), pat'), avoid (* shadows functional version *) -let eq_id avoid id = +let eq_id avoid id = let hid = id_of_string ("Heq_" ^ string_of_id id) in let hid' = next_ident_away_from hid !avoid in avoid := hid' :: !avoid; hid' -let rels_of_patsign = - List.map (fun ((na, b, t) as x) -> - match b with +let rels_of_patsign = + List.map (fun ((na, b, t) as x) -> + match b with | Some t' when kind_of_term t' = Rel 0 -> (na, None, t) | _ -> x) -let vars_of_ctx ctx = +let vars_of_ctx ctx = let _, y = - List.fold_right (fun (na, b, t) (prev, vars) -> - match b with - | Some t' when kind_of_term t' = Rel 0 -> - prev, - (RApp (dummy_loc, + List.fold_right (fun (na, b, t) (prev, vars) -> + match b with + | Some t' when kind_of_term t' = Rel 0 -> + prev, + (RApp (dummy_loc, (RRef (dummy_loc, Lazy.force refl_ref)), [hole; RVar (dummy_loc, prev)])) :: vars | _ -> match na with @@ -1613,7 +1613,7 @@ let vars_of_ctx ctx = ctx (id_of_string "vars_of_ctx_error", []) in List.rev y -let rec is_included x y = +let rec is_included x y = match x, y with | PatVar _, _ -> true | _, PatVar _ -> true @@ -1626,12 +1626,12 @@ let rec is_included x y = *) let build_ineqs prevpatterns pats liftsign = let _tomatchs = List.length pats in - let diffs = - List.fold_left - (fun c eqnpats -> + let diffs = + List.fold_left + (fun c eqnpats -> let acc = List.fold_left2 (* ppat is the pattern we are discriminating against, curpat is the current one. *) - (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) + (fun acc (ppat_sign, ppat_c, (ppat_ty, ppat_tyargs), ppat) (curpat_sign, curpat_c, (curpat_ty, curpat_tyargs), curpat) -> match acc with None -> None @@ -1641,33 +1641,33 @@ let build_ineqs prevpatterns pats liftsign = let lens = List.length ppat_sign in (* Accumulated length of previous pattern's signatures *) let len' = lens + len in - let acc = + let acc = ((* Jump over previous prevpat signs *) - lift_rel_context len ppat_sign @ sign, + lift_rel_context len ppat_sign @ sign, len', succ n, (* nth pattern *) mkApp (Lazy.force eq_ind, [| lift (len' + liftsign) curpat_ty; liftn (len + liftsign) (succ lens) ppat_c ; - lift len' curpat_c |]) :: + lift len' curpat_c |]) :: List.map (lift lens (* Jump over this prevpat signature *)) c) in Some acc else None) (Some ([], 0, 0, [])) eqnpats pats - in match acc with + in match acc with None -> c | Some (sign, len, _, c') -> - let conj = it_mkProd_or_LetIn (mk_not (mk_conj c')) - (lift_rel_context liftsign sign) + let conj = it_mkProd_or_LetIn (mk_not (mk_conj c')) + (lift_rel_context liftsign sign) in conj :: c) [] prevpatterns in match diffs with [] -> None | _ -> Some (mk_conj diffs) - + let subst_rel_context k ctx subst = let (_, ctx') = - List.fold_right + List.fold_right (fun (n, b, t) (k, acc) -> (succ k, (n, Option.map (substnl subst k) b, substnl subst k t) :: acc)) ctx (k, []) @@ -1683,29 +1683,29 @@ let lift_rel_contextn n k sign = let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = let i = ref 0 in - let (x, y, z) = + let (x, y, z) = List.fold_left (fun (branches, eqns, prevpatterns) eqn -> - let _, newpatterns, pats = + let _, newpatterns, pats = List.fold_left2 - (fun (idents, newpatterns, pats) pat arsign -> + (fun (idents, newpatterns, pats) pat arsign -> let pat', cpat, idents = constr_of_pat env isevars arsign pat idents in (idents, pat' :: newpatterns, cpat :: pats)) ([], [], []) eqn.patterns sign in let newpatterns = List.rev newpatterns and opats = List.rev pats in - let rhs_rels, pats, signlen = - List.fold_left - (fun (renv, pats, n) (sign,c, (s, args), p) -> + let rhs_rels, pats, signlen = + List.fold_left + (fun (renv, pats, n) (sign,c, (s, args), p) -> (* Recombine signatures and terms of all of the row's patterns *) let sign' = lift_rel_context n sign in let len = List.length sign' in - (sign' @ renv, + (sign' @ renv, (* lift to get outside of previous pattern's signatures. *) (sign', liftn n (succ len) c, (s, List.map (liftn n (succ len)) args), p) :: pats, len + n)) ([], [], 0) opats in - let pats, _ = List.fold_left + let pats, _ = List.fold_left (* lift to get outside of past patterns to get terms in the combined environment. *) (fun (pats, n) (sign, c, (s, args), p) -> let len = List.length sign in @@ -1716,7 +1716,7 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = let rhs_rels' = rels_of_patsign rhs_rels in let _signenv = push_rel_context rhs_rels' env in let arity = - let args, nargs = + let args, nargs = List.fold_right (fun (sign, c, (_, args), _) (allargs,n) -> (args @ c :: allargs, List.length args + succ n)) pats ([], 0) @@ -1724,7 +1724,7 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = let args = List.rev args in substl args (liftn signlen (succ nargs) arity) in - let rhs_rels', tycon = + let rhs_rels', tycon = let neqs_rels, arity = match ineqs with | None -> [], arity @@ -1740,7 +1740,7 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in let branch_name = id_of_string ("branch_" ^ (string_of_int !i)) in let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in - let branch = + let branch = let bref = RVar (dummy_loc, branch_name) in match vars_of_ctx rhs_rels with [] -> bref @@ -1767,30 +1767,30 @@ let constrs_of_pats typing_fun env isevars eqns tomatchs sign neqs arity = * A type constraint but no annotation case: it is assumed non dependent. *) - -let lift_ctx n ctx = + +let lift_ctx n ctx = let ctx', _ = List.fold_right (fun (c, t) (ctx, n') -> (liftn n n' c, liftn_tomatch_type n n' t) :: ctx, succ n') ctx ([], 0) in ctx' (* Turn matched terms into variables. *) let abstract_tomatch env tomatchs tycon = - let prev, ctx, names, tycon = + let prev, ctx, names, tycon = List.fold_left (fun (prev, ctx, names, tycon) (c, t) -> let lenctx = List.length ctx in match kind_of_term c with Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon - | _ -> + | _ -> let tycon = Option.map (fun t -> subst_term_occ all_occurrences (lift 1 c) (lift 1 t)) tycon in let name = next_ident_away_from (id_of_string "filtered_var") names in - (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, - (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, + (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, + (Name name, Some (lift lenctx c), lift lenctx $ type_of_tomatch t) :: ctx, name :: names, tycon) ([], [], [], tycon) tomatchs in List.rev prev, ctx, tycon - + let is_dependent_ind = function IsInd (_, IndType (indf, args)) when List.length args > 0 -> true | _ -> false @@ -1800,13 +1800,13 @@ let build_dependent_signature env evars avoid tomatchs arsign = let arsign = List.rev arsign in let allnames = List.rev (List.map (List.map pi1) arsign) in let nar = List.fold_left (fun n names -> List.length names + n) 0 allnames in - let eqs, neqs, refls, slift, arsign' = - List.fold_left2 - (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> + let eqs, neqs, refls, slift, arsign' = + List.fold_left2 + (fun (eqs, neqs, refl_args, slift, arsigns) (tm, ty) arsign -> (* The accumulator: - previous eqs, - number of previous eqs, - lift to get outside eqs and in the introduced variables ('as' and 'in'), + previous eqs, + number of previous eqs, + lift to get outside eqs and in the introduced variables ('as' and 'in'), new arity signatures *) match ty with @@ -1819,7 +1819,7 @@ let build_dependent_signature env evars avoid tomatchs arsign = List.fold_left2 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg (name, b, t) -> let argt = Retyping.get_type_of env evars arg in - let eq, refl_arg = + let eq, refl_arg = if Reductionops.is_conv env evars argt t then (mk_eq (lift (nargeqs + slift) argt) (mkRel (nargeqs + slift)) @@ -1832,58 +1832,58 @@ let build_dependent_signature env evars avoid tomatchs arsign = (lift (nargeqs + nar) arg), mk_JMeq_refl argt arg) in - let previd, id = - let name = - match kind_of_term arg with + let previd, id = + let name = + match kind_of_term arg with Rel n -> pi1 (lookup_rel n env) | _ -> name in - make_prime avoid name + make_prime avoid name in - (env, succ nargeqs, - (Name (eq_id avoid previd), None, eq) :: argeqs, + (env, succ nargeqs, + (Name (eq_id avoid previd), None, eq) :: argeqs, refl_arg :: refl_args, pred slift, (Name id, b, t) :: argsign')) (env, 0, [], [], slift, []) args argsign in - let eq = mk_JMeq + let eq = mk_JMeq (lift (nargeqs + slift) appt) (mkRel (nargeqs + slift)) - (lift (nargeqs + nar) ty) - (lift (nargeqs + nar) tm) + (lift (nargeqs + nar) ty) + (lift (nargeqs + nar) tm) in let refl_eq = mk_JMeq_refl ty tm in let previd, id = make_prime avoid appn in - (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, - succ nargeqs, + (((Name (eq_id avoid previd), None, eq) :: argeqs) :: eqs, + succ nargeqs, refl_eq :: refl_args, - pred slift, + pred slift, (((Name id, appb, appt) :: argsign') :: arsigns)) - - | _ -> + + | _ -> (* Non dependent inductive or not inductive, just use a regular equality *) let (name, b, typ) = match arsign with [x] -> x | _ -> assert(false) in let previd, id = make_prime avoid name in let arsign' = (Name id, b, typ) in let tomatch_ty = type_of_tomatch ty in - let eq = + let eq = mk_eq (lift nar tomatch_ty) (mkRel slift) (lift nar tm) in - ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, + ([(Name (eq_id avoid previd), None, eq)] :: eqs, succ neqs, (mk_eq_refl tomatch_ty tm) :: refl_args, pred slift, (arsign' :: []) :: arsigns)) ([], 0, [], nar, []) tomatchs arsign - in + in let arsign'' = List.rev arsign' in assert(slift = 0); (* we must have folded over all elements of the arity signature *) arsign'', allnames, nar, eqs, neqs, refls (**************************************************************************) (* Main entry of the matching compilation *) - -let liftn_rel_context n k sign = + +let liftn_rel_context n k sign = let rec liftrec k = function | (na,c,t)::sign -> (na,Option.map (liftn n k) c,liftn n k t)::(liftrec (k-1) sign) @@ -1891,16 +1891,16 @@ let liftn_rel_context n k sign = in liftrec (k + rel_context_length sign) sign -let nf_evars_env evar_defs (env : env) : env = +let nf_evars_env evar_defs (env : env) : env = let nf t = nf_isevar evar_defs t in - let env0 : env = reset_context env in + let env0 : env = reset_context env in let f e (na, b, t) e' : env = Environ.push_named (na, Option.map nf b, nf t) e' in let env' = Environ.fold_named_context f ~init:env0 env in Environ.fold_rel_context (fun e (na, b, t) e' -> Environ.push_rel (na, Option.map nf b, nf t) e') ~init:env' env - + let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon rtntyp = (* We extract the signature of the arity *) @@ -1910,12 +1910,12 @@ let prepare_predicate_from_rettyp loc typing_fun isevars env tomatchs sign tycon match rtntyp with | Some rtntyp -> let predcclj = typing_fun (mk_tycon (new_Type ())) newenv rtntyp in - let predccl = (j_nf_isevar !isevars predcclj).uj_val in + let predccl = (j_nf_isevar !isevars predcclj).uj_val in Some (build_initial_predicate true allnames predccl) - | None -> + | None -> match valcon_of_tycon tycon with - | Some ty -> - let pred = + | Some ty -> + let pred = prepare_predicate_from_arsign_tycon loc env !isevars tomatchs arsign ty in Some (build_initial_predicate true allnames pred) | None -> None @@ -1926,7 +1926,7 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra (* We build the matrix of patterns and right-hand-side *) let matx = matx_of_eqns env eqns in - + (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in @@ -1935,8 +1935,8 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra let tycon = valcon_of_tycon tycon in let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon in let env = push_rel_context tomatchs_lets env in - let len = List.length eqns in - let sign, allnames, signlen, eqs, neqs, args = + let len = List.length eqns in + let sign, allnames, signlen, eqs, neqs, args = (* The arity signature *) let arsign = extract_arity_signatures env tomatchs (List.map snd tomatchl) in (* Build the dependent arity signature, the equalities which makes @@ -1945,21 +1945,21 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra build_dependent_signature env ( !isevars) avoid tomatchs arsign in - let tycon, arity = + let tycon, arity = match tycon' with | None -> let ev = mkExistential env isevars in ev, ev - | Some t -> + | Some t -> Option.get tycon, prepare_predicate_from_arsign_tycon loc env ( !isevars) tomatchs sign t in - let neqs, arity = + let neqs, arity = let ctx = context_of_arsign eqs in let neqs = List.length ctx in neqs, it_mkProd_or_LetIn (lift neqs arity) ctx in - let lets, matx = + let lets, matx = (* Type the rhs under the assumption of equations *) - constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity + constrs_of_pats typing_fun env isevars matx tomatchs sign neqs arity in let matx = List.rev matx in let _ = assert(len = List.length lets) in @@ -1973,7 +1973,7 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in - + let pb = { env = env; isevars = isevars; @@ -1984,12 +1984,12 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra caseloc = loc; casestyle= style; typing_function = typing_fun } in - + let j = compile pb in (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in - let j = + let j = { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; uj_type = nf_isevar !isevars tycon; } in j @@ -2012,11 +2012,11 @@ let compile_cases loc style (typing_fun, isevars) (tycon : Evarutil.type_constra caseloc = loc; casestyle= style; typing_function = typing_fun } in - + let j = compile pb in (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; - inh_conv_coerce_to_tycon loc env isevars j tycon - + inh_conv_coerce_to_tycon loc env isevars j tycon + end - + diff --git a/plugins/subtac/subtac_classes.ml b/plugins/subtac/subtac_classes.ml index 2b76266718..6fe14da34d 100644 --- a/plugins/subtac/subtac_classes.ml +++ b/plugins/subtac/subtac_classes.ml @@ -35,7 +35,7 @@ let interp_binder_evars evdref env na t = let interp_binders_evars isevars env avoid l = List.fold_left - (fun (env, ids, params) ((loc, i), t) -> + (fun (env, ids, params) ((loc, i), t) -> let n = Name i in let t' = interp_binder_evars isevars env n t in let d = (i,None,t') in @@ -44,7 +44,7 @@ let interp_binders_evars isevars env avoid l = let interp_typeclass_context_evars isevars env avoid l = List.fold_left - (fun (env, ids, params) (iid, bk, cl) -> + (fun (env, ids, params) (iid, bk, cl) -> let t' = interp_binder_evars isevars env (snd iid) cl in let i = match snd iid with | Anonymous -> Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids @@ -56,13 +56,13 @@ let interp_typeclass_context_evars isevars env avoid l = let interp_constrs_evars isevars env avoid l = List.fold_left - (fun (env, ids, params) t -> + (fun (env, ids, params) t -> let t' = interp_binder_evars isevars env Anonymous t in let id = Nameops.next_name_away (Termops.named_hd env t' Anonymous) ids in let d = (id,None,t') in (push_named d env, id :: ids, d::params)) (env, avoid, []) l - + let interp_constr_evars_gen evdref env ?(impls=([],[])) kind c = SPretyping.understand_tcc_evars evdref env kind (intern_gen (kind=IsType) ~impls ( !evdref) env c) @@ -99,11 +99,11 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p match bk with | Implicit -> Implicit_quantifiers.implicit_application Idset.empty (* need no avoid *) - ~allow_partial:false (fun avoid (clname, (id, _, t)) -> - match clname with - | Some (cl, b) -> - let t = - if b then + ~allow_partial:false (fun avoid (clname, (id, _, t)) -> + match clname with + | Some (cl, b) -> + let t = + if b then let _k = class_info cl in CHole (Util.dummy_loc, Some Evd.InternalHole) else CHole (Util.dummy_loc, None) @@ -113,21 +113,21 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p | Explicit -> cl in let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in - let k, ctx', imps, subst = + let k, ctx', imps, subst = let c = Command.generalize_constr_expr tclass ctx in let c', imps = interp_type_evars_impls ~evdref:isevars env c in let ctx, c = decompose_prod_assum c' in let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in cl, ctx, imps, (List.rev args) in - let id = + let id = match snd instid with - | Name id -> + | Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists"); id - | Anonymous -> + | Anonymous -> let i = Nameops.add_suffix (Classes.id_of_class k) "_instance_0" in Termops.next_global_ident_away false i (Termops.ids_of_context env) in @@ -136,29 +136,29 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p isevars := resolve_typeclasses ~onlyargs:false ~fail:true env' !isevars; let sigma = !isevars in let subst = List.map (Evarutil.nf_evar sigma) subst in - let subst = - let props = + let subst = + let props = match props with - | CRecord (loc, _, fs) -> - if List.length fs > List.length k.cl_props then + | CRecord (loc, _, fs) -> + if List.length fs > List.length k.cl_props then Classes.mismatched_props env' (List.map snd fs) k.cl_props; fs - | _ -> - if List.length k.cl_props <> 1 then + | _ -> + if List.length k.cl_props <> 1 then errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body") else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props] in - match k.cl_props with - | [(na,b,ty)] -> + match k.cl_props with + | [(na,b,ty)] -> let term = match props with [] -> CHole (Util.dummy_loc, None) | [(_,f)] -> f | _ -> assert false in let ty' = substl subst ty in let c = interp_casted_constr_evars isevars env' term ty' in c :: subst | _ -> - let props, rest = + let props, rest = List.fold_left - (fun (props, rest) (id,_,_) -> - try + (fun (props, rest) (id,_,_) -> + try let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); @@ -166,23 +166,23 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest) ([], props) k.cl_props in - if rest <> [] then + if rest <> [] then unbound_method env' k.cl_impl (fst (List.hd rest)) else fst (type_ctx_instance isevars env' k.cl_props props subst) in - let subst = List.fold_left2 + let subst = List.fold_left2 (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') [] subst (k.cl_props @ snd k.cl_context) in let inst_constr, ty_constr = instance_constructor k subst in isevars := Evarutil.nf_evar_defs !isevars; let term = Evarutil.nf_isevar !isevars (it_mkLambda_or_LetIn inst_constr ctx') - and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') + and termtype = Evarutil.nf_isevar !isevars (it_mkProd_or_LetIn ty_constr ctx') in isevars := undefined_evars !isevars; Evarutil.check_evars env Evd.empty !isevars termtype; - let hook vis gr = + let hook vis gr = let cst = match gr with ConstRef kn -> kn | _ -> assert false in let inst = Typeclasses.new_instance k pri global cst in Impargs.declare_manual_implicits false gr ~enriching:false imps; @@ -191,4 +191,4 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) p let evm = Subtac_utils.evars_of_term ( !isevars) Evd.empty term in let obls, constr, typ = Eterm.eterm_obligations env id !isevars evm 0 term termtype in id, Subtac_obligations.add_definition id constr typ ~kind:(Global,false,Instance) ~hook obls - + diff --git a/plugins/subtac/subtac_classes.mli b/plugins/subtac/subtac_classes.mli index 917ed80594..eb9f3c8e38 100644 --- a/plugins/subtac/subtac_classes.mli +++ b/plugins/subtac/subtac_classes.mli @@ -32,7 +32,7 @@ val type_ctx_instance : Evd.evar_defs ref -> Term.constr list * ('a * Term.constr option * Term.constr) list -val new_instance : +val new_instance : ?global:bool -> local_binder list -> typeclass_constraint -> diff --git a/plugins/subtac/subtac_coercion.ml b/plugins/subtac/subtac_coercion.ml index ce7b5431b1..4dd3dd32be 100644 --- a/plugins/subtac/subtac_coercion.ml +++ b/plugins/subtac/subtac_coercion.ml @@ -33,7 +33,7 @@ open Pp let pair_of_array a = (a.(0), a.(1)) let make_name s = Name (id_of_string s) -let rec disc_subset x = +let rec disc_subset x = match kind_of_term x with | App (c, l) -> (match kind_of_term c with @@ -47,33 +47,33 @@ let rec disc_subset x = else None | _ -> None) | _ -> None - + and disc_exist env x = match kind_of_term x with | App (c, l) -> (match kind_of_term c with - Construct c -> + Construct c -> if c = Term.destConstruct (Lazy.force sig_).intro then Some (l.(0), l.(1), l.(2), l.(3)) else None | _ -> None) | _ -> None - + module Coercion = struct - + exception NoSubtacCoercion - + let disc_proj_exist env x = match kind_of_term x with | App (c, l) -> - (if Term.eq_constr c (Lazy.force sig_).proj1 - && Array.length l = 3 + (if Term.eq_constr c (Lazy.force sig_).proj1 + && Array.length l = 3 then disc_exist env l.(2) else None) | _ -> None - let sort_rel s1 s2 = + let sort_rel s1 s2 = match s1, s2 with Prop Pos, Prop Pos -> Prop Pos | Prop Pos, Prop Null -> Prop Null @@ -92,27 +92,27 @@ module Coercion = struct in liftrec (List.length sign) sign - let rec mu env isevars t = + let rec mu env isevars t = let isevars = ref isevars in - let rec aux v = + let rec aux v = let v = hnf env isevars v in match disc_subset v with - Some (u, p) -> + Some (u, p) -> let f, ct = aux u in - (Some (fun x -> - app_opt f (mkApp ((Lazy.force sig_).proj1, + (Some (fun x -> + app_opt f (mkApp ((Lazy.force sig_).proj1, [| u; p; x |]))), ct) | None -> (None, v) in aux t - and coerce loc env isevars (x : Term.constr) (y : Term.constr) - : (Term.constr -> Term.constr) option + and coerce loc env isevars (x : Term.constr) (y : Term.constr) + : (Term.constr -> Term.constr) option = let x = nf_evar ( !isevars) x and y = nf_evar ( !isevars) y in let rec coerce_unify env x y = let x = hnf env isevars x and y = hnf env isevars y in - try + try isevars := the_conv_x_leq env x y !isevars; None with Reduction.NotConvertible -> coerce' env x y @@ -125,7 +125,7 @@ module Coercion = struct in let rec coerce_application typ typ' c c' l l' = let len = Array.length l in - let rec aux tele typ typ' i co = + let rec aux tele typ typ' i co = if i < len then let hdx = l.(i) and hdy = l'.(i) in try isevars := the_conv_x_leq env hdx hdy !isevars; @@ -135,15 +135,15 @@ module Coercion = struct with Reduction.NotConvertible -> let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in - let _ = + let _ = try isevars := the_conv_x_leq env eqT eqT' !isevars with Reduction.NotConvertible -> raise NoSubtacCoercion in (* Disallow equalities on arities *) if Reduction.is_arity env eqT then raise NoSubtacCoercion; - let restargs = lift_args 1 + let restargs = lift_args 1 (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) - in + in let args = List.rev (restargs @ mkRel 1 :: lift_args 1 tele) in let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in let eq = mkApp (Lazy.force eq_ind, [| eqT; hdx; hdy |]) in @@ -152,14 +152,14 @@ module Coercion = struct [| eqT; hdx; pred; x; hdy; evar|]) in aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) else Some co - in + in if isEvar c || isEvar c' then (* Second-order unification needed. *) raise NoSubtacCoercion; aux [] typ typ' 0 (fun x -> x) in match (kind_of_term x, kind_of_term y) with - | Sort s, Sort s' -> + | Sort s, Sort s' -> (match s, s' with Prop x, Prop y when x = y -> None | Prop _, Type _ -> None @@ -178,11 +178,11 @@ module Coercion = struct None, None -> failwith "subtac.coerce': Should have detected equivalence earlier" | _, _ -> Some - (fun f -> + (fun f -> mkLambda (name', a', app_opt c2 (mkApp (Term.lift 1 f, [| coec1 |]))))) - + | App (c, l), App (c', l') -> (match kind_of_term c, kind_of_term c' with Ind i, Ind i' -> (* Inductive types *) @@ -192,16 +192,16 @@ module Coercion = struct (* Sigma types *) if len = Array.length l' && len = 2 && i = i' && (i = Term.destInd existS.typ || i = Term.destInd prod.typ) - then - if i = Term.destInd existS.typ + then + if i = Term.destInd existS.typ then - begin - let (a, pb), (a', pb') = - pair_of_array l, pair_of_array l' + begin + let (a, pb), (a', pb') = + pair_of_array l, pair_of_array l' in let c1 = coerce_unify env a a' in - let rec remove_head a c = - match kind_of_term c with + let rec remove_head a c = + match kind_of_term c with | Lambda (n, t, t') -> c, t' (*| Prod (n, t, t') -> t'*) | Evar (k, args) -> @@ -217,35 +217,35 @@ module Coercion = struct let env' = push_rel (make_name "x", None, a) env in let c2 = coerce_unify env' b b' in match c1, c2 with - None, None -> + None, None -> None | _, _ -> - Some + Some (fun x -> - let x, y = + let x, y = app_opt c1 (mkApp (existS.proj1, [| a; pb; x |])), - app_opt c2 (mkApp (existS.proj2, + app_opt c2 (mkApp (existS.proj2, [| a; pb; x |])) in mkApp (existS.intro, [| a'; pb'; x ; y |])) end - else - begin - let (a, b), (a', b') = - pair_of_array l, pair_of_array l' + else + begin + let (a, b), (a', b') = + pair_of_array l, pair_of_array l' in let c1 = coerce_unify env a a' in let c2 = coerce_unify env b b' in match c1, c2 with None, None -> None | _, _ -> - Some + Some (fun x -> - let x, y = + let x, y = app_opt c1 (mkApp (prod.proj1, [| a; b; x |])), - app_opt c2 (mkApp (prod.proj2, + app_opt c2 (mkApp (prod.proj2, [| a; b; x |])) in mkApp (prod.intro, [| a'; b'; x ; y |])) @@ -253,7 +253,7 @@ module Coercion = struct else if i = i' && len = Array.length l' then let evm = !isevars in - (try subco () + (try subco () with NoSubtacCoercion -> let typ = Typing.type_of env evm c in let typ' = Typing.type_of env evm c' in @@ -276,25 +276,25 @@ module Coercion = struct and subset_coerce env isevars x y = match disc_subset x with - Some (u, p) -> + Some (u, p) -> let c = coerce_unify env u y in - let f x = - app_opt c (mkApp ((Lazy.force sig_).proj1, + let f x = + app_opt c (mkApp ((Lazy.force sig_).proj1, [| u; p; x |])) in Some f | None -> match disc_subset y with Some (u, p) -> let c = coerce_unify env x u in - Some + Some (fun x -> let cx = app_opt c x in let evar = make_existential loc env isevars (mkApp (p, [| cx |])) in - (mkApp - ((Lazy.force sig_).intro, + (mkApp + ((Lazy.force sig_).intro, [| u; p; cx; evar |]))) - | None -> + | None -> raise NoSubtacCoercion (*isevars := Evd.add_conv_pb (Reduction.CONV, x, y) !isevars; None*) @@ -304,7 +304,7 @@ module Coercion = struct let evars = ref isevars in let coercion = coerce loc env evars t c1 in !evars, Option.map (app_opt coercion) v - + (* Taken from pretyping/coercion.ml *) (* Typing operations dealing with coercions *) @@ -317,11 +317,11 @@ module Coercion = struct | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) match kind_of_term (whd_betadeltaiota env Evd.empty typ) with - | Prod (_,c1,c2) -> + | Prod (_,c1,c2) -> (* Typage garanti par l'appel à app_coercion*) apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly "apply_coercion_args" - in + in apply_rec [] funj.uj_type argl (* appliquer le chemin de coercions de patterns p *) @@ -342,21 +342,21 @@ module Coercion = struct (* appliquer le chemin de coercions p à hj *) let apply_coercion env sigma p hj typ_cl = - try + try fst (List.fold_left - (fun (ja,typ_cl) i -> + (fun (ja,typ_cl) i -> let fv,isid = coercion_value i in let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in let jres = apply_coercion_args env argl fv in - (if isid then + (if isid then { uj_val = ja.uj_val; uj_type = jres.uj_type } - else + else jres), jres.uj_type) (hj,typ_cl) p) with _ -> anomaly "apply_coercion" - let inh_app_fun env isevars j = + let inh_app_fun env isevars j = let t = whd_betadeltaiota env ( isevars) j.uj_type in match kind_of_term t with | Prod (_,_,_) -> (isevars,j) @@ -369,7 +369,7 @@ module Coercion = struct lookup_path_to_fun_from env ( isevars) j.uj_type in (isevars,apply_coercion env ( isevars) p j t) with Not_found -> - try + try let coercef, t = mu env isevars t in (isevars, { uj_val = app_opt coercef j.uj_val; uj_type = t }) with NoSubtacCoercion | NoCoercion -> @@ -378,7 +378,7 @@ module Coercion = struct let inh_tosort_force loc env isevars j = try let t,p = lookup_path_to_sort_from env ( isevars) j.uj_type in - let j1 = apply_coercion env ( isevars) p j t in + let j1 = apply_coercion env ( isevars) p j t in (isevars,type_judgment env (j_nf_evar ( isevars) j1)) with Not_found -> error_not_a_type_loc loc env ( isevars) j @@ -396,29 +396,29 @@ module Coercion = struct let inh_coerce_to_base loc env isevars j = let typ = whd_betadeltaiota env ( isevars) j.uj_type in let ct, typ' = mu env isevars typ in - isevars, { uj_val = app_opt ct j.uj_val; + isevars, { uj_val = app_opt ct j.uj_val; uj_type = typ' } let inh_coerce_to_prod loc env isevars t = let typ = whd_betadeltaiota env ( isevars) (snd t) in let _, typ' = mu env isevars typ in isevars, (fst t, typ') - + let inh_coerce_to_fail env evd rigidonly v t c1 = if rigidonly & not (Heads.is_rigid env c1 && Heads.is_rigid env t) then raise NoCoercion else let v', t' = - try + try let t2,t1,p = lookup_path_between env ( evd) (t,c1) in match v with - Some v -> + Some v -> let j = apply_coercion env ( evd) p {uj_val = v; uj_type = t} t2 in Some j.uj_val, j.uj_type | None -> None, t - with Not_found -> raise NoCoercion + with Not_found -> raise NoCoercion in try (the_conv_x_leq env t' c1 evd, v') with Reduction.NotConvertible -> raise NoCoercion @@ -433,12 +433,12 @@ module Coercion = struct kind_of_term (whd_betadeltaiota env ( evd) t), kind_of_term (whd_betadeltaiota env ( evd) c1) with - | Prod (name,t1,t2), Prod (_,u1,u2) -> + | Prod (name,t1,t2), Prod (_,u1,u2) -> (* Conversion did not work, we may succeed with a coercion. *) (* We eta-expand (hence possibly modifying the original term!) *) (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *) (* has type forall (x:u1), u2 (with v' recursively obtained) *) - let name = match name with + let name = match name with | Anonymous -> Name (id_of_string "x") | _ -> name in let env1 = push_rel (name,None,u1) env in @@ -456,8 +456,8 @@ module Coercion = struct let inh_conv_coerce_to_gen rigidonly loc env evd cj ((n, t) as _tycon) = match n with None -> - let (evd', val') = - try + let (evd', val') = + try inh_conv_coerce_to_fail loc env evd rigidonly (Some (nf_isevar evd cj.uj_val)) (nf_isevar evd cj.uj_type) (nf_isevar evd t) @@ -482,7 +482,7 @@ module Coercion = struct None -> 0, 0 | Some (init, cur) -> init, cur in - try + try let rels, rng = Reductionops.splay_prod_n env ( isevars) nabs t in (* The final range free variables must have been replaced by evars, we accept only that evars in rng are applied to free vars. *) diff --git a/plugins/subtac/subtac_command.ml b/plugins/subtac/subtac_command.ml index 1095b143cc..d1e890867c 100644 --- a/plugins/subtac/subtac_command.ml +++ b/plugins/subtac/subtac_command.ml @@ -55,11 +55,11 @@ let evar_nf isevars c = let get_undefined_evars evd = Evd.fold (fun ev evi evd' -> - if evi.evar_body = Evar_empty then + if evi.evar_body = Evar_empty then Evd.add evd' ev (nf_evar_info evd evi) else evd') evd Evd.empty -let interp_gen kind isevars env +let interp_gen kind isevars env ?(impls=([],[])) ?(allow_patvar=false) ?(ltacvars=([],[])) c = let c' = Constrintern.intern_gen (kind=IsType) ~impls ~allow_patvar ~ltacvars ( !isevars) env c in @@ -67,16 +67,16 @@ let interp_gen kind isevars env evar_nf isevars c' let interp_constr isevars env c = - interp_gen (OfType None) isevars env c + interp_gen (OfType None) isevars env c let interp_type_evars isevars env ?(impls=([],[])) c = interp_gen IsType isevars env ~impls c let interp_casted_constr isevars env ?(impls=([],[])) c typ = - interp_gen (OfType (Some typ)) isevars env ~impls c + interp_gen (OfType (Some typ)) isevars env ~impls c let interp_casted_constr_evars isevars env ?(impls=([],[])) c typ = - interp_gen (OfType (Some typ)) isevars env ~impls c + interp_gen (OfType (Some typ)) isevars env ~impls c let interp_open_constr isevars env c = msgnl (str "Pretyping " ++ my_print_constr_expr c); @@ -85,17 +85,17 @@ let interp_open_constr isevars env c = evar_nf isevars c' let interp_constr_judgment isevars env c = - let j = + let j = SPretyping.understand_judgment_tcc isevars env - (Constrintern.intern_constr ( !isevars) env c) + (Constrintern.intern_constr ( !isevars) env c) in { uj_val = evar_nf isevars j.uj_val; uj_type = evar_nf isevars j.uj_type } let locate_if_isevar loc na = function - | RHole _ -> + | RHole _ -> (try match na with | Name id -> Reserve.find_reserved_type id - | Anonymous -> raise Not_found + | Anonymous -> raise Not_found with Not_found -> RHole (loc, Evd.BinderType na)) | x -> x @@ -103,7 +103,7 @@ let interp_binder sigma env na t = let t = Constrintern.intern_gen true ( !sigma) env t in SPretyping.understand_tcc_evars sigma env IsType (locate_if_isevar (loc_of_rawconstr t) na t) -let interp_context_evars evdref env params = +let interp_context_evars evdref env params = let bl = Constrintern.intern_context false ( !evdref) env params in let (env, par, _, impls) = List.fold_left @@ -113,7 +113,7 @@ let interp_context_evars evdref env params = let t' = locate_if_isevar (loc_of_rawconstr t) na t in let t = SPretyping.understand_tcc_evars evdref env IsType t' in let d = (na,None,t) in - let impls = + let impls = if k = Implicit then let na = match na with Name n -> Some n | Anonymous -> None in (ExplByPos (n, na), (true, true, true)) :: impls @@ -134,39 +134,39 @@ let list_chop_hd i l = match list_chop i l with | (x :: [], l2) -> ([], x, []) | _ -> assert(false) -let collect_non_rec env = - let rec searchrec lnonrec lnamerec ldefrec larrec nrec = +let collect_non_rec env = + let rec searchrec lnonrec lnamerec ldefrec larrec nrec = try - let i = + let i = list_try_find_i (fun i f -> if List.for_all (fun (_, def) -> not (occur_var env f def)) ldefrec then i else failwith "try_find_i") - 0 lnamerec + 0 lnamerec in let (lf1,f,lf2) = list_chop_hd i lnamerec in let (ldef1,def,ldef2) = list_chop_hd i ldefrec in let (lar1,ar,lar2) = list_chop_hd i larrec in - let newlnv = - try - match list_chop i nrec with + let newlnv = + try + match list_chop i nrec with | (lnv1,_::lnv2) -> (lnv1@lnv2) | _ -> [] (* nrec=[] for cofixpoints *) with Failure "list_chop" -> [] - in - searchrec ((f,def,ar)::lnonrec) + in + searchrec ((f,def,ar)::lnonrec) (lf1@lf2) (ldef1@ldef2) (lar1@lar2) newlnv - with Failure "try_find_i" -> + with Failure "try_find_i" -> (List.rev lnonrec, (Array.of_list lnamerec, Array.of_list ldefrec, Array.of_list larrec, Array.of_list nrec)) - in - searchrec [] + in + searchrec [] -let list_of_local_binders l = +let list_of_local_binders l = let rec aux acc = function Topconstr.LocalRawDef (n, c) :: tl -> aux ((n, Some c, None) :: acc) tl - | Topconstr.LocalRawAssum (nl, k, c) :: tl -> + | Topconstr.LocalRawAssum (nl, k, c) :: tl -> aux (List.fold_left (fun acc n -> (n, None, Some c) :: acc) acc nl) tl | [] -> List.rev acc in aux [] l @@ -201,7 +201,7 @@ let telescope = function | (n, None, t) :: tl -> let ty, tys, (k, constr) = List.fold_left - (fun (ty, tys, (k, constr)) (n, b, t) -> + (fun (ty, tys, (k, constr)) (n, b, t) -> let pred = mkLambda (n, t, ty) in let sigty = mkApp ((Lazy.force sigT).typ, [|t; pred|]) in let intro = mkApp ((Lazy.force sigT).intro, [|lift k t; lift k pred; mkRel k; constr|]) in @@ -215,14 +215,14 @@ let telescope = function (lift 1 proj2, (n, Some proj1, t) :: subst)) (List.rev tys) tl (mkRel 1, []) in ty, ((n, Some last, t) :: subst), constr - + | _ -> raise (Invalid_argument "telescope") let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = Coqlib.check_required_library ["Coq";"Program";"Wf"]; let sigma = Evd.empty in let isevars = ref (Evd.create_evar_defs sigma) in - let env = Global.env() in + let env = Global.env() in let _pr c = my_print_constr env c in let _prr = Printer.pr_rel_context env in let _prn = Printer.pr_named_context env in @@ -235,8 +235,8 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let argtyp, letbinders, make = telescope binders_rel in let argname = id_of_string "recarg" in let arg = (Name argname, None, argtyp) in - let wrapper x = - if List.length binders_rel > 1 then + let wrapper x = + if List.length binders_rel > 1 then it_mkLambda_or_LetIn (mkApp (x, [|make|])) binders_rel else x in @@ -244,12 +244,12 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let binders_env = push_rel_context binders_rel env in let rel = interp_constr isevars env r in let relty = type_of env !isevars rel in - let relargty = + let relargty = let ctx, ar = Reductionops.splay_prod_n env !isevars 2 relty in match ctx, kind_of_term ar with - | [(_, None, t); (_, None, u)], Sort (Prop Null) + | [(_, None, t); (_, None, u)], Sort (Prop Null) when Reductionops.is_conv env !isevars t u -> t - | _, _ -> + | _, _ -> user_err_loc (constr_loc r, "Subtac_command.build_wellfounded", my_print_constr env rel ++ str " is not an homogeneous binary relation.") @@ -261,7 +261,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = it_mkLambda_or_LetIn measure binders in let comb = constr_of_global (Lazy.force measure_on_R_ref) in - let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in + let wf_rel = mkApp (comb, [| argtyp; relargty; rel; measure |]) in let wf_rel_fun x y = mkApp (rel, [| subst1 x measure_body; subst1 y measure_body |]) @@ -280,13 +280,13 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let projection = (* in wfarg :: arg :: before *) mkApp (proj, [| argtyp ; wfargpred ; mkRel 1 |]) in - let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in + let top_arity_let = it_mkLambda_or_LetIn top_arity letbinders in let intern_arity = substl [projection] top_arity_let in (* substitute the projection of wfarg for something, now intern_arity is in wfarg :: arg *) let intern_fun_arity_prod = it_mkProd_or_LetIn intern_arity [wfarg 1] in let intern_fun_binder = (Name (add_suffix recname "'"), None, intern_fun_arity_prod) in - let curry_fun = + let curry_fun = let wfpred = mkLambda (Name argid', argtyp, wf_rel_fun (mkRel 1) (mkRel (2 * len + 4))) in let arg = mkApp ((Lazy.force sig_).intro, [| argtyp; wfpred; lift 1 make; mkRel 1 |]) in let app = mkApp (mkRel (2 * len + 2 (* recproof + orig binders + current binders *)), [| arg |]) in @@ -298,22 +298,22 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = in let fun_bl = intern_fun_binder :: [arg] in let lift_lets = Termops.lift_rel_context 1 letbinders in - let intern_body = + let intern_body = let ctx = (Name recname, None, pi3 curry_fun) :: binders_rel in let impls = Command.compute_interning_datas env Constrintern.Recursive [] [recname] [full_arity] [impls] in - let newimpls = + let newimpls = match snd impls with [(p, (r, l, impls, scopes))] -> [(p, (r, l, impls @ [Some (id_of_string "recproof", Impargs.Manual, (true, false))], scopes @ [None]))] | x -> x - in interp_casted_constr isevars ~impls:(fst impls,newimpls) + in interp_casted_constr isevars ~impls:(fst impls,newimpls) (push_rel_context ctx env) body (lift 1 top_arity) in let intern_body_lam = it_mkLambda_or_LetIn intern_body (curry_fun :: lift_lets @ fun_bl) in let prop = mkLambda (Name argname, argtyp, top_arity_let) in let fix_def = mkApp (constr_of_global (Lazy.force fix_sub_ref), - [| argtyp ; wf_rel ; + [| argtyp ; wf_rel ; make_existential dummy_loc ~opaque:(Define false) env isevars wf_proof ; prop ; intern_body_lam |]) in @@ -328,10 +328,10 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation boxed = let evars, evars_def, evars_typ = Eterm.eterm_obligations env recname !isevars evm 0 fullcoqc fullctyp in Subtac_obligations.add_definition recname evars_def evars_typ ~implicits:impls evars -let nf_evar_context isevars ctx = - List.map (fun (n, b, t) -> +let nf_evar_context isevars ctx = + List.map (fun (n, b, t) -> (n, Option.map (Evarutil.nf_isevar isevars) b, Evarutil.nf_isevar isevars t)) ctx - + let interp_fix_context evdref env fix = interp_context_evars evdref env fix.Command.fix_binders @@ -350,7 +350,7 @@ let prepare_recursive_declaration fixnames fixtypes fixdefs = let names = List.map (fun id -> Name id) fixnames in (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) -let rel_index n ctx = +let rel_index n ctx = list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx)) let rec unfold f b = @@ -359,16 +359,16 @@ let rec unfold f b = | None -> [] let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype = - match n with + match n with | Some (loc, n) -> [rel_index n fixctx] - | None -> + | None -> (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) let len = List.length fixctx in - unfold (function x when x = len -> None + unfold (function x when x = len -> None | n -> Some (n, succ n)) 0 let push_named_context = List.fold_right push_named @@ -402,11 +402,11 @@ let interp_recursive fixkind l boxed = let fixctxs, fiximps = List.split (List.map (interp_fix_context evdref env) fixl) in let fixccls = List.map2 (interp_fix_ccl evdref) fixctxs fixl in let fixtypes = List.map2 build_fix_type fixctxs fixccls in - let rec_sign = + let rec_sign = List.fold_left2 (fun env' id t -> let sort = Retyping.get_type_of env !evdref t in - let fixprot = - try mkApp (Lazy.force Subtac_utils.fix_proto, [|sort; t|]) + let fixprot = + try mkApp (Lazy.force Subtac_utils.fix_proto, [|sort; t|]) with e -> t in (id,None,fixprot) :: env') @@ -419,8 +419,8 @@ let interp_recursive fixkind l boxed = let notations = List.fold_right Option.List.cons ntnl [] in (* Interp bodies with rollback because temp use of notations/implicit *) - let fixdefs = - States.with_state_protection (fun () -> + let fixdefs = + States.with_state_protection (fun () -> List.iter (Command.declare_interning_data impls) notations; list_map3 (interp_fix_body evdref env_rec impls) fixctxs fixl fixccls) () in @@ -434,7 +434,7 @@ let interp_recursive fixkind l boxed = let fixdefs = List.map (nf_evar evd) fixdefs in let fixtypes = List.map (nf_evar evd) fixtypes in let rec_sign = nf_named_context_evar evd rec_sign in - + let recdefs = List.length rec_sign in List.iter (check_evars env_rec Evd.empty evd) fixdefs; List.iter (check_evars env Evd.empty evd) fixtypes; @@ -446,9 +446,9 @@ let interp_recursive fixkind l boxed = let isevars = Evd.undefined_evars evd in let evm = isevars in (* Solve remaining evars *) - let rec collect_evars id def typ imps = + let rec collect_evars id def typ imps = (* Generalize by the recursive prototypes *) - let def = + let def = Termops.it_mkNamedLambda_or_LetIn def rec_sign and typ = Termops.it_mkNamedProd_or_LetIn typ rec_sign @@ -457,14 +457,14 @@ let interp_recursive fixkind l boxed = let evm' = Subtac_utils.evars_of_term evm evm' typ in let evars, def, typ = Eterm.eterm_obligations env id isevars evm' recdefs def typ in (id, def, typ, imps, evars) - in + in let defs = list_map4 collect_evars fixnames fixdefs fixtypes fiximps in (match fixkind with | Command.IsFixpoint wfl -> let possible_indexes = list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in - let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), - Array.of_list fixtypes, + let fixdecls = Array.of_list (List.map (fun x -> Name x) fixnames), + Array.of_list fixtypes, Array.of_list (List.map (subst_vars (List.rev fixnames)) fixdefs) in let indexes = Pretyping.search_guard dummy_loc (Global.env ()) possible_indexes fixdecls in @@ -480,8 +480,8 @@ let build_recursive l b = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] -> - ignore(build_wellfounded (id, n, bl, typ, def) r - (match n with Some n -> mkIdentC (snd n) | None -> + ignore(build_wellfounded (id, n, bl, typ, def) r + (match n with Some n -> mkIdentC (snd n) | None -> errorlabstrm "Subtac_command.build_recursive" (str "Recursive argument required for well-founded fixpoints")) ntn false) @@ -491,15 +491,15 @@ let build_recursive l b = m ntn false) | _, _ when List.for_all (fun (n, ro) -> ro = CStructRec) g -> - let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> - ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn)) l + let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> + ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn)) l in interp_recursive (Command.IsFixpoint g) fixl b - | _, _ -> + | _, _ -> errorlabstrm "Subtac_command.build_recursive" (str "Well-founded fixpoints not allowed in mutually recursive blocks") let build_corecursive l b = - let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> + let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> ({Command.fix_name = id; Command.fix_binders = bl; Command.fix_body = def; Command.fix_type = typ},ntn)) l in interp_recursive Command.IsCoFixpoint fixl b diff --git a/plugins/subtac/subtac_command.mli b/plugins/subtac/subtac_command.mli index 6f73bc9424..6c0c4340f9 100644 --- a/plugins/subtac/subtac_command.mli +++ b/plugins/subtac/subtac_command.mli @@ -47,7 +47,7 @@ val telescope : Term.types * (Names.name * Term.types option * Term.types) list * Term.constr -val build_wellfounded : +val build_wellfounded : Names.identifier * 'a * Topconstr.local_binder list * Topconstr.constr_expr * Topconstr.constr_expr -> Topconstr.constr_expr -> diff --git a/plugins/subtac/subtac_errors.ml b/plugins/subtac/subtac_errors.ml index 3bbfe22bc0..067da150ec 100644 --- a/plugins/subtac/subtac_errors.ml +++ b/plugins/subtac/subtac_errors.ml @@ -4,12 +4,12 @@ open Printer type term_pp = Pp.std_ppcmds -type subtyping_error = +type subtyping_error = | UncoercibleInferType of loc * term_pp * term_pp | UncoercibleInferTerm of loc * term_pp * term_pp * term_pp * term_pp | UncoercibleRewrite of term_pp * term_pp -type typing_error = +type typing_error = | NonFunctionalApp of loc * term_pp * term_pp * term_pp | NonConvertible of loc * term_pp * term_pp | NonSigma of loc * term_pp @@ -17,7 +17,7 @@ type typing_error = exception Subtyping_error of subtyping_error exception Typing_error of typing_error - + exception Debug_msg of string let typing_error e = raise (Typing_error e) diff --git a/plugins/subtac/subtac_obligations.ml b/plugins/subtac/subtac_obligations.ml index fb74867f1b..94bd059c2d 100644 --- a/plugins/subtac/subtac_obligations.ml +++ b/plugins/subtac/subtac_obligations.ml @@ -29,7 +29,7 @@ let explain_no_obligations = function type obligation_info = (Names.identifier * Term.types * loc * obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array - + type obligation = { obl_name : identifier; obl_type : types; @@ -74,18 +74,18 @@ let get_proofs_transparency () = !proofs_transparency open Goptions let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "transparency of Program obligations"; optkey = ["Transparent";"Obligations"]; optread = get_proofs_transparency; - optwrite = set_proofs_transparency; } + optwrite = set_proofs_transparency; } let evar_of_obligation o = make_evar (Global.named_context_val ()) o.obl_type let get_obligation_body expand obl = let c = Option.get obl.obl_body in - if expand && obl.obl_status = Expand then + if expand && obl.obl_status = Expand then match kind_of_term c with | Const c -> constant_value (Global.env ()) c | _ -> c @@ -96,14 +96,14 @@ let subst_deps expand obls deps t = Intset.fold (fun x acc -> let xobl = obls.(x) in - let oblb = + let oblb = try get_obligation_body expand xobl with _ -> assert(false) in (xobl.obl_name, oblb) :: acc) deps [] in(* Termops.it_mkNamedProd_or_LetIn t subst *) Term.replace_vars subst t - + let subst_deps_obl obls obl = let t' = subst_deps false obls obl.obl_deps obl.obl_type in { obl with obl_type = t' } @@ -114,19 +114,19 @@ let map_replace k v m = ProgMap.add k v (ProgMap.remove k m) let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] -let map_cardinal m = - let i = ref 0 in +let map_cardinal m = + let i = ref 0 in ProgMap.iter (fun _ _ -> incr i) m; !i exception Found of program_info -let map_first m = +let map_first m = try ProgMap.iter (fun _ v -> raise (Found v)) m; assert(false) with Found x -> x - + let from_prg : program_info ProgMap.t ref = ref ProgMap.empty let freeze () = !from_prg, !default_tactic_expr @@ -140,7 +140,7 @@ let init () = let _ = init () -let _ = +let _ = Summary.declare_summary "program-tcc-table" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; @@ -155,10 +155,10 @@ let cache (_, (infos, tac)) = let load (_, (_, tac)) = set_default_tactic tac -let subst (_, s, (infos, tac)) = +let subst (_, s, (infos, tac)) = (infos, Tacinterp.subst_tactic s tac) -let (input,output) = +let (input,output) = declare_object { (default_object "Program state") with cache_function = cache; @@ -173,40 +173,40 @@ let (input,output) = subst_function = subst; export_function = (fun x -> Some x) } -let update_state () = +let update_state () = (* msgnl (str "Updating obligations info"); *) Lib.add_anonymous_leaf (input (!from_prg, !default_tactic_expr)) -let set_default_tactic t = +let set_default_tactic t = set_default_tactic t; update_state () - + open Evd -let progmap_remove prg = +let progmap_remove prg = from_prg := ProgMap.remove prg.prg_name !from_prg - + let rec intset_to = function -1 -> Intset.empty | n -> Intset.add n (intset_to (pred n)) - -let subst_body expand prg = + +let subst_body expand prg = let obls, _ = prg.prg_obligations in let ints = intset_to (pred (Array.length obls)) in subst_deps expand obls ints prg.prg_body, subst_deps expand obls ints (Termops.refresh_universes prg.prg_type) - + let declare_definition prg = let body, typ = subst_body false prg in (try trace (str "Declaring: " ++ Ppconstr.pr_id prg.prg_name ++ spc () ++ - my_print_constr (Global.env()) body ++ str " : " ++ + my_print_constr (Global.env()) body ++ str " : " ++ my_print_constr (Global.env()) prg.prg_type); with _ -> ()); let (local, boxed, kind) = prg.prg_kind in - let ce = + let ce = { const_entry_body = body; const_entry_type = Some typ; const_entry_opaque = false; - const_entry_boxed = boxed} + const_entry_boxed = boxed} in (Command.get_declare_definition_hook ()) ce; match local with @@ -215,15 +215,15 @@ let declare_definition prg = SectionLocalDef(ce.const_entry_body,ce.const_entry_type,false) in let _ = declare_variable prg.prg_name (Lib.cwd(),c,IsDefinition kind) in print_message (Subtac_utils.definition_message prg.prg_name); - if Pfedit.refining () then - Flags.if_verbose msg_warning - (str"Local definition " ++ Nameops.pr_id prg.prg_name ++ + if Pfedit.refining () then + Flags.if_verbose msg_warning + (str"Local definition " ++ Nameops.pr_id prg.prg_name ++ str" is not visible from current goals"); progmap_remove prg; update_state (); VarRef prg.prg_name | (Global|Local) -> let c = - Declare.declare_constant + Declare.declare_constant prg.prg_name (DefinitionEntry ce,IsDefinition (pi3 prg.prg_kind)) in let gr = ConstRef c in @@ -243,15 +243,15 @@ let rec lam_index n t acc = if na = Name n then acc else lam_index n b (succ acc) | _ -> raise Not_found - + let compute_possible_guardness_evidences (n,_) fixbody fixtype = - match n with + match n with | Some (loc, n) -> [lam_index n fixbody 0] - | None -> + | None -> (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) let m = Term.nb_prod fixtype in let ctx = fst (decompose_prod_n_assum m fixtype) in @@ -263,9 +263,9 @@ let reduce_fix = let declare_mutual_definition l = let len = List.length l in let first = List.hd l in - let fixdefs, fixtypes, fiximps = + let fixdefs, fixtypes, fiximps = list_split3 - (List.map (fun x -> + (List.map (fun x -> let subs, typ = (subst_body false x) in (strip_lam_n len subs), snd (decompose_prod_n len typ), x.prg_implicits) l) in @@ -285,7 +285,7 @@ let declare_mutual_definition l = Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l | IsCoFixpoint -> None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l - in + in (* Declare the recursive definitions *) let kns = list_map4 (declare_fix boxed kind) fixnames fixdecls fixtypes fiximps in (* Declare notations *) @@ -293,36 +293,36 @@ let declare_mutual_definition l = Flags.if_verbose ppnl (Command.recursive_message kind indexes fixnames); let gr = List.hd kns in let kn = match gr with ConstRef kn -> kn | _ -> assert false in - first.prg_hook local gr; + first.prg_hook local gr; List.iter progmap_remove l; update_state (); kn - + let declare_obligation obl body = match obl.obl_status with | Expand -> { obl with obl_body = Some body } | Define opaque -> - let ce = + let ce = { const_entry_body = body; const_entry_type = Some obl.obl_type; - const_entry_opaque = - (if get_proofs_transparency () then false + const_entry_opaque = + (if get_proofs_transparency () then false else opaque) ; - const_entry_boxed = false} + const_entry_boxed = false} in - let constant = Declare.declare_constant obl.obl_name + let constant = Declare.declare_constant obl.obl_name (DefinitionEntry ce,IsProof Property) in print_message (Subtac_utils.definition_message obl.obl_name); { obl with obl_body = Some (mkConst constant) } - + let red = Reductionops.nf_betaiota Evd.empty let init_prog_info n b t deps fixkind notations obls impls kind hook = - let obls' = + let obls' = Array.mapi (fun i (n, t, l, o, d, tac) -> debug 2 (str "Adding obligation " ++ int i ++ str " with deps : " ++ str (string_of_intset d)); - { obl_name = n ; obl_body = None; + { obl_name = n ; obl_body = None; obl_location = l; obl_type = red t; obl_status = o; obl_deps = d; obl_tac = tac }) obls @@ -330,30 +330,30 @@ let init_prog_info n b t deps fixkind notations obls impls kind hook = { prg_name = n ; prg_body = b; prg_type = red t; prg_obligations = (obls', Array.length obls'); prg_deps = deps; prg_fixkind = fixkind ; prg_notations = notations ; prg_implicits = impls; prg_kind = kind; prg_hook = hook; } - + let get_prog name = let prg_infos = !from_prg in match name with - Some n -> + Some n -> (try ProgMap.find n prg_infos with Not_found -> raise (NoObligations (Some n))) - | None -> + | None -> (let n = map_cardinal prg_infos in - match n with + match n with 0 -> raise (NoObligations None) | 1 -> map_first prg_infos | _ -> error "More than one program with unsolved obligations") -let get_prog_err n = +let get_prog_err n = try get_prog n with NoObligations id -> pperror (explain_no_obligations id) let obligations_solved prg = (snd prg.prg_obligations) = 0 - -type progress = - | Remain of int + +type progress = + | Remain of int | Dependent | Defined of global_reference - + let obligations_message rem = if rem > 0 then if rem = 1 then @@ -363,7 +363,7 @@ let obligations_message rem = else Flags.if_verbose msgnl (str "No more obligations remaining") -let update_obls prg obls rem = +let update_obls prg obls rem = let prg' = { prg with prg_obligations = (obls, rem) } in from_prg := map_replace prg.prg_name prg' !from_prg; obligations_message rem; @@ -379,12 +379,12 @@ let update_obls prg obls rem = let kn = declare_mutual_definition progs in Defined (ConstRef kn) else Dependent) - + let is_defined obls x = obls.(x).obl_body <> None -let deps_remaining obls deps = +let deps_remaining obls deps = Intset.fold - (fun x acc -> + (fun x acc -> if is_defined obls x then acc else x :: acc) deps [] @@ -392,18 +392,18 @@ let deps_remaining obls deps = let has_dependencies obls n = let res = ref false in Array.iteri - (fun i obl -> + (fun i obl -> if i <> n && Intset.mem n obl.obl_deps then res := true) obls; !res - + let kind_of_opacity o = match o with | Define false | Expand -> Subtac_utils.goal_kind | _ -> Subtac_utils.goal_proof_kind -let not_transp_msg = +let not_transp_msg = str "Obligation should be transparent but was declared opaque." ++ spc () ++ str"Use 'Defined' instead." @@ -415,15 +415,15 @@ let rec solve_obligation prg num = let obls, rem = prg.prg_obligations in let obl = obls.(num) in if obl.obl_body <> None then - pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") + pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") else match deps_remaining obls obl.obl_deps with | [] -> let obl = subst_deps_obl obls obl in Command.start_proof obl.obl_name (kind_of_opacity obl.obl_status) obl.obl_type - (fun strength gr -> + (fun strength gr -> let cst = match gr with ConstRef cst -> cst | _ -> assert false in - let obl = + let obl = let transparent = evaluable_constant cst (Global.env ()) in let body = match obl.obl_status with @@ -437,8 +437,8 @@ let rec solve_obligation prg num = in let obls = Array.copy obls in let _ = obls.(num) <- obl in - let res = try update_obls prg obls (pred rem) - with e -> pperror (Cerrors.explain_exn e) + let res = try update_obls prg obls (pred rem) + with e -> pperror (Cerrors.explain_exn e) in match res with | Remain n when n > 0 -> @@ -451,7 +451,7 @@ let rec solve_obligation prg num = Flags.if_verbose (fun () -> msg (Printer.pr_open_subgoals ())) () | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) - + and subtac_obligation (user_num, name, typ) = let num = pred user_num in let prg = get_prog_err name in @@ -462,20 +462,20 @@ and subtac_obligation (user_num, name, typ) = None -> solve_obligation prg num | Some r -> error "Obligation already solved" else error (sprintf "Unknown obligation number %i" (succ num)) - - + + and solve_obligation_by_tac prg obls i tac = let obl = obls.(i) in - match obl.obl_body with + match obl.obl_body with | Some _ -> false - | None -> + | None -> try if deps_remaining obls obl.obl_deps = [] then let obl = subst_deps_obl obls obl in - let tac = + let tac = match tac with | Some t -> t - | None -> + | None -> match obl.obl_tac with | Some t -> Tacinterp.interp t | None -> !default_tactic @@ -491,39 +491,39 @@ and solve_obligation_by_tac prg obls i tac = user_err_loc (obl.obl_location, "solve_obligation", Lazy.force s) | e -> false -and solve_prg_obligations prg tac = +and solve_prg_obligations prg tac = let obls, rem = prg.prg_obligations in let rem = ref rem in let obls' = Array.copy obls in - let _ = - Array.iteri (fun i x -> + let _ = + Array.iteri (fun i x -> if solve_obligation_by_tac prg obls' i tac then decr rem) obls' in update_obls prg obls' !rem -and solve_obligations n tac = +and solve_obligations n tac = let prg = get_prog_err n in solve_prg_obligations prg tac -and solve_all_obligations tac = +and solve_all_obligations tac = ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg - -and try_solve_obligation n prg tac = - let prg = get_prog prg in + +and try_solve_obligation n prg tac = + let prg = get_prog prg in let obls, rem = prg.prg_obligations in let obls' = Array.copy obls in if solve_obligation_by_tac prg obls' n tac then ignore(update_obls prg obls' (pred rem)); -and try_solve_obligations n tac = +and try_solve_obligations n tac = try ignore (solve_obligations n tac) with NoObligations _ -> () and auto_solve_obligations n tac : progress = Flags.if_verbose msgnl (str "Solving obligations automatically..."); try solve_prg_obligations (get_prog_err n) tac with NoObligations _ -> Dependent - + open Pp let show_obligations ?(msg=true) n = let prg = get_prog_err n in @@ -531,17 +531,17 @@ let show_obligations ?(msg=true) n = let obls, rem = prg.prg_obligations in let showed = ref 5 in if msg then msgnl (int rem ++ str " obligation(s) remaining: "); - Array.iteri (fun i x -> - match x.obl_body with - | None -> + Array.iteri (fun i x -> + match x.obl_body with + | None -> if !showed > 0 then ( decr showed; msgnl (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ - str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ + str "of" ++ spc() ++ str (string_of_id n) ++ str ":" ++ spc () ++ hov 1 (my_print_constr (Global.env ()) x.obl_type ++ str "." ++ fnl ()))) | Some _ -> ()) obls - + let show_term n = let prg = get_prog_err n in let n = prg.prg_name in @@ -554,19 +554,19 @@ let add_definition n b t ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic let prg = init_prog_info n b t [] None [] obls implicits kind hook in let obls,_ = prg.prg_obligations in if Array.length obls = 0 then ( - Flags.if_verbose ppnl (str "."); - let cst = declare_definition prg in + Flags.if_verbose ppnl (str "."); + let cst = declare_definition prg in from_prg := ProgMap.remove prg.prg_name !from_prg; Defined cst) else ( let len = Array.length obls in let _ = Flags.if_verbose ppnl (str ", generating " ++ int len ++ str " obligation(s)") in - from_prg := ProgMap.add n prg !from_prg; + from_prg := ProgMap.add n prg !from_prg; let res = auto_solve_obligations (Some n) tactic in match res with | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res | _ -> res) - + let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(hook=fun _ _ -> ()) notations fixkind = let deps = List.map (fun (n, b, t, imps, obls) -> n) l in let upd = List.fold_left @@ -576,23 +576,23 @@ let add_mutual_definitions l ?tactic ?(kind=Global,false,Definition) ?(hook=fun !from_prg l in from_prg := upd; - let _defined = - List.fold_left (fun finished x -> - if finished then finished + let _defined = + List.fold_left (fun finished x -> + if finished then finished else let res = auto_solve_obligations (Some x) tactic in match res with | Defined _ -> (* If one definition is turned into a constant, the whole block is defined. *) true - | _ -> false) + | _ -> false) false deps in () - + let admit_obligations n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in - Array.iteri (fun i x -> - match x.obl_body with - None -> + Array.iteri (fun i x -> + match x.obl_body with + None -> let x = subst_deps_obl obls x in let kn = Declare.declare_constant x.obl_name (ParameterEntry (x.obl_type,false), IsAssumption Conjectural) in assumption_message x.obl_name; @@ -603,7 +603,7 @@ let admit_obligations n = exception Found of int -let array_find f arr = +let array_find f arr = try Array.iteri (fun i x -> if f x then raise (Found i)) arr; raise Not_found with Found i -> i @@ -611,9 +611,9 @@ let array_find f arr = let next_obligation n = let prg = get_prog_err n in let obls, rem = prg.prg_obligations in - let i = + let i = try array_find (fun x -> x.obl_body = None && deps_remaining obls x.obl_deps = []) obls with Not_found -> anomaly "Could not find a solvable obligation." in solve_obligation prg i - + let default_tactic () = !default_tactic diff --git a/plugins/subtac/subtac_obligations.mli b/plugins/subtac/subtac_obligations.mli index 2afcb19413..80d5b9465c 100644 --- a/plugins/subtac/subtac_obligations.mli +++ b/plugins/subtac/subtac_obligations.mli @@ -4,8 +4,8 @@ open Libnames open Evd open Proof_type -type obligation_info = - (identifier * Term.types * loc * +type obligation_info = + (identifier * Term.types * loc * obligation_definition_status * Intset.t * Tacexpr.raw_tactic_expr option) array (* ident, type, location, (opaque or transparent, expand or define), dependencies, tactic to solve it *) @@ -14,14 +14,14 @@ type progress = (* Resolution status of a program *) | Remain of int (* n obligations remaining *) | Dependent (* Dependent on other definitions *) | Defined of global_reference (* Defined as id *) - + val set_default_tactic : Tacexpr.glob_tactic_expr -> unit val default_tactic : unit -> Proof_type.tactic val set_proofs_transparency : bool -> unit (* true = All transparent, false = Opaque if possible *) val get_proofs_transparency : unit -> bool -val add_definition : Names.identifier -> Term.constr -> Term.types -> +val add_definition : Names.identifier -> Term.constr -> Term.types -> ?implicits:(Topconstr.explicitation * (bool * bool * bool)) list -> ?kind:Decl_kinds.definition_kind -> ?tactic:Proof_type.tactic -> @@ -29,9 +29,9 @@ val add_definition : Names.identifier -> Term.constr -> Term.types -> type notations = (string * Topconstr.constr_expr * Topconstr.scope_name option) list -val add_mutual_definitions : +val add_mutual_definitions : (Names.identifier * Term.constr * Term.types * - (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list -> + (Topconstr.explicitation * (bool * bool * bool)) list * obligation_info) list -> ?tactic:Proof_type.tactic -> ?kind:Decl_kinds.definition_kind -> ?hook:Tacexpr.declaration_hook -> @@ -45,7 +45,7 @@ val next_obligation : Names.identifier option -> unit val solve_obligations : Names.identifier option -> Proof_type.tactic option -> progress (* Number of remaining obligations to be solved for this program *) -val solve_all_obligations : Proof_type.tactic option -> unit +val solve_all_obligations : Proof_type.tactic option -> unit val try_solve_obligation : int -> Names.identifier option -> Proof_type.tactic option -> unit diff --git a/plugins/subtac/subtac_pretyping.ml b/plugins/subtac/subtac_pretyping.ml index 91418e05e7..e705e73c16 100644 --- a/plugins/subtac/subtac_pretyping.ml +++ b/plugins/subtac/subtac_pretyping.ml @@ -23,7 +23,7 @@ open Typeops open Libnames open Classops open List -open Recordops +open Recordops open Evarutil open Pretype_errors open Rawterm @@ -54,7 +54,7 @@ type recursion_info = { f_fulltype: types; (* Type with argument and wf proof product first *) } -let my_print_rec_info env t = +let my_print_rec_info env t = str "Name: " ++ Nameops.pr_name t.arg_name ++ spc () ++ str "Arg type: " ++ my_print_constr env t.arg_type ++ spc () ++ str "Wf relation: " ++ my_print_constr env t.wf_relation ++ spc () ++ @@ -65,10 +65,10 @@ let my_print_rec_info env t = (* str " and tycon "++ my_print_tycon env tycon ++ *) (* str " in environment: " ++ my_print_env env); *) -let merge_evms x y = +let merge_evms x y = Evd.fold (fun ev evi evm -> Evd.add evm ev evi) x y -let interp env isevars c tycon = +let interp env isevars c tycon = let j = pretype tycon env isevars ([],[]) c in let _ = isevars := Evarutil.nf_evar_defs !isevars in let evd,_ = consider_remaining_unif_problems env !isevars in @@ -92,7 +92,7 @@ let coqintern_type evd env : Topconstr.constr_expr -> Rawterm.rawconstr = Constr let env_with_binders env isevars l = let rec aux ((env, rels) as acc) = function - Topconstr.LocalRawDef ((loc, name), def) :: tl -> + Topconstr.LocalRawDef ((loc, name), def) :: tl -> let rawdef = coqintern_constr !isevars env def in let coqdef, deftyp = interp env isevars rawdef empty_tycon in let reldecl = (name, Some coqdef, deftyp) in @@ -100,10 +100,10 @@ let env_with_binders env isevars l = | Topconstr.LocalRawAssum (bl, k, typ) :: tl -> let rawtyp = coqintern_type !isevars env typ in let coqtyp, typtyp = interp env isevars rawtyp empty_tycon in - let acc = - List.fold_left (fun (env, rels) (loc, name) -> + let acc = + List.fold_left (fun (env, rels) (loc, name) -> let reldecl = (name, None, coqtyp) in - (push_rel reldecl env, + (push_rel reldecl env, reldecl :: rels)) (env, rels) bl in aux acc tl @@ -112,15 +112,15 @@ let env_with_binders env isevars l = let subtac_process env isevars id bl c tycon = let c = Command.abstract_constr_expr c bl in - let tycon = + let tycon = match tycon with None -> empty_tycon - | Some t -> + | Some t -> let t = Command.generalize_constr_expr t bl in let t = coqintern_type !isevars env t in let coqt, ttyp = interp env isevars t empty_tycon in mk_tycon coqt - in + in let c = coqintern_constr !isevars env c in let imps = Implicit_quantifiers.implicits_of_rawterm c in let coqc, ctyp = interp env isevars c tycon in diff --git a/plugins/subtac/subtac_pretyping_F.ml b/plugins/subtac/subtac_pretyping_F.ml index a1d9603187..f818379e73 100644 --- a/plugins/subtac/subtac_pretyping_F.ml +++ b/plugins/subtac/subtac_pretyping_F.ml @@ -24,7 +24,7 @@ open Libnames open Nameops open Classops open List -open Recordops +open Recordops open Evarutil open Pretype_errors open Rawterm @@ -65,27 +65,27 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let (evd',t) = f !evdref x y z in evdref := evd'; t - + let mt_evd = Evd.empty - + (* Utilisé pour inférer le prédicat des Cases *) (* Semble exagérement fort *) (* Faudra préférer une unification entre les types de toutes les clauses *) (* et autoriser des ? à rester dans le résultat de l'unification *) - + let evar_type_fixpoint loc env evdref lna lar vdefj = - let lt = Array.length vdefj in - if Array.length lar = lt then - for i = 0 to lt-1 do + let lt = Array.length vdefj in + if Array.length lar = lt then + for i = 0 to lt-1 do if not (e_cumul env evdref (vdefj.(i)).uj_type (lift lt lar.(i))) then error_ill_typed_rec_body_loc loc env ( !evdref) i lna vdefj lar done - let check_branches_message loc env evdref c (explft,lft) = + let check_branches_message loc env evdref c (explft,lft) = for i = 0 to Array.length explft - 1 do - if not (e_cumul env evdref lft.(i) explft.(i)) then + if not (e_cumul env evdref lft.(i) explft.(i)) then let sigma = !evdref in error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i) done @@ -137,19 +137,19 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct if n=0 then p else match kind_of_term p with | Lambda (_,_,c) -> decomp (n-1) c - | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) + | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) in let sign,s = decompose_prod_n n pj.uj_type in let ind = build_dependent_inductive env indf in let s' = mkProd (Anonymous, ind, s) in let ccl = lift 1 (decomp n pj.uj_val) in let ccl' = mkLambda (Anonymous, ind, ccl) in - {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign} + {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign} (*************************************************************************) (* Main pretyping function *) - let pretype_ref evdref env ref = + let pretype_ref evdref env ref = let c = constr_of_global ref in make_judge c (Retyping.get_type_of env Evd.empty c) @@ -160,7 +160,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [( evdref)] and *) (* the type constraint tycon *) - let rec pretype (tycon : type_constraint) env evdref lvar c = + let rec pretype (tycon : type_constraint) env evdref lvar c = (* let _ = try Subtac_utils.trace (str "pretype " ++ Subtac_utils.my_print_rawconstr env c ++ *) (* str " with tycon " ++ Evarutil.pr_tycon env tycon) *) (* with _ -> () *) @@ -187,12 +187,12 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let j = (Retyping.get_judgment_of env ( !evdref) c) in inh_conv_coerce_to_tycon loc env evdref j tycon - | RPatVar (loc,(someta,n)) -> + | RPatVar (loc,(someta,n)) -> anomaly "Found a pattern variable in a rawterm to type" - + | RHole (loc,k) -> let ty = - match tycon with + match tycon with | Some (None, ty) -> ty | None | Some _ -> e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in @@ -221,19 +221,19 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let nbfix = Array.length lar in let names = Array.map (fun id -> Name id) names in (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let newenv = - let marked_ftys = + let newenv = + let marked_ftys = Array.map (fun ty -> let sort = Retyping.get_type_of env !evdref ty in mkApp (Lazy.force Subtac_utils.fix_proto, [| sort; ty |])) ftys in - push_rec_types (names,marked_ftys,[||]) env + push_rec_types (names,marked_ftys,[||]) env in let fixi = match fixkind with RFix (vn, i) -> i | RCoFix i -> i in let vdefj = - array_map2_i + array_map2_i (fun i ctxt def -> - let fty = + let fty = let ty = ftys.(i) in if i = fixi then ( Option.iter (fun tycon -> @@ -260,19 +260,19 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (* First, let's find the guard indexes. *) (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem worth the effort (except for huge mutual + but doing it properly involves delta-reduction, and it finally + doesn't seem worth the effort (except for huge mutual fixpoints ?) *) - let possible_indexes = Array.to_list (Array.mapi - (fun i (n,_) -> match n with + let possible_indexes = Array.to_list (Array.mapi + (fun i (n,_) -> match n with | Some n -> [n] | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i)) vn) - in - let fixdecls = (names,ftys,fdefs) in - let indexes = search_guard loc env possible_indexes fixdecls in + in + let fixdecls = (names,ftys,fdefs) in + let indexes = search_guard loc env possible_indexes fixdecls in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) - | RCoFix i -> + | RCoFix i -> let cofix = (i,(names,ftys,fdefs)) in (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e); make_judge (mkCoFix cofix) ftys.(i) in @@ -281,10 +281,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | RSort (loc,s) -> inh_conv_coerce_to_tycon loc env evdref (pretype_sort s) tycon - | RApp (loc,f,args) -> - let length = List.length args in + | RApp (loc,f,args) -> + let length = List.length args in let ftycon = - let ty = + let ty = if length > 0 then match tycon with | None -> None @@ -292,7 +292,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | Some (Some (init, cur), ty) -> Some (Some (length + init, length + cur), ty) else tycon - in + in match ty with | Some (_, t) when Subtac_coercion.disc_subset t = None -> ty | _ -> None @@ -314,14 +314,14 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let hj = pretype (mk_tycon (nf_evar !evdref c1)) env evdref lvar c in let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in let typ' = nf_evar !evdref typ in - apply_rec env (n+1) + apply_rec env (n+1) { uj_val = nf_evar !evdref value; uj_type = nf_evar !evdref typ' } (Option.map (fun (abs, c) -> abs, nf_evar !evdref c) tycon) rest | _ -> let hj = pretype empty_tycon env evdref lvar c in - error_cant_apply_not_functional_loc + error_cant_apply_not_functional_loc (join_loc floc argloc) env ( !evdref) resj [hj] in @@ -337,20 +337,20 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct inh_conv_coerce_to_tycon loc env evdref resj tycon | RLambda(loc,name,k,c1,c2) -> - let tycon' = evd_comb1 - (fun evd tycon -> - match tycon with - | None -> evd, tycon - | Some ty -> + let tycon' = evd_comb1 + (fun evd tycon -> + match tycon with + | None -> evd, tycon + | Some ty -> let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in - evd, Some ty') - evdref tycon + evd, Some ty') + evdref tycon in let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in let dom_valcon = valcon_of_tycon dom in let j = pretype_type dom_valcon env evdref lvar c1 in let var = (name,None,j.utj_val) in - let j' = pretype rng (push_rel var env) evdref lvar c2 in + let j' = pretype rng (push_rel var env) evdref lvar c2 in let resj = judge_of_abstraction env name j j' in inh_conv_coerce_to_tycon loc env evdref resj tycon @@ -363,7 +363,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct try judge_of_product env name j j' with TypeError _ as e -> Stdpp.raise_with_loc loc e in inh_conv_coerce_to_tycon loc env evdref resj tycon - + | RLetIn(loc,name,c1,c2) -> let j = pretype empty_tycon env evdref lvar c1 in let t = refresh_universes j.uj_type in @@ -375,11 +375,11 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct | RLetTuple (loc,nal,(na,po),c,d) -> let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = + let (IndType (indf,realargs)) = try find_rectype env ( !evdref) cj.uj_type with Not_found -> let cloc = loc_of_rawconstr c in - error_case_not_inductive_loc cloc env ( !evdref) cj + error_case_not_inductive_loc cloc env ( !evdref) cj in let cstrs = get_constructors env indf in if Array.length cstrs <> 1 then @@ -406,7 +406,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let ccl = nf_evar ( !evdref) pj.utj_val in let psign = make_arity_signature env true indf in (* with names *) let p = it_mkLambda_or_LetIn ccl psign in - let inst = + let inst = (Array.to_list cs.cs_concl_realargs) @[build_dependent_constructor cs] in let lp = lift cs.cs_nargs p in @@ -416,45 +416,45 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let v = let mis,_ = dest_ind_family indf in let ci = make_case_info env mis LetStyle in - mkCase (ci, p, cj.uj_val,[|f|]) in + mkCase (ci, p, cj.uj_val,[|f|]) in { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } - | None -> + | None -> let tycon = lift_tycon cs.cs_nargs tycon in let fj = pretype tycon env_f evdref lvar d in let f = it_mkLambda_or_LetIn fj.uj_val fsign in let ccl = nf_evar ( !evdref) fj.uj_type in let ccl = if noccur_between 1 cs.cs_nargs ccl then - lift (- cs.cs_nargs) ccl + lift (- cs.cs_nargs) ccl else - error_cant_find_case_type_loc loc env ( !evdref) + error_cant_find_case_type_loc loc env ( !evdref) cj.uj_val in let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = let mis,_ = dest_ind_family indf in let ci = make_case_info env mis LetStyle in - mkCase (ci, p, cj.uj_val,[|f|] ) + mkCase (ci, p, cj.uj_val,[|f|] ) in { uj_val = v; uj_type = ccl }) | RIf (loc,c,(na,po),b1,b2) -> let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = + let (IndType (indf,realargs)) = try find_rectype env ( !evdref) cj.uj_type with Not_found -> let cloc = loc_of_rawconstr c in error_case_not_inductive_loc cloc env ( !evdref) cj in - let cstrs = get_constructors env indf in + let cstrs = get_constructors env indf in if Array.length cstrs <> 2 then user_err_loc (loc,"", str "If is only for inductive types with two constructors."); - let arsgn = + let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then (* Make dependencies from arity signature impossible *) - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in let nar = List.length arsgn in @@ -467,10 +467,10 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred; - uj_type = typ} tycon + uj_type = typ} tycon in jtyp.uj_val, jtyp.uj_type - | None -> + | None -> let p = match tycon with | Some (None, ty) -> ty | None | Some _ -> @@ -484,18 +484,18 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let n = rel_context_length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist (pi, [build_dependent_constructor cs]) in - let csgn = + let csgn = if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args - else - List.map + List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + else + List.map (fun (n, b, t) -> match n with Name _ -> (n, b, t) | Anonymous -> (Name (id_of_string "H"), b, t)) cs.cs_args in - let env_c = push_rels csgn env in + let env_c = push_rels csgn env in (* msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *) let bj = pretype (mk_tycon pi) env_c evdref lvar b in it_mkLambda_or_LetIn bj.uj_val cs.cs_args in @@ -548,7 +548,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct let t = Retyping.get_type_of env sigma v in match kind_of_term (whd_betadeltaiota env sigma t) with | Sort s -> s - | Evar ev when is_Type (existential_type sigma ev) -> + | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort) evdref ev | _ -> anomaly "Found a type constraint which is not a type" in @@ -579,7 +579,7 @@ module SubtacPretyping_F (Coercion : Coercion.S) = struct (pretype_type empty_valcon env evdref lvar c).utj_val in evdref := fst (consider_remaining_unif_problems env !evdref); if resolve_classes then - evdref := + evdref := Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:fail_evar env !evdref; let c = nf_evar !evdref c' in diff --git a/plugins/subtac/subtac_utils.ml b/plugins/subtac/subtac_utils.ml index 645e3e23ec..288d3854fd 100644 --- a/plugins/subtac/subtac_utils.ml +++ b/plugins/subtac/subtac_utils.ml @@ -40,7 +40,7 @@ let sig_ref = make_ref "Init.Specif.sig" let proj1_sig_ref = make_ref "Init.Specif.proj1_sig" let proj2_sig_ref = make_ref "Init.Specif.proj2_sig" -let build_sig () = +let build_sig () = { proj1 = init_constant ["Init"; "Specif"] "proj1_sig"; proj2 = init_constant ["Init"; "Specif"] "proj2_sig"; elim = init_constant ["Init"; "Specif"] "sig_rec"; @@ -67,13 +67,13 @@ let eqdep_rec = lazy (init_constant ["Logic";"Eqdep"] "eq_dep_rec") let eqdep_ind_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep") let eqdep_intro_ref = lazy (init_reference [ "Logic";"Eqdep"] "eq_dep_intro") -let jmeq_ind = - lazy (check_required_library ["Coq";"Logic";"JMeq"]; +let jmeq_ind = + lazy (check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq") -let jmeq_rec = - lazy (check_required_library ["Coq";"Logic";"JMeq"]; +let jmeq_rec = + lazy (check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_rec") -let jmeq_refl = +let jmeq_refl = lazy (check_required_library ["Coq";"Logic";"JMeq"]; init_constant ["Logic";"JMeq"] "JMeq_refl") @@ -88,7 +88,7 @@ let sumboolind = lazy (init_constant ["Init"; "Specif"] "sumbool") let natind = lazy (init_constant ["Init"; "Datatypes"] "nat") let intind = lazy (init_constant ["ZArith"; "binint"] "Z") let existSind = lazy (init_constant ["Init"; "Specif"] "sigS") - + let existS = lazy (build_sigma_type ()) let prod = lazy (build_prod ()) @@ -120,20 +120,20 @@ let debug_level = 2 let debug_on = true -let debug n s = +let debug n s = if debug_on then if !Flags.debug && n >= debug_level then msgnl s else () else () -let debug_msg n s = +let debug_msg n s = if debug_on then if !Flags.debug && n >= debug_level then s else mt () else mt () -let trace s = +let trace s = if debug_on then if !Flags.debug && debug_level > 0 then msgnl s else () @@ -145,28 +145,28 @@ let rec pp_list f = function let wf_relations = Hashtbl.create 10 -let std_relations () = +let std_relations () = let add k v = Hashtbl.add wf_relations k v in add (init_constant ["Init"; "Peano"] "lt") (lazy (init_constant ["Arith"; "Wf_nat"] "lt_wf")) - + let std_relations = Lazy.lazy_from_fun std_relations type binders = Topconstr.local_binder list -let app_opt c e = +let app_opt c e = match c with Some constr -> constr e - | None -> e + | None -> e -let print_args env args = +let print_args env args = Array.fold_right (fun a acc -> my_print_constr env a ++ spc () ++ acc) args (str "") let make_existential loc ?(opaque = Define true) env isevars c = let evar = Evarutil.e_new_evar isevars env ~src:(loc, QuestionMark opaque) c in let (key, args) = destEvar evar in (try trace (str "Constructed evar " ++ int key ++ str " applied to args: " ++ - print_args env args ++ str " for type: "++ + print_args env args ++ str " for type: "++ my_print_constr env c) with _ -> ()); evar @@ -186,29 +186,29 @@ let string_of_hole_kind = function | GoalEvar -> "GoalEvar" | ImpossibleCase -> "ImpossibleCase" -let evars_of_term evc init c = +let evars_of_term evc init c = let rec evrec acc c = match kind_of_term c with | Evar (n, _) when Evd.mem evc n -> Evd.add acc n (Evd.find evc n) | Evar (n, _) -> assert(false) | _ -> fold_constr evrec acc c - in + in evrec init c let non_instanciated_map env evd evm = - List.fold_left - (fun evm (key, evi) -> + List.fold_left + (fun evm (key, evi) -> let (loc,k) = evar_source key !evd in - debug 2 (str "evar " ++ int key ++ str " has kind " ++ + debug 2 (str "evar " ++ int key ++ str " has kind " ++ str (string_of_hole_kind k)); - match k with + match k with | QuestionMark _ -> Evd.add evm key evi | ImplicitArg (_,_,false) -> Evd.add evm key evi | _ -> debug 2 (str " and is an implicit"); Pretype_errors.error_unsolvable_implicit loc env evm (Evarutil.nf_evar_info evm evi) k None) Evd.empty (Evarutil.non_instantiated evm) - + let global_kind = Decl_kinds.IsDefinition Decl_kinds.Definition let goal_kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Definition @@ -222,7 +222,7 @@ open Tactics open Tacticals let id x = x -let filter_map f l = +let filter_map f l = let rec aux acc = function hd :: tl -> (match f hd with Some t -> aux (t :: acc) tl | None -> aux acc tl) @@ -237,36 +237,36 @@ let build_dependent_sum l = (try trace (str " assert: " ++ my_print_constr (Global.env ()) hyptype) with _ -> ()); let tac = assert_tac (Name n) hyptype in - let conttac = - (fun cont -> + let conttac = + (fun cont -> conttac (tclTHENS tac ([intros; - (tclTHENSEQ - [constructor_tac false (Some 1) 1 + (tclTHENSEQ + [constructor_tac false (Some 1) 1 (Rawterm.ImplicitBindings [inj_open (mkVar n)]); cont]); ]))) in - let conttype = - (fun typ -> + let conttype = + (fun typ -> let tex = mkLambda (Name n, t, typ) in conttype (mkApp (Lazy.force ex_ind, [| t; tex |]))) in aux (mkVar n :: names) conttac conttype tl - | (n, t) :: [] -> + | (n, t) :: [] -> (conttac intros, conttype t) | [] -> raise (Invalid_argument "build_dependent_sum") - in aux [] id id (List.rev l) - + in aux [] id id (List.rev l) + open Proof_type open Tacexpr -let mkProj1 a b c = +let mkProj1 a b c = mkApp (Lazy.force proj1, [| a; b; c |]) -let mkProj2 a b c = +let mkProj2 a b c = mkApp (Lazy.force proj2, [| a; b; c |]) let mk_ex_pi1 a b c = @@ -274,8 +274,8 @@ let mk_ex_pi1 a b c = let mk_ex_pi2 a b c = mkApp (Lazy.force ex_pi2, [| a; b; c |]) - -let mkSubset name typ prop = + +let mkSubset name typ prop = mkApp ((Lazy.force sig_).typ, [| typ; mkLambda (name, typ, prop) |]) @@ -300,22 +300,22 @@ let mk_not c = mkApp (notc, [| c |]) let and_tac l hook = - let andc = Coqlib.build_coq_and () in + let andc = Coqlib.build_coq_and () in let rec aux ((accid, goal, tac, extract) as acc) = function | [] -> (* Singleton *) acc - + | (id, x, elgoal, eltac) :: tl -> let tac' = tclTHEN simplest_split (tclTHENLIST [tac; eltac]) in let proj = fun c -> mkProj2 goal elgoal c in let extract = List.map (fun (id, x, y, f) -> (id, x, y, (fun c -> f (mkProj1 goal elgoal c)))) extract in - aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac', + aux ((string_of_id id) ^ "_" ^ accid, mkApp (andc, [| goal; elgoal |]), tac', (id, x, elgoal, proj) :: extract) tl in - let and_proof_id, and_goal, and_tac, and_extract = + let and_proof_id, and_goal, and_tac, and_extract = match l with | [] -> raise (Invalid_argument "and_tac: empty list of goals") - | (hdid, x, hdg, hdt) :: tl -> + | (hdid, x, hdg, hdt) :: tl -> aux (string_of_id hdid, hdg, hdt, [hdid, x, hdg, (fun c -> c)]) tl in let and_proofid = id_of_string (and_proof_id ^ "_and_proof") in @@ -324,20 +324,20 @@ let and_tac l hook = trace (str "Started and proof"); Pfedit.by and_tac; trace (str "Applied and tac") - -let destruct_ex ext ex = - let rec aux c acc = + +let destruct_ex ext ex = + let rec aux c acc = match kind_of_term c with App (f, args) -> (match kind_of_term f with Ind i when i = Term.destInd (Lazy.force ex_ind) && Array.length args = 2 -> - let (dom, rng) = + let (dom, rng) = try (args.(0), args.(1)) with _ -> assert(false) in let pi1 = (mk_ex_pi1 dom rng acc) in - let rng_body = + let rng_body = match kind_of_term rng with Lambda (_, _, t) -> subst1 pi1 t | t -> rng @@ -348,14 +348,14 @@ let destruct_ex ext ex = in aux ex ext open Rawterm - + let id_of_name = function Name n -> n | Anonymous -> raise (Invalid_argument "id_of_name") let definition_message id = Nameops.pr_id id ++ str " is defined" - + let recursive_message v = match Array.length v with | 0 -> error "no recursive definition" @@ -398,7 +398,7 @@ let rec string_of_list sep f = function | x :: [] -> f x | x :: ((y :: _) as tl) -> f x ^ sep ^ string_of_list sep f tl -let string_of_intset d = +let string_of_intset d = string_of_list "," string_of_int (Intset.elements d) (**********************************************************) @@ -416,20 +416,20 @@ let pr_meta_map evd = | _ -> mt() in let pr_meta_binding = function | (mv,Cltyp (na,b)) -> - hov 0 + hov 0 (pr_meta mv ++ pr_name na ++ str " : " ++ print_constr b.rebus ++ fnl ()) | (mv,Clval(na,b,_)) -> - hov 0 + hov 0 (pr_meta mv ++ pr_name na ++ str " := " ++ print_constr (fst b).rebus ++ fnl ()) in - prlist pr_meta_binding ml + prlist pr_meta_binding ml let pr_idl idl = prlist_with_sep pr_spc pr_id idl let pr_evar_info evi = - let phyps = + let phyps = (*pr_idl (List.rev (ids_of_named_context (evar_context evi))) *) Printer.pr_named_context (Global.env()) (evar_context evi) in @@ -442,7 +442,7 @@ let pr_evar_info evi = hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]") let pr_evar_defs sigma = - h 0 + h 0 (prlist_with_sep pr_fnl (fun (ev,evi) -> h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi)) @@ -454,7 +454,7 @@ let pr_constraints pbs = print_constr t1 ++ spc() ++ str (match pbty with | Reduction.CONV -> "==" - | Reduction.CUMUL -> "<=") ++ + | Reduction.CUMUL -> "<=") ++ spc() ++ print_constr t2) pbs) let pr_evar_defs evd = diff --git a/plugins/subtac/subtac_utils.mli b/plugins/subtac/subtac_utils.mli index dff1df8f96..e7ee6c7483 100644 --- a/plugins/subtac/subtac_utils.mli +++ b/plugins/subtac/subtac_utils.mli @@ -85,7 +85,7 @@ val wf_relations : (constr, constr lazy_t) Hashtbl.t type binders = local_binder list val app_opt : ('a -> 'a) option -> 'a -> 'a val print_args : env -> constr array -> std_ppcmds -val make_existential : loc -> ?opaque:obligation_definition_status -> +val make_existential : loc -> ?opaque:obligation_definition_status -> env -> evar_defs ref -> types -> constr val make_existential_expr : loc -> 'a -> 'b -> constr_expr val string_of_hole_kind : hole_kind -> string @@ -111,7 +111,7 @@ val mk_conj : types list -> types val mk_not : types -> types val build_dependent_sum : (identifier * types) list -> Proof_type.tactic * types -val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> +val and_tac : (identifier * 'a * constr * Proof_type.tactic) list -> ((constr -> (identifier * 'a * constr * constr) list) -> Tacexpr.declaration_hook) -> unit val destruct_ex : constr -> constr -> constr list diff --git a/plugins/subtac/test/ListDep.v b/plugins/subtac/test/ListDep.v index da612c4367..e3dbd127f9 100644 --- a/plugins/subtac/test/ListDep.v +++ b/plugins/subtac/test/ListDep.v @@ -22,7 +22,7 @@ Section Map_DependentRecursor. Variable l : list U. Variable f : { x : U | In x l } -> V. - Obligations Tactic := unfold sub_list in * ; + Obligations Tactic := unfold sub_list in * ; program_simpl ; intuition. Program Fixpoint map_rec ( l' : list U | sub_list l' l ) @@ -32,16 +32,16 @@ Section Map_DependentRecursor. | cons x tl => let tl' := map_rec tl in f x :: tl' end. - + Next Obligation. destruct_call map_rec. simpl in *. subst l'. simpl ; auto with arith. Qed. - + Program Definition map : list V := map_rec l. - + End Map_DependentRecursor. Extraction map. diff --git a/plugins/subtac/test/ListsTest.v b/plugins/subtac/test/ListsTest.v index 05fc0803fc..2cea0841de 100644 --- a/plugins/subtac/test/ListsTest.v +++ b/plugins/subtac/test/ListsTest.v @@ -7,7 +7,7 @@ Set Implicit Arguments. Section Accessors. Variable A : Set. - Program Definition myhd : forall (l : list A | length l <> 0), A := + Program Definition myhd : forall (l : list A | length l <> 0), A := fun l => match l with | nil => ! @@ -34,22 +34,22 @@ Section app. match l with | nil => l' | hd :: tl => hd :: (tl ++ l') - end + end where "x ++ y" := (app x y). Next Obligation. intros. destruct_call app ; program_simpl. Defined. - + Program Lemma app_id_l : forall l : list A, l = nil ++ l. Proof. simpl ; auto. Qed. - + Program Lemma app_id_r : forall l : list A, l = l ++ nil. Proof. - induction l ; simpl in * ; auto. + induction l ; simpl in * ; auto. rewrite <- IHl ; auto. Qed. @@ -61,7 +61,7 @@ Section Nth. Variable A : Set. - Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := + Program Fixpoint nth (l : list A) (n : nat | n < length l) { struct l } : A := match n, l with | 0, hd :: _ => hd | S n', _ :: tl => nth tl n' @@ -70,7 +70,7 @@ Section Nth. Next Obligation. Proof. - simpl in *. auto with arith. + simpl in *. auto with arith. Defined. Next Obligation. @@ -78,7 +78,7 @@ Section Nth. inversion H. Qed. - Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A := + Program Fixpoint nth' (l : list A) (n : nat | n < length l) { struct l } : A := match l, n with | hd :: _, 0 => hd | _ :: tl, S n' => nth' tl n' @@ -86,7 +86,7 @@ Section Nth. end. Next Obligation. Proof. - simpl in *. auto with arith. + simpl in *. auto with arith. Defined. Next Obligation. diff --git a/plugins/subtac/test/Mutind.v b/plugins/subtac/test/Mutind.v index ac49ca96a4..01e2d75f33 100644 --- a/plugins/subtac/test/Mutind.v +++ b/plugins/subtac/test/Mutind.v @@ -1,11 +1,11 @@ Require Import List. -Program Fixpoint f a : { x : nat | x > 0 } := +Program Fixpoint f a : { x : nat | x > 0 } := match a with | 0 => 1 | S a' => g a a' end -with g a b : { x : nat | x > 0 } := +with g a b : { x : nat | x > 0 } := match b with | 0 => 1 | S b' => f b' diff --git a/plugins/subtac/test/Test1.v b/plugins/subtac/test/Test1.v index 14b8085496..7e0755d571 100644 --- a/plugins/subtac/test/Test1.v +++ b/plugins/subtac/test/Test1.v @@ -1,4 +1,4 @@ -Program Definition test (a b : nat) : { x : nat | x = a + b } := +Program Definition test (a b : nat) : { x : nat | x = a + b } := ((a + b) : { x : nat | x = a + b }). Proof. intros. diff --git a/plugins/subtac/test/euclid.v b/plugins/subtac/test/euclid.v index 501aa79815..97c3d9414d 100644 --- a/plugins/subtac/test/euclid.v +++ b/plugins/subtac/test/euclid.v @@ -1,12 +1,12 @@ Require Import Coq.Program.Program. Require Import Coq.Arith.Compare_dec. Notation "( x & y )" := (existS _ x y) : core_scope. - + Require Import Omega. Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf lt a} : { q : nat & { r : nat | a = b * q + r /\ r < b } } := - if le_lt_dec b a then let (q', r) := euclid (a - b) b in + if le_lt_dec b a then let (q', r) := euclid (a - b) b in (S q' & r) else (O & a). diff --git a/plugins/subtac/test/take.v b/plugins/subtac/test/take.v index 2e17959c3e..90ae8bae84 100644 --- a/plugins/subtac/test/take.v +++ b/plugins/subtac/test/take.v @@ -11,7 +11,7 @@ Print cons. Program Fixpoint take (A : Set) (l : list A) (n : nat | n <= length l) { struct l } : { l' : list A | length l' = n } := match n with | 0 => nil - | S p => + | S p => match l with | cons hd tl => let rest := take tl p in cons hd rest | nil => ! diff --git a/plugins/subtac/test/wf.v b/plugins/subtac/test/wf.v index 49fec2b80c..5ccc154afd 100644 --- a/plugins/subtac/test/wf.v +++ b/plugins/subtac/test/wf.v @@ -29,7 +29,7 @@ Require Import Wf_nat. Program Fixpoint euclid (a : nat) (b : { b : nat | b <> O }) {wf a lt} : { q : nat & { r : nat | a = b * q + r /\ r < b } } := - if le_lt_dec b a then let (q', r) := euclid (a - b) b in + if le_lt_dec b a then let (q', r) := euclid (a - b) b in (S q' & r) else (O & a). destruct b ; simpl_subtac. diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index f9ca94ff6c..f60abaf855 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -38,7 +38,7 @@ let glob_Ascii = lazy (make_reference "Ascii") open Lazy let interp_ascii dloc p = - let rec aux n p = + let rec aux n p = if n = 0 then [] else let mp = p mod 2 in RRef (dloc,if mp = 0 then glob_false else glob_true) @@ -46,7 +46,7 @@ let interp_ascii dloc p = RApp (dloc,RRef(dloc,force glob_Ascii), aux 8 p) let interp_ascii_string dloc s = - let p = + let p = if String.length s = 1 then int_of_char s.[0] else if String.length s = 3 & is_digit s.[0] & is_digit s.[1] & is_digit s.[2] @@ -62,12 +62,12 @@ let uninterp_ascii r = | RRef (_,k)::l when k = glob_true -> 1+2*(uninterp_bool_list (n-1) l) | RRef (_,k)::l when k = glob_false -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in - try + try let rec aux = function | RApp (_,RRef (_,k),l) when k = force glob_Ascii -> uninterp_bool_list 8 l | _ -> raise Non_closed_ascii in Some (aux r) - with + with Non_closed_ascii -> None let make_ascii_string n = diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index c62c813778..5d20c2a3c8 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -33,7 +33,7 @@ open Names let nat_of_int dloc n = if is_pos_or_zero n then begin if less_than (of_string "5000") n then - Flags.if_warn msg_warning + Flags.if_warn msg_warning (strbrk "Stack overflow or segmentation fault happens when " ++ strbrk "working with large numbers in nat (observed threshold " ++ strbrk "may vary from 5000 to 70000 depending on your system " ++ @@ -41,11 +41,11 @@ let nat_of_int dloc n = let ref_O = RRef (dloc, glob_O) in let ref_S = RRef (dloc, glob_S) in let rec mk_nat acc n = - if n <> zero then + if n <> zero then mk_nat (RApp (dloc,ref_S, [acc])) (sub_1 n) - else + else acc - in + in mk_nat ref_O n end else @@ -61,9 +61,9 @@ let rec int_of_nat = function | RApp (_,RRef (_,s),[a]) when s = glob_S -> add_1 (int_of_nat a) | RRef (_,z) when z = glob_O -> zero | _ -> raise Non_closed_number - + let uninterp_nat p = - try + try Some (int_of_nat p) with Non_closed_number -> None diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index 94e4c103a9..e58618219b 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -22,7 +22,7 @@ let make_dir l = Names.make_dirpath (List.map Names.id_of_string (List.rev l)) let make_path dir id = Libnames.make_path (make_dir dir) (Names.id_of_string id) (* copied on g_zsyntax.ml, where it is said to be a temporary hack*) -(* takes a path an identifier in the form of a string list and a string, +(* takes a path an identifier in the form of a string list and a string, returns a kernel_name *) let make_kn dir id = Libnames.encode_kn (make_dir dir) (Names.id_of_string id) @@ -50,7 +50,7 @@ let zn2z_WW = ConstructRef ((zn2z_id "zn2z",0),2) let bigN_module = ["Coq"; "Numbers"; "Natural"; "BigN"; "BigN" ] let bigN_path = make_path (bigN_module@["BigN"]) "t" (* big ugly hack *) -let bigN_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigN_module)), +let bigN_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigN_module)), Names.mk_label "BigN")), [], Names.id_of_string id) : Names.kernel_name) let bigN_scope = "bigN_scope" @@ -69,7 +69,7 @@ let bigN_constructor = else 2*(to_int quo) in - fun i -> + fun i -> ConstructRef ((bigN_id "t_",0), if less_than i n_inlined then (to_int i)+1 @@ -81,7 +81,7 @@ let bigN_constructor = let bigZ_module = ["Coq"; "Numbers"; "Integer"; "BigZ"; "BigZ" ] let bigZ_path = make_path (bigZ_module@["BigZ"]) "t" (* big ugly hack bis *) -let bigZ_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigZ_module)), +let bigZ_id id = (Obj.magic ((Names.MPdot ((Names.MPfile (make_dir bigZ_module)), Names.mk_label "BigZ")), [], Names.id_of_string id) : Names.kernel_name) let bigZ_scope = "bigZ_scope" @@ -108,7 +108,7 @@ exception Non_closed (* parses a *non-negative* integer (from bigint.ml) into an int31 wraps modulo 2^31 *) -let int31_of_pos_bigint dloc n = +let int31_of_pos_bigint dloc n = let ref_construct = RRef (dloc, int31_construct) in let ref_0 = RRef (dloc, int31_0) in let ref_1 = RRef (dloc, int31_1) in @@ -124,7 +124,7 @@ let int31_of_pos_bigint dloc n = let error_negative dloc = Util.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.") -let interp_int31 dloc n = +let interp_int31 dloc n = if is_pos_or_zero n then int31_of_pos_bigint dloc n else @@ -132,20 +132,20 @@ let interp_int31 dloc n = (* Pretty prints an int31 *) -let bigint_of_int31 = - let rec args_parsing args cur = - match args with +let bigint_of_int31 = + let rec args_parsing args cur = + match args with | [] -> cur | (RRef (_,b))::l when b = int31_0 -> args_parsing l (mult_2 cur) | (RRef (_,b))::l when b = int31_1 -> args_parsing l (add_1 (mult_2 cur)) | _ -> raise Non_closed in - function + function | RApp (_, RRef (_, c), args) when c=int31_construct -> args_parsing args zero | _ -> raise Non_closed -let uninterp_int31 i = - try +let uninterp_int31 i = + try Some (bigint_of_int31 i) with Non_closed -> None @@ -169,12 +169,12 @@ let rank n = pow base (pow two n) (* splits a number bi at height n, that is the rest needs 2^n int31 to be stored it is expected to be used only when the quotient would also need 2^n int31 to be stored *) -let split_at n bi = +let split_at n bi = euclid bi (rank (sub_1 n)) (* search the height of the Coq bigint needed to represent the integer bi *) let height bi = - let rec height_aux n = + let rec height_aux n = if less_than bi (rank n) then n else @@ -199,7 +199,7 @@ let word_of_pos_bigint dloc hght n = decomp (sub_1 hgt) l]) in decomp hght n - + let bigN_of_pos_bigint dloc n = let ref_constructor i = RRef (dloc, bigN_constructor i) in let result h word = RApp (dloc, ref_constructor h, if less_than h n_inlined then @@ -210,11 +210,11 @@ let bigN_of_pos_bigint dloc n = in let hght = height n in result hght (word_of_pos_bigint dloc hght n) - + let bigN_error_negative dloc = Util.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") -let interp_bigN dloc n = +let interp_bigN dloc n = if is_pos_or_zero n then bigN_of_pos_bigint dloc n else @@ -223,13 +223,13 @@ let interp_bigN dloc n = (* Pretty prints a bigN *) -let bigint_of_word = +let bigint_of_word = let rec get_height rc = match rc with - | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW -> + | RApp (_,RRef(_,c), [_;lft;rght]) when c = zn2z_WW -> let hleft = get_height lft in let hright = get_height rght in - add_1 + add_1 (if less_than hleft hright then hright else @@ -248,15 +248,15 @@ let bigint_of_word = fun rc -> let hght = get_height rc in transform hght rc - + let bigint_of_bigN rc = match rc with | RApp (_,_,[one_arg]) -> bigint_of_word one_arg | RApp (_,_,[_;second_arg]) -> bigint_of_word second_arg | _ -> raise Non_closed -let uninterp_bigN rc = - try +let uninterp_bigN rc = + try Some (bigint_of_bigN rc) with Non_closed -> None @@ -266,7 +266,7 @@ let uninterp_bigN rc = numeral interpreter *) let bigN_list_of_constructors = - let rec build i = + let rec build i = if less_than i (add_1 n_inlined) then RRef (Util.dummy_loc, bigN_constructor i)::(build (add_1 i)) else @@ -284,7 +284,7 @@ let _ = Notation.declare_numeral_interpreter bigN_scope (*** Parsing for bigZ in digital notation ***) -let interp_bigZ dloc n = +let interp_bigZ dloc n = let ref_pos = RRef (dloc, bigZ_pos) in let ref_neg = RRef (dloc, bigZ_neg) in if is_pos_or_zero n then @@ -295,8 +295,8 @@ let interp_bigZ dloc n = (* pretty printing functions for bigZ *) let bigint_of_bigZ = function | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_pos -> bigint_of_bigN one_arg - | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_neg -> - let opp_val = bigint_of_bigN one_arg in + | RApp (_, RRef(_,c), [one_arg]) when c = bigZ_neg -> + let opp_val = bigint_of_bigN one_arg in if equal opp_val zero then raise Non_closed else @@ -304,8 +304,8 @@ let bigint_of_bigZ = function | _ -> raise Non_closed -let uninterp_bigZ rc = - try +let uninterp_bigZ rc = + try Some (bigint_of_bigZ rc) with Non_closed -> None @@ -320,7 +320,7 @@ let _ = Notation.declare_numeral_interpreter bigZ_scope true) (*** Parsing for bigQ in digital notation ***) -let interp_bigQ dloc n = +let interp_bigQ dloc n = let ref_z = RRef (dloc, bigQ_z) in let ref_pos = RRef (dloc, bigZ_pos) in let ref_neg = RRef (dloc, bigZ_neg) in diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 4a5972cc71..f85309e671 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -65,7 +65,7 @@ let r_of_posint dloc n = let r_of_int dloc z = if is_strictly_neg z then - RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) + RApp (dloc, RRef(dloc,glob_Ropp), [r_of_posint dloc (neg z)]) else r_of_posint dloc z @@ -90,7 +90,7 @@ let rec bignat_of_pos = function mult_2 (bignat_of_pos b) (* 1+(1+1)*b *) | RApp (_,RRef (_,p1), [RRef (_,o); RApp (_,RRef (_,p2),[a;b])]) - when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1 -> + when p1 = glob_Rplus & p2 = glob_Rmult & o = glob_R1 -> if bignat_of_pos a <> two then raise Non_closed_number; add_1 (mult_2 (bignat_of_pos b)) | _ -> raise Non_closed_number diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index d1c263dc8c..bc02357aea 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -38,14 +38,14 @@ open Lazy let interp_string dloc s = let le = String.length s in - let rec aux n = + let rec aux n = if n = le then RRef (dloc, force glob_EmptyString) else RApp (dloc,RRef (dloc, force glob_String), [interp_ascii dloc (int_of_char s.[n]); aux (n+1)]) in aux 0 let uninterp_string r = - try + try let b = Buffer.create 16 in let rec aux = function | RApp (_,RRef (_,k),[a;s]) when k = force glob_String -> @@ -57,13 +57,13 @@ let uninterp_string r = | _ -> raise Non_closed_string in aux r - with + with Non_closed_string -> None let _ = Notation.declare_string_interpreter "string_scope" (string_path,["Coq";"Strings";"String"]) interp_string - ([RRef (dummy_loc,static_glob_String); + ([RRef (dummy_loc,static_glob_String); RRef (dummy_loc,static_glob_EmptyString)], uninterp_string, true) diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index bfbe54c28c..a10c76013f 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -33,7 +33,7 @@ let positive_path = make_path positive_module "positive" (* TODO: temporary hack *) let make_kn dir id = Libnames.encode_kn dir id -let positive_kn = +let positive_kn = make_kn (make_dir positive_module) (id_of_string "positive") let glob_positive = IndRef (positive_kn,0) let path_of_xI = ((positive_kn,0),1) @@ -52,10 +52,10 @@ let pos_of_bignat dloc x = | (q,false) -> RApp (dloc, ref_xO,[pos_of q]) | (q,true) when q <> zero -> RApp (dloc,ref_xI,[pos_of q]) | (q,true) -> ref_xH - in + in pos_of x -let error_non_positive dloc = +let error_non_positive dloc = user_err_loc (dloc, "interp_positive", str "Only strictly positive numbers in type \"positive\".") @@ -74,9 +74,9 @@ let rec bignat_of_pos = function | _ -> raise Non_closed_number let uninterp_positive p = - try + try Some (bignat_of_pos p) - with Non_closed_number -> + with Non_closed_number -> None (************************************************************************) @@ -87,7 +87,7 @@ let _ = Notation.declare_numeral_interpreter "positive_scope" (positive_path,positive_module) interp_positive ([RRef (dummy_loc, glob_xI); - RRef (dummy_loc, glob_xO); + RRef (dummy_loc, glob_xO); RRef (dummy_loc, glob_xH)], uninterp_positive, true) @@ -106,10 +106,10 @@ let glob_Npos = ConstructRef path_of_Npos let n_path = make_path binnat_module "N" -let n_of_binnat dloc pos_or_neg n = +let n_of_binnat dloc pos_or_neg n = if n <> zero then RApp(dloc, RRef (dloc,glob_Npos), [pos_of_bignat dloc n]) - else + else RRef (dloc, glob_N0) let error_negative dloc = @@ -138,11 +138,11 @@ let uninterp_n p = let _ = Notation.declare_numeral_interpreter "N_scope" (n_path,binnat_module) n_of_int - ([RRef (dummy_loc, glob_N0); + ([RRef (dummy_loc, glob_N0); RRef (dummy_loc, glob_Npos)], uninterp_n, true) - + (**********************************************************************) (* Parsing Z via scopes *) (**********************************************************************) @@ -158,12 +158,12 @@ let glob_ZERO = ConstructRef path_of_ZERO let glob_POS = ConstructRef path_of_POS let glob_NEG = ConstructRef path_of_NEG -let z_of_int dloc n = +let z_of_int dloc n = if n <> zero then let sgn, n = if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n]) - else + else RRef (dloc, glob_ZERO) (**********************************************************************) @@ -187,8 +187,8 @@ let uninterp_z p = let _ = Notation.declare_numeral_interpreter "Z_scope" (z_path,binint_module) z_of_int - ([RRef (dummy_loc, glob_ZERO); - RRef (dummy_loc, glob_POS); + ([RRef (dummy_loc, glob_ZERO); + RRef (dummy_loc, glob_POS); RRef (dummy_loc, glob_NEG)], uninterp_z, true) diff --git a/plugins/xml/acic.ml b/plugins/xml/acic.ml index 032ddbebe0..40bc61bb80 100644 --- a/plugins/xml/acic.ml +++ b/plugins/xml/acic.ml @@ -56,7 +56,7 @@ type obj = | InductiveDefinition of inductiveType list * (* inductive types , *) params * int (* parameters,n ind. pars*) -and inductiveType = +and inductiveType = identifier * bool * constr * (* typename, inductive, arity *) constructor list (* constructors *) and constructor = @@ -78,9 +78,9 @@ type aconstr = | ACase of id * uri * int * aconstr * aconstr * aconstr list | AFix of id * int * ainductivefun list | ACoFix of id * int * acoinductivefun list -and ainductivefun = +and ainductivefun = id * identifier * int * aconstr * aconstr -and acoinductivefun = +and acoinductivefun = id * identifier * aconstr * aconstr and explicit_named_substitution = id option * (uri * aconstr) list @@ -101,7 +101,7 @@ type aobj = | AInductiveDefinition of id * anninductiveType list * (* inductive types , *) params * int (* parameters,n ind. pars*) -and anninductiveType = +and anninductiveType = id * identifier * bool * aconstr * (* typename, inductive, arity *) annconstructor list (* constructors *) and annconstructor = diff --git a/plugins/xml/acic2Xml.ml4 b/plugins/xml/acic2Xml.ml4 index 64dc8a0503..fb40ed86e8 100644 --- a/plugins/xml/acic2Xml.ml4 +++ b/plugins/xml/acic2Xml.ml4 @@ -44,7 +44,7 @@ let print_term ids_to_inner_sorts = X.xml_empty "VAR" ["uri", uri ; "id",id ; "sort",sort] | A.AEvar (id,n,l) -> let sort = Hashtbl.find ids_to_inner_sorts id in - X.xml_nempty "META" + X.xml_nempty "META" ["no",(export_existential n) ; "id",id ; "sort",sort] (List.fold_left (fun i t -> diff --git a/plugins/xml/cic2Xml.ml b/plugins/xml/cic2Xml.ml index 08d3a85010..981503a663 100644 --- a/plugins/xml/cic2Xml.ml +++ b/plugins/xml/cic2Xml.ml @@ -6,7 +6,7 @@ let print_xml_term ch env sigma cic = let ids_to_inner_types = Hashtbl.create 503 in let seed = ref 0 in let acic = - Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids + Cic2acic.acic_of_cic_context' true seed ids_to_terms constr_to_ids ids_to_father_ids ids_to_inner_sorts ids_to_inner_types env [] sigma (Unshare.unshare cic) None in let xml = Acic2Xml.print_term ids_to_inner_sorts acic in diff --git a/plugins/xml/cic2acic.ml b/plugins/xml/cic2acic.ml index 1ac022159a..5bb7635b9d 100644 --- a/plugins/xml/cic2acic.ml +++ b/plugins/xml/cic2acic.ml @@ -22,12 +22,12 @@ let get_module_path_of_full_path path = List.filter (function modul -> Libnames.is_dirpath_prefix_of modul dirpath) modules with - [] -> + [] -> Pp.warning ("Modules not supported: reference to "^ Libnames.string_of_path path^" will be wrong"); dirpath | [modul] -> modul - | _ -> + | _ -> raise TwoModulesWhoseDirPathIsOneAPrefixOfTheOther ;; @@ -134,7 +134,7 @@ let token_list_of_kernel_name ~keep_sections kn tag = else let module_path = let f = N.string_of_id (N.id_of_msid self) in - let _,longf = + let _,longf = System.find_file_in_path (Library.get_load_path ()) (f^".v") in let ldir0 = Library.find_logical_path (Filename.dirname longf) in let id = Names.id_of_string (Filename.basename f) in @@ -159,9 +159,9 @@ let token_list_of_kernel_name tag = let module N = Names in let module LN = Libnames in let id,dir = match tag with - | Variable kn -> + | Variable kn -> N.id_of_label (N.label kn), Lib.cwd () - | Constant con -> + | Constant con -> N.id_of_label (N.con_label con), Lib.remove_section_part (LN.ConstRef con) | Inductive kn -> @@ -211,7 +211,7 @@ module CPropRetyping = | T.Prod (na,c1,c2) -> subst_type env sigma (T.subst1 h c2) rest | _ -> Util.anomaly "Non-functional construction" - + let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env ar = match T.kind_of_term (DoubleTypeInference.whd_betadeltaiotacprop env sigma ar) with @@ -219,7 +219,7 @@ module CPropRetyping = | T.Sort s -> Coq_sort (T.family_of_sort s) | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args)) in concl_of_arity env ft - + let typeur sigma metamap = let rec type_of env cstr= match Term.kind_of_term cstr with @@ -265,7 +265,7 @@ let typeur sigma metamap = | Coq_sort T.InSet -> T.mkSet | Coq_sort T.InType -> T.mkType Univ.type1_univ (* ERROR HERE *) | CProp -> T.mkConst DoubleTypeInference.cprop - + and sort_of env t = match Term.kind_of_term t with | T.Cast (c,_, s) when T.isSort s -> family_of_term s @@ -287,7 +287,7 @@ let typeur sigma metamap = | T.Lambda _ | T.Fix _ | T.Construct _ -> Util.anomaly "sort_of: Not a type (1)" | _ -> outsort env sigma (type_of env t) - + and sort_family_of env t = match T.kind_of_term t with | T.Cast (c,_, s) when T.isSort s -> family_of_term s @@ -299,7 +299,7 @@ let typeur sigma metamap = | T.Lambda _ | T.Fix _ | T.Construct _ -> Util.anomaly "sort_of: Not a type (1)" | _ -> outsort env sigma (type_of env t) - + in type_of, sort_of, sort_family_of let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c @@ -484,7 +484,7 @@ print_endline "PASSATO" ; flush stdout ; (* an explicit named substitution of "type" *) (* (variable * argument) list, whose *) (* second element is the list of residual *) - (* arguments and whose third argument is *) + (* arguments and whose third argument is *) (* the list of uninstantiated variables *) let rec get_explicit_subst variables arguments = match variables,arguments with @@ -497,7 +497,7 @@ print_endline "PASSATO" ; flush stdout ; let he1'' = String.concat "/" (List.map Names.string_of_id (List.rev he1')) ^ "/" - ^ (Names.string_of_id he1_id) ^ ".var" + ^ (Names.string_of_id he1_id) ^ ".var" in (he1'',he2)::subst, extra_args, uninst in @@ -528,7 +528,7 @@ print_endline "PASSATO" ; flush stdout ; in (* Now that we have all the auxiliary functions we *) - (* can finally proceed with the main case analysis. *) + (* can finally proceed with the main case analysis. *) match T.kind_of_term tt with T.Rel n -> let id = diff --git a/plugins/xml/doubleTypeInference.ml b/plugins/xml/doubleTypeInference.ml index 17d1d5dab4..f8921aec9e 100644 --- a/plugins/xml/doubleTypeInference.ml +++ b/plugins/xml/doubleTypeInference.ml @@ -69,12 +69,12 @@ let double_type_of env sigma cstr expectedty subterms_to_types = T.Meta n -> Util.error "DoubleTypeInference.double_type_of: found a non-instanciated goal" - + | T.Evar ((n,l) as ev) -> let ty = Unshare.unshare (Evd.existential_type sigma ev) in let jty = execute env sigma ty None in let jty = assumption_of_judgment env sigma jty in - let evar_context = + let evar_context = E.named_context_of_val (Evd.find sigma n).Evd.evar_hyps in let rec iter actual_args evar_context = match actual_args,evar_context with @@ -96,25 +96,25 @@ let double_type_of env sigma cstr expectedty subterms_to_types = (* for side effects only *) iter (List.rev (Array.to_list l)) (List.rev evar_context) ; E.make_judge cstr jty - - | T.Rel n -> + + | T.Rel n -> Typeops.judge_of_relative env n - | T.Var id -> + | T.Var id -> Typeops.judge_of_variable env id - + | T.Const c -> E.make_judge cstr (Typeops.type_of_constant env c) - + | T.Ind ind -> E.make_judge cstr (Inductiveops.type_of_inductive env ind) - - | T.Construct cstruct -> + + | T.Construct cstruct -> E.make_judge cstr (Inductiveops.type_of_constructor env cstruct) - + | T.Case (ci,p,c,lf) -> let expectedtype = - Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in + Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma c) in let cj = execute env sigma c (Some expectedtype) in let pj = execute env sigma p None in let (expectedtypes,_,_) = @@ -126,18 +126,18 @@ let double_type_of env sigma cstr expectedty subterms_to_types = (Array.map (function x -> Some x) expectedtypes) in let (j,_) = Typeops.judge_of_case env ci pj cj lfj in j - + | T.Fix ((vn,i as vni),recdef) -> let (_,tys,_ as recdef') = execute_recdef env sigma recdef in let fix = (vni,recdef') in E.make_judge (T.mkFix fix) tys.(i) - + | T.CoFix (i,recdef) -> let (_,tys,_ as recdef') = execute_recdef env sigma recdef in let cofix = (i,recdef') in E.make_judge (T.mkCoFix cofix) tys.(i) - - | T.Sort (T.Prop c) -> + + | T.Sort (T.Prop c) -> Typeops.judge_of_prop_contents c | T.Sort (T.Type u) -> @@ -153,8 +153,8 @@ let double_type_of env sigma cstr expectedty subterms_to_types = ) | T.App (f,args) -> - let expected_head = - Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in + let expected_head = + Reduction.whd_betadeltaiota env (Retyping.get_type_of env sigma f) in let j = execute env sigma f (Some expected_head) in let expected_args = let rec aux typ = @@ -172,8 +172,8 @@ let double_type_of env sigma cstr expectedty subterms_to_types = let jl = execute_array env sigma args expected_args in let (j,_) = Typeops.judge_of_apply env j jl in j - - | T.Lambda (name,c1,c2) -> + + | T.Lambda (name,c1,c2) -> let j = execute env sigma c1 None in let var = type_judgment env sigma j in let env1 = E.push_rel (name,None,var.E.utj_val) env in @@ -186,9 +186,9 @@ let double_type_of env sigma cstr expectedty subterms_to_types = Some (Reductionops.nf_beta sigma expected_target_type) | _ -> assert false in - let j' = execute env1 sigma c2 expectedc2type in + let j' = execute env1 sigma c2 expectedc2type in Typeops.judge_of_abstraction env1 name var j' - + | T.Prod (name,c1,c2) -> let j = execute env sigma c1 None in let varj = type_judgment env sigma j in @@ -212,7 +212,7 @@ let double_type_of env sigma cstr expectedty subterms_to_types = in let j3 = execute env1 sigma c3 None in Typeops.judge_of_letin env name j1 j2 j3 - + | T.Cast (c,k,t) -> let cj = execute env sigma c (Some (Reductionops.nf_beta sigma t)) in let tj = execute env sigma t None in diff --git a/plugins/xml/doubleTypeInference.mli b/plugins/xml/doubleTypeInference.mli index 2e14b5580b..b604ec4c4c 100644 --- a/plugins/xml/doubleTypeInference.mli +++ b/plugins/xml/doubleTypeInference.mli @@ -12,7 +12,7 @@ (* http://helm.cs.unibo.it *) (************************************************************************) -type types = { synthesized : Term.types; expected : Term.types option; } +type types = { synthesized : Term.types; expected : Term.types option; } val cprop : Names.constant diff --git a/plugins/xml/dumptree.ml4 b/plugins/xml/dumptree.ml4 index 407f86b363..82e90876de 100644 --- a/plugins/xml/dumptree.ml4 +++ b/plugins/xml/dumptree.ml4 @@ -42,7 +42,7 @@ let thin_sign osign sign = ;; let pr_tactic_xml = function - | TacArg (Tacexp t) -> str "" + | TacArg (Tacexp t) -> str "" | t -> str "" ;; @@ -68,10 +68,10 @@ let pr_rule_xml pr = function let pr_var_decl_xml env (id,c,typ) = let ptyp = print_constr_env env typ in match c with - | None -> + | None -> (str "") | Some c -> - (* Force evaluation *) + (* Force evaluation *) let pb = print_constr_env env c in (str "") @@ -81,7 +81,7 @@ let pr_rel_decl_xml env (na,c,typ) = let pbody = match c with | None -> mt () | Some c -> - (* Force evaluation *) + (* Force evaluation *) let pb = print_constr_env env c in (str" body=\"" ++ xmlstream pb ++ str "\"") in let ptyp = print_constr_env env typ in @@ -108,8 +108,8 @@ let pr_context_xml env = ;; let pr_subgoal_metas_xml metas env= - let pr_one (meta, typ) = - fnl () ++ str "" in List.fold_left (++) (mt ()) (List.map pr_one metas) @@ -124,7 +124,7 @@ let pr_goal_xml g = (pr_context_xml env)) ++ fnl () ++ str "") else - (hov 2 (str "" ++ + (hov 2 (str "" ++ (pr_context_xml env)) ++ fnl () ++ str "") ;; @@ -140,13 +140,13 @@ let rec print_proof_xml sigma osign pf = (List.fold_left (fun x y -> x ++ fnl () ++ y) (mt ()) (List.map (print_proof_xml sigma hyps) spfl))) ++ fnl () ++ str "" ;; -let print_proof_xml () = - let pp = print_proof_xml Evd.empty Sign.empty_named_context +let print_proof_xml () = + let pp = print_proof_xml Evd.empty Sign.empty_named_context (Tacmach.proof_of_pftreestate (Refiner.top_of_tree (Pfedit.get_pftreestate ()))) in msgnl pp ;; VERNAC COMMAND EXTEND DumpTree - [ "Dump" "Tree" ] -> [ print_proof_xml () ] -END + [ "Dump" "Tree" ] -> [ print_proof_xml () ] +END diff --git a/plugins/xml/proof2aproof.ml b/plugins/xml/proof2aproof.ml index f7524671fd..1beabf26ca 100644 --- a/plugins/xml/proof2aproof.ml +++ b/plugins/xml/proof2aproof.ml @@ -63,8 +63,8 @@ let nf_evar sigma ~preserve = (* Warning: statuses, goals, prim_rules and tactic_exprs are not unshared! *) let rec unshare_proof_tree = let module PT = Proof_type in - function {PT.open_subgoals = status ; - PT.goal = goal ; + function {PT.open_subgoals = status ; + PT.goal = goal ; PT.ref = ref} -> let unshared_ref = match ref with @@ -78,8 +78,8 @@ let rec unshare_proof_tree = in Some (unshared_rule, List.map unshare_proof_tree pfs) in - {PT.open_subgoals = status ; - PT.goal = goal ; + {PT.open_subgoals = status ; + PT.goal = goal ; PT.ref = unshared_ref} ;; @@ -105,13 +105,13 @@ let extract_open_proof sigma pf = match node with {PT.ref=Some(PT.Prim _,_)} as pf -> L.prim_extractor proof_extractor vl pf - + | {PT.ref=Some(PT.Nested (_,hidden_proof),spfl)} -> let sgl,v = Refiner.frontier hidden_proof in let flat_proof = v spfl in ProofTreeHash.add proof_tree_to_flattened_proof_tree node flat_proof ; proof_extractor vl flat_proof - + | {PT.ref=None;PT.goal=goal} -> let visible_rels = Util.map_succeed @@ -124,14 +124,14 @@ let extract_open_proof sigma pf = (*CSC: it becomes a Rel; otherwise a Var. Then it can be already used *) (*CSC: as the evar_instance. Ordering the instance becomes useless (it *) (*CSC: will already be ordered. *) - (Termops.ids_of_named_context + (Termops.ids_of_named_context (Environ.named_context_of_val goal.Evd.evar_hyps)) in let sorted_rels = Sort.list (fun (n1,_) (n2,_) -> n1 < n2 ) visible_rels in let context = - let l = + let l = List.map - (fun (_,id) -> Sign.lookup_named id + (fun (_,id) -> Sign.lookup_named id (Environ.named_context_of_val goal.Evd.evar_hyps)) sorted_rels in Environ.val_of_named_context l @@ -144,7 +144,7 @@ let extract_open_proof sigma pf = evar_instance in evd := evd' ; evar - + | _ -> Util.anomaly "Bug : a case has been forgotten in proof_extractor" in let unsharedconstr = diff --git a/plugins/xml/proofTree2Xml.ml4 b/plugins/xml/proofTree2Xml.ml4 index 7503d6328a..3f1e0a630b 100644 --- a/plugins/xml/proofTree2Xml.ml4 +++ b/plugins/xml/proofTree2Xml.ml4 @@ -45,7 +45,7 @@ let constr_to_xml obj sigma env = let rel_context = Sign.push_named_to_rel_context named_context' [] in let rel_env = Environ.push_rel_context rel_context - (Environ.reset_with_named_context + (Environ.reset_with_named_context (Environ.val_of_named_context real_named_context) env) in let obj' = Term.subst_vars (List.map (function (i,_,_) -> i) named_context') obj in @@ -149,7 +149,7 @@ Pp.ppnl (Pp.(++) (Pp.str Proof2aproof.ProofTreeHash.find proof_tree_to_flattened_proof_tree node in begin match tactic_expr with - | T.TacArg (T.Tacexp _) -> + | T.TacArg (T.Tacexp _) -> (* We don't need to keep the level of abstraction introduced at *) (* user-level invocation of tactic... (see Tacinterp.hide_interp)*) aux flat_proof old_hyps @@ -189,7 +189,7 @@ Pp.ppnl (Pp.(++) (Pp.str end | {PT.ref=Some((PT.Nested(PT.Proof_instr (_,_),_)|PT.Decl_proof _),nodes)} -> - Util.anomaly "Not Implemented" + Util.anomaly "Not Implemented" | {PT.ref=Some(PT.Daimon,_)} -> X.xml_empty "Hidden_open_goal" of_attribute diff --git a/plugins/xml/xmlcommand.ml b/plugins/xml/xmlcommand.ml index 4a27c3247d..a46500b89c 100644 --- a/plugins/xml/xmlcommand.ml +++ b/plugins/xml/xmlcommand.ml @@ -38,7 +38,7 @@ let print_if_verbose s = if !verbose then print_string s;; (* Next exception is used only inside print_coq_object and tag_of_string_tag *) exception Uninteresting;; -(* NOT USED anymore, we back to the V6 point of view with global parameters +(* NOT USED anymore, we back to the V6 point of view with global parameters (* Internally, for Coq V7, params of inductive types are associated *) (* not to the whole block of mutual inductive (as it was in V6) but to *) @@ -106,7 +106,7 @@ let filter_params pvars hyps = aux (Names.repr_dirpath modulepath) (List.rev pvars) ;; -type variables_type = +type variables_type = Definition of string * Term.constr * Term.types | Assumption of string * Term.constr ;; @@ -246,7 +246,7 @@ let find_hyps t = match T.kind_of_term t with T.Var id when not (List.mem id l) -> let (_,bo,ty) = Global.lookup_named id in - let boids = + let boids = match bo with Some bo' -> aux l bo' | None -> l @@ -393,7 +393,7 @@ let mk_inductive_obj sp mib packs variables nparams hyps finite = (* The current channel for .theory files *) let theory_buffer = Buffer.create 4000;; -let theory_output_string ?(do_not_quote = false) s = +let theory_output_string ?(do_not_quote = false) s = (* prepare for coqdoc post-processing *) let s = if do_not_quote then s else "(** #"^s^"\n#*)\n" in print_if_verbose s; @@ -423,7 +423,7 @@ let kind_of_variable id = | _ -> Util.anomaly "Unsupported variable kind" ;; -let kind_of_constant kn = +let kind_of_constant kn = let module DK = Decl_kinds in match Decls.constant_kind kn with | DK.IsAssumption DK.Definitional -> "AXIOM","Declaration" @@ -432,7 +432,7 @@ let kind_of_constant kn = Pp.warning "Conjecture not supported in dtd (used Declaration instead)"; "AXIOM","Declaration" | DK.IsDefinition DK.Definition -> "DEFINITION","Definition" - | DK.IsDefinition DK.Example -> + | DK.IsDefinition DK.Example -> Pp.warning "Example not supported in dtd (used Definition instead)"; "DEFINITION","Definition" | DK.IsDefinition DK.Coercion -> @@ -461,10 +461,10 @@ let kind_of_constant kn = "DEFINITION","Definition" | DK.IsDefinition DK.Instance -> Pp.warning "Instance not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" + "DEFINITION","Definition" | DK.IsDefinition DK.Method -> Pp.warning "Method not supported in dtd (used Definition instead)"; - "DEFINITION","Definition" + "DEFINITION","Definition" | DK.IsProof (DK.Theorem|DK.Lemma|DK.Corollary|DK.Fact|DK.Remark as thm) -> "THEOREM",DK.string_of_theorem_kind thm | DK.IsProof _ -> @@ -476,7 +476,7 @@ let kind_of_global r = let module Ln = Libnames in let module DK = Decl_kinds in match r with - | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> + | Ln.IndRef kn | Ln.ConstructRef (kn,_) -> let isrecord = try let _ = Recordops.lookup_projections kn in true with Not_found -> false in @@ -515,7 +515,7 @@ let print internal glob_ref kind xml_library_root = match glob_ref with Ln.VarRef id -> (* this kn is fake since it is not provided by Coq *) - let kn = + let kn = let (mod_path,dir_path) = Lib.current_prefix () in N.make_kn mod_path dir_path (N.label_of_id id) in @@ -615,13 +615,13 @@ let _ = (function (internal,kn) -> match !proof_to_export with None -> - print internal (Libnames.ConstRef kn) (kind_of_constant kn) + print internal (Libnames.ConstRef kn) (kind_of_constant kn) xml_library_root | Some pftreestate -> (* It is a proof. Let's export it starting from the proof-tree *) (* I saved in the Pfedit.set_xml_cook_proof callback. *) let fn = filename_of_path xml_library_root (Cic2acic.Constant kn) in - show_pftreestate internal fn pftreestate + show_pftreestate internal fn pftreestate (Names.id_of_label (Names.con_label kn)) ; proof_to_export := None) ;; @@ -629,7 +629,7 @@ let _ = let _ = Declare.set_xml_declare_inductive (function (isrecord,(sp,kn)) -> - print false (Libnames.IndRef (kn,0)) (kind_of_inductive isrecord kn) + print false (Libnames.IndRef (kn,0)) (kind_of_inductive isrecord kn) xml_library_root) ;; @@ -664,7 +664,7 @@ let _ = Buffer.output_buffer ch theory_buffer ; close_out ch end ; - Option.iter + Option.iter (fun fn -> let coqdoc = Filename.concat (Envars.coqbin ()) ("coqdoc" ^ Coq_config.exec_extension) in let options = " --html -s --body-only --no-index --latin1 --raw-comments" in @@ -684,7 +684,7 @@ let _ = let _ = Lexer.set_xml_output_comment (theory_output_string ~do_not_quote:true) ;; let uri_of_dirpath dir = - "/" ^ String.concat "/" + "/" ^ String.concat "/" (List.map Names.string_of_id (List.rev (Names.repr_dirpath dir))) ;; @@ -702,7 +702,7 @@ let _ = let _ = Library.set_xml_require - (fun d -> theory_output_string + (fun d -> theory_output_string (Printf.sprintf "Require %s.
" (uri_of_dirpath d) (Names.string_of_dirpath d))) ;; diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 1f9cc0f1f4..899fb64e1c 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -73,11 +73,11 @@ let set_impossible_default_clause c = impossible_default_case := Some c let coq_unit_judge = let na1 = Name (id_of_string "A") in let na2 = Name (id_of_string "H") in - fun () -> + fun () -> match !impossible_default_case with | Some (id,type_of_id) -> make_judge id type_of_id - | None -> + | None -> (* In case the constants id/ID are not defined *) make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))) @@ -88,7 +88,7 @@ module type S = sig val compile_cases : loc -> case_style -> (type_constraint -> env -> evar_defs ref -> rawconstr -> unsafe_judgment) * evar_defs ref -> - type_constraint -> + type_constraint -> env -> rawconstr option * tomatch_tuples * cases_clauses -> unsafe_judgment end @@ -97,8 +97,8 @@ let rec list_try_compile f = function | [a] -> f a | [] -> anomaly "try_find_f" | h::t -> - try f h - with UserError _ | TypeError _ | PretypeError _ + try f h + with UserError _ | TypeError _ | PretypeError _ | Stdpp.Exc_located (_,(UserError _ | TypeError _ | PretypeError _)) -> list_try_compile f t @@ -119,7 +119,7 @@ let msg_may_need_inversion () = (* Utils *) let make_anonymous_patvars n = - list_make n (PatVar (dummy_loc,Anonymous)) + list_make n (PatVar (dummy_loc,Anonymous)) (* Environment management *) let push_rels vars env = List.fold_right push_rel vars env @@ -169,7 +169,7 @@ type 'a rhs = it : 'a option} type 'a equation = - { patterns : cases_pattern list; + { patterns : cases_pattern list; rhs : 'a rhs; alias_stack : name list; eqn_loc : loc; @@ -212,7 +212,7 @@ let feed_history arg = function Continuation (n-1, arg :: l, h) | Continuation (n, _, _) -> anomaly ("Bad number of expected remaining patterns: "^(string_of_int n)) - | Result _ -> + | Result _ -> anomaly "Exhausted pattern history" (* This is for non exhaustive error message *) @@ -243,7 +243,7 @@ let rec simplify_history = function let pat = match f with | AliasConstructor pci -> PatCstr (dummy_loc,pci,pargs,Anonymous) - | AliasLeaf -> + | AliasLeaf -> assert (l = []); PatVar (dummy_loc, Anonymous) in feed_history pat rh @@ -261,7 +261,7 @@ let push_history_pattern n current cont = where tomatch is some sequence of "instructions" (t1 ... tn) - and mat is some matrix + and mat is some matrix (p11 ... p1n -> rhs1) ( ... ) (pm1 ... pmn -> rhsm) @@ -322,7 +322,7 @@ let rec find_row_ind = function let inductive_template evdref env tmloc ind = let arsign = get_full_arity_sign env ind in - let hole_source = match tmloc with + let hole_source = match tmloc with | Some loc -> fun i -> (loc, TomatchTypeParameter (ind,i)) | None -> fun _ -> (dummy_loc, InternalHole) in let (_,evarl,_) = @@ -332,7 +332,7 @@ let inductive_template evdref env tmloc ind = | None -> let ty' = substl subst ty in let e = e_new_evar evdref env ~src:(hole_source n) ty' in - (e::subst,e::evarl,n+1) + (e::subst,e::evarl,n+1) | Some b -> (b::subst,evarl,n+1)) arsign ([],[],1) in @@ -349,7 +349,7 @@ let try_find_ind env sigma typ realnames = let inh_coerce_to_ind evdref env ty tyi = let expected_typ = inductive_template evdref env None tyi in - (* devrait être indifférent d'exiger leq ou pas puisque pour + (* devrait être indifférent d'exiger leq ou pas puisque pour un inductif cela doit être égal *) let _ = e_cumul env evdref expected_typ ty in () @@ -363,9 +363,9 @@ let unify_tomatch_with_patterns evdref env loc typ pats realnames = let find_tomatch_tycon evdref env loc = function (* Try if some 'in I ...' is present and can be used as a constraint *) - | Some (_,ind,_,realnal) -> + | Some (_,ind,_,realnal) -> mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal) - | None -> + | None -> empty_tycon,None let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) = @@ -404,7 +404,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = (* Ideally, we could find a common inductive type to which both the term to match and the patterns coerce *) (* In practice, we coerce the term to match if it is not already an - inductive type and it is not dependent; moreover, we use only + inductive type and it is not dependent; moreover, we use only the first pattern type and forget about the others *) let typ,names = match typ with IsInd(t,_,names) -> t,Some names | NotInd(_,t) -> t,None in @@ -483,7 +483,7 @@ let rec adjust_local_defs loc = function | [], [] -> [] | _ -> raise NotAdjustable -let check_and_adjust_constructor env ind cstrs = function +let check_and_adjust_constructor env ind cstrs = function | PatVar _ as pat -> pat | PatCstr (loc,((_,i) as cstr),args,alias) as pat -> (* Check it is constructor of the right type *) @@ -494,7 +494,7 @@ let check_and_adjust_constructor env ind cstrs = function let nb_args_constr = ci.cs_nargs in if List.length args = nb_args_constr then pat else - try + try let args' = adjust_local_defs loc (args, List.rev ci.cs_args) in PatCstr (loc, cstr, args', alias) with NotAdjustable -> @@ -504,7 +504,7 @@ let check_and_adjust_constructor env ind cstrs = function (* Try to insert a coercion *) try Coercion.inh_pattern_coerce_to loc pat ind' ind - with Not_found -> + with Not_found -> error_bad_constructor_loc loc cstr ind let check_all_variables typ mat = @@ -516,14 +516,14 @@ let check_all_variables typ mat = mat let check_unused_pattern env eqn = - if not !(eqn.used) then + if not !(eqn.used) then raise_pattern_matching_error (eqn.eqn_loc, env, UnusedClause eqn.patterns) let set_used_pattern eqn = eqn.used := true let extract_rhs pb = - match pb.mat with + match pb.mat with | [] -> errorlabstrm "build_leaf" (msg_may_need_inversion()) | eqn::_ -> set_used_pattern eqn; @@ -574,7 +574,7 @@ let dependencies_in_rhs nargs current tms eqns = let rec find_dependency_list k n = function | [] -> [] - | (used,tdeps,d)::rest -> + | (used,tdeps,d)::rest -> let deps = find_dependency_list k (n+1) rest in if used && dependent_decl (mkRel n) d then list_add_set (List.length rest + 1) (list_union deps tdeps) @@ -601,7 +601,7 @@ let find_dependencies_signature deps_in_rhs typs = let regeneralize_index_tomatch n = let rec genrec depth = function - | [] -> + | [] -> [] | Pushed ((c,tm),l,dep) :: rest -> let c = regeneralize_index n depth c in @@ -615,7 +615,7 @@ let regeneralize_index_tomatch n = :: genrec (depth+1) rest in genrec 0 -let rec replace_term n c k t = +let rec replace_term n c k t = if t = mkRel (n+k) then lift k c else map_constr_with_binders succ (replace_term n c) k t @@ -673,7 +673,7 @@ let lift_tomatch_stack n = liftn_tomatch_stack n 1 [match y with (S (S x)) => x | x => x end] should be compiled into [match y with O => y | (S n) => match n with O => y | (S x) => x end end] - and [match y with (S (S n)) => n | n => n end] into + and [match y with (S (S n)) => n | n => n end] into [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end] i.e. user names should be preserved and created names should not @@ -688,7 +688,7 @@ let merge_names get_name = List.map2 (merge_name get_name) let get_names env sign eqns = let names1 = list_make (List.length sign) Anonymous in (* If any, we prefer names used in pats, from top to bottom *) - let names2 = + let names2 = List.fold_right (fun (pats,eqn) names -> merge_names alias_of_pat pats names) eqns names1 in @@ -702,7 +702,7 @@ let get_names env sign eqns = let na = merge_name (fun (na,_,t) -> Name (next_name_away (named_hd env t na) avoid)) - d na + d na in (na::l,(out_name na)::avoid)) ([],allvars) (List.rev sign) names2 in @@ -739,7 +739,7 @@ let build_aliases_context env sigma names allpats pats = let oldallpats = List.map List.tl oldallpats in let decl = (na,Some deppat,t) in let a = (deppat,nondeppat,d,t) in - insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) + insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1) newallpats oldallpats (pats,names) | [], [] -> newallpats, sign1, sign2, env | _ -> anomaly "Inconsistent alias and name lists" in @@ -759,7 +759,7 @@ let insert_aliases env sigma alias eqns = let eqnsnames = List.map (fun eqn -> List.hd eqn.alias_stack) eqns in let alias_rests = List.map (fun eqn -> List.tl eqn.alias_stack) eqns in (* name2 takes the meet of all needed aliases *) - let name2 = + let name2 = List.fold_right (merge_name (fun x -> x)) eqnsnames Anonymous in (* Only needed aliases are kept by build_aliases_context *) let eqnsnames, sign1, sign2, env = @@ -776,7 +776,7 @@ let noccur_between_without_evar n m term = | Rel p -> if n<=p && p () | _ -> iter_constr_with_binders succ occur_rec n c - in + in (m = 0) or (try occur_rec n term; true with Occur -> false) @@ -853,7 +853,7 @@ let subst_predicate (args,copt) ccl tms = let specialize_predicate_var (cur,typ,dep) tms ccl = let c = if dep<>Anonymous then Some cur else None in - let l = + let l = match typ with | IsInd (_,IndType(_,realargs),names) -> if names<>[] then realargs else [] | NotInd _ -> [] in @@ -901,7 +901,7 @@ let abstract_predicate env sigma indf cur (names,(nadep,_)) tms ccl = | Rel i -> regeneralize_index_tomatch (i+n) tms | _ -> (* Initial case *) tms in let sign = List.map2 (fun na (_,c,t) -> (na,c,t)) (nadep::names) sign in - let ccl = if nadep <> Anonymous then ccl else lift_predicate 1 ccl tms in + let ccl = if nadep <> Anonymous then ccl else lift_predicate 1 ccl tms in let pred = extract_predicate [] ccl tms in it_mkLambda_or_LetIn_name env pred sign @@ -913,7 +913,7 @@ let known_dependent (_,dep) = (dep = KnownDep) by gamma, x1...xn, x1...xk-1 |- [X=realargs]pred (if not dep) *) let expand_arg tms ccl ((_,t),_,na) = - let k = length_of_tomatch_type_sign na t in + let k = length_of_tomatch_type_sign na t in lift_predicate (k-1) ccl tms let adjust_impossible_cases pb pred tomatch submat = @@ -928,9 +928,9 @@ let adjust_impossible_cases pb pred tomatch submat = map_succeed (function Alias _ -> Anonymous | _ -> failwith"") tomatch in [ { patterns = pats; - rhs = { rhs_env = pb.env; - rhs_vars = []; - avoid_ids = []; + rhs = { rhs_env = pb.env; + rhs_vars = []; + avoid_ids = []; it = None }; alias_stack = Anonymous::aliasnames; eqn_loc = dummy_loc; @@ -1024,8 +1024,8 @@ let group_equations pb ind current cstrs mat = (fun eqn () -> let rest = remove_current_pattern eqn in let pat = current_pattern eqn in - match check_and_adjust_constructor pb.env ind cstrs pat with - | PatVar (_,name) -> + match check_and_adjust_constructor pb.env ind cstrs pat with + | PatVar (_,name) -> (* This is a default clause that we expand *) for i=1 to Array.length cstrs do let args = make_anonymous_patvars cstrs.(i-1).cs_nargs in @@ -1074,10 +1074,10 @@ let build_branch current deps (realnames,dep) pb arsign eqns const_info = & not (known_dependent dep) & deps = [] then NonDepAlias - else + else DepAlias in - let history = + let history = push_history_pattern const_info.cs_nargs (AliasConstructor const_info.cs_cstr) pb.history in @@ -1096,10 +1096,10 @@ let build_branch current deps (realnames,dep) pb arsign eqns const_info = let dep_sign = find_dependencies_signature - (dependencies_in_rhs const_info.cs_nargs current pb.tomatch eqns) + (dependencies_in_rhs const_info.cs_nargs current pb.tomatch eqns) (List.rev typs) in - (* The dependent term to subst in the types of the remaining UnPushed + (* The dependent term to subst in the types of the remaining UnPushed terms is relative to the current context enriched by topushs *) let ci = build_dependent_constructor const_info in @@ -1109,7 +1109,7 @@ let build_branch current deps (realnames,dep) pb arsign eqns const_info = (* into "Gamma; typs; curalias |- tms" *) let tomatch = lift_tomatch_stack const_info.cs_nargs pb.tomatch in - let typs'' = + let typs'' = list_map2_i (fun i (na,t) deps -> let dep = match dep with @@ -1123,7 +1123,7 @@ let build_branch current deps (realnames,dep) pb arsign eqns const_info = ((mkRel i, lift_tomatch_type i t),deps,dep)) 1 typs' (List.rev dep_sign) in - let pred = + let pred = specialize_predicate typs'' (realnames,dep) arsign const_info tomatch pb.pred in let currents = List.map (fun x -> Pushed x) typs'' in @@ -1199,7 +1199,7 @@ and match_current pb tomatch = (* We build the (elementary) case analysis *) let brvals = Array.map (fun (v,_) -> v) brs in let (pred,typ,s) = - find_predicate pb.caseloc pb.env pb.evdref + find_predicate pb.caseloc pb.env pb.evdref pb.pred current indt (names,dep) pb.tomatch in let ci = make_case_info pb.env mind pb.casestyle in let case = mkCase (ci,nf_betaiota Evd.empty pred,current,brvals) in @@ -1284,7 +1284,7 @@ let matx_of_eqns env tomatchl eqns = variables (in practice, there is no reason that ti is already constructed and the qi will be degenerated). - We then look for a type U(..a1jk..b1 .. ..amjk..bm) so that + We then look for a type U(..a1jk..b1 .. ..amjk..bm) so that T = U(..v1jk..t1 .. ..vmjk..tm). This a higher-order matching problem with a priori different solution (one of them if T itself!). @@ -1303,13 +1303,13 @@ let matx_of_eqns env tomatchl eqns = let adjust_to_extended_env_and_remove_deps env extenv subst t = let n = rel_context_length (rel_context env) in let n' = rel_context_length (rel_context extenv) in - (* We first remove the bindings that are dependently typed (they are + (* We first remove the bindings that are dependently typed (they are difficult to manage and it is not sure these are so useful in practice); Notes: - [subst] is made of pairs [(id,u)] where id is a name in [extenv] and [u] a term typed in [env]; - [subst0] is made of items [(p,u,(u,ty))] where [ty] is the type of [u] - and both are adjusted to [extenv] while [p] is the index of [id] in + and both are adjusted to [extenv] while [p] is the index of [id] in [extenv] (after expansion of the aliases) *) let subst0 = map_succeed (fun (x,u) -> (* d1 ... dn dn+1 ... dn'-p+1 ... dn' *) @@ -1337,8 +1337,8 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t = * defined in some environment env. The vijk and ti are supposed to be * instances for variables aijk and bi. * - * [abstract_tycon Gamma0 Sigma subst T Gamma] looks for U(..v1jk..t1 .. ..vmjk..tm) - * defined in some extended context + * [abstract_tycon Gamma0 Sigma subst T Gamma] looks for U(..v1jk..t1 .. ..vmjk..tm) + * defined in some extended context * "Gamma0, ..a1jk:V1jk.. b1:W1 .. ..amjk:Vmjk.. bm:Wm" * such that env |- T = U(..v1jk..t1 .. ..vmjk..tm). To not commit to * a particular solution, we replace each subterm t in T that unifies with @@ -1362,11 +1362,11 @@ let abstract_tycon loc env evdref subst _tycon extenv t = if good <> [] then let (u,ty) = pi3 (List.hd good) in let vl = List.map pi1 good in - let inst = + let inst = list_map_i (fun i _ -> if List.mem i vl then u else mkRel i) 1 (rel_context extenv) in - let rel_filter = + let rel_filter = List.map (fun a -> not (isRel a) or dependent a u) inst in let named_filter = List.map (fun (id,_,_) -> dependent (mkVar id) u) @@ -1377,10 +1377,10 @@ let abstract_tycon loc env evdref subst _tycon extenv t = evdref := add_conv_pb (Reduction.CONV,extenv,substl inst ev,u) !evdref; lift k ev else - map_constr_with_full_binders + map_constr_with_full_binders (fun d (k,env,subst) -> k+1, - push_rel d env, + push_rel d env, List.map (fun (na,u,d) -> (na,lift 1 u,d)) subst) aux x t in aux (0,extenv,subst0) t0 @@ -1388,11 +1388,11 @@ let abstract_tycon loc env evdref subst _tycon extenv t = let build_tycon loc env tycon_env subst tycon extenv evdref t = let t = match t with | None -> - (* This is the situation we are building a return predicate and + (* This is the situation we are building a return predicate and we are in an impossible branch *) let n = rel_context_length (rel_context env) in let n' = rel_context_length (rel_context tycon_env) in - let impossible_case_type = + let impossible_case_type = e_new_evar evdref env ~src:(loc,ImpossibleCase) (new_Type ()) in lift (n'-n) impossible_case_type | Some t -> abstract_tycon loc tycon_env evdref subst tycon extenv t in @@ -1400,7 +1400,7 @@ let build_tycon loc env tycon_env subst tycon extenv evdref t = (* For a multiple pattern-matching problem Xi on t1..tn with return * type T, [build_inversion_problem Gamma Sigma (t1..tn) T] builds a return - * predicate for Xi that is itself made by an auxiliary + * predicate for Xi that is itself made by an auxiliary * pattern-matching problem of which the first clause reveals the * pattern structure of the constraints on the inductive types of the t1..tn, * and the second clause is a wildcard clause for catching the @@ -1485,11 +1485,11 @@ let build_inversion_problem loc env evdref tms t = alias_stack = []; eqn_loc = dummy_loc; used = ref false; - rhs = { rhs_env = pb_env; - rhs_vars = []; + rhs = { rhs_env = pb_env; + rhs_vars = []; avoid_ids = avoid0; it = None } } in - (* [pb] is the auxiliary pattern-matching serving as skeleton for the + (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) let pb = { env = pb_env; @@ -1520,7 +1520,7 @@ let prepare_predicate_from_tycon loc dep env evdref tomatchs sign c = let n,allargs,env',signs = List.fold_left cook (0, [], env, []) tomatchs in let names = List.rev (List.map (List.map pi1) signs) in names, build_inversion_problem loc env evdref tomatchs c - + (* Here, [pred] is assumed to be in the context built from all *) (* realargs and terms to match *) let build_initial_predicate knowndep allnames pred = @@ -1547,10 +1547,10 @@ let build_initial_predicate knowndep allnames pred = let extract_arity_signature env0 tomatchl tmsign = let get_one_sign n tm (na,t) = match tm with - | NotInd (bo,typ) -> + | NotInd (bo,typ) -> (match t with | None -> [na,Option.map (lift n) bo,lift n typ] - | Some (loc,_,_,_) -> + | Some (loc,_,_,_) -> user_err_loc (loc,"", str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> @@ -1598,11 +1598,11 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon = let prepare_predicate_from_arsign_tycon loc env tomatchs sign arsign c = let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in - let subst, len = + let subst, len = List.fold_left2 (fun (subst, len) (tm, tmtype) sign -> let signlen = List.length sign in match kind_of_term tm with - | Rel n when dependent tm c + | Rel n when dependent tm c && signlen = 1 (* The term to match is not of a dependent type itself *) -> ((n, len) :: subst, len - signlen) | Rel n when signlen > 1 (* The term is of a dependent type, @@ -1610,12 +1610,12 @@ let prepare_predicate_from_arsign_tycon loc env tomatchs sign arsign c = (match tmtype with NotInd _ -> (* len - signlen, subst*) assert false (* signlen > 1 *) | IsInd (_, IndType(indf,realargs),_) -> - let subst = - if dependent tm c && List.for_all isRel realargs - then (n, 1) :: subst else subst + let subst = + if dependent tm c && List.for_all isRel realargs + then (n, 1) :: subst else subst in List.fold_left - (fun (subst, len) arg -> + (fun (subst, len) arg -> match kind_of_term arg with | Rel n when dependent arg c -> ((n, len) :: subst, pred len) @@ -1626,16 +1626,16 @@ let prepare_predicate_from_arsign_tycon loc env tomatchs sign arsign c = in let rec predicate lift c = match kind_of_term c with - | Rel n when n > lift -> - (try + | Rel n when n > lift -> + (try (* Make the predicate dependent on the matched variable *) let idx = List.assoc (n - lift) subst in mkRel (idx + lift) - with Not_found -> + with Not_found -> (* A variable that is not matched, lift over the arsign. *) mkRel (n + nar)) | _ -> - map_constr_with_binders succ predicate lift c + map_constr_with_binders succ predicate lift c in predicate 0 c @@ -1666,16 +1666,16 @@ let prepare_predicate loc typing_fun evdref env tomatchs sign tycon pred = let pred1 = prepare_predicate_from_arsign_tycon loc env' tomatchs sign arsign t in let nal1,pred1 = build_initial_predicate KnownDep names1 pred1 in (* Second strategy: we build an "inversion" predicate *) - let names2,pred2 = + let names2,pred2 = prepare_predicate_from_tycon loc true env evdref2 tomatchs sign t - in + in let nal2,pred2 = build_initial_predicate DepUnknown names2 pred2 in [evdref, nal1, pred1; evdref2, nal2, pred2] | Some (None, t) -> (* Only one strategy: we build an "inversion" predicate *) - let names,pred = + let names,pred = prepare_predicate_from_tycon loc true env evdref tomatchs sign t - in + in let nal,pred = build_initial_predicate DepUnknown names pred in [evdref, nal, pred] | _ -> @@ -1683,9 +1683,9 @@ let prepare_predicate loc typing_fun evdref env tomatchs sign tycon pred = let evdref2 = ref !evdref in let t1 = mkExistential env ~src:(loc, CasesType) evdref in (* First strategy: we pose a possibly dependent "inversion" evar *) - let names1,pred1 = + let names1,pred1 = prepare_predicate_from_tycon loc true env evdref tomatchs sign t1 - in + in let nal1,pred1 = build_initial_predicate DepUnknown names1 pred1 in (* Second strategy: we pose a non dependent evar *) let t2 = mkExistential env ~src:(loc, CasesType) evdref2 in @@ -1701,34 +1701,34 @@ let prepare_predicate loc typing_fun evdref env tomatchs sign tycon pred = let env = List.fold_right push_rels arsign env in let allnames = List.rev (List.map (List.map pi1) arsign) in let predcclj = typing_fun (mk_tycon (new_Type ())) env evdref rtntyp in - let _ = - Option.map (fun tycon -> - evdref := Coercion.inh_conv_coerces_to loc env !evdref predcclj.uj_val + let _ = + Option.map (fun tycon -> + evdref := Coercion.inh_conv_coerces_to loc env !evdref predcclj.uj_val (lift_tycon_type (List.length arsign) tycon)) tycon in - let predccl = (j_nf_isevar !evdref predcclj).uj_val in + let predccl = (j_nf_isevar !evdref predcclj).uj_val in let nal,pred = build_initial_predicate KnownDep allnames predccl in [evdref, nal, pred] (**************************************************************************) (* Main entry of the matching compilation *) - + let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) = (* We build the matrix of patterns and right-hand-side *) let matx = matx_of_eqns env tomatchl eqns in - + (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) let tomatchs = coerce_to_indtype typing_fun evdref env matx tomatchl in - + (* If an elimination predicate is provided, we check it is compatible with the type of arguments to match; if none is provided, we build alternative possible predicates *) let sign = List.map snd tomatchl in let preds = prepare_predicate loc typing_fun evdref env tomatchs sign tycon predopt in - + let compile_for_one_predicate (myevdref,nal,pred) = (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous *) diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 4b203586ac..e6d42e10d9 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -65,7 +65,7 @@ module type S = sig val compile_cases : loc -> case_style -> (type_constraint -> env -> evar_defs ref -> rawconstr -> unsafe_judgment) * evar_defs ref -> - type_constraint -> + type_constraint -> env -> rawconstr option * tomatch_tuples * cases_clauses -> unsafe_judgment end diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 70cf980f44..8c03d0df47 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -75,7 +75,7 @@ and cbv_stack = | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack (* les vars pourraient etre des constr, - cela permet de retarder les lift: utile ?? *) + cela permet de retarder les lift: utile ?? *) (* relocation of a value; used when a value stored in a context is expanded * in a larger context. e.g. [%k (S.t)](k+1) --> [^k]t (t is shifted of k) @@ -173,7 +173,7 @@ let fixp_reducible flgs ((reci,i),_) stk = CONSTR _ -> true | _ -> false) | _ -> false - else + else false let cofixp_reducible flgs _ stk = @@ -181,7 +181,7 @@ let cofixp_reducible flgs _ stk = match stk with | (CASE _ | APP(_,CASE _)) -> true | _ -> false - else + else false @@ -261,7 +261,7 @@ and norm_head_ref k info env stack normt = * env, with context stack, i.e. ([env]t stack). First computes weak * head normal form of t and checks if a redex appears with the stack. * If so, recursive call to reach the real head normal form. If not, - * we build a value. + * we build a value. *) and cbv_stack_term info stack env t = match norm_head info env t stack with @@ -297,15 +297,15 @@ and cbv_stack_term info stack env t = let cargs = Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in cbv_stack_term info (stack_app cargs stk) env br.(n-1) - + (* constructor of arity 0 in a Case -> IOTA *) | (CONSTR((_,n),_), CASE(_,br,_,env,stk)) when red_set (info_flags info) fIOTA -> cbv_stack_term info stk env br.(n-1) - (* may be reduced later by application *) - | (FIXP(fix,env,[||]), APP(appl,TOP)) -> FIXP(fix,env,appl) - | (COFIXP(cofix,env,[||]), APP(appl,TOP)) -> COFIXP(cofix,env,appl) + (* may be reduced later by application *) + | (FIXP(fix,env,[||]), APP(appl,TOP)) -> FIXP(fix,env,appl) + | (COFIXP(cofix,env,[||]), APP(appl,TOP)) -> COFIXP(cofix,env,appl) | (CONSTR(c,[||]), APP(appl,TOP)) -> CONSTR(c,appl) (* definitely a value *) @@ -350,14 +350,14 @@ and cbv_norm_value info = function (* reduction under binders *) (mkFix (lij, (names, Array.map (cbv_norm_term info env) lty, - Array.map (cbv_norm_term info + Array.map (cbv_norm_term info (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) | COFIXP ((j,(names,lty,bds)),env,args) -> mkApp (mkCoFix (j, (names,Array.map (cbv_norm_term info env) lty, - Array.map (cbv_norm_term info + Array.map (cbv_norm_term info (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) | CONSTR (c,args) -> diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 348ae46dc6..a4b4260ad8 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -28,8 +28,8 @@ open Mod_subst (* A class is a type constructor, its type is an arity whose number of arguments is cl_param (0 for CL_SORT and CL_FUN) *) -type cl_typ = - | CL_SORT +type cl_typ = + | CL_SORT | CL_FUN | CL_SECVAR of variable | CL_CONST of constant @@ -82,7 +82,7 @@ let inheritance_graph = let freeze () = (!class_tab, !coercion_tab, !inheritance_graph) -let unfreeze (fcl,fco,fig) = +let unfreeze (fcl,fco,fig) = class_tab:=fcl; coercion_tab:=fco; inheritance_graph:=fig @@ -93,20 +93,20 @@ let add_new_class cl s = if not (Bijint.mem cl !class_tab) then class_tab := Bijint.add cl s !class_tab -let add_new_coercion coe s = +let add_new_coercion coe s = coercion_tab := Gmap.add coe s !coercion_tab let add_new_path x y = inheritance_graph := Gmap.add x y !inheritance_graph let init () = - class_tab:= Bijint.empty; + class_tab:= Bijint.empty; add_new_class CL_FUN { cl_param = 0 }; add_new_class CL_SORT { cl_param = 0 }; coercion_tab:= Gmap.empty; inheritance_graph:= Gmap.empty -let _ = +let _ = Summary.declare_summary "inh_graph" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; @@ -151,12 +151,12 @@ let subst_cl_typ subst ct = match ct with CL_SORT | CL_FUN | CL_SECVAR _ -> ct - | CL_CONST kn -> - let kn',t = subst_con subst kn in + | CL_CONST kn -> + let kn',t = subst_con subst kn in if kn' == kn then ct else fst (find_class_type (Global.env()) Evd.empty t) | CL_IND (kn,i) -> - let kn' = subst_kn subst kn in + let kn' = subst_kn subst kn in if kn' == kn then ct else CL_IND (kn',i) @@ -166,15 +166,15 @@ let subst_coe_typ subst t = fst (subst_global subst t) (* class_of : Term.constr -> int *) -let class_of env sigma t = - let (t, n1, i, args) = +let class_of env sigma t = + let (t, n1, i, args) = try let (cl,args) = find_class_type env sigma t in let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in - let (cl, args) = find_class_type env sigma t in + let (cl, args) = find_class_type env sigma t in let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, args) in @@ -218,7 +218,7 @@ let apply_on_class_of env sigma t cont = with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in - let (cl, args) = find_class_type env sigma t in + let (cl, args) = find_class_type env sigma t in let (i, { cl_param = n1 } ) = class_info cl in if List.length args <> n1 then raise Not_found; t, cont i @@ -233,7 +233,7 @@ let lookup_path_between env sigma (s,t) = let lookup_path_to_fun_from env sigma s = apply_on_class_of env sigma s lookup_path_to_fun_from_class -let lookup_path_to_sort_from env sigma s = +let lookup_path_to_sort_from env sigma s = apply_on_class_of env sigma s lookup_path_to_sort_from_class let get_coercion_constructor coe = @@ -241,7 +241,7 @@ let get_coercion_constructor coe = Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty coe.coe_value in match kind_of_term c with - | Construct cstr -> + | Construct cstr -> (cstr, Inductiveops.constructor_nrealargs (Global.env()) cstr -1) | _ -> raise Not_found @@ -263,14 +263,14 @@ let path_printer = ref (fun _ -> str "" : (int * int) * inheritance_path -> std_ppcmds) let install_path_printer f = path_printer := f - + let print_path x = !path_printer x -let message_ambig l = +let message_ambig l = (str"Ambiguous paths:" ++ spc () ++ prlist_with_sep pr_fnl (fun ijp -> print_path ijp) l) -(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit +(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) let different_class_params i j = @@ -281,7 +281,7 @@ let add_coercion_in_graph (ic,source,target) = let ambig_paths = (ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in let try_add_new_path (i,j as ij) p = - try + try if i=j then begin if different_class_params i j then begin let _ = lookup_path_between_class ij in @@ -297,26 +297,26 @@ let add_coercion_in_graph (ic,source,target) = true end in - let try_add_new_path1 ij p = - let _ = try_add_new_path ij p in () + let try_add_new_path1 ij p = + let _ = try_add_new_path ij p in () in if try_add_new_path (source,target) [ic] then begin - Gmap.iter + Gmap.iter (fun (s,t) p -> if s<>t then begin if t = source then begin try_add_new_path1 (s,target) (p@[ic]); Gmap.iter (fun (u,v) q -> - if u<>v & (u = target) & (p <> q) then + if u<>v & (u = target) & (p <> q) then try_add_new_path1 (s,v) (p@[ic]@q)) old_inheritance_graph end; if s = target then try_add_new_path1 (source,t) (ic::p) end) - old_inheritance_graph + old_inheritance_graph end; - if (!ambig_paths <> []) && is_verbose () then + if (!ambig_paths <> []) && is_verbose () then ppnl (message_ambig !ambig_paths) type coercion = coe_typ * locality * bool * cl_typ * cl_typ * int @@ -343,7 +343,7 @@ let load_coercion i (_,(coe,stre,isid,cls,clt,ps)) = add_class clt; let is,_ = class_info cls in let it,_ = class_info clt in - let xf = + let xf = { coe_value = constr_of_global coe; coe_type = Global.type_of_global coe; coe_strength = stre; @@ -368,7 +368,7 @@ let discharge_cl = function | cl -> cl let discharge_coercion (_,(coe,stre,isid,cls,clt,ps)) = - if stre = Local then None else + if stre = Local then None else let n = try Array.length (Lib.section_instance coe) with Not_found -> 0 in Some (Lib.discharge_global coe, stre, @@ -378,7 +378,7 @@ let discharge_coercion (_,(coe,stre,isid,cls,clt,ps)) = n + ps) let (inCoercion,_) = - declare_object {(default_object "COERCION") with + declare_object {(default_object "COERCION") with load_function = load_coercion; cache_function = cache_coercion; subst_function = subst_coercion; @@ -401,7 +401,7 @@ let inheritance_graph () = Gmap.to_list !inheritance_graph let coercion_of_reference r = let ref = Nametab.global r in if not (coercion_exists ref) then - errorlabstrm "try_add_coercion" + errorlabstrm "try_add_coercion" (Nametab.pr_global_env Idset.empty ref ++ str" is not a coercion."); ref diff --git a/pretyping/classops.mli b/pretyping/classops.mli index a5f139ab11..63d5b0a4e0 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -19,9 +19,9 @@ open Mod_subst (*i*) (*s This is the type of class kinds *) -type cl_typ = - | CL_SORT - | CL_FUN +type cl_typ = + | CL_SORT + | CL_FUN | CL_SECVAR of variable | CL_CONST of constant | CL_IND of inductive @@ -36,7 +36,7 @@ type cl_info_typ = { type coe_typ = Libnames.global_reference (* This is the type of infos for declared coercions *) -type coe_info_typ +type coe_info_typ (* [cl_index] is the type of class keys *) type cl_index @@ -65,7 +65,7 @@ val inductive_class_of : inductive -> cl_index val class_args_of : env -> evar_map -> types -> constr list (*s [declare_coercion] adds a coercion in the graph of coercion paths *) -val declare_coercion : +val declare_coercion : coe_typ -> locality -> isid:bool -> src:cl_typ -> target:cl_typ -> params:int -> unit @@ -77,18 +77,18 @@ val coercion_value : coe_index -> (unsafe_judgment * bool) (*s Lookup functions for coercion paths *) val lookup_path_between_class : cl_index * cl_index -> inheritance_path -val lookup_path_between : env -> evar_map -> types * types -> +val lookup_path_between : env -> evar_map -> types * types -> types * types * inheritance_path val lookup_path_to_fun_from : env -> evar_map -> types -> types * inheritance_path -val lookup_path_to_sort_from : env -> evar_map -> types -> +val lookup_path_to_sort_from : env -> evar_map -> types -> types * inheritance_path -val lookup_pattern_path_between : +val lookup_pattern_path_between : inductive * inductive -> (constructor * int) list (*i Crade *) open Pp -val install_path_printer : +val install_path_printer : ((cl_index * cl_index) * inheritance_path -> std_ppcmds) -> unit (*i*) diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml index 420cbe2900..4b5e40408d 100644 --- a/pretyping/clenv.ml +++ b/pretyping/clenv.ml @@ -46,7 +46,7 @@ type clausenv = { let cl_env ce = ce.env let cl_sigma ce = ce.evd -let subst_clenv sub clenv = +let subst_clenv sub clenv = { templval = map_fl (subst_mps sub) clenv.templval; templtyp = map_fl (subst_mps sub) clenv.templtyp; evd = subst_evar_defs_light sub clenv.evd; @@ -100,7 +100,7 @@ let clenv_environments evd bound t = (if dep then (subst1 (mkMeta mv) t2) else t2) | (n, LetIn (na,b,_,t)) -> clrec (e,metas) n (subst1 b t) | (n, _) -> (e, List.rev metas, t) - in + in clrec (evd,[]) bound t (* Instantiate the first [bound] products of [t] with evars (all products if @@ -118,7 +118,7 @@ let clenv_environments_evars env evd bound t = (if dep then (subst1 constr t2) else t2) | (n, LetIn (na,b,_,t)) -> clrec (e,ts) n (subst1 b t) | (n, _) -> (e, List.rev ts, t) - in + in clrec (evd,[]) bound t let clenv_conv_leq env sigma t c bound = @@ -144,7 +144,7 @@ let mk_clenv_from_n gls n (c,cty) = let mk_clenv_from gls = mk_clenv_from_n gls None -let mk_clenv_rename_from_n gls n (c,t) = +let mk_clenv_rename_from_n gls n (c,t) = mk_clenv_from_n gls n (c,rename_bound_var (pf_env gls) [] t) let mk_clenv_type_of gls t = mk_clenv_from gls (t,pf_type_of gls t) @@ -171,14 +171,14 @@ let error_incompatible_inst clenv mv = match na with Name id -> errorlabstrm "clenv_assign" - (str "An incompatible instantiation has already been found for " ++ + (str "An incompatible instantiation has already been found for " ++ pr_id id) | _ -> anomaly "clenv_assign: non dependent metavar already assigned" -(* TODO: replace by clenv_unify (mkMeta mv) rhs ? *) +(* TODO: replace by clenv_unify (mkMeta mv) rhs ? *) let clenv_assign mv rhs clenv = - let rhs_fls = mk_freelisted rhs in + let rhs_fls = mk_freelisted rhs in if meta_exists (mentions clenv mv) rhs_fls.freemetas then error "clenv_assign: circularity in unification"; try @@ -187,10 +187,10 @@ let clenv_assign mv rhs clenv = error_incompatible_inst clenv mv else clenv - else + else let st = (ConvUpToEta 0,TypeNotProcessed) in {clenv with evd = meta_assign mv (rhs_fls.rebus,st) clenv.evd} - with Not_found -> + with Not_found -> error "clenv_assign: undefined meta" @@ -216,7 +216,7 @@ let dependent_metas clenv mvs conclmetas = Metaset.union deps (clenv_metavars clenv.evd mv)) mvs conclmetas -let duplicated_metas c = +let duplicated_metas c = let rec collrec (one,more as acc) c = match kind_of_term c with | Meta mv -> if List.mem mv one then (one,mv::more) else (mv::one,more) @@ -259,7 +259,7 @@ let clenv_unique_resolver allow_K ?(flags=default_unify_flags) clenv gl = * For each dependent evar in the clause-env which does not have a value, * pose a value for it by constructing a fresh evar. We do this in * left-to-right order, so that every evar's type is always closed w.r.t. - * metas. + * metas. * Node added 14/4/08 [HH]: before this date, evars were collected in clenv_dependent by collect_metas in the fold_constr order which is @@ -271,7 +271,7 @@ let clenv_unique_resolver allow_K ?(flags=default_unify_flags) clenv gl = dependency order when a clenv_fchain occurs (because clenv_fchain plugs a term with a list of consecutive metas in place of a - a priori - arbitrary metavariable belonging to another sequence of consecutive metas: - e.g., clenv_fchain may plug (H ?1 ?2) at the position ?6 of + e.g., clenv_fchain may plug (H ?1 ?2) at the position ?6 of (nat_ind ?3 ?4 ?5 ?6), leading to a dependency order 3<4<5<1<2). To ensure the dependency order, we check that the type of each meta to pose is already meta-free, otherwise we postpone the transformation, @@ -285,13 +285,13 @@ let clenv_unique_resolver allow_K ?(flags=default_unify_flags) clenv gl = let clenv_pose_metas_as_evars clenv dep_mvs = let rec fold clenv = function | [] -> clenv - | mv::mvs -> + | mv::mvs -> let ty = clenv_meta_type clenv mv in (* Postpone the evar-ization if dependent on another meta *) (* This assumes no cycle in the dependencies - is it correct ? *) if occur_meta ty then fold clenv (mvs@[mv]) else - let (evd,evar) = + let (evd,evar) = new_evar clenv.evd (cl_env clenv) ~src:(dummy_loc,GoalEvar) ty in let clenv = clenv_assign mv evar {clenv with evd=evd} in fold clenv mvs in @@ -315,9 +315,9 @@ let connect_clenv gls clenv = * resolution can cause unification of already-existing metavars, and * of the fresh ones which get created. This operation is a composite * of operations which pose new metavars, perform unification on - * terms, and make bindings. + * terms, and make bindings. - Otherwise said, from + Otherwise said, from [clenv] = [env;sigma;metas |- c:T] [clenv'] = [env';sigma';metas' |- d:U] @@ -334,7 +334,7 @@ let clenv_fchain ?(allow_K=true) ?(flags=default_unify_flags) mv clenv nextclenv let clenv' = { templval = clenv.templval; templtyp = clenv.templtyp; - evd = + evd = evar_merge (meta_merge clenv.evd nextclenv.evd) clenv.evd; env = nextclenv.env } in (* unify the type of the template of [nextclenv] with the type of [mv] *) @@ -346,7 +346,7 @@ let clenv_fchain ?(allow_K=true) ?(flags=default_unify_flags) mv clenv nextclenv (* assign the metavar *) let clenv''' = clenv_assign mv (clenv_term clenv' nextclenv.templval) clenv'' - in + in clenv''' (***************************************************************) @@ -368,9 +368,9 @@ let clenv_independent clenv = let check_bindings bl = match list_duplicates (List.map pi2 bl) with - | NamedHyp s :: _ -> + | NamedHyp s :: _ -> errorlabstrm "" - (str "The variable " ++ pr_id s ++ + (str "The variable " ++ pr_id s ++ str " occurs more than once in binding list."); | AnonHyp n :: _ -> errorlabstrm "" @@ -433,7 +433,7 @@ let clenv_match_args bl clenv = let clenv_constrain_last_binding c clenv = let all_mvs = collect_metas clenv.templval.rebus in let k = - try list_last all_mvs + try list_last all_mvs with Failure _ -> anomaly "clenv_constrain_with_bindings" in clenv_assign_binding clenv k (Evd.empty,c) @@ -444,8 +444,8 @@ let clenv_constrain_dep_args hyps_only bl clenv = let occlist = clenv_dependent hyps_only clenv in if List.length occlist = List.length bl then List.fold_left2 clenv_assign_binding clenv occlist bl - else - errorlabstrm "" + else + errorlabstrm "" (strbrk "Not the right number of missing arguments (expected " ++ int (List.length occlist) ++ str ").") diff --git a/pretyping/clenv.mli b/pretyping/clenv.mli index dfa7513495..8e4dba5b5d 100644 --- a/pretyping/clenv.mli +++ b/pretyping/clenv.mli @@ -60,14 +60,14 @@ val mk_clenv_from_env : env -> evar_map -> int option -> constr * types -> claus (* linking of clenvs *) val connect_clenv : evar_info sigma -> clausenv -> clausenv -val clenv_fchain : +val clenv_fchain : ?allow_K:bool -> ?flags:unify_flags -> metavariable -> clausenv -> clausenv -> clausenv (***************************************************************) (* Unification with clenvs *) (* Unifies two terms in a clenv. The boolean is [allow_K] (see [Unification]) *) -val clenv_unify : +val clenv_unify : bool -> ?flags:unify_flags -> conv_pb -> constr -> constr -> clausenv -> clausenv (* unifies the concl of the goal with the type of the clenv *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index ee4306b7dc..586ad716d6 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -24,13 +24,13 @@ open Termops module type S = sig (*s Coercions. *) - + (* [inh_app_fun env evd j] coerces [j] to a function; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type a product; it returns [j] if no coercion is applicable *) val inh_app_fun : env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment - + (* [inh_coerce_to_sort env evd j] coerces [j] to a type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type a sort; it fails if no coercion is applicable *) @@ -42,24 +42,24 @@ module type S = sig type its base type (the notion depends on the coercion system) *) val inh_coerce_to_base : loc -> env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment - + (* [inh_coerce_to_prod env evars t] coerces [t] to a product type *) val inh_coerce_to_prod : loc -> env -> evar_defs -> type_constraint_type -> evar_defs * type_constraint_type - (* [inh_conv_coerce_to loc env evd j t] coerces [j] to an object of type + (* [inh_conv_coerce_to loc env evd j t] coerces [j] to an object of type [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and [j.uj_type] are convertible; it fails if no coercion is applicable *) - val inh_conv_coerce_to : loc -> + val inh_conv_coerce_to : loc -> env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment - val inh_conv_coerce_rigid_to : loc -> + val inh_conv_coerce_rigid_to : loc -> env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment (* [inh_conv_coerces_to loc env evd t t'] checks if an object of type [t] is coercible to an object of type [t'] adding evar constraints if needed; it fails if no coercion exists *) - val inh_conv_coerces_to : loc -> + val inh_conv_coerces_to : loc -> env -> evar_defs -> types -> type_constraint_type -> evar_defs (* [inh_pattern_coerce_to loc env evd pat ind1 ind2] coerces the Cases @@ -81,11 +81,11 @@ module Default = struct | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) match kind_of_term (whd_betadeltaiota env Evd.empty typ) with - | Prod (_,c1,c2) -> + | Prod (_,c1,c2) -> (* Typage garanti par l'appel à app_coercion*) apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly "apply_coercion_args" - in + in apply_rec [] funj.uj_type argl (* appliquer le chemin de coercions de patterns p *) @@ -107,21 +107,21 @@ module Default = struct (* appliquer le chemin de coercions p à hj *) let apply_coercion env sigma p hj typ_cl = - try + try fst (List.fold_left - (fun (ja,typ_cl) i -> + (fun (ja,typ_cl) i -> let fv,isid = coercion_value i in let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in let jres = apply_coercion_args env argl fv in - (if isid then + (if isid then { uj_val = ja.uj_val; uj_type = jres.uj_type } - else + else jres), jres.uj_type) (hj,typ_cl) p) with _ -> anomaly "apply_coercion" - let inh_app_fun env evd j = + let inh_app_fun env evd j = let t = whd_betadeltaiota env evd j.uj_type in match kind_of_term t with | Prod (_,_,_) -> (evd,j) @@ -132,7 +132,7 @@ module Default = struct let t,p = lookup_path_to_fun_from env ( evd) j.uj_type in (evd,apply_coercion env ( evd) p j t) - + let inh_app_fun env evd j = try inh_app_fun env evd j with Not_found -> @@ -142,7 +142,7 @@ module Default = struct let inh_tosort_force loc env evd j = try let t,p = lookup_path_to_sort_from env ( evd) j.uj_type in - let j1 = apply_coercion env ( evd) p j t in + let j1 = apply_coercion env ( evd) p j t in let j2 = on_judgment_type (whd_evar ( evd)) j1 in (evd,type_judgment env j2) with Not_found -> @@ -167,16 +167,16 @@ module Default = struct raise NoCoercion else let v', t' = - try + try let t2,t1,p = lookup_path_between env evd (t,c1) in match v with - Some v -> + Some v -> let j = apply_coercion env evd p {uj_val = v; uj_type = t} t2 in Some j.uj_val, j.uj_type | None -> None, t - with Not_found -> raise NoCoercion + with Not_found -> raise NoCoercion in try (the_conv_x_leq env t' c1 evd, v') with Reduction.NotConvertible -> raise NoCoercion @@ -190,12 +190,12 @@ module Default = struct kind_of_term (whd_betadeltaiota env evd t), kind_of_term (whd_betadeltaiota env evd c1) with - | Prod (name,t1,t2), Prod (_,u1,u2) -> + | Prod (name,t1,t2), Prod (_,u1,u2) -> (* Conversion did not work, we may succeed with a coercion. *) (* We eta-expand (hence possibly modifying the original term!) *) (* and look for a coercion c:u1->t1 s.t. fun x:u1 => v' (c x)) *) (* has type forall (x:u1), u2 (with v' recursively obtained) *) - let name = match name with + let name = match name with | Anonymous -> Name (id_of_string "x") | _ -> name in let env1 = push_rel (name,None,u1) env in @@ -213,8 +213,8 @@ module Default = struct let inh_conv_coerce_to_gen rigidonly loc env evd cj (n, t) = match n with None -> - let (evd', val') = - try + let (evd', val') = + try inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercion -> let evd = saturate_evd env evd in @@ -230,19 +230,19 @@ module Default = struct let inh_conv_coerce_to = inh_conv_coerce_to_gen false let inh_conv_coerce_rigid_to = inh_conv_coerce_to_gen true - + let inh_conv_coerces_to loc env (evd : evar_defs) t (abs, t') = evd - (* Still problematic, as it changes unification - let nabsinit, nabs = + (* Still problematic, as it changes unification + let nabsinit, nabs = match abs with None -> 0, 0 | Some (init, cur) -> init, cur in - try - let (rels, rng) = - (* a little more effort to get products is needed *) + try + let (rels, rng) = + (* a little more effort to get products is needed *) try decompose_prod_n nabs t - with _ -> + with _ -> if !Flags.debug then msg_warning (str "decompose_prod_n failed"); raise (Invalid_argument "Coercion.inh_conv_coerces_to") @@ -250,11 +250,11 @@ module Default = struct (* The final range free variables must have been replaced by evars, we accept only that evars in rng are applied to free vars. *) if noccur_with_meta 0 (succ nabsinit) rng then ( - let env', t, t' = + let env', t, t' = let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in env', rng, lift nabs t' in - try + try pi1 (inh_conv_coerce_to_fail loc env' evd None t t') with NoCoercion -> evd) (* Maybe not enough information to unify *) diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index ff33d679df..0329cc07c5 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -21,13 +21,13 @@ open Rawterm module type S = sig (*s Coercions. *) - + (* [inh_app_fun env isevars j] coerces [j] to a function; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type a product; it returns [j] if no coercion is applicable *) val inh_app_fun : env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment - + (* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it inserts a coercion into [j], if needed, in such a way it gets as type a sort; it fails if no coercion is applicable *) @@ -43,22 +43,22 @@ module type S = sig (* [inh_coerce_to_prod env isevars t] coerces [t] to a product type *) val inh_coerce_to_prod : loc -> env -> evar_defs -> type_constraint_type -> evar_defs * type_constraint_type - - (* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type + + (* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and [j.uj_type] are convertible; it fails if no coercion is applicable *) - val inh_conv_coerce_to : loc -> + val inh_conv_coerce_to : loc -> env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment - val inh_conv_coerce_rigid_to : loc -> + val inh_conv_coerce_rigid_to : loc -> env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment - + (* [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t] is coercible to an object of type [t'] adding evar constraints if needed; it fails if no coercion exists *) - val inh_conv_coerces_to : loc -> + val inh_conv_coerces_to : loc -> env -> evar_defs -> types -> type_constraint_type -> evar_defs - + (* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; raises [Not_found] if no coercion found *) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 2c3de28a5f..f9c872f9ed 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -60,7 +60,7 @@ let encode_tuple r = x module PrintingCasesMake = - functor (Test : sig + functor (Test : sig val encode : reference -> inductive * int array val member_message : std_ppcmds -> bool -> std_ppcmds val field : string @@ -81,22 +81,22 @@ module PrintingCasesMake = end module PrintingCasesIf = - PrintingCasesMake (struct + PrintingCasesMake (struct let encode = encode_bool let field = "If" let title = "Types leading to pretty-printing of Cases using a `if' form: " let member_message s b = - str "Cases on elements of " ++ s ++ + str "Cases on elements of " ++ s ++ str (if b then " are printed using a `if' form" else " are not printed using a `if' form") end) module PrintingCasesLet = - PrintingCasesMake (struct + PrintingCasesMake (struct let encode = encode_tuple let field = "Let" - let title = + let title = "Types leading to a pretty-printing of Cases using a `let' form:" let member_message s b = str "Cases on elements of " ++ s ++ @@ -115,7 +115,7 @@ open Goptions let wildcard_value = ref true let force_wildcard () = !wildcard_value -let _ = declare_bool_option +let _ = declare_bool_option { optsync = true; optname = "forced wildcard"; optkey = ["Printing";"Wildcard"]; @@ -125,7 +125,7 @@ let _ = declare_bool_option let synth_type_value = ref true let synthetize_type () = !synth_type_value -let _ = declare_bool_option +let _ = declare_bool_option { optsync = true; optname = "pattern matching return type synthesizability"; optkey = ["Printing";"Synth"]; @@ -135,7 +135,7 @@ let _ = declare_bool_option let reverse_matching_value = ref true let reverse_matching () = !reverse_matching_value -let _ = declare_bool_option +let _ = declare_bool_option { optsync = true; optname = "pattern-matching reversibility"; optkey = ["Printing";"Matching"]; @@ -164,23 +164,23 @@ let computable p k = (nb_lam p = k+1) && - let _,ccl = decompose_lam p in + let _,ccl = decompose_lam p in noccur_between 1 (k+1) ccl let avoid_flag isgoal = if isgoal then Some true else None - + let lookup_name_as_renamed env t s = let rec lookup avoid env_names n c = match kind_of_term c with | Prod (name,_,c') -> (match concrete_name (Some true) avoid env_names name c' with - | (Name id,avoid') -> - if id=s then (Some n) + | (Name id,avoid') -> + if id=s then (Some n) else lookup avoid' (add_name (Name id) env_names) (n+1) c' | (Anonymous,avoid') -> lookup avoid' env_names (n+1) (pop c')) | LetIn (name,_,_,c') -> (match concrete_name (Some true) avoid env_names name c' with - | (Name id,avoid') -> - if id=s then (Some n) + | (Name id,avoid') -> + if id=s then (Some n) else lookup avoid' (add_name (Name id) env_names) (n+1) c' | (Anonymous,avoid') -> lookup avoid' env_names (n+1) (pop c')) | Cast (c,_,_) -> lookup avoid env_names n c @@ -192,22 +192,22 @@ let lookup_index_as_renamed env t n = | Prod (name,_,c') -> (match concrete_name (Some true) [] empty_names_context name c' with (Name _,_) -> lookup n (d+1) c' - | (Anonymous,_) -> + | (Anonymous,_) -> if n=0 then Some (d-1) - else if n=1 then - Some d - else + else if n=1 then + Some d + else lookup (n-1) (d+1) c') | LetIn (name,_,_,c') -> (match concrete_name (Some true) [] empty_names_context name c' with | (Name _,_) -> lookup n (d+1) c' - | (Anonymous,_) -> - if n=0 then - Some (d-1) - else if n=1 then - Some d - else + | (Anonymous,_) -> + if n=0 then + Some (d-1) + else if n=1 then + Some d + else lookup (n-1) (d+1) c' ) | Cast (c,_,_) -> lookup n d c @@ -231,8 +231,8 @@ let rec decomp_branch n nal b (avoid,env as e) c = match kind_of_term (strip_outer_cast c) with | Lambda (na,_,c) -> na,c,concrete_let_name | LetIn (na,_,_,c) -> na,c,concrete_name - | _ -> - Name (id_of_string "x"),(applist (lift 1 c, [mkRel 1])), + | _ -> + Name (id_of_string "x"),(applist (lift 1 c, [mkRel 1])), concrete_name in let na',avoid' = f (Some b) avoid env na c in decomp_branch (n-1) (na'::nal) b (avoid',add_name na' env) c @@ -248,14 +248,14 @@ and align_tree nal isgoal (e,c as rhs) = match nal with | [] -> [[],rhs] | na::nal -> match kind_of_term c with - | Case (ci,p,c,cl) when c = mkRel (list_index na (snd e)) + | Case (ci,p,c,cl) when c = mkRel (list_index na (snd e)) & (* don't contract if p dependent *) computable p (ci.ci_pp_info.ind_nargs) -> let clauses = build_tree na isgoal e ci cl in List.flatten (List.map (fun (pat,rhs) -> let lines = align_tree nal isgoal rhs in - List.map (fun (hd,rest) -> pat::hd,rest) lines) + List.map (fun (hd,rest) -> pat::hd,rest) lines) clauses) | _ -> let pat = PatVar(dl,update_name na rhs) in @@ -299,9 +299,9 @@ let it_destRLambda_or_LetIn_names n c = (* if occur_rawconstr x c then next (x::l) else x in *) x in - let x = next (free_rawvars c) in + let x = next (free_rawvars c) in let a = RVar (dl,x) in - aux (n-1) (Name x :: nal) + aux (n-1) (Name x :: nal) (match c with | RApp (loc,p,l) -> RApp (loc,c,l@[a]) | _ -> (RApp (dl,c,[a]))) @@ -311,16 +311,16 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = let (indsp,st,nparams,consnargsl,k) = data in let synth_type = synthetize_type () in let tomatch = detype c in - let alias, aliastyp, pred= - if (not !Flags.raw_print) & synth_type & computable & Array.length bl<>0 - then + let alias, aliastyp, pred= + if (not !Flags.raw_print) & synth_type & computable & Array.length bl<>0 + then Anonymous, None, None else match Option.map detype p with | None -> Anonymous, None, None | Some p -> let nl,typ = it_destRLambda_or_LetIn_names k p in - let n,typ = match typ with + let n,typ = match typ with | RLambda (_,x,_,t,c) -> x, c | _ -> Anonymous, typ in let aliastyp = @@ -331,21 +331,21 @@ let detype_case computable detype detype_eqns testdep avoid data p c bl = let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in let eqnl = detype_eqns constructs consnargsl bl in let tag = - try + try if !Flags.raw_print then RegularStyle - else if st = LetPatternStyle then + else if st = LetPatternStyle then st else if PrintingLet.active (indsp,consnargsl) then LetStyle - else if PrintingIf.active (indsp,consnargsl) then + else if PrintingIf.active (indsp,consnargsl) then IfStyle - else + else st with Not_found -> st in match tag with - | LetStyle when aliastyp = None -> + | LetStyle when aliastyp = None -> let bl' = Array.map detype bl in let (nal,d) = it_destRLambda_or_LetIn_names consnargsl.(0) bl'.(0) in RLetTuple (dl,nal,(alias,pred),tomatch,d) @@ -399,7 +399,7 @@ let rec detype (isgoal:bool) avoid env t = array_map_to_list (detype isgoal avoid env) args) | Const sp -> RRef (dl, ConstRef sp) | Evar (ev,cl) -> - REvar (dl, ev, + REvar (dl, ev, Some (List.map (detype isgoal avoid env) (Array.to_list cl))) | Ind ind_sp -> RRef (dl, IndRef ind_sp) @@ -409,7 +409,7 @@ let rec detype (isgoal:bool) avoid env t = let comp = computable p (ci.ci_pp_info.ind_nargs) in detype_case comp (detype isgoal avoid env) (detype_eqns isgoal avoid env ci comp) - is_nondep_branch avoid + is_nondep_branch avoid (ci.ci_ind,ci.ci_pp_info.style,ci.ci_npar, ci.ci_cstr_nargs,ci.ci_pp_info.ind_nargs) (Some p) c bl @@ -420,7 +420,7 @@ and detype_fix isgoal avoid env (vn,_ as nvn) (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left (fun (avoid, env, l) na -> - let id = next_name_away na avoid in + let id = next_name_away na avoid in (id::avoid, add_name (Name id) env, id::l)) (avoid, env, []) names in let n = Array.length tys in @@ -436,7 +436,7 @@ and detype_cofix isgoal avoid env n (names,tys,bodies) = let def_avoid, def_env, lfi = Array.fold_left (fun (avoid, env, l) na -> - let id = next_name_away na avoid in + let id = next_name_away na avoid in (id::avoid, add_name (Name id) env, id::l)) (avoid, env, []) names in let ntys = Array.length tys in @@ -455,16 +455,16 @@ and share_names isgoal n l avoid env c t = let na = match (na,na') with Name _, _ -> na | _, Name _ -> na' - | _ -> na in + | _ -> na in let t = detype isgoal avoid env t in - let id = next_name_away na avoid in + let id = next_name_away na avoid in let avoid = id::avoid and env = add_name (Name id) env in share_names isgoal (n-1) ((Name id,Explicit,None,t)::l) avoid env c c' (* May occur for fix built interactively *) | LetIn (na,b,t',c), _ when n > 0 -> let t' = detype isgoal avoid env t' in let b = detype isgoal avoid env b in - let id = next_name_away na avoid in + let id = next_name_away na avoid in let avoid = id::avoid and env = add_name (Name id) env in share_names isgoal n ((Name id,Explicit,Some b,t')::l) avoid env c t (* Only if built with the f/n notation or w/o let-expansion in types *) @@ -473,7 +473,7 @@ and share_names isgoal n l avoid env c t = (* If it is an open proof: we cheat and eta-expand *) | _, Prod (na',t',c') when n > 0 -> let t' = detype isgoal avoid env t' in - let id = next_name_away na' avoid in + let id = next_name_away na' avoid in let avoid = id::avoid and env = add_name (Name id) env in let appc = mkApp (lift 1 c,[|mkRel 1|]) in share_names isgoal (n-1) ((Name id,Explicit,None,t')::l) avoid env appc c' @@ -498,22 +498,22 @@ and detype_eqn isgoal avoid env constr construct_nargs branch = let make_pat x avoid env b ids = if force_wildcard () & noccurn 1 b then PatVar (dl,Anonymous),avoid,(add_name Anonymous env),ids - else + else let id = next_name_away_in_cases_pattern x avoid in PatVar (dl,Name id),id::avoid,(add_name (Name id) env),id::ids in let rec buildrec ids patlist avoid env n b = if n=0 then - (dl, ids, + (dl, ids, [PatCstr(dl, constr, List.rev patlist,Anonymous)], detype isgoal avoid env b) else match kind_of_term b with - | Lambda (x,_,b) -> + | Lambda (x,_,b) -> let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b - | LetIn (x,_,_,b) -> + | LetIn (x,_,_,b) -> let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b @@ -527,8 +527,8 @@ and detype_eqn isgoal avoid env constr construct_nargs branch = let pat,new_avoid,new_env,new_ids = make_pat Anonymous avoid env new_b ids in buildrec new_ids (pat::patlist) new_avoid new_env (n-1) new_b - - in + + in buildrec [] [] avoid env construct_nargs branch and detype_binder isgoal bk avoid env na ty c = @@ -562,19 +562,19 @@ let rec detype_rel_context where avoid env sign = (**********************************************************************) (* Module substitution: relies on detyping *) -let rec subst_cases_pattern subst pat = +let rec subst_cases_pattern subst pat = match pat with | PatVar _ -> pat - | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_kn subst kn + | PatCstr (loc,((kn,i),j),cpl,n) -> + let kn' = subst_kn subst kn and cpl' = list_smartmap (subst_cases_pattern subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) -let rec subst_rawconstr subst raw = +let rec subst_rawconstr subst raw = match raw with - | RRef (loc,ref) -> - let ref',t = subst_global subst ref in + | RRef (loc,ref) -> + let ref',t = subst_global subst ref in if ref' == ref then raw else detype false [] [] t @@ -582,38 +582,38 @@ let rec subst_rawconstr subst raw = | REvar _ -> raw | RPatVar _ -> raw - | RApp (loc,r,rl) -> - let r' = subst_rawconstr subst r + | RApp (loc,r,rl) -> + let r' = subst_rawconstr subst r and rl' = list_smartmap (subst_rawconstr subst) rl in if r' == r && rl' == rl then raw else RApp(loc,r',rl') - | RLambda (loc,n,bk,r1,r2) -> + | RLambda (loc,n,bk,r1,r2) -> let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in if r1' == r1 && r2' == r2 then raw else RLambda (loc,n,bk,r1',r2') - | RProd (loc,n,bk,r1,r2) -> + | RProd (loc,n,bk,r1,r2) -> let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in if r1' == r1 && r2' == r2 then raw else RProd (loc,n,bk,r1',r2') - | RLetIn (loc,n,r1,r2) -> + | RLetIn (loc,n,r1,r2) -> let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in if r1' == r1 && r2' == r2 then raw else RLetIn (loc,n,r1',r2') - | RCases (loc,sty,rtno,rl,branches) -> + | RCases (loc,sty,rtno,rl,branches) -> let rtno' = Option.smartmap (subst_rawconstr subst) rtno and rl' = list_smartmap (fun (a,x as y) -> let a' = subst_rawconstr subst a in - let (n,topt) = x in + let (n,topt) = x in let topt' = Option.smartmap (fun (loc,(sp,i),x,y as t) -> let sp' = subst_kn subst sp in if sp == sp' then t else (loc,(sp',i),x,y)) topt in if a == a' && topt == topt' then y else (a',(n,topt'))) rl - and branches' = list_smartmap + and branches' = list_smartmap (fun (loc,idl,cpl,r as branch) -> let cpl' = list_smartmap (subst_cases_pattern subst) cpl @@ -627,20 +627,20 @@ let rec subst_rawconstr subst raw = | RLetTuple (loc,nal,(na,po),b,c) -> let po' = Option.smartmap (subst_rawconstr subst) po - and b' = subst_rawconstr subst b + and b' = subst_rawconstr subst b and c' = subst_rawconstr subst c in if po' == po && b' == b && c' == c then raw else RLetTuple (loc,nal,(na,po'),b',c') - + | RIf (loc,c,(na,po),b1,b2) -> let po' = Option.smartmap (subst_rawconstr subst) po - and b1' = subst_rawconstr subst b1 - and b2' = subst_rawconstr subst b2 + and b1' = subst_rawconstr subst b1 + and b2' = subst_rawconstr subst b2 and c' = subst_rawconstr subst c in if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else RIf (loc,c',(na,po'),b1',b2') - | RRec (loc,fix,ida,bl,ra1,ra2) -> + | RRec (loc,fix,ida,bl,ra1,ra2) -> let ra1' = array_smartmap (subst_rawconstr subst) ra1 and ra2' = array_smartmap (subst_rawconstr subst) ra2 in let bl' = array_smartmap @@ -655,19 +655,19 @@ let rec subst_rawconstr subst raw = | RSort _ -> raw | RHole (loc,ImplicitArg (ref,i,b)) -> - let ref',_ = subst_global subst ref in + let ref',_ = subst_global subst ref in if ref' == ref then raw else RHole (loc,InternalHole) | RHole (loc, (BinderType _ | QuestionMark _ | CasesType | InternalHole | TomatchTypeParameter _ | GoalEvar | ImpossibleCase)) -> raw - | RCast (loc,r1,k) -> - (match k with + | RCast (loc,r1,k) -> + (match k with CastConv (k,r2) -> let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in if r1' == r1 && r2' == r2 then raw else RCast (loc,r1', CastConv (k,r2')) - | CastCoerce -> + | CastCoerce -> let r1' = subst_rawconstr subst r1 in if r1' == r1 then raw else RCast (loc,r1',k)) | RDynamic _ -> raw diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 72379dfcfa..d1e0d10494 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -30,9 +30,9 @@ val subst_rawconstr : substitution -> rawconstr -> rawconstr val detype : bool -> identifier list -> names_context -> constr -> rawconstr -val detype_case : +val detype_case : bool -> ('a -> rawconstr) -> - (constructor array -> int array -> 'a array -> + (constructor array -> int array -> 'a array -> (loc * identifier list * cases_pattern list * rawconstr) list) -> ('a -> int -> bool) -> identifier list -> inductive * case_style * int * int array * int -> @@ -54,7 +54,7 @@ val synthetize_type : unit -> bool (* Utilities to transform kernel cases to simple pattern-matching problem *) val it_destRLambda_or_LetIn_names : int -> rawconstr -> name list * rawconstr -val simple_cases_matrix_of_branches : +val simple_cases_matrix_of_branches : inductive -> int list -> rawconstr list -> cases_clauses val return_type_of_predicate : inductive -> int -> int -> rawconstr -> predicate_pattern * rawconstr option diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index f197f7a9a7..b6e697e4de 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -19,13 +19,13 @@ open Termops open Environ open Typing open Classops -open Recordops +open Recordops open Evarutil open Libnames open Evd type flex_kind_of_term = - | Rigid of constr + | Rigid of constr | MaybeFlexible of constr | Flexible of existential @@ -93,31 +93,31 @@ let position_problem l2r = function let check_conv_record (t1,l1) (t2,l2) = try let proji = global_of_constr t1 in - let canon_s,l2_effective = + let canon_s,l2_effective = try match kind_of_term t2 with Prod (_,a,b) -> (* assert (l2=[]); *) if dependent (mkRel 1) b then raise Not_found else lookup_canonical_conversion (proji, Prod_cs),[a;pop b] - | Sort s -> - lookup_canonical_conversion + | Sort s -> + lookup_canonical_conversion (proji, Sort_cs (family_of_sort s)),[] - | _ -> + | _ -> let c2 = global_of_constr t2 in lookup_canonical_conversion (proji, Const_cs c2),l2 - with Not_found -> + with Not_found -> lookup_canonical_conversion (proji,Default_cs),[] in - let { o_DEF = c; o_INJ=n; o_TABS = bs; + let { o_DEF = c; o_INJ=n; o_TABS = bs; o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in let params1, c1, extra_args1 = - match list_chop nparams l1 with + match list_chop nparams l1 with | params1, c1::extra_args1 -> params1, c1, extra_args1 | _ -> raise Not_found in let us2,extra_args2 = list_chop (List.length us) l2_effective in c,bs,(params,params1),(us,us2),(extra_args1,extra_args2),c1, (n,applist(t2,l2)) - with Failure _ | Not_found -> + with Failure _ | Not_found -> raise Not_found (* Precondition: one of the terms of the pb is an uninstantiated evar, @@ -156,12 +156,12 @@ let ise_array2 evd f v1 v2 = | n -> let (i',b) = f i v1.(n) v2.(n) in if b then allrec i' (n-1) else (evd,false) - in + in let lv1 = Array.length v1 in - if lv1 = Array.length v2 then allrec evd (pred lv1) + if lv1 = Array.length v2 then allrec evd (pred lv1) else (evd,false) -let rec evar_conv_x env evd pbty term1 term2 = +let rec evar_conv_x env evd pbty term1 term2 = let sigma = evd in let term1 = whd_castappevar sigma term1 in let term2 = whd_castappevar sigma term2 in @@ -195,7 +195,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = match (flex_kind_of_term term1 l1, flex_kind_of_term term2 l2) with | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) -> let f1 i = - if List.length l1 > List.length l2 then + if List.length l1 > List.length l2 then let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in ise_and i [(fun i -> solve_simple_eqn evar_conv_x env i @@ -212,18 +212,18 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = and f2 i = if sp1 = sp2 then ise_and i - [(fun i -> ise_list2 i + [(fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) l1 l2); (fun i -> solve_refl evar_conv_x env i sp1 al1 al2, true)] else (i,false) - in + in ise_try evd [f1; f2] | Flexible ev1, MaybeFlexible flex2 -> let f1 i = - if - is_unification_pattern_evar env ev1 l1 (applist appr2) & + if + is_unification_pattern_evar env ev1 l1 (applist appr2) & not (occur_evar (fst ev1) (applist appr2)) then (* Miller-Pfenning's patterns unification *) @@ -250,13 +250,13 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | Some v2 -> evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2) | None -> (i,false) - in + in ise_try evd [f1; f4] | MaybeFlexible flex1, Flexible ev2 -> let f1 i = - if - is_unification_pattern_evar env ev2 l2 (applist appr1) & + if + is_unification_pattern_evar env ev2 l2 (applist appr1) & not (occur_evar (fst ev2) (applist appr1)) then (* Miller-Pfenning's patterns unification *) @@ -282,7 +282,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | Some v1 -> evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2 | None -> (i,false) - in + in ise_try evd [f1; f4] | MaybeFlexible flex1, MaybeFlexible flex2 -> @@ -320,12 +320,12 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | Some v1 -> evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2 | None -> (i,false) - in + in ise_try evd [f1; f2; f3] | Flexible ev1, Rigid _ -> - if - is_unification_pattern_evar env ev1 l1 (applist appr2) & + if + is_unification_pattern_evar env ev1 l1 (applist appr2) & not (occur_evar (fst ev1) (applist appr2)) then (* Miller-Pfenning's patterns unification *) @@ -340,8 +340,8 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = true | Rigid _, Flexible ev2 -> - if - is_unification_pattern_evar env ev2 l2 (applist appr1) & + if + is_unification_pattern_evar env ev2 l2 (applist appr1) & not (occur_evar (fst ev2) (applist appr1)) then (* Miller-Pfenning's patterns unification *) @@ -364,11 +364,11 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | Some v1 -> evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2 | None -> (i,false) - in + in ise_try evd [f3; f4] - - | Rigid _ , MaybeFlexible flex2 -> - let f3 i = + + | Rigid _ , MaybeFlexible flex2 -> + let f3 i = (try conv_record env i (check_conv_record appr2 appr1) with Not_found -> (i,false)) and f4 i = @@ -376,11 +376,11 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | Some v2 -> evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2) | None -> (i,false) - in + in ise_try evd [f3; f4] | Rigid c1, Rigid c2 -> match kind_of_term c1, kind_of_term c2 with - + | Cast (c1,_,_), _ -> evar_eqappr_x env evd pbty (c1,l1) appr2 | _, Cast (c2,_,_) -> evar_eqappr_x env evd pbty appr1 (c2,l2) @@ -388,7 +388,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | Sort s1, Sort s2 when l1=[] & l2=[] -> (evd,base_sort_cmp pbty s1 s2) - | Lambda (na,c1,c'1), Lambda (_,c2,c'2) when l1=[] & l2=[] -> + | Lambda (na,c1,c'1), Lambda (_,c2,c'2) when l1=[] & l2=[] -> ise_and evd [(fun i -> evar_conv_x env i CONV c1 c2); (fun i -> @@ -409,7 +409,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = let appr1 = evar_apprec env i l1 (subst1 b1 c'1) and appr2 = evar_apprec env i l2 (subst1 b2 c'2) in evar_eqappr_x env i pbty appr1 appr2 - in + in ise_try evd [f1; f2] | LetIn (_,b1,_,c'1), _ ->(* On fait commuter les args avec le Let *) @@ -420,7 +420,7 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = let appr2 = evar_apprec env evd l2 (subst1 b2 c'2) in evar_eqappr_x env evd pbty appr1 appr2 - | Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> + | Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] -> ise_and evd [(fun i -> evar_conv_x env i CONV c1 c2); (fun i -> @@ -474,13 +474,13 @@ and evar_eqappr_x env evd pbty (term1,l1 as appr1) (term2,l2 as appr2) = | (Ind _ | Construct _ | Sort _ | Prod _), _ -> (evd,false) | _, (Ind _ | Construct _ | Sort _ | Prod _) -> (evd,false) - | (App _ | Case _ | Fix _ | CoFix _), + | (App _ | Case _ | Fix _ | CoFix _), (App _ | Case _ | Fix _ | CoFix _) -> (evd,false) | (Rel _ | Var _ | Const _ | Evar _), _ -> assert false | _, (Rel _ | Var _ | Const _ | Evar _) -> assert false -and conv_record env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = +and conv_record env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = let (evd',ks,_) = List.fold_left (fun (i,ks,m) b -> @@ -535,7 +535,7 @@ let apply_conversion_problem_heuristic env evd pbty t1 t2 = (* The typical kind of constraint coming from pattern-matching return type inference *) choose_less_dependent_instance evk1 evd term2 args1, true - | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = [] + | (Rel _|Var _), Evar (evk2,args2) when l1 = [] & l2 = [] & array_for_all (fun a -> a = term1 or isEvar a) args2 -> (* The typical kind of constraint coming from pattern-matching return type inference *) @@ -569,7 +569,7 @@ let the_conv_x_leq env t1 t2 evd = match evar_conv_x env evd CUMUL t1 t2 with (evd', true) -> evd' | _ -> raise Reduction.NotConvertible - + let e_conv env evd t1 t2 = match evar_conv_x env !evd CONV t1 t2 with (evd',true) -> evd := evd'; true diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index a281a3898f..a85f0f7395 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -20,7 +20,7 @@ open Evd val the_conv_x : env -> constr -> constr -> evar_defs -> evar_defs val the_conv_x_leq : env -> constr -> constr -> evar_defs -> evar_defs -(* The same function resolving evars by side-effect and +(* The same function resolving evars by side-effect and catching the exception *) val e_conv : env -> evar_defs ref -> constr -> constr -> bool val e_cumul : env -> evar_defs ref -> constr -> constr -> bool @@ -28,7 +28,7 @@ val e_cumul : env -> evar_defs ref -> constr -> constr -> bool (*i For debugging *) val evar_conv_x : env -> evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool -val evar_eqappr_x : +val evar_eqappr_x : env -> evar_defs -> conv_pb -> constr * constr list -> constr * constr list -> evar_defs * bool @@ -39,5 +39,5 @@ val consider_remaining_unif_problems : env -> evar_defs -> evar_defs * bool val check_conv_record : constr * types list -> constr * types list -> constr * constr list * (constr list * constr list) * (constr list * types list) * - (constr list * types list) * constr * + (constr list * types list) * constr * (int * constr) diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 451860477a..8d19feea4e 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -38,7 +38,7 @@ let rec whd_ise sigma c = (* Expand evars, possibly in the head of an application *) -let whd_castappevar_stack sigma c = +let whd_castappevar_stack sigma c = let rec whrec (c, l as s) = match kind_of_term c with | Evar (evk,args as ev) when Evd.mem sigma evk & Evd.is_defined sigma evk @@ -46,7 +46,7 @@ let whd_castappevar_stack sigma c = | Cast (c,_,_) -> whrec (c, l) | App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l) | _ -> s - in + in whrec (c, []) let whd_castappevar sigma c = applist (whd_castappevar_stack sigma c) @@ -57,19 +57,19 @@ let jl_nf_evar = Pretype_errors.jl_nf_evar let jv_nf_evar = Pretype_errors.jv_nf_evar let tj_nf_evar = Pretype_errors.tj_nf_evar -let nf_named_context_evar sigma ctx = +let nf_named_context_evar sigma ctx = Sign.map_named_context (Reductionops.nf_evar sigma) ctx -let nf_rel_context_evar sigma ctx = +let nf_rel_context_evar sigma ctx = Sign.map_rel_context (Reductionops.nf_evar sigma) ctx - -let nf_env_evar sigma env = + +let nf_env_evar sigma env = let nc' = nf_named_context_evar sigma (Environ.named_context env) in let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env) let nf_evar_info evc info = - { info with + { info with evar_concl = Reductionops.nf_evar evc info.evar_concl; evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps; evar_body = match info.evar_body with @@ -110,13 +110,13 @@ let collect_evars emap c = let push_dependent_evars sigma emap = Evd.fold (fun ev {evar_concl = ccl} (sigma',emap') -> - List.fold_left - (fun (sigma',emap') ev -> + List.fold_left + (fun (sigma',emap') ev -> (Evd.add sigma' ev (Evd.find emap' ev),Evd.remove emap' ev)) (sigma',emap') (collect_evars emap' ccl)) emap (sigma,emap) -let push_duplicated_evars sigma emap c = +let push_duplicated_evars sigma emap c = let rec collrec (one,(sigma,emap) as acc) c = match kind_of_term c with | Evar (evk,_) when not (Evd.mem sigma evk) -> @@ -149,11 +149,11 @@ let evars_to_metas sigma (emap, c) = (* The list of non-instantiated existential declarations *) -let non_instantiated sigma = +let non_instantiated sigma = let listev = to_list sigma in - List.fold_left - (fun l (ev,evi) -> - if evi.evar_body = Evar_empty then + List.fold_left + (fun l (ev,evi) -> + if evi.evar_body = Evar_empty then ((ev,nf_evar_info sigma evi)::l) else l) [] listev @@ -194,7 +194,7 @@ let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) ?filter insta let make_projectable_subst sigma evi args = let sign = evar_filtered_context evi in - let rec alias_of_var id = + let rec alias_of_var id = match pi2 (Sign.lookup_named id sign) with | Some t when isVar t -> alias_of_var (destVar t) | _ -> id in @@ -217,12 +217,12 @@ let make_pure_subst evi args = (* [push_rel_context_to_named_context] builds the defining context and the * initial instance of an evar. If the evar is to be used in context - * + * * Gamma = a1 ... an xp ... x1 * \- named part -/ \- de Bruijn part -/ - * + * * then the x1...xp are turned into variables so that the evar is declared in - * context + * context * * a1 ... an xp ... x1 * \----------- named part ------------/ @@ -230,7 +230,7 @@ let make_pure_subst evi args = * but used applied to the initial instance "a1 ... an Rel(p) ... Rel(1)" * so that ev[a1:=a1 ... an:=an xp:=Rel(p) ... x1:=Rel(1)] is correctly typed * in context Gamma. - * + * * Remark 1: The instance is reverted in practice (i.e. Rel(1) comes first) * Remark 2: If some of the ai or xj are definitions, we keep them in the * instance. This is necessary so that no unfolding of local definitions @@ -239,7 +239,7 @@ let make_pure_subst evi args = * we want the hole to be instantiated by x', not by x (which would have the * case in [invert_instance] if x' had disappear of the instance). * Note that at any time, if, in some context env, the instance of - * declaration x:A is t and the instance of definition x':=phi(x) is u, then + * declaration x:A is t and the instance of definition x':=phi(x) is u, then * we have the property that u and phi(t) are convertible in env. *) @@ -259,7 +259,7 @@ let push_rel_context_to_named_context env typ = (mkVar id :: subst, id::avoid, push_named d env)) (rel_context env) ~init:([], ids, env) in (named_context_val env, substl subst typ, inst_rels@inst_vars) - + (* [new_evar] declares a new existential in an env env with type typ *) (* Converting the env into the sign of the evar to define *) @@ -288,9 +288,9 @@ let is_pattern inst = *) -(* We have x1..xq |- ?e1 and had to solve something like - * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some - * ?e2[v1..vn], hence flexible. We had to go through k binders and now +(* We have x1..xq |- ?e1 and had to solve something like + * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some + * ?e2[v1..vn], hence flexible. We had to go through k binders and now * virtually have x1..xq, y1..yk | ?e1' and the equation * Γ, y1..yk |- ?e1'[u1..uq y1..yk] = c. * What we do is to formally introduce ?e1' in context x1..xq, Γ, y1..yk, @@ -299,10 +299,10 @@ let is_pattern inst = * * In fact, we optimize a little and try to compute a maximum * common subpart of x1..xq and Γ. This is done by detecting the - * longest subcontext x1..xp such that Γ = x1'..xp' z1..zm and + * longest subcontext x1..xp such that Γ = x1'..xp' z1..zm and * u1..up = x1'..xp'. * - * At the end, we return ?e1'[x1..xn z1..zm y1..yk] so that ?e1 can be + * At the end, we return ?e1'[x1..xn z1..zm y1..yk] so that ?e1 can be * instantiated by (...\y1 ... \yk ... ?e1[x1..xn z1..zm y1..yk]) and the * new problem is Σ; Γ, y1..yk |- ?e1'[u1..un z1..zm y1..yk] = c, * making the z1..zm unavailable. @@ -316,10 +316,10 @@ let shrink_context env subst ty = (* We merge the contexts (optimization) *) let rec shrink_rel i subst rel_subst rev_rel_sign = match subst,rev_rel_sign with - | (id,c)::subst,_::rev_rel_sign when c = mkRel i -> + | (id,c)::subst,_::rev_rel_sign when c = mkRel i -> shrink_rel (i-1) subst (mkVar id::rel_subst) rev_rel_sign | _ -> - substl_rel_context rel_subst (List.rev rev_rel_sign), + substl_rel_context rel_subst (List.rev rev_rel_sign), substl rel_subst ty in let rec shrink_named subst named_subst rev_named_sign = @@ -364,7 +364,7 @@ let extend_evar env evdref k (evk1,args1) c = let subfilter p filter l = let (filter,_,l) = List.fold_left (fun (filter,l,newl) b -> - if b then + if b then let a,l' = match l with a::args -> a,args | _ -> assert false in if p a then (true::filter,l',a::newl) else (false::filter,l',newl) else (false::filter,l,newl)) @@ -400,10 +400,10 @@ let rec check_and_clear_in_constr evdref err ids c = (* returns a new constr where all the evars have been 'cleaned' (ie the hypotheses ids have been removed from the contexts of evars) *) - let check id' = + let check id' = if List.mem id' ids then raise (ClearDependencyError (id',err)) - in + in match kind_of_term c with | Var id' -> check id'; c @@ -412,12 +412,12 @@ let rec check_and_clear_in_constr evdref err ids c = let vars = Environ.vars_of_global (Global.env()) c in List.iter check vars; c - | Evar (evk,l as ev) -> + | Evar (evk,l as ev) -> if Evd.is_defined_evar !evdref ev then (* If evk is already defined we replace it by its definition *) - let nc = whd_evar !evdref c in + let nc = whd_evar !evdref c in (check_and_clear_in_constr evdref err ids nc) - else + else (* We check for dependencies to elements of ids in the evar_info corresponding to e and in the instance of arguments. Concurrently, we build a new evar @@ -426,11 +426,11 @@ let rec check_and_clear_in_constr evdref err ids c = let evi = Evd.find !evdref evk in let ctxt = Evd.evar_filtered_context evi in let (nhyps,nargs,rids) = - List.fold_right2 + List.fold_right2 (fun (rid,ob,c as h) a (hy,ar,ri) -> (* Check if some id to clear occurs in the instance a of rid in ev and remember the dependency *) - match + match List.filter (fun id -> List.mem id ids) (collect_vars a) with | id :: _ -> (hy,ar,(rid,id)::ri) @@ -448,8 +448,8 @@ let rec check_and_clear_in_constr evdref err ids c = in the type of ev and adjust the source of the dependency *) let nconcl = try check_and_clear_in_constr evdref (EvarTypingBreak ev) - (List.map fst rids) (evar_concl evi) - with ClearDependencyError (rid,err) -> + (List.map fst rids) (evar_concl evi) + with ClearDependencyError (rid,err) -> raise (ClearDependencyError (List.assoc rid rids,err)) in let env = Sign.fold_named_context push_named nhyps ~init:(empty_env) in @@ -466,7 +466,7 @@ let clear_hyps_in_evi evdref hyps concl ids = the contexts of the evars occuring in evi *) let nconcl = check_and_clear_in_constr evdref (OccurHypInSimpleClause None) ids concl in - let nhyps = + let nhyps = let check_context (id,ob,c) = let err = OccurHypInSimpleClause (Some id) in (id, Option.map (check_and_clear_in_constr evdref err ids) ob, @@ -488,7 +488,7 @@ let clear_hyps_in_evi evdref hyps concl ids = (nhyps,nconcl) -(* Expand rels and vars that are bound to other rels or vars so that +(* Expand rels and vars that are bound to other rels or vars so that dependencies in variables are canonically associated to the most ancient variable in its family of aliased variables *) @@ -513,7 +513,7 @@ let rec expand_var_at_least_once env x = let expand_var env x = try expand_var_at_least_once env x with Not_found -> x - + let expand_var_opt env x = try Some (expand_var_at_least_once env x) with Not_found -> None @@ -522,7 +522,7 @@ let rec expand_vars_in_term env t = match kind_of_term t with | _ -> map_constr_with_full_binders push_rel expand_vars_in_term env t let rec expansions_of_var env x = - try + try let t = expand_var_once env x in t :: expansions_of_var env t with Not_found -> @@ -534,7 +534,7 @@ let rec expansions_of_var env x = * * - ?n[...;x:=y;...] = y * - ?n[...;x:=?m[args];...] = y with ?m[args] = y recursively solvable - * + * * (see test-suite/success/Fixpoint.v for an example of application of * the second kind of problem). * @@ -563,8 +563,8 @@ let rec expansions_of_var env x = exception NotUnique exception NotUniqueInType of types -type evar_projection = -| ProjectVar +type evar_projection = +| ProjectVar | ProjectEvar of existential * evar_info * identifier * evar_projection let rec find_projectable_vars with_evars env sigma y subst = @@ -577,7 +577,7 @@ let rec find_projectable_vars with_evars env sigma y subst = let evi = Evd.find sigma evk in let subst = make_projectable_subst sigma evi argsv in let l = find_projectable_vars with_evars env sigma y subst in - match l with + match l with | [id',p] -> (idc,(true,(id,ProjectEvar (t,evi,id',p)))) | _ -> failwith "" else failwith "" in @@ -635,7 +635,7 @@ let rec do_projection_effects define_fun env ty evd = function evd (* Assuming Σ; Γ, y1..yk |- c, [invert_subst Γ k Σ [x1:=u1;...;xn:=un] c] - * tries to return φ(x1..xn) such that equation φ(u1..un) = c is valid. + * tries to return φ(x1..xn) such that equation φ(u1..un) = c is valid. * The strategy is to imitate the structure of c and then to invert * the variables of c (i.e. rels or vars of Γ) using the algorithm * implemented by project_with_effects/find_projectable_vars. @@ -643,14 +643,14 @@ let rec do_projection_effects define_fun env ty evd = function * 1 solutions is found. * * Precondition: Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un - * Postcondition: if φ(x1..xn) is returned then + * Postcondition: if φ(x1..xn) is returned then * Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn) * * The effects correspond to evars instantiated while trying to project. * * [invert_subst] is used on instances of evars. Since the evars are flexible, * these instances are potentially erasable. This is why we don't investigate - * whether evars in the instances of evars are unifiable, to the contrary of + * whether evars in the instances of evars are unifiable, to the contrary of * [invert_definition]. *) @@ -673,7 +673,7 @@ let invert_arg_from_subst env k sigma subst_in_env c_in_env_extended_with_k_bind project_with_effects env sigma effects t subst_in_env | _ -> map_constr_with_binders succ aux k t in - try + try let c = aux k c_in_env_extended_with_k_binders in Invertible (UniqueProjection (c,!effects)) with @@ -725,7 +725,7 @@ let restrict_hyps evd evk filter = occurrence of x in the hnf of C), then z should be removed too. - If y is in a non-erasable position in T(x,y,z) then the problem is unsolvable. - Computing whether y is erasable or not may be costly and the + Computing whether y is erasable or not may be costly and the interest for this early detection in practice is not obvious. We let it for future work. In any case, thanks to the use of filters, the whole (unrestricted) context remains consistent. *) @@ -779,13 +779,13 @@ let postpone_evar_evar env evd projs1 (evk1,args1) projs2 (evk2,args2) = let pb = (Reduction.CONV,env,mkEvar(evk1',args1'),mkEvar (evk2',args2')) in add_conv_pb pb evd -(* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic +(* [solve_evar_evar f Γ Σ ?e1[u1..un] ?e2[v1..vp]] applies an heuristic * to solve the equation Σ; Γ ⊢ ?e1[u1..un] = ?e2[v1..vp]: - * - if there are at most one φj for each vj s.t. vj = φj(u1..un), - * we first restrict ?2 to the subset v_k1..v_kq of the vj that are + * - if there are at most one φj for each vj s.t. vj = φj(u1..un), + * we first restrict ?2 to the subset v_k1..v_kq of the vj that are * inversible and we set ?1[x1..xn] := ?2[φk1(x1..xn)..φkp(x1..xn)] - * - symmetrically if there are at most one ψj for each uj s.t. - * uj = ψj(v1..vp), + * - symmetrically if there are at most one ψj for each uj s.t. + * uj = ψj(v1..vp), * - otherwise, each position i s.t. ui does not occur in v1..vp has to * be restricted and similarly for the vi, and we leave the equation * as an open equation (performed by [postpone_evar]) @@ -819,12 +819,12 @@ let solve_evar_evar f env evd ev1 ev2 = (* We try to instantiate the evar assuming the body won't depend * on arguments that are not Rels or Vars, or appearing several times - * (i.e. we tackle a generalization of Miller-Pfenning patterns unification) + * (i.e. we tackle a generalization of Miller-Pfenning patterns unification) * * 1) Let "env |- ?ev[hyps:=args] = rhs" be the unification problem * 2) We limit it to a patterns unification problem "env |- ev[subst] = rhs" * where only Rel's and Var's are relevant in subst - * 3) We recur on rhs, "imitating" the term, and failing if some Rel/Var is + * 3) We recur on rhs, "imitating" the term, and failing if some Rel/Var is * not in the scope of ?ev. For instance, the problem * "y:nat |- ?x[] = y" where "|- ?1:nat" is not satisfiable because * ?1 would be instantiated by y which is not in the scope of ?1. @@ -834,9 +834,9 @@ let solve_evar_evar f env evd ev1 ev2 = * Note: we don't assume rhs in normal form, it may fail while it would * have succeeded after some reductions. * - * This is the work of [invert_definition Γ Σ ?ev[hyps:=args] + * This is the work of [invert_definition Γ Σ ?ev[hyps:=args] * Precondition: Σ; Γ, y1..yk |- c /\ Σ; Γ |- u1..un - * Postcondition: if φ(x1..xn) is returned then + * Postcondition: if φ(x1..xn) is returned then * Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn) *) @@ -852,7 +852,7 @@ let rec invert_definition choose env evd (evk,argsv as ev) rhs = (* Projection *) let project_variable t = (* Evar/Var problem: unifiable iff variable projectable from ev subst *) - try + try let sols = find_projectable_vars true env !evdref t subst in let c, p = match sols with | [] -> raise Not_found @@ -896,7 +896,7 @@ let rec invert_definition choose env evd (evk,argsv as ev) rhs = (try (* Try to project (a restriction of) the right evar *) let eprojs' = effective_projections projs' in - let evd,args' = + let evd,args' = list_fold_map (instance_of_projection evar_define env' t) !evdref eprojs' in let evd,evk' = do_restrict_hyps evd evk' projs' in @@ -948,7 +948,7 @@ and evar_define ?(choose=false) env (evk,_ as ev) rhs evd = let body = refresh_universes body in (* Cannot strictly type instantiations since the unification algorithm * does not unify applications from left to right. - * e.g problem f x == g y yields x==y and f==g (in that order) + * e.g problem f x == g y yields x==y and f==g (in that order) * Another problem is that type variables are evars of type Type let _ = try @@ -966,7 +966,7 @@ and evar_define ?(choose=false) env (evk,_ as ev) rhs evd = with | NotEnoughInformationToProgress -> postpone_evar_term env evd ev rhs - | NotInvertibleUsingOurAlgorithm t -> + | NotInvertibleUsingOurAlgorithm t -> error_not_clean env evd evk t (evar_source evk evd) (*-------------------*) @@ -1000,15 +1000,15 @@ let is_ground_env evd env = structures *) let is_ground_env = memo1_2 is_ground_env -let head_evar = +let head_evar = let rec hrec c = match kind_of_term c with | Evar (evk,_) -> evk | Case (_,_,c,_) -> hrec c | App (c,_) -> hrec c | Cast (c,_,_) -> hrec c | _ -> failwith "headconstant" - in - hrec + in + hrec (* Check if an applied evar "?X[args] l" is a Miller's pattern; note that we don't care whether args itself contains Rel's or even Rel's @@ -1063,7 +1063,7 @@ let is_unification_pattern (env,nb) f l t = (* From a unification problem "?X l1 = term1 l2" such that l1 is made of distinct rel's, build "\x1...xn.(term1 l2)" (patterns unification) *) (* NB: does not work when (term1 l2) contains metas because metas - *implicitly* depend on Vars but lambda abstraction will not reflect this + *implicitly* depend on Vars but lambda abstraction will not reflect this dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *) let solve_pattern_eqn env l1 c = @@ -1074,7 +1074,7 @@ let solve_pattern_eqn env l1 c = (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> let (na,_,t) = lookup_rel n env in mkLambda (na,lift n t,c') | Var id -> let (id,_,t) = lookup_named id env in mkNamedLambda id t c' - | _ -> assert false) + | _ -> assert false) l1 c in (* Warning: we may miss some opportunity to eta-reduce more since c' is not in normal form *) @@ -1107,7 +1107,7 @@ let solve_pattern_eqn env l1 c = *) let status_changed lev (pbty,_,t1,t2) = - try + try ExistentialSet.mem (head_evar t1) lev or ExistentialSet.mem (head_evar t2) lev with Failure _ -> try ExistentialSet.mem (head_evar t2) lev with Failure _ -> false @@ -1172,7 +1172,7 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1) | _ -> let evd = if pbty = Some false then - check_instance_type conv_algo env evd ev1 t2 + check_instance_type conv_algo env evd ev1 t2 else evd in let evd = evar_define ~choose env ev1 t2 evd in @@ -1180,11 +1180,11 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1) if occur_existential evd evi.evar_concl then let evenv = evar_env evi in let evc = nf_isevar evd evi.evar_concl in - match evi.evar_body with - | Evar_defined body -> + match evi.evar_body with + | Evar_defined body -> let ty = nf_isevar evd (Retyping.get_type_of evenv evd body) in add_conv_pb (Reduction.CUMUL,evenv,ty,evc) evd - | Evar_empty -> (* Resulted in a constraint *) + | Evar_empty -> (* Resulted in a constraint *) evd else evd in @@ -1196,29 +1196,29 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1) with e when precatchable_exception e -> (evd,false) -let evars_of_term c = +let evars_of_term c = let rec evrec acc c = match kind_of_term c with | Evar (n, _) -> Intset.add n acc | _ -> fold_constr evrec acc c - in + in evrec Intset.empty c let evars_of_named_context nc = List.fold_right (fun (_, b, t) s -> - Option.fold_left (fun s t -> + Option.fold_left (fun s t -> Intset.union s (evars_of_term t)) (Intset.union s (evars_of_term t)) b) nc Intset.empty - + let evars_of_evar_info evi = Intset.union (evars_of_term evi.evar_concl) - (Intset.union - (match evi.evar_body with + (Intset.union + (match evi.evar_body with | Evar_empty -> Intset.empty | Evar_defined b -> evars_of_term b) (evars_of_named_context (named_context_of_val evi.evar_hyps))) - + (* [check_evars] fails if some unresolved evar remains *) (* it assumes that the defined existentials have already been substituted *) @@ -1289,7 +1289,7 @@ let define_evar_as_abstraction abs evd (ev,args) = (ids_of_named_context (evar_context evi)) in let newenv = push_named (nvar, None, dom) evenv in let (evd2,rng) = - new_evar evd1 newenv ~src:(evar_source ev evd1) (new_Type()) + new_evar evd1 newenv ~src:(evar_source ev evd1) (new_Type()) ~filter:(true::evar_filter evi) in let prod = abs (Name nvar, dom, subst_var nvar rng) in let evd3 = Evd.define ev prod evd2 in @@ -1298,7 +1298,7 @@ let define_evar_as_abstraction abs evd (ev,args) = fst (destEvar rng), array_cons (mkRel 1) (Array.map (lift 1) args) in let prod' = abs (Name nvar, mkEvar evdom, mkEvar evrng) in (evd3,prod') - + let define_evar_as_product evd (ev,args) = define_evar_as_abstraction (fun t -> mkProd t) evd (ev,args) @@ -1319,8 +1319,8 @@ let judge_of_new_Type () = Typeops.judge_of_type (new_univ ()) constraint on its domain and codomain. If the input constraint is an evar instantiate it with the product of 2 new evars. *) -let split_tycon loc env evd tycon = - let rec real_split evd c = +let split_tycon loc env evd tycon = + let rec real_split evd c = let t = whd_betadeltaiota env evd c in match kind_of_term t with | Prod (na,dom,rng) -> evd, (na, dom, rng) @@ -1334,29 +1334,29 @@ let split_tycon loc env evd tycon = | None -> evd,(Anonymous,None,None) | Some (abs, c) -> (match abs with - None -> + None -> let evd', (n, dom, rng) = real_split evd c in evd', (n, mk_tycon dom, mk_tycon rng) | Some (init, cur) -> - if cur = 0 then + if cur = 0 then let evd', (x, dom, rng) = real_split evd c in - evd, (Anonymous, - Some (None, dom), + evd, (Anonymous, + Some (None, dom), Some (None, rng)) else - evd, (Anonymous, None, + evd, (Anonymous, None, Some (if cur = 1 then None,c else Some (init, pred cur), c))) - -let valcon_of_tycon x = + +let valcon_of_tycon x = match x with | Some (None, t) -> Some t | _ -> None - + let lift_abstr_tycon_type n (abs, t) = - match abs with + match abs with None -> raise (Invalid_argument "lift_abstr_tycon_type: not an abstraction") | Some (init, abs) -> - let abs' = abs + n in + let abs' = abs + n in if abs' < 0 then raise (Invalid_argument "lift_abstr_tycon_type") else (Some (init, abs'), t) @@ -1364,10 +1364,10 @@ let lift_tycon_type n (abs, t) = (abs, lift n t) let lift_tycon n = Option.map (lift_tycon_type n) let pr_tycon_type env (abs, t) = - match abs with + match abs with None -> Termops.print_constr_env env t | Some (init, cur) -> str "Abstract (" ++ int init ++ str "," ++ int cur ++ str ") " ++ Termops.print_constr_env env t - + let pr_tycon env = function None -> str "None" | Some t -> pr_tycon_type env t diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index 8df301c668..dc212c9cab 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -42,7 +42,7 @@ val e_new_evar : (* Create a fresh evar in a context different from its definition context: [new_evar_instance sign evd ty inst] creates a new evar of context [sign] and type [ty], [inst] is a mapping of the evar context to - the context where the evar should occur. This means that the terms + the context where the evar should occur. This means that the terms of [inst] are typed in the occurrence context and their type (seen as a telescope) is [sign] *) val new_evar_instance : @@ -74,7 +74,7 @@ val non_instantiated : evar_map -> (evar * evar_info) list val is_ground_term : evar_defs -> constr -> bool val is_ground_env : evar_defs -> env -> bool -val solve_refl : +val solve_refl : (env -> evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool) -> env -> evar_defs -> existential_key -> constr array -> constr array -> evar_defs @@ -91,7 +91,7 @@ val define_evar_as_product : evar_defs -> existential -> evar_defs * types val define_evar_as_lambda : evar_defs -> existential -> evar_defs * types val define_evar_as_sort : evar_defs -> existential -> evar_defs * sorts -val is_unification_pattern_evar : env -> existential -> constr list -> +val is_unification_pattern_evar : env -> existential -> constr list -> constr -> bool val is_unification_pattern : env * int -> constr -> constr array -> constr -> bool @@ -120,7 +120,7 @@ val empty_valcon : val_constraint val mk_valcon : constr -> val_constraint val split_tycon : - loc -> env -> evar_defs -> type_constraint -> + loc -> env -> evar_defs -> type_constraint -> evar_defs * (name * type_constraint * type_constraint) val valcon_of_tycon : type_constraint -> val_constraint @@ -170,7 +170,7 @@ val whd_castappevar : evar_map -> constr -> constr (* Replace the vars and rels that are aliases to other vars and rels by *) (* their representative that is most ancient in the context *) -val expand_vars_in_term : env -> constr -> constr +val expand_vars_in_term : env -> constr -> constr (*********************************************************************) (* debug pretty-printer: *) diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 191c8e62af..c96cc20cf9 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -27,7 +27,7 @@ let string_of_existential evk = "?" ^ string_of_int evk let existential_of_int evk = evk type evar_body = - | Evar_empty + | Evar_empty | Evar_defined of constr type evar_info = { @@ -51,15 +51,15 @@ let evar_context evi = named_context_of_val evi.evar_hyps let evar_body evi = evi.evar_body let evar_filter evi = evi.evar_filter let evar_unfiltered_env evi = Global.env_of_context evi.evar_hyps -let evar_filtered_context evi = +let evar_filtered_context evi = snd (list_filter2 (fun b c -> b) (evar_filter evi,evar_context evi)) -let evar_env evi = +let evar_env evi = List.fold_right push_named (evar_filtered_context evi) (reset_context (Global.env())) let eq_evar_info ei1 ei2 = - ei1 == ei2 || - eq_constr ei1.evar_concl ei2.evar_concl && + ei1 == ei2 || + eq_constr ei1.evar_concl ei2.evar_concl && eq_named_context_val (ei1.evar_hyps) (ei2.evar_hyps) && ei1.evar_body = ei2.evar_body @@ -73,7 +73,7 @@ let eq_evar_info ei1 ei2 = module ExistentialMap = Intmap module ExistentialSet = Intset -(* This exception is raised by *.existential_value *) +(* This exception is raised by *.existential_value *) exception NotInstantiatedEvar module EvarInfoMap = struct @@ -82,7 +82,7 @@ module EvarInfoMap = struct let empty = ExistentialMap.empty let to_list evc = (* Workaround for change in Map.fold behavior *) - let l = ref [] in + let l = ref [] in ExistentialMap.iter (fun evk x -> l := (evk,x)::!l) evc; !l @@ -96,7 +96,7 @@ module EvarInfoMap = struct let equal = ExistentialMap.equal - let define evd evk body = + let define evd evk body = let oldinfo = try find evd evk with Not_found -> error "Evd.define: cannot define undeclared evar" in @@ -110,7 +110,7 @@ module EvarInfoMap = struct let is_evar sigma evk = mem sigma evk let is_defined sigma evk = - let info = find sigma evk in + let info = find sigma evk in not (info.evar_body = Evar_empty) @@ -131,7 +131,7 @@ module EvarInfoMap = struct | ([],[]) -> [] | ([],_) | (_,[]) -> anomaly "Signature and its instance do not match" - in + in instrec (sign,args) let instantiate_evar sign c args = @@ -247,7 +247,7 @@ let set_leq_sort (u1,(leq1,geq1)) (u2,(leq2,geq2)) scstr = match UniverseMap.find u1 scstr with EqSort u1' -> search_rec (is_b,betw,not_betw) u1' | SortVar(leq,_) -> - let (is_b',betw',not_betw') = + let (is_b',betw',not_betw') = List.fold_left search_rec (false,betw,not_betw) leq in if is_b' then (true, u1::betw', not_betw') else (false, betw', not_betw') @@ -317,9 +317,9 @@ module EvarMap = struct UniverseMap.equal (=) (snd x) (snd y)) let merge e e' = fold (fun n v sigma -> add sigma n v) e' e - + end - + (*******************************************************************) (* Metamaps *) @@ -391,16 +391,16 @@ let clb_name = function | Clval (na,_,_) -> (na,true) (***********************) - + module Metaset = Intset - + let meta_exists p s = Metaset.fold (fun x b -> b || (p x)) s false module Metamap = Intmap let metamap_to_list m = Metamap.fold (fun n v l -> (n,v)::l) m [] - + (*************************) (* Unification state *) @@ -430,7 +430,7 @@ type evar_map = evar_defs (* spiwack: this function seems to be used only for the definition of the progress tactical. I would recommand not using it in other places. *) let eq_evar_map d1 d2 = - EvarMap.eq_evar_map d1.evars d2.evars + EvarMap.eq_evar_map d1.evars d2.evars (* spiwack: tentative. It might very well not be the semantics we want for merging evar_defs *) @@ -450,7 +450,7 @@ let mem d e = EvarMap.mem d.evars e (* spiwack: this function loses information from the original evar_defs it might be an idea not to export it. *) let to_list d = EvarMap.to_list d.evars -(* spiwack: not clear what folding over an evar_defs, for now we shall +(* spiwack: not clear what folding over an evar_defs, for now we shall simply fold over the inner evar_map. *) let fold f d a = EvarMap.fold f d.evars a let is_evar d e = EvarMap.is_evar d.evars e @@ -463,14 +463,14 @@ let existential_opt_value d e = EvarMap.existential_opt_value d.evars e (*** /Lifting... ***) (* evar_defs are considered empty disregarding histories *) -let is_empty d = +let is_empty d = d.evars = EvarMap.empty && d.conv_pbs = [] && Metamap.is_empty d.metas let subst_named_context_val s = map_named_val (subst_mps s) -let subst_evar_info s evi = +let subst_evar_info s evi = let subst_evb = function Evar_empty -> Evar_empty | Evar_defined c -> Evar_defined (subst_mps s c) in { evi with @@ -494,12 +494,12 @@ let create_evar_defs sigma = { sigma with (* spiwack: tentatively deprecated *) let create_goal_evar_defs sigma = { sigma with conv_pbs=[]; last_mods=ExistentialSet.empty; metas=Metamap.empty } -let empty = { - evars=EvarMap.empty; - conv_pbs=[]; - last_mods = ExistentialSet.empty; - history=[]; - metas=Metamap.empty +let empty = { + evars=EvarMap.empty; + conv_pbs=[]; + last_mods = ExistentialSet.empty; + history=[]; + metas=Metamap.empty } let evars_reset_evd evd d = {d with evars = evd.evars} @@ -512,7 +512,7 @@ let evar_source evk d = let define evk body evd = { evd with evars = EvarMap.define evd.evars evk body; - last_mods = + last_mods = match evd.conv_pbs with | [] -> evd.last_mods | _ -> ExistentialSet.add evk evd.last_mods } @@ -542,23 +542,23 @@ let is_undefined_evar evd c = match kind_of_term c with | Evar ev -> not (is_defined_evar evd ev) | _ -> false -let undefined_evars evd = - let evars = - EvarMap.fold (fun evk evi sigma -> if evi.evar_body = Evar_empty then - EvarMap.add sigma evk evi else sigma) +let undefined_evars evd = + let evars = + EvarMap.fold (fun evk evi sigma -> if evi.evar_body = Evar_empty then + EvarMap.add sigma evk evi else sigma) evd.evars EvarMap.empty - in + in { evd with evars = evars } (* extracts conversion problems that satisfy predicate p *) (* Note: conv_pbs not satisying p are stored back in reverse order *) let extract_conv_pbs evd p = - let (pbs,pbs1) = + let (pbs,pbs1) = List.fold_left (fun (pbs,pbs1) pb -> - if p pb then + if p pb then (pb::pbs,pbs1) - else + else (pbs,pb::pbs1)) ([],[]) evd.conv_pbs @@ -604,7 +604,7 @@ let undefined_metas evd = | (n,Cltyp (_,typ)) -> n) (meta_list evd)) -let metas_of evd = +let metas_of evd = List.map (function | (n,Clval(_,_,typ)) -> (n,typ.rebus) | (n,Cltyp (_,typ)) -> (n,typ.rebus)) @@ -612,8 +612,8 @@ let metas_of evd = let map_metas_fvalue f evd = { evd with metas = - Metamap.map - (function + Metamap.map + (function | Clval(id,(c,s),typ) -> Clval(id,(mk_freelisted (f c.rebus),s),typ) | x -> x) evd.metas } @@ -633,7 +633,7 @@ let try_meta_fvalue evd mv = | Cltyp _ -> raise Not_found let meta_fvalue evd mv = - try try_meta_fvalue evd mv + try try_meta_fvalue evd mv with Not_found -> anomaly "meta_fvalue: meta has no value" let meta_value evd mv = @@ -645,10 +645,10 @@ let meta_ftype evd mv = | Clval(_,_,b) -> b let meta_type evd mv = (meta_ftype evd mv).rebus - + let meta_declare mv v ?(name=Anonymous) evd = { evd with metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas } - + let meta_assign mv (v,pb) evd = match Metamap.find mv evd.metas with | Cltyp(na,ty) -> @@ -680,12 +680,12 @@ let meta_with_name evd id = else l) evd.metas ([],[]) in match mvnodef, mvl with - | _,[] -> + | _,[] -> errorlabstrm "Evd.meta_with_name" (str"No such bound variable " ++ pr_id id ++ str".") - | ([n],_|_,[n]) -> + | ([n],_|_,[n]) -> n - | _ -> + | _ -> errorlabstrm "Evd.meta_with_name" (str "Binder name \"" ++ pr_id id ++ strbrk "\" occurs more than once in clause.") @@ -694,14 +694,14 @@ let meta_with_name evd id = (* spiwack: we should try and replace this List.fold_left by a Metamap.fold. *) let meta_merge evd1 evd2 = {evd2 with - metas = List.fold_left (fun m (n,v) -> Metamap.add n v m) + metas = List.fold_left (fun m (n,v) -> Metamap.add n v m) evd2.metas (metamap_to_list evd1.metas) } type metabinding = metavariable * constr * instance_status let retract_coercible_metas evd = - let mc,ml = - Metamap.fold (fun n v (mc,ml) -> + let mc,ml = + Metamap.fold (fun n v (mc,ml) -> match v with | Clval (na,(b,(UserGiven,CoerceToType as s)),typ) -> (n,b.rebus,s)::mc, Metamap.add n (Cltyp (na,typ)) ml @@ -714,7 +714,7 @@ let rec list_assoc_in_triple x = function [] -> raise Not_found | (a,b,_)::l -> if compare a x = 0 then b else list_assoc_in_triple x l -let subst_defined_metas bl c = +let subst_defined_metas bl c = let rec substrec c = match kind_of_term c with | Meta i -> substrec (list_assoc_in_triple i bl) | _ -> map_constr substrec c @@ -729,7 +729,7 @@ type open_constr = evar_map * constr type 'a sigma = { it : 'a ; sigma : evar_map} - + let sig_it x = x.it let sig_sig x = x.sigma @@ -761,13 +761,13 @@ let pr_meta_map mmap = | _ -> mt() in let pr_meta_binding = function | (mv,Cltyp (na,b)) -> - hov 0 + hov 0 (pr_meta mv ++ pr_name na ++ str " : " ++ print_constr b.rebus ++ fnl ()) | (mv,Clval(na,(b,s),t)) -> - hov 0 + hov 0 (pr_meta mv ++ pr_name na ++ str " := " ++ - print_constr b.rebus ++ + print_constr b.rebus ++ str " : " ++ print_constr t.rebus ++ spc () ++ pr_instance_status s ++ fnl ()) in @@ -776,7 +776,7 @@ let pr_meta_map mmap = let pr_decl ((id,b,_),ok) = match b with | None -> if ok then pr_id id else (str "{" ++ pr_id id ++ str "}") - | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ + | Some c -> str (if ok then "(" else "{") ++ pr_id id ++ str ":=" ++ print_constr c ++ str (if ok then ")" else "}") let pr_evar_info evi = @@ -791,7 +791,7 @@ let pr_evar_info evi = hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]") let pr_evar_defs_t (evars,cstrs as sigma) = - let evs = + let evs = if evars = EvarInfoMap.empty then mt () else str"EVARS:"++brk(0,1)++ @@ -801,7 +801,7 @@ let pr_evar_defs_t (evars,cstrs as sigma) = (EvarMap.to_list sigma))++fnl() and cs = if cstrs = UniverseMap.empty then mt () - else pr_sort_cstrs cstrs++fnl() + else pr_sort_cstrs cstrs++fnl() in evs ++ cs let pr_constraints pbs = @@ -810,7 +810,7 @@ let pr_constraints pbs = print_constr t1 ++ spc() ++ str (match pbty with | Reduction.CONV -> "==" - | Reduction.CUMUL -> "<=") ++ + | Reduction.CUMUL -> "<=") ++ spc() ++ print_constr t2) pbs) let pr_evar_defs evd = @@ -825,5 +825,5 @@ let pr_evar_defs evd = str"METAS:"++brk(0,1)++pr_meta_map evd.metas in v 0 (pp_evm ++ cstrs ++ pp_met) -let pr_metaset metas = +let pr_metaset metas = str "[" ++ prlist_with_sep spc pr_meta (Metaset.elements metas) ++ str "]" diff --git a/pretyping/evd.mli b/pretyping/evd.mli index e5cf8e2690..07706c0ba4 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -44,7 +44,7 @@ val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted (e.g. the solution [P] to [?X u v = P u v] can be eta-expanded twice) *) -type instance_constraint = +type instance_constraint = IsSuperType | IsSubType | ConvUpToEta of int | UserGiven (* Status of the unification of the type of an instance against the type of @@ -80,11 +80,11 @@ val map_clb : (constr -> constr) -> clbinding -> clbinding (*** Existential variables and unification states ***) (* A unification state (of type [evar_defs]) is primarily a finite mapping - from existential variables to records containing the type of the evar - ([evar_concl]), the context under which it was introduced ([evar_hyps]) - and its definition ([evar_body]). [evar_extra] is used to add any other - kind of information. - It also contains conversion constraints, debugging information and + from existential variables to records containing the type of the evar + ([evar_concl]), the context under which it was introduced ([evar_hyps]) + and its definition ([evar_body]). [evar_extra] is used to add any other + kind of information. + It also contains conversion constraints, debugging information and information about meta variables. *) (* Information about existential variables. *) @@ -94,7 +94,7 @@ val string_of_existential : evar -> string val existential_of_int : int -> evar type evar_body = - | Evar_empty + | Evar_empty | Evar_defined of constr type evar_info = { @@ -197,7 +197,7 @@ type evar_constraint = conv_pb * env * constr * constr val add_conv_pb : evar_constraint -> evar_defs -> evar_defs module ExistentialSet : Set.S with type elt = existential_key -val extract_changed_conv_pbs : evar_defs -> +val extract_changed_conv_pbs : evar_defs -> (ExistentialSet.t -> evar_constraint -> bool) -> evar_defs * evar_constraint list val extract_all_conv_pbs : evar_defs -> evar_defs * evar_constraint list @@ -208,7 +208,7 @@ val find_meta : evar_defs -> metavariable -> clbinding val meta_list : evar_defs -> (metavariable * clbinding) list val meta_defined : evar_defs -> metavariable -> bool (* [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if - meta has no value *) + meta has no value *) val meta_value : evar_defs -> metavariable -> constr val meta_fvalue : evar_defs -> metavariable -> constr freelisted * instance_status val meta_opt_fvalue : evar_defs -> metavariable -> (constr freelisted * instance_status) option diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 92c5dfcc3d..eed795cdcf 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -44,12 +44,12 @@ let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c) (**********************************************************************) (* Building case analysis schemes *) (* Nouvelle version, plus concise mais plus coûteuse à cause de - lift_constructor et lift_inductive_family qui ne se contentent pas de + lift_constructor et lift_inductive_family qui ne se contentent pas de lifter les paramètres globaux *) let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind = let lnamespar = mib.mind_params_ctxt in - let dep = match depopt with + let dep = match depopt with | None -> inductive_sort_family mip <> InProp | Some d -> d in @@ -67,7 +67,7 @@ let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind = let indf = make_ind_family(ind, extended_rel_list 0 lnamespar) in let constrs = get_constructors env indf in - let rec add_branch env k = + let rec add_branch env k = if k = Array.length mip.mind_consnames then let nbprod = k+1 in @@ -82,7 +82,7 @@ let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind = (mkRel (ndepar + nbprod), if dep then extended_rel_vect 0 deparsign else extended_rel_vect 1 arsign) in - let p = + let p = it_mkLambda_or_LetIn_name env' ((if dep then mkLambda_name env' else mkLambda) (Anonymous,depind,pbody)) @@ -100,27 +100,27 @@ let mis_make_case_com depopt env sigma ind (mib,mip as specif) kind = (add_branch (push_rel (Anonymous, None, t) env) (k+1)) in let typP = make_arity env' dep indf (new_sort_in_family kind) in - it_mkLambda_or_LetIn_name env + it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar - + (* check if the type depends recursively on one of the inductive scheme *) (**********************************************************************) (* Building the recursive elimination *) (* - * t is the type of the constructor co and recargs is the information on + * t is the type of the constructor co and recargs is the information on * the recursive calls. (It is assumed to be in form given by the user). * build the type of the corresponding branch of the recurrence principle - * assuming f has this type, branch_rec gives also the term - * [x1]..[xk](f xi (F xi) ...) to be put in the corresponding branch of + * assuming f has this type, branch_rec gives also the term + * [x1]..[xk](f xi (F xi) ...) to be put in the corresponding branch of * the case operation - * FPvect gives for each inductive definition if we want an elimination - * on it with which predicate and which recursive function. + * FPvect gives for each inductive definition if we want an elimination + * on it with which predicate and which recursive function. *) -let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = +let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let make_prod = make_prod_dep dep in let nparams = List.length vargs in let process_pos env depK pk = @@ -136,39 +136,39 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = | Ind (_,_) -> let realargs = list_skipn nparams largs in let base = applist (lift i pk,realargs) in - if depK then + if depK then Reduction.beta_appvect base [|applist (mkRel (i+1),extended_rel_list 0 sign)|] - else + else base - | _ -> assert false + | _ -> assert false in prec env 0 [] in let rec process_constr env i c recargs nhyps li = - if nhyps > 0 then match kind_of_term c with + if nhyps > 0 then match kind_of_term c with | Prod (n,t,c_0) -> - let (optionpos,rest) = - match recargs with + let (optionpos,rest) = + match recargs with | [] -> None,[] | ra::rest -> - (match dest_recarg ra with + (match dest_recarg ra with | Mrec j when is_rec -> (depPvect.(j),rest) - | Imbr _ -> - Flags.if_verbose warning "Ignoring recursive call"; - (None,rest) + | Imbr _ -> + Flags.if_verbose warning "Ignoring recursive call"; + (None,rest) | _ -> (None, rest)) - in - (match optionpos with - | None -> + in + (match optionpos with + | None -> make_prod env (n,t, process_constr (push_rel (n,None,t) env) (i+1) c_0 rest (nhyps-1) (i::li)) - | Some(dep',p) -> + | Some(dep',p) -> let nP = lift (i+1+decP) p in let env' = push_rel (n,None,t) env in - let t_0 = process_pos env' dep' nP (lift 1 t) in + let t_0 = process_pos env' dep' nP (lift 1 t) in make_prod_dep (dep or dep') env (n,t, mkArrow t_0 @@ -190,14 +190,14 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = else c in let nhyps = List.length cs.cs_args in - let nP = match depPvect.(tyi) with + let nP = match depPvect.(tyi) with | Some(_,p) -> lift (nhyps+decP) p | _ -> assert false in let base = appvect (nP,cs.cs_concl_realargs) in let c = it_mkProd_or_LetIn base cs.cs_args in process_constr env 0 c recargs nhyps [] -let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = +let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let process_pos env fk = let rec prec env i hyps p = let p',largs = whd_betadeltaiota_nolet_stack env sigma p in @@ -208,9 +208,9 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = | LetIn (n,b,t,c) -> let d = (n,Some b,t) in mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) - | Ind _ -> + | Ind _ -> let realargs = list_skipn nparrec largs - and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in + and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in applist(lift i fk,realargs@[arg]) | _ -> assert false in @@ -218,23 +218,23 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = in (* ici, cstrprods est la liste des produits du constructeur instantié *) let rec process_constr env i f = function - | (n,None,t as d)::cprest, recarg::rest -> - let optionpos = - match dest_recarg recarg with + | (n,None,t as d)::cprest, recarg::rest -> + let optionpos = + match dest_recarg recarg with | Norec -> None | Imbr _ -> None | Mrec i -> fvect.(i) - in - (match optionpos with + in + (match optionpos with | None -> lambda_name env (n,t,process_constr (push_rel d env) (i+1) (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1)]))) (cprest,rest)) - | Some(_,f_0) -> + | Some(_,f_0) -> let nF = lift (i+1+decF) f_0 in let env' = push_rel d env in - let arg = process_pos env' nF (lift 1 t) in + let arg = process_pos env' nF (lift 1 t) in lambda_name env (n,t,process_constr env' (i+1) (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1); arg]))) @@ -251,9 +251,9 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = process_constr env 0 f (List.rev cstr.cs_args, recargs) -(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k +(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k variables *) -let context_chop k ctx = +let context_chop k ctx = let rec chop_aux acc = function | (0, l2) -> (List.rev acc, l2) | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t) @@ -266,24 +266,24 @@ let context_chop k ctx = let mis_make_indrec env sigma listdepkind mib = let nparams = mib.mind_nparams in let nparrec = mib. mind_nparams_rec in - let lnonparrec,lnamesparrec = + let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let nrec = List.length listdepkind in let depPvec = - Array.create mib.mind_ntypes (None : (bool * constr) option) in - let _ = - let rec - assign k = function + Array.create mib.mind_ntypes (None : (bool * constr) option) in + let _ = + let rec + assign k = function | [] -> () - | (indi,mibi,mipi,dep,_)::rest -> + | (indi,mibi,mipi,dep,_)::rest -> (Array.set depPvec (snd indi) (Some(dep,mkRel k)); assign (k-1) rest) - in - assign nrec listdepkind in + in + assign nrec listdepkind in let recargsvec = Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in (* recarg information for non recursive parameters *) - let rec recargparn l n = + let rec recargparn l n = if n = 0 then l else recargparn (mk_norec::l) (n-1) in let recargpar = recargparn [] (nparams-nparrec) in let make_one_rec p = @@ -293,80 +293,80 @@ let mis_make_indrec env sigma listdepkind mib = let tyi = snd indi in let nctyi = Array.length mipi.mind_consnames in (* nb constructeurs du type*) - + (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) let args = extended_rel_list (nrec+nbconstruct) lnamesparrec in let indf = make_ind_family(indi,args) in - + let arsign,_ = get_arity env indf in let depind = build_dependent_inductive env indf in let deparsign = (Anonymous,None,depind)::arsign in - + let nonrecpar = rel_context_length lnonparrec in let larsign = rel_context_length deparsign in let ndepar = larsign - nonrecpar in let dect = larsign+nrec+nbconstruct in - + (* constructors in context of the Cases expr, i.e. P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) let args' = extended_rel_list (dect+nrec) lnamesparrec in let args'' = extended_rel_list ndepar lnonparrec in let indf' = make_ind_family(indi,args'@args'') in - - let branches = + + let branches = let constrs = get_constructors env indf' in let fi = rel_vect (dect-i-nctyi) nctyi in - let vecfi = Array.map + let vecfi = Array.map (fun f -> appvect (f,extended_rel_vect ndepar lnonparrec)) - fi + fi in array_map3 - (make_rec_branch_arg env sigma + (make_rec_branch_arg env sigma (nparrec,depPvec,larsign)) - vecfi constrs (dest_subterms recargsvec.(tyi)) + vecfi constrs (dest_subterms recargsvec.(tyi)) in - - let j = (match depPvec.(tyi) with - | Some (_,c) when isRel c -> destRel c - | _ -> assert false) + + let j = (match depPvec.(tyi) with + | Some (_,c) when isRel c -> destRel c + | _ -> assert false) in - + (* Predicate in the context of the case *) - + let depind' = build_dependent_inductive env indf' in let arsign',_ = get_arity env indf' in let deparsign' = (Anonymous,None,depind')::arsign' in - + let pargs = - let nrpar = extended_rel_list (2*ndepar) lnonparrec + let nrpar = extended_rel_list (2*ndepar) lnonparrec and nrar = if dep then extended_rel_list 0 deparsign' else extended_rel_list 1 arsign' in nrpar@nrar - + in (* body of i-th component of the mutual fixpoint *) - let deftyi = + let deftyi = let ci = make_case_info env indi RegularStyle in - let concl = applist (mkRel (dect+j+ndepar),pargs) in + let concl = applist (mkRel (dect+j+ndepar),pargs) in let pred = - it_mkLambda_or_LetIn_name env + it_mkLambda_or_LetIn_name env ((if dep then mkLambda_name env else mkLambda) (Anonymous,depind',concl)) arsign' in it_mkLambda_or_LetIn_name env - (mkCase (ci, pred, + (mkCase (ci, pred, mkRel 1, branches)) (lift_rel_context nrec deparsign) in - + (* type of i-th component of the mutual fixpoint *) - + let typtyi = - let concl = + let concl = let pargs = if dep then extended_rel_vect 0 deparsign else extended_rel_vect 1 arsign in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs) @@ -374,25 +374,25 @@ let mis_make_indrec env sigma listdepkind mib = concl deparsign in - mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp) + mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp) (deftyi::ldef) rest - | [] -> + | [] -> let fixn = Array.of_list (List.rev ln) in let fixtyi = Array.of_list (List.rev ltyp) in - let fixdef = Array.of_list (List.rev ldef) in + let fixdef = Array.of_list (List.rev ldef) in let names = Array.create nrec (Name(id_of_string "F")) in mkFix ((fixn,p),(names,fixtyi,fixdef)) - in - mrec 0 [] [] [] - in - let rec make_branch env i = function + in + mrec 0 [] [] [] + in + let rec make_branch env i = function | (indi,mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nconstr = Array.length mipi.mind_consnames in - let rec onerec env j = - if j = nconstr then - make_branch env (i+j) rest - else + let rec onerec env j = + if j = nconstr then + make_branch env (i+j) rest + else let recarg = (dest_subterms recargsvec.(tyi)).(j) in let recarg = recargpar@recarg in let vargs = extended_rel_list (nrec+i+j) lnamesparrec in @@ -400,36 +400,36 @@ let mis_make_indrec env sigma listdepkind mib = let p_0 = type_rec_branch true dep env sigma (vargs,depPvec,i+j) tyi cs recarg - in + in mkLambda_string "f" p_0 (onerec (push_rel (Anonymous,None,p_0) env) (j+1)) in onerec env 0 - | [] -> + | [] -> makefix i listdepkind in - let rec put_arity env i = function - | (indi,_,_,dep,kinds)::rest -> + let rec put_arity env i = function + | (indi,_,_,dep,kinds)::rest -> let indf = make_ind_family (indi,extended_rel_list i lnamesparrec) in let typP = make_arity env dep indf (new_sort_in_family kinds) in mkLambda_string "P" typP (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest) - | [] -> - make_branch env 0 listdepkind + | [] -> + make_branch env 0 listdepkind in - + (* Body on make_one_rec *) let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in - + if (mis_is_recursive_subset (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind) - mipi.mind_recargs) - then + mipi.mind_recargs) + then let env' = push_rel_context lnamesparrec env in - it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) + it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamesparrec - else - mis_make_case_com (Some dep) env sigma indi (mibi,mipi) kind - in + else + mis_make_case_com (Some dep) env sigma indi (mibi,mipi) kind + in (* Body of mis_make_indrec *) list_tabulate make_one_rec nrec @@ -437,11 +437,11 @@ let mis_make_indrec env sigma listdepkind mib = (* This builds elimination predicate for Case tactic *) let make_case_com depopt env sigma ity kind = - let (mib,mip) = lookup_mind_specif env ity in + let (mib,mip) = lookup_mind_specif env ity in mis_make_case_com depopt env sigma ity (mib,mip) kind let make_case_dep env = make_case_com (Some true) env -let make_case_nodep env = make_case_com (Some false) env +let make_case_nodep env = make_case_com (Some false) env let make_case_gen env = make_case_com None env @@ -449,24 +449,24 @@ let make_case_gen env = make_case_com None env (* [instantiate_indrec_scheme s rec] replace the sort of the scheme [rec] by [s] *) -let change_sort_arity sort = +let change_sort_arity sort = let rec drec a = match kind_of_term a with - | Cast (c,_,_) -> drec c + | Cast (c,_,_) -> drec c | Prod (n,t,c) -> mkProd (n, t, drec c) | LetIn (n,b,t,c) -> mkLetIn (n,b, t, drec c) | Sort _ -> mkSort sort | _ -> assert false - in - drec + in + drec (* [npar] is the number of expected arguments (then excluding letin's) *) let instantiate_indrec_scheme sort = let rec drec npar elim = match kind_of_term elim with - | Lambda (n,t,c) -> - if npar = 0 then + | Lambda (n,t,c) -> + if npar = 0 then mkLambda (n, change_sort_arity sort t, c) - else + else mkLambda (n, t, drec (npar-1) c) | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c) | _ -> anomaly "instantiate_indrec_scheme: wrong elimination type" @@ -478,28 +478,28 @@ let instantiate_indrec_scheme sort = let instantiate_type_indrec_scheme sort npars term = let rec drec np elim = match kind_of_term elim with - | Prod (n,t,c) -> - if np = 0 then + | Prod (n,t,c) -> + if np = 0 then let t' = change_sort_arity sort t in mkProd (n, t', c), mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) - else + else let c',term' = drec (np-1) c in mkProd (n, t, c'), mkLambda (n, t, term') | LetIn (n,b,t,c) -> let c',term' = drec np c in - mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') + mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') | _ -> anomaly "instantiate_type_indrec_scheme: wrong elimination type" in drec npars (**********************************************************************) (* Interface to build complex Scheme *) -(* Check inductive types only occurs once +(* Check inductive types only occurs once (otherwise we obtain a meaning less scheme) *) -let check_arities listdepkind = +let check_arities listdepkind = let _ = List.fold_left - (fun ln ((_,ni as mind),mibi,mipi,dep,kind) -> + (fun ln ((_,ni as mind),mibi,mipi,dep,kind) -> let kelim = elim_sorts (mibi,mipi) in if not (List.exists ((=) kind) kelim) then raise (RecursionSchemeError @@ -510,10 +510,10 @@ let check_arities listdepkind = [] listdepkind in true -let build_mutual_indrec env sigma = function +let build_mutual_indrec env sigma = function | (mind,mib,mip,dep,s)::lrecspec -> let (sp,tyi) = mind in - let listdepkind = + let listdepkind = (mind,mib,mip, dep,s):: (List.map (function (mind',mibi',mipi',dep',s') -> @@ -525,7 +525,7 @@ let build_mutual_indrec env sigma = function raise (RecursionSchemeError (NotMutualInScheme (mind,mind')))) lrecspec) in - let _ = check_arities listdepkind in + let _ = check_arities listdepkind in mis_make_indrec env sigma listdepkind mib | _ -> anomaly "build_indrec expects a non empty list of inductive types" @@ -542,7 +542,7 @@ let build_indrec env sigma ind = (* To interpret Case and Match operators *) (* Expects a dependent predicate *) -let type_rec_branches recursive env sigma indt p c = +let type_rec_branches recursive env sigma indt p c = let IndType (indf,realargs) = indt in let (ind,params) = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in @@ -591,11 +591,11 @@ let lookup_eliminator ind_sp s = errorlabstrm "default_elim" (strbrk "Cannot find the elimination combinator " ++ pr_id id ++ strbrk ", the elimination of the inductive definition " ++ - pr_global_env Idset.empty (IndRef ind_sp) ++ + pr_global_env Idset.empty (IndRef ind_sp) ++ strbrk " on sort " ++ pr_sort_family s ++ strbrk " is probably not allowed.") -(* Build the congruence lemma associated to an inductive type +(* Build the congruence lemma associated to an inductive type I p1..pn a1..am with one constructor C : I q1..qn b1..bm *) (* TODO: extend it to types with more than one index *) @@ -638,10 +638,10 @@ let build_congr env (eq,refl) ind (mib,mip) = (Anonymous, applist (mkInd ind, - extended_rel_list (2*mip.mind_nrealargs_ctxt+3) + extended_rel_list (2*mip.mind_nrealargs_ctxt+3) mib.mind_params_ctxt @ extended_rel_list 0 realsign), - mkApp (eq, + mkApp (eq, [|mkVar varB; mkApp (mkVar varf, [|lift (2*mip.mind_nrealargs_ctxt+4) c|]); mkApp (mkVar varf, [|mkRel (mip.mind_nrealargs - i + 2)|])|]))), @@ -649,4 +649,4 @@ let build_congr env (eq,refl) ind (mib,mip) = [|mkApp (refl, [|mkVar varB; mkApp (mkVar varf, [|lift (mip.mind_nrealargs+3) c|])|])|])))))) - + diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index d7507bd66c..ac6a61c3c4 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -43,7 +43,7 @@ val instantiate_type_indrec_scheme : sorts -> int -> constr -> types -> (** Complex recursion schemes [Scheme] *) -val build_mutual_indrec : +val build_mutual_indrec : env -> evar_map -> (inductive * mutual_inductive_body * one_inductive_body * bool * sorts_family) list @@ -53,7 +53,7 @@ val build_mutual_indrec : val type_rec_branches : bool -> env -> evar_map -> inductive_type -> constr -> constr -> constr array * constr -val make_rec_branch_arg : +val make_rec_branch_arg : env -> evar_map -> int * ('b * constr) option array * int -> constr -> constructor_summary -> wf_paths list -> constr diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 727fd6f859..bfe1522f9c 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -71,15 +71,15 @@ let substnl_ind_type l n = map_inductive_type (substnl l n) let mkAppliedInd (IndType ((ind,params), realargs)) = applist (mkInd ind,params@realargs) -(* Does not consider imbricated or mutually recursive types *) -let mis_is_recursive_subset listind rarg = - let rec one_is_rec rvec = +(* Does not consider imbricated or mutually recursive types *) +let mis_is_recursive_subset listind rarg = + let rec one_is_rec rvec = List.exists (fun ra -> match dest_recarg ra with - | Mrec i -> List.mem i listind + | Mrec i -> List.mem i listind | _ -> false) rvec - in + in array_exists one_is_rec (dest_subterms rarg) let mis_is_recursive (ind,mib,mip) = @@ -90,7 +90,7 @@ let mis_nf_constructor_type (ind,mib,mip) j = let specif = mip.mind_nf_lc and ntypes = mib.mind_ntypes and nconstr = Array.length mip.mind_consnames in - let make_Ik k = mkInd ((fst ind),ntypes-k-1) in + let make_Ik k = mkInd ((fst ind),ntypes-k-1) in if j > nconstr then error "Not enough constructors in the type."; substl (list_tabulate make_Ik ntypes) specif.(j-1) @@ -101,15 +101,15 @@ let mis_constr_nargs indsp = let recargs = dest_subterms mip.mind_recargs in Array.map List.length recargs -let mis_constr_nargs_env env (kn,i) = +let mis_constr_nargs_env env (kn,i) = let mib = Environ.lookup_mind kn env in - let mip = mib.mind_packets.(i) in + let mip = mib.mind_packets.(i) in let recargs = dest_subterms mip.mind_recargs in Array.map List.length recargs let mis_constructor_nargs_env env ((kn,i),j) = let mib = Environ.lookup_mind kn env in - let mip = mib.mind_packets.(i) in + let mip = mib.mind_packets.(i) in recarg_length mip.mind_recargs j + mib.mind_nparams let constructor_nrealargs env (ind,j) = @@ -124,7 +124,7 @@ let get_full_arity_sign env ind = let (mib,mip) = Inductive.lookup_mind_specif env ind in mip.mind_arity_ctxt -let nconstructors ind = +let nconstructors ind = let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in Array.length mip.mind_consnames @@ -175,7 +175,7 @@ let instantiate_params t args sign = (match kind_of_term t with | Prod(_,_,t) -> inst (a::s) t (ctxt,args) | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") - | ((_,(Some b),_)::ctxt,args) -> + | ((_,(Some b),_)::ctxt,args) -> (match kind_of_term t with | LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args) | _ -> anomaly"instantiate_params: type, ctxt and args mismatch") @@ -252,7 +252,7 @@ let build_dependent_constructor cs = let build_dependent_inductive env ((ind, params) as indf) = let arsign,_ = get_arity env indf in let nrealargs = List.length arsign in - applist + applist (mkInd ind, (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign)) @@ -325,7 +325,7 @@ let find_coinductive env sigma c = (* find appropriate names for pattern variables. Useful in the Case and Inversion (case_then_using et case_nodep_then_using) tactics. *) -let is_predicate_explicitly_dep env pred arsign = +let is_predicate_explicitly_dep env pred arsign = let rec srec env pval arsign = let pv' = whd_betadeltaiota env Evd.empty pval in match kind_of_term pv', arsign with @@ -405,7 +405,7 @@ let arity_of_case_predicate env (ind,params) dep k = (* Check if u (sort of a parameter) appears in the sort of the inductive (is). This is done by trying to enforce u > u' >= is in the empty univ graph. If an inconsistency appears, then - is depends on u. *) + is depends on u. *) let is_constrained is u = try let u' = fresh_local_univ() in @@ -456,7 +456,7 @@ let type_of_inductive_knowing_conclusion env mip conclty = (* A function which checks that a term well typed verifies both syntactic conditions *) -let control_only_guard env c = +let control_only_guard env c = let check_fix_cofix e c = match kind_of_term c with | CoFix (_,(_,_,_) as cofix) -> Inductive.check_cofix e cofix @@ -464,12 +464,12 @@ let control_only_guard env c = Inductive.check_fix e fix | _ -> () in - let rec iter env c = - check_fix_cofix env c; + let rec iter env c = + check_fix_cofix env c; iter_constr_with_full_binders push_rel iter env c in iter env c -let subst_inductive subst (kn,i as ind) = +let subst_inductive subst (kn,i as ind) = let kn' = Mod_subst.subst_kn subst kn in if kn == kn' then ind else (kn',i) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index cea769955e..a9a51d9ac5 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -110,7 +110,7 @@ val type_case_branches_with_names : types array * types val make_case_info : env -> inductive -> case_style -> case_info -(*i Compatibility +(*i Compatibility val make_default_case_info : env -> case_style -> inductive -> case_info i*) diff --git a/pretyping/matching.ml b/pretyping/matching.ml index 341fc28f27..0b1e05de98 100644 --- a/pretyping/matching.ml +++ b/pretyping/matching.ml @@ -75,15 +75,15 @@ let add_binders na1 na2 (names,terms as subst) = ((id1,id2)::names,terms)); | _ -> subst -let build_lambda toabstract stk (m : constr) = - let rec buildrec m p_0 p_1 = match p_0,p_1 with +let build_lambda toabstract stk (m : constr) = + let rec buildrec m p_0 p_1 = match p_0,p_1 with | (_, []) -> m - | (n, (na,t)::tl) -> + | (n, (na,t)::tl) -> if List.mem n toabstract then buildrec (mkLambda (na,t,m)) (n+1) tl - else + else buildrec (lift (-1) m) (n+1) tl - in + in buildrec m 1 stk let memb_metavars m n = @@ -98,7 +98,7 @@ let same_case_structure (_,cs1,ind,_) ci2 br1 br2 = | Some ind -> ind = ci2.ci_ind | None -> cs1 = ci2.ci_cstr_nargs -let matches_core convert allow_partial_app pat c = +let matches_core convert allow_partial_app pat c = let conv = match convert with | None -> eq_constr | Some (env,sigma) -> is_conv env sigma in @@ -127,7 +127,7 @@ let matches_core convert allow_partial_app pat c = let frels = Intset.elements (free_rels cT) in if List.for_all (fun i -> i > depth) frels then constrain (n,lift (-depth) cT) subst - else + else raise PatternMatchingFailure | PMeta None, m -> subst @@ -195,7 +195,7 @@ let matches_core convert allow_partial_app pat c = | PCase (ci1,p1,a1,br1), Case (ci2,p2,a2,br2) -> if same_case_structure ci1 ci2 br1 br2 then - array_fold_left2 (sorec stk) + array_fold_left2 (sorec stk) (sorec stk (sorec stk subst a1 a2) p1 p2) br1 br2 else raise PatternMatchingFailure @@ -216,7 +216,7 @@ let special_meta = (-1) (* Tells if it is an authorized occurrence and if the instance is closed *) let authorized_occ partial_app closed pat c mk_ctx next = - try + try let sigma = matches_core None partial_app pat c in if closed && not (List.for_all (fun (_,c) -> closed0 c) (snd sigma)) then next () @@ -251,7 +251,7 @@ let sub_match ?(partial_app=false) ?(closed=true) pat c = if topdown then let lc1 = Array.sub lc 0 (Array.length lc - 1) in let app = mkApp (c1,lc1) in - let mk_ctx = function + let mk_ctx = function | [app';c] -> mk_ctx (mkApp (app',[|c|])) | _ -> assert false in try_aux [app;array_last lc] mk_ctx next @@ -274,7 +274,7 @@ let sub_match ?(partial_app=false) ?(closed=true) pat c = try_aux (c1::Array.to_list lc) mk_ctx next) | Case (ci,hd,c1,lc) -> authorized_occ partial_app closed pat c mk_ctx (fun () -> - let mk_ctx le = + let mk_ctx le = mk_ctx (mkCase (ci,hd,List.hd le,Array.of_list (List.tl le))) in try_aux (c1::Array.to_list lc) mk_ctx next) | Construct _ | Fix _ | Ind _|CoFix _ |Evar _|Const _ diff --git a/pretyping/matching.mli b/pretyping/matching.mli index 4b3bc6c05c..98d16b1128 100644 --- a/pretyping/matching.mli +++ b/pretyping/matching.mli @@ -34,7 +34,7 @@ val matches : constr_pattern -> constr -> patvar_map in [c] that matches the bound variables in [pat]; if several bound variables or metavariables have the same name, the metavariable, or else the rightmost bound variable, takes precedence *) -val extended_matches : +val extended_matches : constr_pattern -> constr -> bound_ident_map * patvar_map (* [is_matching pat c] just tells if [c] matches against [pat] *) @@ -59,14 +59,14 @@ type subterm_matching_result = val match_subterm : constr_pattern -> constr -> subterm_matching_result (* [match_appsubterm pat c] returns the substitution and the context - corresponding to the first **closed** subterm of [c] matching [pat], + corresponding to the first **closed** subterm of [c] matching [pat], considering application contexts as well. It also returns a continuation that looks for the next matching subterm. It raises PatternMatchingFailure if no subterm matches the pattern *) val match_appsubterm : constr_pattern -> constr -> subterm_matching_result (* [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *) -val match_subterm_gen : bool (* true = with app context *) -> +val match_subterm_gen : bool (* true = with app context *) -> constr_pattern -> constr -> subterm_matching_result (* [is_matching_appsubterm pat c] tells if a subterm of [c] matches diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index d4b21fba50..be37e6531c 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -69,8 +69,8 @@ exception BoundPattern;; let rec head_pattern_bound t = match t with - | PProd (_,_,b) -> head_pattern_bound b - | PLetIn (_,_,b) -> head_pattern_bound b + | PProd (_,_,b) -> head_pattern_bound b + | PLetIn (_,_,b) -> head_pattern_bound b | PApp (c,args) -> head_pattern_bound c | PIf (c,_,_) -> head_pattern_bound c | PCase (_,p,c,br) -> head_pattern_bound c @@ -149,11 +149,11 @@ let rec subst_pattern subst pat = match pat with let ref',t = subst_global subst ref in if ref' == ref then pat else pattern_of_constr t - | PVar _ + | PVar _ | PEvar _ | PRel _ -> pat | PApp (f,args) -> - let f' = subst_pattern subst f in + let f' = subst_pattern subst f in let args' = array_smartmap (subst_pattern subst) args in if f' == f && args' == args then pat else PApp (f',args') @@ -176,7 +176,7 @@ let rec subst_pattern subst pat = match pat with let c2' = subst_pattern subst c2 in if c1' == c1 && c2' == c2 then pat else PLetIn (name,c1',c2') - | PSort _ + | PSort _ | PMeta _ -> pat | PIf (c,c1,c2) -> let c' = subst_pattern subst c in @@ -186,12 +186,12 @@ let rec subst_pattern subst pat = match pat with PIf (c',c1',c2') | PCase ((a,b,ind,n as cs),typ,c,branches) -> let ind' = Option.smartmap (Inductiveops.subst_inductive subst) ind in - let typ' = subst_pattern subst typ in + let typ' = subst_pattern subst typ in let c' = subst_pattern subst c in let branches' = array_smartmap (subst_pattern subst) branches in let cs' = if ind == ind' then cs else (a,b,ind',n) in if typ' == typ && c' == c && branches' == branches then pat else - PCase(cs',typ', c', branches') + PCase(cs',typ', c', branches') | PFix fixpoint -> let cstr = mkFix fixpoint in let fixpoint' = destFix (subst_mps subst cstr) in @@ -204,7 +204,7 @@ let rec subst_pattern subst pat = match pat with PCoFix cofixpoint' let mkPLambda na b = PLambda(na,PMeta None,b) -let rev_it_mkPLambda = List.fold_right mkPLambda +let rev_it_mkPLambda = List.fold_right mkPLambda let rec pat_of_raw metas vars = function | RVar (_,id) -> @@ -217,14 +217,14 @@ let rec pat_of_raw metas vars = function (* Hack pour ne pas réécrire une interprétation complète des patterns*) | RApp (_, RPatVar (_,(true,n)), cl) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) - | RApp (_,c,cl) -> + | RApp (_,c,cl) -> PApp (pat_of_raw metas vars c, Array.of_list (List.map (pat_of_raw metas vars) cl)) | RLambda (_,na,bk,c1,c2) -> name_iter (fun n -> metas := n::!metas) na; PLambda (na, pat_of_raw metas vars c1, pat_of_raw metas (na::vars) c2) - | RProd (_,na,bk,c1,c2) -> + | RProd (_,na,bk,c1,c2) -> name_iter (fun n -> metas := n::!metas) na; PProd (na, pat_of_raw metas vars c1, pat_of_raw metas (na::vars) c2) @@ -264,7 +264,7 @@ let rec pat_of_raw metas vars = function let cstr_nargs,brs = (Array.map fst cbrs, Array.map snd cbrs) in PCase ((sty,cstr_nargs,ind,ind_nargs), pred, pat_of_raw metas vars c, brs) - + | r -> let loc = loc_of_rawconstr r in user_err_loc (loc,"pattern_of_rawconstr", Pp.str"Non supported pattern.") @@ -287,7 +287,7 @@ and pat_of_raw_branch loc metas vars ind brs i = | PatCstr(loc,_,_,_) -> user_err_loc (loc,"pattern_of_rawconstr", Pp.str "Non supported pattern.")) lv in - let vars' = List.rev lna @ vars in + let vars' = List.rev lna @ vars in List.length lv, rev_it_mkPLambda lna (pat_of_raw metas vars' br) | _ -> user_err_loc (loc,"pattern_of_rawconstr", str "No unique branch for " ++ int (i+1) ++ diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli index ee0eefade7..b0229ab618 100644 --- a/pretyping/pattern.mli +++ b/pretyping/pattern.mli @@ -72,7 +72,7 @@ val pattern_of_constr : constr -> constr_pattern a pattern; variables bound in [l] are replaced by the pattern to which they are bound *) -val pattern_of_rawconstr : rawconstr -> +val pattern_of_rawconstr : rawconstr -> patvar list * constr_pattern val instantiate_pattern : diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 06d1aa533b..aa83f71c27 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -25,7 +25,7 @@ type pretype_error = (* Unification *) | OccurCheck of existential_key * constr | NotClean of existential_key * constr * Evd.hole_kind - | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind * + | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind * Evd.unsolvability_explanation option | CannotUnify of constr * constr | CannotUnifyLocal of constr * constr * constr @@ -47,7 +47,7 @@ let precatchable_exception = function | _ -> false let nf_evar = Reductionops.nf_evar -let j_nf_evar sigma j = +let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; uj_type = nf_evar sigma j.uj_type } let jl_nf_evar sigma jl = List.map (j_nf_evar sigma) jl @@ -76,7 +76,7 @@ let contract env lc = | Some c' when isRel c' -> l := (substl !l c') :: !l; env - | _ -> + | _ -> let t' = substl !l t in let c' = Option.map (substl !l) c in let na' = named_hd env t' na in @@ -161,7 +161,7 @@ let error_unsolvable_implicit loc env sigma evi e explain = let error_cannot_unify env sigma (m,n) = raise (PretypeError (env_ise sigma env,CannotUnify (m,n))) -let error_cannot_unify_local env sigma (m,n,sn) = +let error_cannot_unify_local env sigma (m,n,sn) = raise (PretypeError (env_ise sigma env,CannotUnifyLocal (m,n,sn))) let error_cannot_coerce env sigma (m,n) = diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index a276b4ed51..ca48f70211 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -27,7 +27,7 @@ type pretype_error = (* Unification *) | OccurCheck of existential_key * constr | NotClean of existential_key * constr * Evd.hole_kind - | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind * + | UnsolvableImplicit of Evd.evar_info * Evd.hole_kind * Evd.unsolvability_explanation option | CannotUnify of constr * constr | CannotUnifyLocal of constr * constr * constr @@ -59,22 +59,22 @@ val tj_nf_evar : val error_actual_type_loc : loc -> env -> Evd.evar_map -> unsafe_judgment -> constr -> 'b -val error_cant_apply_not_functional_loc : +val error_cant_apply_not_functional_loc : loc -> env -> Evd.evar_map -> unsafe_judgment -> unsafe_judgment list -> 'b -val error_cant_apply_bad_type_loc : - loc -> env -> Evd.evar_map -> int * constr * constr -> +val error_cant_apply_bad_type_loc : + loc -> env -> Evd.evar_map -> int * constr * constr -> unsafe_judgment -> unsafe_judgment list -> 'b val error_case_not_inductive_loc : loc -> env -> Evd.evar_map -> unsafe_judgment -> 'b -val error_ill_formed_branch_loc : +val error_ill_formed_branch_loc : loc -> env -> Evd.evar_map -> constr -> int -> constr -> constr -> 'b -val error_number_branches_loc : +val error_number_branches_loc : loc -> env -> Evd.evar_map -> unsafe_judgment -> int -> 'b @@ -95,7 +95,7 @@ val error_not_clean : env -> Evd.evar_map -> existential_key -> constr -> loc * Evd.hole_kind -> 'b val error_unsolvable_implicit : - loc -> env -> Evd.evar_map -> Evd.evar_info -> Evd.hole_kind -> + loc -> env -> Evd.evar_map -> Evd.evar_info -> Evd.hole_kind -> Evd.unsolvability_explanation option -> 'b val error_cannot_unify : env -> Evd.evar_map -> constr * constr -> 'b diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index d8ae031305..956b778e06 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -23,7 +23,7 @@ open Libnames open Nameops open Classops open List -open Recordops +open Recordops open Evarutil open Pretype_errors open Rawterm @@ -47,27 +47,27 @@ open Inductiveops exception Found of int array -let search_guard loc env possible_indexes fixdefs = +let search_guard loc env possible_indexes fixdefs = (* Standard situation with only one possibility for each fix. *) (* We treat it separately in order to get proper error msg. *) - if List.for_all (fun l->1=List.length l) possible_indexes then - let indexes = Array.of_list (List.map List.hd possible_indexes) in + if List.for_all (fun l->1=List.length l) possible_indexes then + let indexes = Array.of_list (List.map List.hd possible_indexes) in let fix = ((indexes, 0),fixdefs) in - (try check_fix env fix with + (try check_fix env fix with | e -> if loc = dummy_loc then raise e else Stdpp.raise_with_loc loc e); indexes else (* we now search recursively amoungst all combinations *) - (try - List.iter - (fun l -> - let indexes = Array.of_list l in + (try + List.iter + (fun l -> + let indexes = Array.of_list l in let fix = ((indexes, 0),fixdefs) in - try check_fix env fix; raise (Found indexes) + try check_fix env fix; raise (Found indexes) with TypeError _ -> ()) - (list_combinations possible_indexes); - let errmsg = "Cannot guess decreasing argument of fix." in - if loc = dummy_loc then error errmsg else + (list_combinations possible_indexes); + let errmsg = "Cannot guess decreasing argument of fix." in + if loc = dummy_loc then error errmsg else user_err_loc (loc,"search_guard", Pp.str errmsg) with Found indexes -> indexes) @@ -76,66 +76,66 @@ let ((constr_in : constr -> Dyn.t), (constr_out : Dyn.t -> constr)) = create "constr" (** Miscellaneous interpretation functions *) - + let interp_sort = function | RProp c -> Prop c | RType _ -> new_Type_sort () - + let interp_elimination_sort = function | RProp Null -> InProp | RProp Pos -> InSet | RType _ -> InType -module type S = +module type S = sig module Cases : Cases.S - + (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) val allow_anonymous_refs : bool ref (* Generic call to the interpreter from rawconstr to open_constr, leaving unresolved holes as evars and returning the typing contexts of these evars. Work as [understand_gen] for the rest. *) - + val understand_tcc : ?resolve_classes:bool -> evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr val understand_tcc_evars : ?fail_evar:bool -> ?resolve_classes:bool -> evar_defs ref -> env -> typing_constraint -> rawconstr -> constr - + (* More general entry point with evars from ltac *) - + (* Generic call to the interpreter from rawconstr to constr, failing unresolved holes in the rawterm cannot be instantiated. - + In [understand_ltac sigma env ltac_env constraint c], - + sigma : initial set of existential variables (typically dependent subgoals) ltac_env : partial substitution of variables (used for the tactic language) - constraint : tell if interpreted as a possibly constrained term or a type + constraint : tell if interpreted as a possibly constrained term or a type *) - + val understand_ltac : evar_map -> env -> var_map * unbound_ltac_var_map -> typing_constraint -> rawconstr -> evar_defs * constr - + (* Standard call to get a constr from a rawconstr, resolving implicit args *) - + val understand : evar_map -> env -> ?expected_type:Term.types -> rawconstr -> constr - + (* Idem but the rawconstr is intended to be a type *) - + val understand_type : evar_map -> env -> rawconstr -> constr - + (* A generalization of the two previous case *) - - val understand_gen : typing_constraint -> evar_map -> env -> + + val understand_gen : typing_constraint -> evar_map -> env -> rawconstr -> constr - + (* Idem but returns the judgment of the understood term *) - + val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment (* Idem but do not fail on unresolved evars *) @@ -146,12 +146,12 @@ sig (* Internal of Pretyping... * Unused outside, but useful for debugging *) - val pretype : - type_constraint -> env -> evar_defs ref -> + val pretype : + type_constraint -> env -> evar_defs ref -> var_map * (identifier * identifier option) list -> rawconstr -> unsafe_judgment - - val pretype_type : + + val pretype_type : val_constraint -> env -> evar_defs ref -> var_map * (identifier * identifier option) list -> rawconstr -> unsafe_type_judgment @@ -190,27 +190,27 @@ module Pretyping_F (Coercion : Coercion.S) = struct let (evd',t) = f !evdref x y z in evdref := evd'; t - + let mt_evd = Evd.empty - + (* Utilisé pour inférer le prédicat des Cases *) (* Semble exagérement fort *) (* Faudra préférer une unification entre les types de toutes les clauses *) (* et autoriser des ? à rester dans le résultat de l'unification *) - + let evar_type_fixpoint loc env evdref lna lar vdefj = - let lt = Array.length vdefj in - if Array.length lar = lt then - for i = 0 to lt-1 do + let lt = Array.length vdefj in + if Array.length lar = lt then + for i = 0 to lt-1 do if not (e_cumul env evdref (vdefj.(i)).uj_type (lift lt lar.(i))) then error_ill_typed_rec_body_loc loc env !evdref i lna vdefj lar done - let check_branches_message loc env evdref c (explft,lft) = + let check_branches_message loc env evdref c (explft,lft) = for i = 0 to Array.length explft - 1 do - if not (e_cumul env evdref lft.(i) explft.(i)) then + if not (e_cumul env evdref lft.(i) explft.(i)) then let sigma = !evdref in error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i) done @@ -257,14 +257,14 @@ module Pretyping_F (Coercion : Coercion.S) = struct if n=0 then p else match kind_of_term p with | Lambda (_,_,c) -> decomp (n-1) c - | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) + | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1])) in let sign,s = decompose_prod_n n pj.uj_type in let ind = build_dependent_inductive env indf in let s' = mkProd (Anonymous, ind, s) in let ccl = lift 1 (decomp n pj.uj_val) in let ccl' = mkLambda (Anonymous, ind, ccl) in - {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign} + {uj_val=it_mkLambda ccl' sign; uj_type=it_mkProd s' sign} let evar_kind_of_term sigma c = kind_of_term (whd_evar sigma c) @@ -272,7 +272,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct (*************************************************************************) (* Main pretyping function *) - let pretype_ref evdref env ref = + let pretype_ref evdref env ref = let c = constr_of_global ref in make_judge c (Retyping.get_type_of env Evd.empty c) @@ -307,12 +307,12 @@ module Pretyping_F (Coercion : Coercion.S) = struct let j = (Retyping.get_judgment_of env !evdref c) in inh_conv_coerce_to_tycon loc env evdref j tycon - | RPatVar (loc,(someta,n)) -> + | RPatVar (loc,(someta,n)) -> anomaly "Found a pattern variable in a rawterm to type" - + | RHole (loc,k) -> let ty = - match tycon with + match tycon with | Some (None, ty) -> ty | None | Some _ -> e_new_evar evdref env ~src:(loc,InternalHole) (new_Type ()) in @@ -343,7 +343,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct (* Note: bodies are not used by push_rec_types, so [||] is safe *) let newenv = push_rec_types (names,ftys,[||]) env in let vdefj = - array_map2_i + array_map2_i (fun i ctxt def -> (* we lift nbfix times the type in tycon, because of * the nbfix variables pushed to newenv *) @@ -363,17 +363,17 @@ module Pretyping_F (Coercion : Coercion.S) = struct (* First, let's find the guard indexes. *) (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem worth the effort (except for huge mutual + but doing it properly involves delta-reduction, and it finally + doesn't seem worth the effort (except for huge mutual fixpoints ?) *) - let possible_indexes = Array.to_list (Array.mapi - (fun i (n,_) -> match n with + let possible_indexes = Array.to_list (Array.mapi + (fun i (n,_) -> match n with | Some n -> [n] | None -> list_map_i (fun i _ -> i) 0 ctxtv.(i)) vn) - in - let fixdecls = (names,ftys,fdefs) in - let indexes = search_guard loc env possible_indexes fixdecls in + in + let fixdecls = (names,ftys,fdefs) in + let indexes = search_guard loc env possible_indexes fixdecls in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | RCoFix i -> let cofix = (i,(names,ftys,fdefs)) in @@ -384,7 +384,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct | RSort (loc,s) -> inh_conv_coerce_to_tycon loc env evdref (pretype_sort s) tycon - | RApp (loc,f,args) -> + | RApp (loc,f,args) -> let fj = pretype empty_tycon env evdref lvar f in let floc = loc_of_rawconstr f in let rec apply_rec env n resj = function @@ -397,13 +397,13 @@ module Pretyping_F (Coercion : Coercion.S) = struct | Prod (na,c1,c2) -> let hj = pretype (mk_tycon c1) env evdref lvar c in let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in - apply_rec env (n+1) + apply_rec env (n+1) { uj_val = value; uj_type = typ } rest | _ -> let hj = pretype empty_tycon env evdref lvar c in - error_cant_apply_not_functional_loc + error_cant_apply_not_functional_loc (join_loc floc argloc) env !evdref resj [hj] in @@ -429,7 +429,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct let dom_valcon = valcon_of_tycon dom in let j = pretype_type dom_valcon env evdref lvar c1 in let var = (name,None,j.utj_val) in - let j' = pretype rng (push_rel var env) evdref lvar c2 in + let j' = pretype rng (push_rel var env) evdref lvar c2 in judge_of_abstraction env (orelse_name name name') j j' | RProd(loc,name,bk,c1,c2) -> @@ -447,12 +447,12 @@ module Pretyping_F (Coercion : Coercion.S) = struct try judge_of_product env name j j' with TypeError _ as e -> Stdpp.raise_with_loc loc e in inh_conv_coerce_to_tycon loc env evdref resj tycon - + | RLetIn(loc,name,c1,c2) -> - let j = + let j = match c1 with | RCast (loc, c, CastConv (DEFAULTcast, t)) -> - let tj = pretype_type empty_valcon env evdref lvar t in + let tj = pretype_type empty_valcon env evdref lvar t in pretype (mk_tycon tj.utj_val) env evdref lvar c | _ -> pretype empty_tycon env evdref lvar c1 in @@ -465,11 +465,11 @@ module Pretyping_F (Coercion : Coercion.S) = struct | RLetTuple (loc,nal,(na,po),c,d) -> let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = + let (IndType (indf,realargs)) = try find_rectype env !evdref cj.uj_type with Not_found -> let cloc = loc_of_rawconstr c in - error_case_not_inductive_loc cloc env !evdref cj + error_case_not_inductive_loc cloc env !evdref cj in let cstrs = get_constructors env indf in if Array.length cstrs <> 1 then @@ -496,7 +496,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct let ccl = nf_evar !evdref pj.utj_val in let psign = make_arity_signature env true indf in (* with names *) let p = it_mkLambda_or_LetIn ccl psign in - let inst = + let inst = (Array.to_list cs.cs_concl_realargs) @[build_dependent_constructor cs] in let lp = lift cs.cs_nargs p in @@ -506,46 +506,46 @@ module Pretyping_F (Coercion : Coercion.S) = struct let v = let mis,_ = dest_ind_family indf in let ci = make_case_info env mis LetStyle in - mkCase (ci, p, cj.uj_val,[|f|]) in + mkCase (ci, p, cj.uj_val,[|f|]) in { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } - | None -> + | None -> let tycon = lift_tycon cs.cs_nargs tycon in let fj = pretype tycon env_f evdref lvar d in let f = it_mkLambda_or_LetIn fj.uj_val fsign in let ccl = nf_evar !evdref fj.uj_type in let ccl = if noccur_between 1 cs.cs_nargs ccl then - lift (- cs.cs_nargs) ccl + lift (- cs.cs_nargs) ccl else - error_cant_find_case_type_loc loc env !evdref + error_cant_find_case_type_loc loc env !evdref cj.uj_val in let ccl = refresh_universes ccl in let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = let mis,_ = dest_ind_family indf in let ci = make_case_info env mis LetStyle in - mkCase (ci, p, cj.uj_val,[|f|] ) + mkCase (ci, p, cj.uj_val,[|f|] ) in { uj_val = v; uj_type = ccl }) | RIf (loc,c,(na,po),b1,b2) -> let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = + let (IndType (indf,realargs)) = try find_rectype env !evdref cj.uj_type with Not_found -> let cloc = loc_of_rawconstr c in error_case_not_inductive_loc cloc env !evdref cj in - let cstrs = get_constructors env indf in + let cstrs = get_constructors env indf in if Array.length cstrs <> 2 then user_err_loc (loc,"", str "If is only for inductive types with two constructors."); - let arsgn = + let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then (* Make dependencies from arity signature impossible *) - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in let nar = List.length arsgn in @@ -558,10 +558,10 @@ module Pretyping_F (Coercion : Coercion.S) = struct let pred = it_mkLambda_or_LetIn ccl psign in let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in let jtyp = inh_conv_coerce_to_tycon loc env evdref {uj_val = pred; - uj_type = typ} tycon + uj_type = typ} tycon in jtyp.uj_val, jtyp.uj_type - | None -> + | None -> let p = match tycon with | Some (None, ty) -> ty | None | Some _ -> @@ -574,18 +574,18 @@ module Pretyping_F (Coercion : Coercion.S) = struct let n = rel_context_length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist (pi, [build_dependent_constructor cs]) in - let csgn = + let csgn = if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args - else - List.map + List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + else + List.map (fun (n, b, t) -> match n with Name _ -> (n, b, t) | Anonymous -> (Name (id_of_string "H"), b, t)) cs.cs_args in - let env_c = push_rels csgn env in + let env_c = push_rels csgn env in let bj = pretype (mk_tycon pi) env_c evdref lvar b in it_mkLambda_or_LetIn bj.uj_val cs.cs_args in let b1 = f cstrs.(0) b1 in @@ -596,7 +596,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in { uj_val = v; uj_type = p } - + | RCases (loc,sty,po,tml,eqns) -> Cases.compile_cases loc sty ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) @@ -640,7 +640,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct let t = Retyping.get_type_of env sigma v in match kind_of_term (whd_betadeltaiota env sigma t) with | Sort s -> s - | Evar ev when is_Type (existential_type sigma ev) -> + | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort) evdref ev | _ -> anomaly "Found a type constraint which is not a type" in @@ -671,7 +671,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct (pretype_type empty_valcon env evdref lvar c).utj_val in evdref := fst (consider_remaining_unif_problems env !evdref); if resolve_classes then - evdref := + evdref := Typeclasses.resolve_typeclasses ~onlyargs:false ~split:true ~fail:fail_evar env !evdref; let c = nf_evar !evdref c' in @@ -688,7 +688,7 @@ module Pretyping_F (Coercion : Coercion.S) = struct let j = pretype empty_tycon env evdref ([],[]) c in let evd,_ = consider_remaining_unif_problems env !evdref in let evd = Typeclasses.resolve_typeclasses ~onlyargs:true ~split:false - ~fail:true env evd + ~fail:true env evd in let j = j_nf_evar evd j in check_evars env sigma evd (mkCast(j.uj_val,DEFAULTcast, j.uj_type)); diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 9b1f57484b..7524c72a64 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -20,7 +20,7 @@ open Evarutil (* An auxiliary function for searching for fixpoint guard indexes *) -val search_guard : +val search_guard : Util.loc -> env -> int list list -> rec_declaration -> int array type typing_constraint = OfType of types option | IsType @@ -28,56 +28,56 @@ type typing_constraint = OfType of types option | IsType type var_map = (identifier * unsafe_judgment) list type unbound_ltac_var_map = (identifier * identifier option) list -module type S = +module type S = sig module Cases : Cases.S - + (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) val allow_anonymous_refs : bool ref (* Generic call to the interpreter from rawconstr to open_constr, leaving unresolved holes as evars and returning the typing contexts of these evars. Work as [understand_gen] for the rest. *) - + val understand_tcc : ?resolve_classes:bool -> evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr - + val understand_tcc_evars : ?fail_evar:bool -> ?resolve_classes:bool -> evar_defs ref -> env -> typing_constraint -> rawconstr -> constr (* More general entry point with evars from ltac *) - + (* Generic call to the interpreter from rawconstr to constr, failing unresolved holes in the rawterm cannot be instantiated. - + In [understand_ltac sigma env ltac_env constraint c], - + sigma : initial set of existential variables (typically dependent subgoals) ltac_env : partial substitution of variables (used for the tactic language) - constraint : tell if interpreted as a possibly constrained term or a type + constraint : tell if interpreted as a possibly constrained term or a type *) - + val understand_ltac : evar_map -> env -> var_map * unbound_ltac_var_map -> typing_constraint -> rawconstr -> evar_defs * constr - + (* Standard call to get a constr from a rawconstr, resolving implicit args *) - + val understand : evar_map -> env -> ?expected_type:Term.types -> rawconstr -> constr - + (* Idem but the rawconstr is intended to be a type *) - + val understand_type : evar_map -> env -> rawconstr -> constr - + (* A generalization of the two previous case *) - - val understand_gen : typing_constraint -> evar_map -> env -> + + val understand_gen : typing_constraint -> evar_map -> env -> rawconstr -> constr - + (* Idem but returns the judgment of the understood term *) - + val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment (* Idem but do not fail on unresolved evars *) @@ -86,12 +86,12 @@ sig (*i*) (* Internal of Pretyping... *) - val pretype : - type_constraint -> env -> evar_defs ref -> + val pretype : + type_constraint -> env -> evar_defs ref -> var_map * (identifier * identifier option) list -> rawconstr -> unsafe_judgment - - val pretype_type : + + val pretype_type : val_constraint -> env -> evar_defs ref -> var_map * (identifier * identifier option) list -> rawconstr -> unsafe_type_judgment @@ -102,17 +102,17 @@ sig typing_constraint -> rawconstr -> constr (*i*) - + end module Pretyping_F (C : Coercion.S) : S module Default : S (* To embed constr in rawconstr *) - + val constr_in : constr -> Dyn.t val constr_out : Dyn.t -> constr -val interp_sort : rawsort -> sorts +val interp_sort : rawsort -> sorts val interp_elimination_sort : rawsort -> sorts_family diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml index d8eae2d0d6..727ac117ca 100644 --- a/pretyping/rawterm.ml +++ b/pretyping/rawterm.ml @@ -42,7 +42,7 @@ type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list -type 'a bindings = +type 'a bindings = | ImplicitBindings of 'a list | ExplicitBindings of 'a explicit_bindings | NoBindings @@ -53,7 +53,7 @@ type 'a cast_type = | CastConv of cast_kind * 'a | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *) -type rawconstr = +type rawconstr = | RRef of (loc * global_reference) | RVar of (loc * identifier) | REvar of loc * existential_key * rawconstr list option @@ -63,7 +63,7 @@ type rawconstr = | RProd of loc * name * binding_kind * rawconstr * rawconstr | RLetIn of loc * name * rawconstr * rawconstr | RCases of loc * case_style * rawconstr option * tomatch_tuples * cases_clauses - | RLetTuple of loc * name list * (name * rawconstr option) * + | RLetTuple of loc * name list * (name * rawconstr option) * rawconstr * rawconstr | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr | RRec of loc * fix_kind * identifier array * rawdecl list array * @@ -99,7 +99,7 @@ let cases_predicate_names tml = (*i - if PRec (_, names, arities, bodies) is in env then arities are typed in env too and bodies are typed in env enriched by the - arities incrementally lifted + arities incrementally lifted [On pourrait plutot mettre les arités aves le type qu'elles auront dans le contexte servant à typer les body ???] @@ -127,7 +127,7 @@ let map_rawconstr f = function Array.map f tyl,Array.map f bv) | RCast (loc,c,k) -> RCast (loc,f c, match k with CastConv (k,t) -> CastConv (k, f t) | x -> x) | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> x - + (* let name_app f e = function @@ -178,10 +178,10 @@ let occur_rawconstr id = (occur_option rtntypopt) or (List.exists (fun (tm,_) -> occur tm) tml) or (List.exists occur_pattern pl) - | RLetTuple (loc,nal,rtntyp,b,c) -> + | RLetTuple (loc,nal,rtntyp,b,c) -> occur_return_type rtntyp id or (occur b) or (not (List.mem (Name id) nal) & (occur c)) - | RIf (loc,c,rtntyp,b1,b2) -> + | RIf (loc,c,rtntyp,b1,b2) -> occur_return_type rtntyp id or (occur c) or (occur b1) or (occur b2) | RRec (loc,fk,idl,bl,tyl,bv) -> not (array_for_all4 (fun fid bl ty bd -> @@ -207,67 +207,67 @@ let occur_rawconstr id = in occur -let add_name_to_ids set na = - match na with - | Anonymous -> set - | Name id -> Idset.add id set +let add_name_to_ids set na = + match na with + | Anonymous -> set + | Name id -> Idset.add id set let free_rawvars = let rec vars bounded vs = function | RVar (loc,id') -> if Idset.mem id' bounded then vs else Idset.add id' vs | RApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args) - | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) -> - let vs' = vars bounded vs ty in - let bounded' = add_name_to_ids bounded na in + | RLambda (loc,na,_,ty,c) | RProd (loc,na,_,ty,c) | RLetIn (loc,na,ty,c) -> + let vs' = vars bounded vs ty in + let bounded' = add_name_to_ids bounded na in vars bounded' vs' c | RCases (loc,sty,rtntypopt,tml,pl) -> - let vs1 = vars_option bounded vs rtntypopt in - let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in + let vs1 = vars_option bounded vs rtntypopt in + let vs2 = List.fold_left (fun vs (tm,_) -> vars bounded vs tm) vs1 tml in List.fold_left (vars_pattern bounded) vs2 pl | RLetTuple (loc,nal,rtntyp,b,c) -> - let vs1 = vars_return_type bounded vs rtntyp in - let vs2 = vars bounded vs1 b in + let vs1 = vars_return_type bounded vs rtntyp in + let vs2 = vars bounded vs1 b in let bounded' = List.fold_left add_name_to_ids bounded nal in vars bounded' vs2 c - | RIf (loc,c,rtntyp,b1,b2) -> - let vs1 = vars_return_type bounded vs rtntyp in - let vs2 = vars bounded vs1 c in - let vs3 = vars bounded vs2 b1 in + | RIf (loc,c,rtntyp,b1,b2) -> + let vs1 = vars_return_type bounded vs rtntyp in + let vs2 = vars bounded vs1 c in + let vs3 = vars bounded vs2 b1 in vars bounded vs3 b2 | RRec (loc,fk,idl,bl,tyl,bv) -> - let bounded' = Array.fold_right Idset.add idl bounded in - let vars_fix i vs fid = - let vs1,bounded1 = - List.fold_left - (fun (vs,bounded) (na,k,bbd,bty) -> - let vs' = vars_option bounded vs bbd in + let bounded' = Array.fold_right Idset.add idl bounded in + let vars_fix i vs fid = + let vs1,bounded1 = + List.fold_left + (fun (vs,bounded) (na,k,bbd,bty) -> + let vs' = vars_option bounded vs bbd in let vs'' = vars bounded vs' bty in - let bounded' = add_name_to_ids bounded na in + let bounded' = add_name_to_ids bounded na in (vs'',bounded') ) (vs,bounded') bl.(i) in - let vs2 = vars bounded1 vs1 tyl.(i) in + let vs2 = vars bounded1 vs1 tyl.(i) in vars bounded1 vs2 bv.(i) in array_fold_left_i vars_fix vs idl - | RCast (loc,c,k) -> let v = vars bounded vs c in + | RCast (loc,c,k) -> let v = vars bounded vs c in (match k with CastConv (_,t) -> vars bounded v t | _ -> v) | (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> vs - and vars_pattern bounded vs (loc,idl,p,c) = - let bounded' = List.fold_right Idset.add idl bounded in + and vars_pattern bounded vs (loc,idl,p,c) = + let bounded' = List.fold_right Idset.add idl bounded in vars bounded' vs c and vars_option bounded vs = function None -> vs | Some p -> vars bounded vs p - and vars_return_type bounded vs (na,tyopt) = - let bounded' = add_name_to_ids bounded na in + and vars_return_type bounded vs (na,tyopt) = + let bounded' = add_name_to_ids bounded na in vars_option bounded' vs tyopt - in - fun rt -> - let vs = vars Idset.empty Idset.empty rt in + in + fun rt -> + let vs = vars Idset.empty Idset.empty rt in Idset.elements vs diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli index 6bb4eceb37..5cf227440a 100644 --- a/pretyping/rawterm.mli +++ b/pretyping/rawterm.mli @@ -46,7 +46,7 @@ type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier type 'a explicit_bindings = (loc * quantified_hypothesis * 'a) list -type 'a bindings = +type 'a bindings = | ImplicitBindings of 'a list | ExplicitBindings of 'a explicit_bindings | NoBindings @@ -57,7 +57,7 @@ type 'a cast_type = | CastConv of cast_kind * 'a | CastCoerce (* Cast to a base type (eg, an underlying inductive type) *) -type rawconstr = +type rawconstr = | RRef of (loc * global_reference) | RVar of (loc * identifier) | REvar of loc * existential_key * rawconstr list option @@ -67,7 +67,7 @@ type rawconstr = | RProd of loc * name * binding_kind * rawconstr * rawconstr | RLetIn of loc * name * rawconstr * rawconstr | RCases of loc * case_style * rawconstr option * tomatch_tuples * cases_clauses - | RLetTuple of loc * name list * (name * rawconstr option) * + | RLetTuple of loc * name list * (name * rawconstr option) * rawconstr * rawconstr | RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr | RRec of loc * fix_kind * identifier array * rawdecl list array * @@ -100,7 +100,7 @@ val cases_predicate_names : tomatch_tuples -> name list (*i - if PRec (_, names, arities, bodies) is in env then arities are typed in env too and bodies are typed in env enriched by the - arities incrementally lifted + arities incrementally lifted [On pourrait plutot mettre les arités aves le type qu'elles auront dans le contexte servant à typer les body ???] @@ -112,7 +112,7 @@ i*) val map_rawconstr : (rawconstr -> rawconstr) -> rawconstr -> rawconstr (*i -val map_rawconstr_with_binders_loc : loc -> +val map_rawconstr_with_binders_loc : loc -> (identifier -> 'a -> identifier * 'a) -> ('a -> rawconstr -> rawconstr) -> 'a -> rawconstr -> rawconstr i*) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index c298959123..048ec92de3 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -32,7 +32,7 @@ open Reductionops projection ou bien une fonction constante (associée à un LetIn) *) type struc_typ = { - s_CONST : constructor; + s_CONST : constructor; s_EXPECTEDPARAM : int; s_PROJKIND : (name * bool) list; s_PROJ : constant option list } @@ -45,19 +45,19 @@ let load_structure i (_,(ind,id,kl,projs)) = let struc = { s_CONST = id; s_EXPECTEDPARAM = n; s_PROJ = projs; s_PROJKIND = kl } in structure_table := Indmap.add ind struc !structure_table; - projection_table := + projection_table := List.fold_right (Option.fold_right (fun proj -> Cmap.add proj struc)) projs !projection_table let cache_structure o = load_structure 1 o -let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) = +let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) = let kn' = subst_kn subst kn in let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) - list_smartmap + list_smartmap (Option.smartmap (fun kn -> fst (subst_con subst kn))) projs in @@ -65,7 +65,7 @@ let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) = if projs' == projs && kn' == kn && id' == id then obj else ((kn',i),id',kl,projs') -let discharge_constructor (ind, n) = +let discharge_constructor (ind, n) = (Lib.discharge_inductive ind, n) let discharge_structure (_,(ind,id,kl,projs)) = @@ -73,7 +73,7 @@ let discharge_structure (_,(ind,id,kl,projs)) = List.map (Option.map Lib.discharge_con) projs) let (inStruc,outStruc) = - declare_object {(default_object "STRUCTURE") with + declare_object {(default_object "STRUCTURE") with cache_function = cache_structure; load_function = load_structure; subst_function = subst_structure; @@ -81,7 +81,7 @@ let (inStruc,outStruc) = discharge_function = discharge_structure; export_function = (function x -> Some x) } -let declare_structure (s,c,kl,pl) = +let declare_structure (s,c,kl,pl) = Lib.add_anonymous_leaf (inStruc (s,c,kl,pl)) let lookup_structure indsp = Indmap.find indsp !structure_table @@ -99,21 +99,21 @@ let find_projection = function (* Management of a field store : each field + argument of the inferred * records are stored in a discrimination tree *) -let subst_id s (gr,ev,evm) = +let subst_id s (gr,ev,evm) = (fst(subst_global s gr),ev,Evd.subst_evar_map s evm) -module MethodsDnet : Term_dnet.S +module MethodsDnet : Term_dnet.S with type ident = global_reference * Evd.evar * Evd.evar_map = Term_dnet.Make - (struct + (struct type t = global_reference * Evd.evar * Evd.evar_map let compare = Pervasives.compare let subst = subst_id let constr_of (_,ev,evm) = Evd.evar_concl (Evd.find evm ev) - end) - (struct - let reduce c = Reductionops.head_unfold_under_prod - Names.full_transparent_state (Global.env()) Evd.empty c + end) + (struct + let reduce c = Reductionops.head_unfold_under_prod + Names.full_transparent_state (Global.env()) Evd.empty c let direction = true end) @@ -121,7 +121,7 @@ let meth_dnet = ref MethodsDnet.empty open Summary -let _ = +let _ = declare_summary "record-methods-state" { freeze_function = (fun () -> !meth_dnet); unfreeze_function = (fun m -> meth_dnet := m); @@ -132,14 +132,14 @@ open Libobject let load_method (_,(ty,id)) = meth_dnet := MethodsDnet.add ty id !meth_dnet -let (in_method,out_method) = +let (in_method,out_method) = declare_object { (default_object "RECMETHODS") with load_function = (fun _ -> load_method); cache_function = load_method; subst_function = (fun (_,s,(ty,id)) -> Mod_subst.subst_mps s ty,subst_id s id); export_function = (fun x -> Some x); - classify_function = (fun x -> Substitute x) + classify_function = (fun x -> Substitute x) } let methods_matching c = MethodsDnet.search_pattern !meth_dnet c @@ -188,7 +188,7 @@ type cs_pattern = let object_table = ref (Refmap.empty : (cs_pattern * obj_typ) list Refmap.t) -let canonical_projections () = +let canonical_projections () = Refmap.fold (fun x -> List.fold_right (fun (y,c) acc -> ((x,y),c)::acc)) !object_table [] @@ -198,19 +198,19 @@ let keep_true_projections projs kinds = let cs_pattern_of_constr t = match kind_of_term t with - App (f,vargs) -> - begin + App (f,vargs) -> + begin try Const_cs (global_of_constr f) , -1, Array.to_list vargs with - _ -> raise Not_found - end + _ -> raise Not_found + end | Rel n -> Default_cs, pred n, [] | Prod (_,a,b) when not (dependent (mkRel 1) b) -> Prod_cs, -1, [a;pop b] | Sort s -> Sort_cs (family_of_sort s), -1, [] - | _ -> - begin + | _ -> + begin try Const_cs (global_of_constr t) , -1, [] with - _ -> raise Not_found - end + _ -> raise Not_found + end (* Intended to always succeed *) let compute_canonical_projections (con,ind) = @@ -219,7 +219,7 @@ let compute_canonical_projections (con,ind) = let lt,t = Reductionops.splay_lam (Global.env()) Evd.empty c in let lt = List.rev (List.map snd lt) in let args = snd (decompose_app t) in - let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = + let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in let params, projs = list_chop p args in let lpj = keep_true_projections lpj kl in @@ -230,16 +230,16 @@ let compute_canonical_projections (con,ind) = match spopt with | Some proji_sp -> begin - try + try let patt, n , args = cs_pattern_of_constr t in ((ConstRef proji_sp, patt, n, args) :: l) - with Not_found -> l + with Not_found -> l end | _ -> l) [] lps in List.map (fun (refi,c,inj,argj) -> (refi,c), - {o_DEF=v; o_INJ=inj; o_TABS=lt; + {o_DEF=v; o_INJ=inj; o_TABS=lt; o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj}) comp @@ -265,7 +265,7 @@ let discharge_canonical_structure (_,(cst,ind)) = Some (Lib.discharge_con cst,Lib.discharge_inductive ind) let (inCanonStruc,outCanonStruct) = - declare_object {(default_object "CANONICAL-STRUCTURE") with + declare_object {(default_object "CANONICAL-STRUCTURE") with open_function = open_canonical_structure; cache_function = cache_canonical_structure; subst_function = subst_canonical_structure; @@ -309,7 +309,7 @@ let lookup_canonical_conversion (proj,pat) = List.assoc pat (Refmap.find proj !object_table) let is_open_canonical_projection sigma (c,args) = - try + try let l = Refmap.find (global_of_constr c) !object_table in let n = (snd (List.hd l)).o_NPARAMS in try isEvar_or_Meta (whd_evar sigma (List.nth args n)) with Failure _ -> false @@ -318,7 +318,7 @@ let is_open_canonical_projection sigma (c,args) = let freeze () = !structure_table, !projection_table, !object_table -let unfreeze (s,p,o) = +let unfreeze (s,p,o) = structure_table := s; projection_table := p; object_table := o let init () = @@ -327,7 +327,7 @@ let init () = let _ = init() -let _ = +let _ = Summary.declare_summary "objdefs" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 4d28ee55b1..5d3180ff7b 100755 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -22,12 +22,12 @@ open Library constructor (the name of which defaults to Build_S) *) type struc_typ = { - s_CONST : constructor; + s_CONST : constructor; s_EXPECTEDPARAM : int; s_PROJKIND : (name * bool) list; s_PROJ : constant option list } -val declare_structure : +val declare_structure : inductive * constructor * (name * bool) list * constant option list -> unit (* [lookup_projections isp] returns the projections associated to the @@ -46,8 +46,8 @@ val find_projection : global_reference -> struc_typ val declare_method : global_reference -> Evd.evar -> Evd.evar_map -> unit (* and here is how to search for methods matched by a given term: *) -val methods_matching : constr -> - ((global_reference*Evd.evar*Evd.evar_map) * +val methods_matching : constr -> + ((global_reference*Evd.evar*Evd.evar_map) * (constr*existential_key)*Termops.subst) list (*s A canonical structure declares "canonical" conversion hints between *) @@ -56,7 +56,7 @@ val methods_matching : constr -> type cs_pattern = Const_cs of global_reference - | Prod_cs + | Prod_cs | Sort_cs of sorts_family | Default_cs @@ -69,10 +69,10 @@ type obj_typ = { o_TCOMPS : constr list } (* ordered *) val cs_pattern_of_constr : constr -> cs_pattern * int * constr list - + val lookup_canonical_conversion : (global_reference * cs_pattern) -> obj_typ val declare_canonical_structure : global_reference -> unit val is_open_canonical_projection : Evd.evar_map -> (constr * constr list) -> bool -val canonical_projections : unit -> +val canonical_projections : unit -> ((global_reference * cs_pattern) * obj_typ) list diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 1bff68cbf0..bbc0ceae7d 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -25,7 +25,7 @@ exception Elimconst (**********************************************************************) -(* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) +(* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) type 'a stack_member = | Zapp of 'a list @@ -80,12 +80,12 @@ let rec list_of_stack = function let rec app_stack = function | f, [] -> f | f, (Zapp [] :: s) -> app_stack (f, s) - | f, (Zapp args :: s) -> + | f, (Zapp args :: s) -> app_stack (applist (f, args), s) | _ -> assert false let rec stack_assign s p c = match s with | Zapp args :: s -> - let q = List.length args in + let q = List.length args in if p >= q then Zapp args :: stack_assign s (p-q) c else @@ -109,20 +109,20 @@ let rec stack_nth s p = match s with | _ -> raise Not_found (**************************************************************) -(* The type of (machine) states (= lambda-bar-calculus' cuts) *) +(* The type of (machine) states (= lambda-bar-calculus' cuts) *) type state = constr * constr stack type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr -type contextual_stack_reduction_function = +type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = evar_map -> constr -> constr * constr list -type contextual_state_reduction_function = +type contextual_state_reduction_function = env -> evar_map -> state -> state type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state @@ -159,16 +159,16 @@ let stack_reduction_of_reduction red_fun env sigma s = let t = red_fun env sigma (app_stack s) in whd_stack t -let strong whdfun env sigma t = +let strong whdfun env sigma t = let rec strongrec env t = map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in strongrec env t -let local_strong whdfun sigma = +let local_strong whdfun sigma = let rec strongrec t = map_constr strongrec (whdfun sigma t) in strongrec -let rec strong_prodspine redfun sigma c = +let rec strong_prodspine redfun sigma c = let x = redfun sigma c in match kind_of_term x with | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun sigma b) @@ -203,7 +203,7 @@ module RedFlags = (struct type flags = int let fbeta = 1 let fdelta = 2 - let feta = 8 + let feta = 8 let fiota = 16 let fzeta = 32 let mkflags = List.fold_left (lor) 0 @@ -282,7 +282,7 @@ let contract_fix ((recindices,bodynum),(types,names,bodies as typedbodies)) = let fix_recarg ((recindices,bodynum),_) stack = assert (0 <= bodynum & bodynum < Array.length recindices); let recargnum = Array.get recindices bodynum in - try + try Some (recargnum, stack_nth stack recargnum) with Not_found -> None @@ -303,12 +303,12 @@ let reduce_fix whdfun sigma fix stack = (* Y avait un commentaire pour whd_betadeltaiota : - NB : Cette fonction alloue peu c'est l'appel + NB : Cette fonction alloue peu c'est l'appel ``let (c,cargs) = whfun (recarg, empty_stack)'' ------------------- qui coute cher *) -let rec whd_state_gen flags env sigma = +let rec whd_state_gen flags env sigma = let rec whrec (x, stack as s) = match kind_of_term x with | Rel n when red_delta flags -> @@ -361,19 +361,19 @@ let rec whd_state_gen flags env sigma = whrec (reduce_mind_case {mP=p; mconstr=c; mcargs=list_of_stack cargs; mci=ci; mlf=lf}, stack) - else + else (mkCase (ci, p, app_stack (c,cargs), lf), stack) - + | Fix fix when red_iota flags -> (match reduce_fix (fun _ -> whrec) sigma fix stack with | Reduced s' -> whrec s' | NotReducible -> s) | x -> s - in + in whrec -let local_whd_state_gen flags sigma = +let local_whd_state_gen flags sigma = let rec whrec (x, stack as s) = match kind_of_term x with | LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack @@ -383,7 +383,7 @@ let local_whd_state_gen flags sigma = (match decomp_stack stack with | Some (a,m) when red_beta flags -> stacklam whrec [a] c m | None when red_eta flags -> - (match kind_of_term (app_stack (whrec (c, empty_stack))) with + (match kind_of_term (app_stack (whrec (c, empty_stack))) with | App (f,cl) -> let napp = Array.length cl in if napp > 0 then @@ -404,9 +404,9 @@ let local_whd_state_gen flags sigma = whrec (reduce_mind_case {mP=p; mconstr=c; mcargs=list_of_stack cargs; mci=ci; mlf=lf}, stack) - else + else (mkCase (ci, p, app_stack (c,cargs), lf), stack) - + | Fix fix when red_iota flags -> (match reduce_fix (fun _ ->whrec) sigma fix stack with | Reduced s' -> whrec s' @@ -423,7 +423,7 @@ let local_whd_state_gen flags sigma = | None -> s) | x -> s - in + in whrec @@ -464,7 +464,7 @@ let whd_betadelta env = let whd_betadeltaeta_state e = whd_state_gen betadeltaeta e let whd_betadeltaeta_stack env = stack_red_of_state_red (whd_betadeltaeta_state env) -let whd_betadeltaeta env = +let whd_betadeltaeta env = red_of_state_red (whd_betadeltaeta_state env) (* 3. Iota reduction Functions *) @@ -480,19 +480,19 @@ let whd_betaiotazeta = red_of_state_red whd_betaiotazeta_state let whd_betadeltaiota_state e = whd_state_gen betadeltaiota e let whd_betadeltaiota_stack env = stack_red_of_state_red (whd_betadeltaiota_state env) -let whd_betadeltaiota env = +let whd_betadeltaiota env = red_of_state_red (whd_betadeltaiota_state env) let whd_betadeltaiotaeta_state e = whd_state_gen betadeltaiotaeta e let whd_betadeltaiotaeta_stack env = stack_red_of_state_red (whd_betadeltaiotaeta_state env) -let whd_betadeltaiotaeta env = +let whd_betadeltaiotaeta env = red_of_state_red (whd_betadeltaiotaeta_state env) let whd_betadeltaiota_nolet_state e = whd_state_gen betadeltaiota_nolet e let whd_betadeltaiota_nolet_stack env = stack_red_of_state_red (whd_betadeltaiota_nolet_state env) -let whd_betadeltaiota_nolet env = +let whd_betadeltaiota_nolet env = red_of_state_red (whd_betadeltaiota_nolet_state env) (* 3. Eta reduction Functions *) @@ -530,53 +530,53 @@ let nf_betadeltaiota env sigma = clos_norm_flags Closure.betadeltaiota env sigma -(* Attention reduire un beta-redexe avec un argument qui n'est pas +(* Attention reduire un beta-redexe avec un argument qui n'est pas une variable, peut changer enormement le temps de conversion lors du type checking : (fun x => x + x) M *) -let rec whd_betaiota_preserving_vm_cast env sigma t = - let rec stacklam_var subst t stack = - match (decomp_stack stack,kind_of_term t) with - | Some (h,stacktl), Lambda (_,_,c) -> - begin match kind_of_term h with - | Rel i when not (evaluable_rel i env) -> - stacklam_var (h::subst) c stacktl - | Var id when not (evaluable_named id env)-> - stacklam_var (h::subst) c stacktl - | _ -> whrec (substl subst t, stack) - end - | _ -> whrec (substl subst t, stack) - and whrec (x, stack as s) = - match kind_of_term x with - | Evar ev -> - (match safe_evar_value sigma ev with - | Some body -> whrec (body, stack) - | None -> s) - | Cast (c,VMcast,t) -> - let c = app_stack (whrec (c,empty_stack)) in - let t = app_stack (whrec (t,empty_stack)) in - (mkCast(c,VMcast,t),stack) - | Cast (c,DEFAULTcast,_) -> - whrec (c, stack) - | App (f,cl) -> whrec (f, append_stack cl stack) - | Lambda (na,t,c) -> - (match decomp_stack stack with - | Some (a,m) -> stacklam_var [a] c m - | _ -> s) - | Case (ci,p,d,lf) -> - let (c,cargs) = whrec (d, empty_stack) in - if reducible_mind_case c then - whrec (reduce_mind_case - {mP=p; mconstr=c; mcargs=list_of_stack cargs; - mci=ci; mlf=lf}, stack) - else - (mkCase (ci, p, app_stack (c,cargs), lf), stack) - | x -> s - in +let rec whd_betaiota_preserving_vm_cast env sigma t = + let rec stacklam_var subst t stack = + match (decomp_stack stack,kind_of_term t) with + | Some (h,stacktl), Lambda (_,_,c) -> + begin match kind_of_term h with + | Rel i when not (evaluable_rel i env) -> + stacklam_var (h::subst) c stacktl + | Var id when not (evaluable_named id env)-> + stacklam_var (h::subst) c stacktl + | _ -> whrec (substl subst t, stack) + end + | _ -> whrec (substl subst t, stack) + and whrec (x, stack as s) = + match kind_of_term x with + | Evar ev -> + (match safe_evar_value sigma ev with + | Some body -> whrec (body, stack) + | None -> s) + | Cast (c,VMcast,t) -> + let c = app_stack (whrec (c,empty_stack)) in + let t = app_stack (whrec (t,empty_stack)) in + (mkCast(c,VMcast,t),stack) + | Cast (c,DEFAULTcast,_) -> + whrec (c, stack) + | App (f,cl) -> whrec (f, append_stack cl stack) + | Lambda (na,t,c) -> + (match decomp_stack stack with + | Some (a,m) -> stacklam_var [a] c m + | _ -> s) + | Case (ci,p,d,lf) -> + let (c,cargs) = whrec (d, empty_stack) in + if reducible_mind_case c then + whrec (reduce_mind_case + {mP=p; mconstr=c; mcargs=list_of_stack cargs; + mci=ci; mlf=lf}, stack) + else + (mkCase (ci, p, app_stack (c,cargs), lf), stack) + | x -> s + in app_stack (whrec (t,empty_stack)) -let nf_betaiota_preserving_vm_cast = +let nf_betaiota_preserving_vm_cast = strong whd_betaiota_preserving_vm_cast (* lazy weak head reduction functions *) @@ -638,12 +638,12 @@ let whd_meta metasubst c = match kind_of_term c with (* Try to replace all metas. Does not replace metas in the metas' values * Differs from (strong whd_meta). *) -let plain_instance s c = +let plain_instance s c = let rec irec n u = match kind_of_term u with | Meta p -> (try lift n (List.assoc p s) with Not_found -> u) | App (f,l) when isCast f -> let (f,_,t) = destCast f in - let l' = Array.map (irec n) l in + let l' = Array.map (irec n) l in (match kind_of_term f with | Meta p -> (* Don't flatten application nodes: this is used to extract a @@ -651,21 +651,21 @@ let plain_instance s c = of the proof-tree *) (try let g = List.assoc p s in match kind_of_term g with - | App _ -> + | App _ -> let h = id_of_string "H" in mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l')) | _ -> mkApp (g,l') with Not_found -> mkApp (f,l')) - | _ -> mkApp (irec n f,l')) + | _ -> mkApp (irec n f,l')) | Cast (m,_,_) when isMeta m -> (try lift n (List.assoc (destMeta m) s) with Not_found -> u) | _ -> map_constr_with_binders succ irec n u - in + in if s = [] then c else irec 0 c (* [instance] is used for [res_pf]; the call to [local_strong whd_betaiota] - has (unfortunately) different subtle side effects: + has (unfortunately) different subtle side effects: - ** Order of subgoals ** If the lemma is a case analysis with parameters, it will move the @@ -682,7 +682,7 @@ let plain_instance s c = been contracted). A goal to rewrite may then fail or succeed differently. - - ** Naming of hypotheses ** + - ** Naming of hypotheses ** If a lemma is a function of the form "fun H:(forall a:A, P a) => .. F H .." where the expected type of H is "forall b:A, P b", then, without reduction, the application of the lemma will @@ -713,24 +713,24 @@ let hnf_prod_app env sigma t n = | Prod (_,_,b) -> subst1 n b | _ -> anomaly "hnf_prod_app: Need a product" -let hnf_prod_appvect env sigma t nl = +let hnf_prod_appvect env sigma t nl = Array.fold_left (hnf_prod_app env sigma) t nl -let hnf_prod_applist env sigma t nl = +let hnf_prod_applist env sigma t nl = List.fold_left (hnf_prod_app env sigma) t nl - + let hnf_lam_app env sigma t n = match kind_of_term (whd_betadeltaiota env sigma t) with | Lambda (_,_,b) -> subst1 n b | _ -> anomaly "hnf_lam_app: Need an abstraction" -let hnf_lam_appvect env sigma t nl = +let hnf_lam_appvect env sigma t nl = Array.fold_left (hnf_lam_app env sigma) t nl -let hnf_lam_applist env sigma t nl = +let hnf_lam_applist env sigma t nl = List.fold_left (hnf_lam_app env sigma) t nl -let splay_prod env sigma = +let splay_prod env sigma = let rec decrec env m c = let t = whd_betadeltaiota env sigma c in match kind_of_term t with @@ -738,10 +738,10 @@ let splay_prod env sigma = decrec (push_rel (n,None,a) env) ((n,a)::m) c0 | _ -> m,t - in + in decrec env [] -let splay_lam env sigma = +let splay_lam env sigma = let rec decrec env m c = let t = whd_betadeltaiota env sigma c in match kind_of_term t with @@ -749,10 +749,10 @@ let splay_lam env sigma = decrec (push_rel (n,None,a) env) ((n,a)::m) c0 | _ -> m,t - in + in decrec env [] -let splay_prod_assum env sigma = +let splay_prod_assum env sigma = let rec prodec_rec env l c = let t = whd_betadeltaiota_nolet env sigma c in match kind_of_term t with @@ -775,24 +775,24 @@ let splay_arity env sigma c = let sort_of_arity env c = snd (splay_arity env Evd.empty c) -let splay_prod_n env sigma n = - let rec decrec env m ln c = if m = 0 then (ln,c) else +let splay_prod_n env sigma n = + let rec decrec env m ln c = if m = 0 then (ln,c) else match kind_of_term (whd_betadeltaiota env sigma c) with | Prod (n,a,c0) -> decrec (push_rel (n,None,a) env) (m-1) (add_rel_decl (n,None,a) ln) c0 | _ -> invalid_arg "splay_prod_n" - in + in decrec env n empty_rel_context -let splay_lam_n env sigma n = - let rec decrec env m ln c = if m = 0 then (ln,c) else +let splay_lam_n env sigma n = + let rec decrec env m ln c = if m = 0 then (ln,c) else match kind_of_term (whd_betadeltaiota env sigma c) with | Lambda (n,a,c0) -> decrec (push_rel (n,None,a) env) (m-1) (add_rel_decl (n,None,a) ln) c0 | _ -> invalid_arg "splay_lam_n" - in + in decrec env n empty_rel_context exception NotASort @@ -803,22 +803,22 @@ let decomp_sort env sigma t = | _ -> raise NotASort let is_sort env sigma arity = - try let _ = decomp_sort env sigma arity in true + try let _ = decomp_sort env sigma arity in true with NotASort -> false (* reduction to head-normal-form allowing delta/zeta only in argument of case/fix (heuristic used by evar_conv) *) let whd_betaiota_deltazeta_for_iota_state env sigma s = - let rec whrec s = + let rec whrec s = let (t, stack as s) = whd_betaiota_state sigma s in match kind_of_term t with | Case (ci,p,d,lf) -> let (cr,crargs) = whd_betadeltaiota_stack env sigma d in let rslt = mkCase (ci, p, applist (cr,crargs), lf) in - if reducible_mind_case cr then + if reducible_mind_case cr then whrec (rslt, stack) - else + else s | Fix fix -> (match reduce_fix (whd_betadeltaiota_state env) sigma fix stack with @@ -832,15 +832,15 @@ let whd_betaiota_deltazeta_for_iota_state env sigma s = * Used in Correctness. * Added by JCF, 29/1/98. *) -let whd_programs_stack env sigma = +let whd_programs_stack env sigma = let rec whrec (x, stack as s) = match kind_of_term x with | App (f,cl) -> let n = Array.length cl - 1 in let c = cl.(n) in - if occur_existential c then - s - else + if occur_existential c then + s + else whrec (mkApp (f, Array.sub cl 0 n), append_stack [|c|] stack) | LetIn (_,b,_,c) -> if occur_existential b then @@ -867,7 +867,7 @@ let whd_programs_stack env sigma = | Reduced s' -> whrec s' | NotReducible -> s) | _ -> s - in + in whrec let whd_programs env sigma x = @@ -882,7 +882,7 @@ let find_conclusion env sigma = | Prod (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 | Lambda (x,t,c0) -> decrec (push_rel (x,None,t) env) c0 | t -> t - in + in decrec env let is_arity env sigma c = @@ -893,29 +893,29 @@ let is_arity env sigma c = (*************************************) (* Metas *) -let meta_value evd mv = +let meta_value evd mv = let rec valrec mv = match meta_opt_fvalue evd mv with - | Some (b,_) -> + | Some (b,_) -> instance (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas)) b.rebus | None -> mkMeta mv - in + in valrec mv let meta_instance env b = let c_sigma = - List.map + List.map (fun mv -> (mv,meta_value env mv)) (Metaset.elements b.freemetas) - in + in if c_sigma = [] then b.rebus else instance c_sigma b.rebus let nf_meta env c = meta_instance env (mk_freelisted c) (* Instantiate metas that create beta/iota redexes *) -let meta_value evd mv = +let meta_value evd mv = let rec valrec mv = match meta_opt_fvalue evd mv with | Some (b,_) -> @@ -923,14 +923,14 @@ let meta_value evd mv = (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas)) b.rebus | None -> mkMeta mv - in + in valrec mv let meta_reducible_instance evd b = let fm = Metaset.elements b.freemetas in - let metas = List.fold_left (fun l mv -> + let metas = List.fold_left (fun l mv -> match (try meta_opt_fvalue evd mv with Not_found -> None) with - | Some (g,(_,s)) -> (mv,(g.rebus,s))::l + | Some (g,(_,s)) -> (mv,(g.rebus,s))::l | None -> l) [] fm in let rec irec u = let u = whd_betaiota Evd.empty u in @@ -959,21 +959,21 @@ let meta_reducible_instance evd b = (try let g,s = List.assoc m metas in if s<>CoerceToType then irec g else u with Not_found -> u) | _ -> map_constr irec u - in + in if fm = [] then (* nf_betaiota? *) b.rebus else irec b.rebus -let head_unfold_under_prod ts env _ c = - let unfold cst = +let head_unfold_under_prod ts env _ c = + let unfold cst = if Cpred.mem cst (snd ts) then match constant_opt_value env cst with - | Some c -> c + | Some c -> c | None -> mkConst cst else mkConst cst in let rec aux c = match kind_of_term c with | Prod (n,t,c) -> mkProd (n,aux t, aux c) - | _ -> + | _ -> let (h,l) = decompose_app c in match kind_of_term h with | Const cst -> beta_applist (unfold cst,l) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 535101d743..3c3190484a 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -56,13 +56,13 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr -type contextual_stack_reduction_function = +type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = evar_map -> constr -> constr * constr list -type contextual_state_reduction_function = +type contextual_state_reduction_function = env -> evar_map -> state -> state type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state @@ -79,15 +79,15 @@ val strong : reduction_function -> reduction_function val local_strong : local_reduction_function -> local_reduction_function val strong_prodspine : local_reduction_function -> local_reduction_function (*i -val stack_reduction_of_reduction : +val stack_reduction_of_reduction : 'a reduction_function -> 'a state_reduction_function i*) -val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a +val stacklam : (state -> 'a) -> constr list -> constr -> constr stack -> 'a (*s Generic Optimized Reduction Function using Closures *) val clos_norm_flags : Closure.RedFlags.reds -> reduction_function -(* Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) +(* Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) val nf_beta : local_reduction_function val nf_betaiota : local_reduction_function val nf_betadeltaiota : reduction_function diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index b16508053a..1e0649da6d 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -81,7 +81,7 @@ let retype sigma = | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) - and sort_of env t = + and sort_of env t = match kind_of_term t with | Cast (c,_, s) when isSort s -> destSort s | Sort (Prop c) -> type1_sort @@ -111,14 +111,14 @@ let retype sigma = | Cast (c,_, s) when isSort s -> family_of_sort (destSort s) | Sort (Prop c) -> InType | Sort (Type u) -> InType - | Prod (name,t,c2) -> + | Prod (name,t,c2) -> let s2 = sort_family_of (push_rel (name,None,t) env) c2 in if Environ.engagement env <> Some ImpredicativeSet && s2 = InSet & sort_family_of env t = InType then InType else s2 | App(f,args) when isGlobalRef f -> let t = type_of_global_reference_knowing_parameters env f args in family_of_sort (sort_of_atomic_type env sigma t args) - | App(f,args) -> + | App(f,args) -> family_of_sort (sort_of_atomic_type env sigma (type_of env f) args) | Lambda _ | Fix _ | Construct _ -> anomaly "sort_of: Not a type (1)" diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 9b65494c1e..8576d5baa3 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -31,8 +31,8 @@ val get_assumption_of : env -> evar_map -> constr -> types (* Makes an unsafe judgment from a constr *) val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment -val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> +val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> constr array -> types - + val type_of_global_reference_knowing_conclusion : env -> evar_map -> constr -> types -> types diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index fc790c672a..51c00122b5 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -25,7 +25,7 @@ open Rawterm (* Errors *) -type reduction_tactic_error = +type reduction_tactic_error = InvalidAbstraction of env * constr * (env * Type_errors.type_error) exception ReductionTacticError of reduction_tactic_error @@ -37,7 +37,7 @@ exception Redelimination let error_not_evaluable r = errorlabstrm "error_not_evaluable" - (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Idset.empty r ++ + (str "Cannot coerce" ++ spc () ++ Nametab.pr_global_env Idset.empty r ++ spc () ++ str "to an evaluable reference.") let is_evaluable_const env cst = @@ -112,7 +112,7 @@ let reference_value sigma env c = (* Reduction of constants hiding a fixpoint (e.g. for "simpl" tactic). *) (* One reuses the name of the function after reduction of the fixpoint *) -type constant_evaluation = +type constant_evaluation = | EliminationFix of int * int * (int * (int * constr) list * int) | EliminationMutualFix of int * evaluable_reference * @@ -136,7 +136,7 @@ let freeze () = let unfreeze ct = eval_table := ct -let _ = +let _ = Summary.declare_summary "evaluation" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; @@ -147,9 +147,9 @@ let _ = either [yn:Tn]..[y1:T1](match yi with f1..fk end g1 ..gp) or [yn:Tn]..[y1:T1](Fix(f|t) yi1..yip) - with yi1..yip distinct variables among the yi, not occurring in t + with yi1..yip distinct variables among the yi, not occurring in t - In the second case, [check_fix_reversibility [T1;...;Tn] args fix] + In the second case, [check_fix_reversibility [T1;...;Tn] args fix] checks that [args] is a subset of disjoint variables in y1..yn (a necessary condition for reversibility). It also returns the relevant information ([i1,Ti1;..;ip,Tip],n) in order to compute an @@ -158,7 +158,7 @@ let _ = g := [xp:Tip']..[x1:Ti1'](f a1..an) == [xp:Tip']..[x1:Ti1'](Fix(f|t) yi1..yip) - with a_k:=y_k if k<>i_j, a_k:=args_k otherwise, and + with a_k:=y_k if k<>i_j, a_k:=args_k otherwise, and Tij':=Tij[x1..xi(j-1) <- a1..ai(j-1)] Note that the types Tk, when no i_j=k, must not be dependent on @@ -177,15 +177,15 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) = if array_for_all (noccurn k) tys && array_for_all (noccurn (k+nbfix)) bds - then - (k, List.nth labs (k-1)) - else + then + (k, List.nth labs (k-1)) + else raise Elimconst - | _ -> + | _ -> raise Elimconst) args in let reversible_rels = List.map fst li in - if not (list_distinct reversible_rels) then + if not (list_distinct reversible_rels) then raise Elimconst; list_iter_i (fun i t_i -> if not (List.mem_assoc (i+1) li) then @@ -194,8 +194,8 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) = labs; let k = lv.(i) in if k < nargs then -(* Such an optimisation would need eta-expansion - let p = destRel (List.nth args k) in +(* Such an optimisation would need eta-expansion + let p = destRel (List.nth args k) in EliminationFix (n-p+1,(nbfix,li,n)) *) EliminationFix (n,nargs,(nbfix,li,n)) @@ -206,7 +206,7 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) = components of a mutual fixpoint *) let invert_name labs l na0 env sigma ref = function - | Name id -> + | Name id -> let minfxargs = List.length l in if na0 <> Name id then let refi = match ref with @@ -220,7 +220,7 @@ let invert_name labs l na0 env sigma ref = function | Some ref -> try match reference_opt_value sigma env ref with | None -> None - | Some c -> + | Some c -> let labs',ccl = decompose_lam c in let _, l' = whd_betalet_stack sigma ccl in let labs' = List.map snd labs' in @@ -241,11 +241,11 @@ let compute_consteval_direct sigma env ref = | Lambda (id,t,g) when l=[] -> srec (push_rel (id,None,t) env) (n+1) (t::labs) g | Fix fix -> - (try check_fix_reversibility labs l fix + (try check_fix_reversibility labs l fix with Elimconst -> NotAnElimination) | Case (_,_,d,_) when isRel d -> EliminationCases n | _ -> NotAnElimination - in + in match reference_opt_value sigma env ref with | None -> NotAnElimination | Some c -> srec env 0 [] c @@ -276,7 +276,7 @@ let compute_consteval_mutual_fix sigma env ref = | None -> anomaly "Should have been trapped by compute_direct" | Some c -> srec env (minarg-nargs) [] ref c) | _ -> (* Should not occur *) NotAnElimination - in + in match reference_opt_value sigma env ref with | None -> (* Should not occur *) NotAnElimination | Some c -> srec env 0 [] ref c @@ -286,9 +286,9 @@ let compute_consteval sigma env ref = | EliminationFix (_,_,(nbfix,_,_)) when nbfix <> 1 -> compute_consteval_mutual_fix sigma env ref | elim -> elim - + let reference_eval sigma env = function - | EvalConst cst as ref -> + | EvalConst cst as ref -> (try Cmap.find cst !eval_table with Not_found -> begin @@ -298,15 +298,15 @@ let reference_eval sigma env = function end) | ref -> compute_consteval sigma env ref -let rev_firstn_liftn fn ln = - let rec rfprec p res l = - if p = 0 then - res +let rev_firstn_liftn fn ln = + let rec rfprec p res l = + if p = 0 then + res else match l with | [] -> invalid_arg "Reduction.rev_firstn_liftn" | a::rest -> rfprec (p-1) ((lift ln a)::res) rest - in + in rfprec fn [] (* If f is bound to EliminationFix (n',infos), then n' is the minimal @@ -323,7 +323,7 @@ let rev_firstn_liftn fn ln = s.t. (g u1 ... up) reduces to (Fix(..) u1 ... up) - This is made possible by setting + This is made possible by setting a_k:=x_j if k=i_j for some j a_k:=arg_k otherwise @@ -337,25 +337,25 @@ let make_elim_fun (names,(nbfix,lv,n)) largs = let p = List.length lv in let lyi = List.map fst lv in let la = - list_map_i (fun q aq -> - (* k from the comment is q+1 *) + list_map_i (fun q aq -> + (* k from the comment is q+1 *) try mkRel (p+1-(list_index (n-q) lyi)) with Not_found -> aq) - 0 (List.map (lift p) lu) - in + 0 (List.map (lift p) lu) + in fun i -> match names.(i) with | None -> None | Some (minargs,ref) -> let body = applistc (mkEvalRef ref) la in - let g = + let g = list_fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> let subst = List.map (lift (-q)) (list_firstn (n-ij) la) in let tij' = substl (List.rev subst) tij in mkLambda (x,tij',c)) 1 body (List.rev lv) in Some (minargs,g) -(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: +(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: do so that the reduction uses this extra information *) let dummy = mkProp @@ -453,7 +453,7 @@ let reduce_fix_use_function env sigma f whfun fix stack = let (recarg'hd,_ as recarg') = if isRel recarg then (* The recarg cannot be a local def, no worry about the right env *) - (recarg, empty_stack) + (recarg, empty_stack) else whfun (recarg, empty_stack) in let stack' = stack_assign stack recargnum (app_stack recarg') in @@ -471,7 +471,7 @@ let contract_cofix_use_function env sigma f (nf_beta sigma bodies.(bodynum)) let reduce_mind_case_use_function func env sigma mia = - match kind_of_term mia.mconstr with + match kind_of_term mia.mconstr with | Construct(ind_sp,i) -> let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1), real_cargs) @@ -485,9 +485,9 @@ let reduce_mind_case_use_function func env sigma mia = else match names.(i) with | Anonymous -> None | Name id -> - (* In case of a call to another component of a block of + (* In case of a call to another component of a block of mutual inductive, try to reuse the global name if - the block was indeed initially built as a global + the block was indeed initially built as a global definition *) let kn = make_con mp dp (label_of_id id) in try match constant_opt_value env kn with @@ -503,8 +503,8 @@ let reduce_mind_case_use_function func env sigma mia = | _ -> assert false let special_red_case env sigma whfun (ci, p, c, lf) = - let rec redrec s = - let (constr, cargs) = whfun s in + let rec redrec s = + let (constr, cargs) = whfun s in if isEvalRef env constr then let ref = destEvalRef constr in match reference_opt_value sigma env ref with @@ -521,9 +521,9 @@ let special_red_case env sigma whfun (ci, p, c, lf) = reduce_mind_case {mP=p; mconstr=constr; mcargs=list_of_stack cargs; mci=ci; mlf=lf} - else + else raise Redelimination - in + in redrec (c, empty_stack) (* [red_elim_const] contracts iota/fix/cofix redexes hidden behind @@ -570,14 +570,14 @@ and whd_simpl_state env sigma s = let rec redrec (x, stack as s) = match kind_of_term x with | Lambda (na,t,c) -> - (match decomp_stack stack with + (match decomp_stack stack with | None -> s | Some (a,rest) -> stacklam redrec [a] c rest) | LetIn (n,b,t,c) -> stacklam redrec [b] c stack | App (f,cl) -> redrec (f, append_stack cl stack) | Cast (c,_,_) -> redrec (c, stack) | Case (ci,p,c,lf) -> - (try + (try redrec (special_red_case env sigma redrec (ci,p,c,lf), stack) with Redelimination -> s) @@ -593,13 +593,13 @@ and whd_simpl_state env sigma s = with Redelimination -> s) | _ -> s - in + in redrec s (* reduce until finding an applied constructor or fail *) and whd_construct_state env sigma s = - let (constr, cargs as s') = whd_simpl_state env sigma s in + let (constr, cargs as s') = whd_simpl_state env sigma s in if reducible_mind_case constr then s' else if isEvalRef env constr then let ref = destEvalRef constr in @@ -617,11 +617,11 @@ and whd_construct_state env sigma s = sequence of products; fails if no delta redex is around *) -let try_red_product env sigma c = +let try_red_product env sigma c = let simpfun = clos_norm_flags betaiotazeta env sigma in let rec redrec env x = match kind_of_term x with - | App (f,l) -> + | App (f,l) -> (match kind_of_term f with | Fix fix -> let stack = append_stack l empty_stack in @@ -636,7 +636,7 @@ let try_red_product env sigma c = | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b) | LetIn (x,a,b,t) -> redrec env (subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) - | _ when isEvalRef env x -> + | _ when isEvalRef env x -> (* TO DO: re-fold fixpoints after expansion *) (* to get true one-step reductions *) let ref = destEvalRef x in @@ -646,17 +646,17 @@ let try_red_product env sigma c = | _ -> raise Redelimination in redrec env c -let red_product env sigma c = +let red_product env sigma c = try try_red_product env sigma c with Redelimination -> error "Not reducible." (* -(* This old version of hnf uses betadeltaiota instead of itself (resp +(* This old version of hnf uses betadeltaiota instead of itself (resp whd_construct_state) to reduce the argument of Case (resp Fix); The new version uses the "simpl" strategy instead. For instance, Variable n:nat. - Eval hnf in match (plus (S n) O) with S n => n | _ => O end. + Eval hnf in match (plus (S n) O) with S n => n | _ => O end. returned @@ -683,7 +683,7 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = | Case (ci,p,d,lf) -> (try redrec (special_red_case env sigma whd_all (ci,p,d,lf), stack) - with Redelimination -> + with Redelimination -> s) | Fix fix -> (match reduce_fix whd_all fix stack with @@ -696,7 +696,7 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = with Redelimination -> match reference_opt_value sigma env ref with | Some c -> - (match kind_of_term ((strip_lam c)) with + (match kind_of_term ((strip_lam c)) with | CoFix _ | Fix _ -> s | _ -> redrec (c, stack)) | None -> s) @@ -710,11 +710,11 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = let whd_simpl_orelse_delta_but_fix env sigma c = let rec redrec s = - let (constr, stack as s') = whd_simpl_state env sigma s in + let (constr, stack as s') = whd_simpl_state env sigma s in if isEvalRef env constr then match reference_opt_value sigma env (destEvalRef constr) with | Some c -> - (match kind_of_term ((strip_lam c)) with + (match kind_of_term ((strip_lam c)) with | CoFix _ | Fix _ -> s' | _ -> redrec (c, stack)) | None -> s' @@ -746,7 +746,7 @@ let contextually byhead ((nowhere_except_in,locs),c) f env sigma t = if nowhere_except_in & (!pos > maxocc) then t else if (not byhead & eq_constr c t) or (byhead & is_head c t) then - let ok = + let ok = if nowhere_except_in then List.mem !pos locs else not (List.mem !pos locs) in incr pos; @@ -780,7 +780,7 @@ let substlin env evalref n (nowhere_except_in,locs) c = let rec substrec () c = if nowhere_except_in & !pos > maxocc then c else if c = term then - let ok = + let ok = if nowhere_except_in then List.mem !pos locs else not (List.mem !pos locs) in incr pos; @@ -796,7 +796,7 @@ let substlin env evalref n (nowhere_except_in,locs) c = let string_of_evaluable_ref env = function | EvalVarRef id -> string_of_id id | EvalConstRef kn -> - string_of_qualid + string_of_qualid (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn)) let unfold env sigma name = @@ -813,14 +813,14 @@ let unfoldoccs env sigma ((nowhere_except_in,locs as plocs),name) c = if locs = [] then if nowhere_except_in then c else unfold env sigma name c else let (nbocc,uc) = substlin env name 1 plocs c in - if nbocc = 1 then + if nbocc = 1 then error ((string_of_evaluable_ref env name)^" does not occur."); let rest = List.filter (fun o -> o >= nbocc) locs in if rest <> [] then error_invalid_occurrence rest; nf_betaiota sigma uc (* Unfold reduction tactic: *) -let unfoldn loccname env sigma c = +let unfoldn loccname env sigma c = List.fold_left (fun c occname -> unfoldoccs env sigma occname c) c loccname (* Re-folding constants tactics: refold com in term c *) @@ -863,9 +863,9 @@ let abstract_scheme env sigma (locc,a) c = let ta = Retyping.get_type_of env sigma a in let na = named_hd env ta Anonymous in if occur_meta ta then error "Cannot find a type for the generalisation."; - if occur_meta a then + if occur_meta a then mkLambda (na,ta,c) - else + else mkLambda (na,ta,subst_term_occ locc a c) let pattern_occs loccs_trm env sigma c = @@ -881,7 +881,7 @@ let pattern_occs loccs_trm env sigma c = (* put t as t'=(x1:A1)..(xn:An)B with B an inductive definition of name name return name, B and t' *) -let reduce_to_ind_gen allow_product env sigma t = +let reduce_to_ind_gen allow_product env sigma t = let rec elimrec env t l = let t = hnf_constr env sigma t in match kind_of_term (fst (decompose_app t)) with @@ -909,7 +909,7 @@ let reduce_to_atomic_ind x = reduce_to_ind_gen false x exception NotStepReducible -let one_step_reduce env sigma c = +let one_step_reduce env sigma c = let rec redrec (x, stack) = match kind_of_term x with | Lambda (n,t,c) -> @@ -938,7 +938,7 @@ let one_step_reduce env sigma c = | None -> raise NotStepReducible) | _ -> raise NotStepReducible - in + in app_stack (redrec (c, empty_stack)) let isIndRef = function IndRef _ -> true | _ -> false @@ -947,34 +947,34 @@ let reduce_to_ref_gen allow_product env sigma ref t = if isIndRef ref then let (mind,t) = reduce_to_ind_gen allow_product env sigma t in if IndRef mind <> ref then - errorlabstrm "" (str "Cannot recognize a statement based on " ++ + errorlabstrm "" (str "Cannot recognize a statement based on " ++ Nametab.pr_global_env Idset.empty ref ++ str".") else t else (* lazily reduces to match the head of [t] with the expected [ref] *) - let rec elimrec env t l = + let rec elimrec env t l = let c, _ = Reductionops.whd_stack sigma t in match kind_of_term c with | Prod (n,ty,t') -> if allow_product then elimrec (push_rel (n,None,t) env) t' ((n,None,ty)::l) - else - errorlabstrm "" - (str "Cannot recognize an atomic statement based on " ++ + else + errorlabstrm "" + (str "Cannot recognize an atomic statement based on " ++ Nametab.pr_global_env Idset.empty ref ++ str".") | _ -> - try - if global_of_constr c = ref + try + if global_of_constr c = ref then it_mkProd_or_LetIn t l else raise Not_found with Not_found -> - try - let t' = nf_betaiota sigma (one_step_reduce env sigma t) in + try + let t' = nf_betaiota sigma (one_step_reduce env sigma t) in elimrec env t' l with NotStepReducible -> errorlabstrm "" - (str "Cannot recognize a statement based on " ++ + (str "Cannot recognize a statement based on " ++ Nametab.pr_global_env Idset.empty ref ++ str".") in elimrec env t [] diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index c29a3f335a..26d62379ac 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -19,7 +19,7 @@ open Rawterm open Termops (*i*) -type reduction_tactic_error = +type reduction_tactic_error = InvalidAbstraction of env * constr * (env * Type_errors.type_error) exception ReductionTacticError of reduction_tactic_error @@ -47,7 +47,7 @@ val red_product : reduction_function val try_red_product : reduction_function (* Simpl *) -val simpl : reduction_function +val simpl : reduction_function (* Simpl only at the head *) val whd_simpl : reduction_function @@ -57,7 +57,7 @@ val whd_simpl : reduction_function val hnf_constr : reduction_function (* Unfold *) -val unfoldn : +val unfoldn : (occurrences * evaluable_global_reference) list -> reduction_function (* Fold *) diff --git a/pretyping/term_dnet.ml b/pretyping/term_dnet.ml index 4c6c5e6310..f47485780e 100644 --- a/pretyping/term_dnet.ml +++ b/pretyping/term_dnet.ml @@ -20,9 +20,9 @@ open Pp (* debug *) (* Representation/approximation of terms to use in the dnet: - * + * * - no meta or evar (use ['a pattern] for that) - * + * * - [Rel]s and [Sort]s are not taken into account (that's why we need * a second pass of linear filterin on the results - it's not a perfect * term indexing structure) @@ -52,7 +52,7 @@ struct | DNil type dconstr = dconstr t - + (* debug *) let rec pr_dconstr f : 'a t -> std_ppcmds = function | DRel -> str "*" @@ -64,7 +64,7 @@ struct | DCase (_,t1,t2,ta) -> str "case" | DFix _ -> str "fix" | DCoFix _ -> str "cofix" - | DCons ((t,dopt),tl) -> f t ++ (match dopt with + | DCons ((t,dopt),tl) -> f t ++ (match dopt with Some t' -> str ":=" ++ f t' | None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl | DNil -> str "[]" @@ -116,10 +116,10 @@ struct then invalid_arg "fold2:compare" else match c1,c2 with | (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _) -> acc - | (DCtx (c1,t1), DCtx (c2,t2) + | (DCtx (c1,t1), DCtx (c2,t2) | DApp (c1,t1), DApp (c2,t2) | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2 - | DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) -> + | DCase (ci,p1,c1,bl1),DCase (_,p2,c2,bl2) -> array_fold_left2 f (f (f acc p1 p2) c1 c2) bl1 bl2 | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> array_fold_left2 f (array_fold_left2 f acc ta1 ta2) ca1 ca2 @@ -129,7 +129,7 @@ struct f (Option.fold_left2 f (f acc t1 t2) topt1 topt2) u1 u2 | _ -> assert false - let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t = + let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t = let head w = map (fun _ -> ()) w in if compare (head c1) (head c2) <> 0 then invalid_arg "map2_t:compare" else @@ -139,29 +139,29 @@ struct | DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2) | DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2) | DApp (t1,u1), DApp (t2,u2) -> DApp (f t1 t2,f u1 u2) - | DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) -> + | DCase (ci,p1,c1,bl1), DCase (_,p2,c2,bl2) -> DCase (ci, f p1 p2, f c1 c2, array_map2 f bl1 bl2) | DFix (ia,i,ta1,ca1), DFix (_,_,ta2,ca2) -> DFix (ia,i,array_map2 f ta1 ta2,array_map2 f ca1 ca2) | DCoFix (i,ta1,ca1), DCoFix (_,ta2,ca2) -> DCoFix (i,array_map2 f ta1 ta2,array_map2 f ca1 ca2) - | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> + | DCons ((t1,topt1),u1), DCons ((t2,topt2),u2) -> DCons ((f t1 t2,Option.lift2 f topt1 topt2), f u1 u2) | _ -> assert false let terminal = function | (DRel | DSort | DNil | DRef _) -> true - | _ -> false + | _ -> false end - + (* * Terms discrimination nets * Uses the general dnet datatype on DTerm.t * (here you can restart reading) *) -(* - * Construction of the module +(* + * Construction of the module *) module type IDENT = @@ -185,7 +185,7 @@ struct module TDnet : Dnet.S with type ident=Ident.t and type 'a structure = 'a DTerm.t - and type meta = metavariable + and type meta = metavariable = Dnet.Make(DTerm)(Ident) (struct type t = metavariable @@ -193,20 +193,20 @@ struct end) type t = TDnet.t - + type ident = TDnet.ident - + type 'a pattern = 'a TDnet.pattern type term_pattern = term_pattern DTerm.t pattern - + type idset = TDnet.Idset.t type result = ident * (constr*existential_key) * Termops.subst open DTerm open TDnet - - let rec pat_of_constr c : term_pattern = + + let rec pat_of_constr c : term_pattern = match kind_of_term c with | Rel _ -> Term DRel | Sort _ -> Term DSort @@ -216,46 +216,46 @@ struct | Construct c -> Term (DRef (ConstructRef c)) | Term.Meta _ -> assert false | Evar (i,_) -> Meta i - | Case (ci,c1,c2,ca) -> + | Case (ci,c1,c2,ca) -> Term(DCase(ci,pat_of_constr c1,pat_of_constr c2,Array.map pat_of_constr ca)) - | Fix ((ia,i),(_,ta,ca)) -> + | Fix ((ia,i),(_,ta,ca)) -> Term(DFix(ia,i,Array.map pat_of_constr ta, Array.map pat_of_constr ca)) - | CoFix (i,(_,ta,ca)) -> + | CoFix (i,(_,ta,ca)) -> Term(DCoFix(i,Array.map pat_of_constr ta,Array.map pat_of_constr ca)) | Cast (c,_,_) -> pat_of_constr c | Lambda (_,t,c) -> Term(DLambda (pat_of_constr t, pat_of_constr c)) - | (Prod (_,_,_) | LetIn(_,_,_,_)) -> + | (Prod (_,_,_) | LetIn(_,_,_,_)) -> let (ctx,c) = ctx_of_constr (Term DNil) c in Term (DCtx (ctx,c)) - | App (f,ca) -> + | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) (pat_of_constr f) (Array.map pat_of_constr ca) - and ctx_of_constr ctx c : term_pattern * term_pattern = + and ctx_of_constr ctx c : term_pattern * term_pattern = match kind_of_term c with | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c | LetIn(_,d,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t, Some (pat_of_constr d)),ctx))) c | _ -> ctx,pat_of_constr c - + let empty_ctx : term_pattern -> term_pattern = function | Meta _ as c -> c | Term (DCtx(_,_)) as c -> c | c -> Term (DCtx (Term DNil, c)) - - (* + + (* * Basic primitives *) let empty = TDnet.empty - - let subst s t = + + let subst s t = let sleaf id = Ident.subst s id in let snode = function | DTerm.DRef gr -> DTerm.DRef (fst (subst_global s gr)) | n -> n in TDnet.map sleaf snode t - + let union = TDnet.union - + let add (c:constr) (id:Ident.t) (dn:t) = let c = Opt.reduce c in let c = empty_ctx (pat_of_constr c) in @@ -264,11 +264,11 @@ struct let new_meta_no = let ctr = ref 0 in fun () -> decr ctr; !ctr - + let new_meta_no = Evarutil.new_untyped_evar let neutral_meta = new_meta_no() - + let new_meta () = Meta (new_meta_no()) let new_evar () = mkEvar(new_meta_no(),[||]) @@ -292,19 +292,19 @@ struct let subst_evar i c = e_subst_evar i (fun _ -> c) (* debug *) - let rec pr_term_pattern p = - (fun pr_t -> function + let rec pr_term_pattern p = + (fun pr_t -> function | Term t -> pr_t t | Meta m -> str"["++Util.pr_int (Obj.magic m)++str"]" ) (pr_dconstr pr_term_pattern) p - let search_pat cpat dpat dn (up,plug) = + let search_pat cpat dpat dn (up,plug) = let whole_c = subst_evar plug cpat up in TDnet.Idset.fold - (fun id acc -> + (fun id acc -> let c_id = Opt.reduce (Ident.constr_of id) in - let (ctx,wc) = - try Termops.align_prod_letin whole_c c_id + let (ctx,wc) = + try Termops.align_prod_letin whole_c c_id with Invalid_argument _ -> [],c_id in let up = it_mkProd_or_LetIn up ctx in let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in @@ -326,11 +326,11 @@ struct let fold_pattern_up f acc dpat cpat dn (up,plug) = fold_pattern_nonlin ( fun m dn acc -> - f dn (subst_evar plug (e_subst_evar neutral_meta new_evar cpat) up, m) acc + f dn (subst_evar plug (e_subst_evar neutral_meta new_evar cpat) up, m) acc ) acc dpat dn - let possibly_under pat k dn (up,plug) = - let rec aux fst dn (up,plug) acc = + let possibly_under pat k dn (up,plug) = + let rec aux fst dn (up,plug) acc = let cpat = pat() in let dpat = pat_of_constr cpat in let dpat = if fst then empty_ctx dpat else dpat in @@ -345,24 +345,24 @@ struct * High-level primitives describing specific search problems *) - let search_pattern dn pat = + let search_pattern dn pat = let pat = Opt.reduce pat in search_pat pat (empty_ctx (pat_of_constr pat)) dn init - + let search_concl dn pat = let pat = Opt.reduce pat in search_pat pat (under_prod (empty_ctx (pat_of_constr pat))) dn init - let search_eq_concl dn eq pat = + let search_eq_concl dn eq pat = let pat = Opt.reduce pat in let eq_pat = eq_pat eq () in let eq_dpat = under_prod (empty_ctx (pat_of_constr eq_pat)) in snd (fold_pattern_up - (fun dn up acc -> + (fun dn up acc -> search_pat pat (pat_of_constr pat) dn up @ acc ) [] eq_dpat eq_pat dn init) - - let search_head_concl dn pat = + + let search_head_concl dn pat = let pat = Opt.reduce pat in possibly_under app_pat (search_pat pat (pat_of_constr pat)) dn init @@ -370,12 +370,12 @@ struct let map f dn = TDnet.map f (fun x -> x) dn end - + module type S = sig type t type ident - + type result = ident * (constr*existential_key) * Termops.subst val empty : t diff --git a/pretyping/term_dnet.mli b/pretyping/term_dnet.mli index f6c1b5b611..0e7fdb82a7 100644 --- a/pretyping/term_dnet.mli +++ b/pretyping/term_dnet.mli @@ -15,8 +15,8 @@ open Libnames open Mod_subst (*i*) -(* Dnets on constr terms. - +(* Dnets on constr terms. + An instantiation of Dnet on (an approximation of) constr. It associates a term (possibly with Evar) with an identifier. Identifiers must be unique (no two terms sharing the @@ -51,7 +51,7 @@ module type OPT = sig (* pre-treatment to terms before adding or searching *) val reduce : constr -> constr - (* direction of post-filtering w.r.t sort subtyping : + (* direction of post-filtering w.r.t sort subtyping : - true means query <= terms in the structure - false means terms <= query *) @@ -78,14 +78,14 @@ sig val subst : substitution -> t -> t - (* - * High-level primitives describing specific search problems + (* + * High-level primitives describing specific search problems *) (* [search_pattern dn c] returns all terms/patterns in dn matching/matched by c *) val search_pattern : t -> constr -> result list - + (* [search_concl dn c] returns all matches under products and letins, i.e. it finds subterms whose conclusion matches c. The complexity depends only on c ! *) @@ -95,7 +95,7 @@ sig heads. Finds terms of the form [forall H_1...H_n, C t_1...t_n] where C matches c *) val search_head_concl : t -> constr -> result list - + (* [search_eq_concl dn eq c] searches terms of the form [forall H1...Hn, eq _ X1 X2] where either X1 or X2 matches c *) val search_eq_concl : t -> constr -> constr -> result list diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 47bc972513..f0a7ce4c81 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -42,7 +42,7 @@ let rec pr_constr c = match kind_of_term c with | Meta n -> str "Meta(" ++ int n ++ str ")" | Var id -> pr_id id | Sort s -> print_sort s - | Cast (c,_, t) -> hov 1 + | Cast (c,_, t) -> hov 1 (str"(" ++ pr_constr c ++ cut() ++ str":" ++ pr_constr t ++ str")") | Prod (Name(id),t,c) -> hov 1 @@ -99,7 +99,7 @@ let pr_var_decl env (id,c,typ) = let pbody = match c with | None -> (mt ()) | Some c -> - (* Force evaluation *) + (* Force evaluation *) let pb = print_constr_env env c in (str" := " ++ pb ++ cut () ) in let pt = print_constr_env env typ in @@ -110,7 +110,7 @@ let pr_rel_decl env (na,c,typ) = let pbody = match c with | None -> mt () | Some c -> - (* Force evaluation *) + (* Force evaluation *) let pb = print_constr_env env c in (str":=" ++ spc () ++ pb ++ spc ()) in let ptyp = print_constr_env env typ in @@ -120,39 +120,39 @@ let pr_rel_decl env (na,c,typ) = let print_named_context env = hv 0 (fold_named_context - (fun env d pps -> + (fun env d pps -> pps ++ ws 2 ++ pr_var_decl env d) env ~init:(mt ())) -let print_rel_context env = +let print_rel_context env = hv 0 (fold_rel_context (fun env d pps -> pps ++ ws 2 ++ pr_rel_decl env d) env ~init:(mt ())) - + let print_env env = let sign_env = fold_named_context (fun env d pps -> let pidt = pr_var_decl env d in (pps ++ fnl () ++ pidt)) - env ~init:(mt ()) + env ~init:(mt ()) in let db_env = fold_rel_context (fun env d pps -> let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat)) env ~init:(mt ()) - in + in (sign_env ++ db_env) - + (*let current_module = ref empty_dirpath let set_module m = current_module := m*) -let new_univ = +let new_univ = let univ_gen = ref 0 in (fun sp -> - incr univ_gen; + incr univ_gen; Univ.make_univ (Lib.library_dp(),!univ_gen)) let new_Type () = mkType (new_univ ()) let new_Type_sort () = Type (new_univ ()) @@ -173,7 +173,7 @@ let refresh_universes_gen strict t = let refresh_universes = refresh_universes_gen false let refresh_universes_strict = refresh_universes_gen true -let new_sort_in_family = function +let new_sort_in_family = function | InProp -> prop_sort | InSet -> set_sort | InType -> Type (new_univ ()) @@ -183,10 +183,10 @@ let new_sort_in_family = function (* [Rel (n+m);...;Rel(n+1)] *) let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) -let rel_list n m = - let rec reln l p = +let rel_list n m = + let rec reln l p = if p>m then l else reln (mkRel(n+p)::l) (p+1) - in + in reln [] 1 (* Same as [rel_list] but takes a context as argument and skips let-ins *) @@ -195,7 +195,7 @@ let extended_rel_list n hyps = | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps | (_,Some _,_) :: hyps -> reln l (p+1) hyps | [] -> l - in + in reln [] 1 hyps let extended_rel_vect n hyps = Array.of_list (extended_rel_list n hyps) @@ -218,12 +218,12 @@ let push_named_rec_types (lna,typarray,_) env = Array.fold_left (fun e assum -> push_named assum e) env ctxt -let rec lookup_rel_id id sign = +let rec lookup_rel_id id sign = let rec lookrec = function | (n, (Anonymous,_,_)::l) -> lookrec (n+1,l) | (n, (Name id',_,t)::l) -> if id' = id then (n,t) else lookrec (n+1,l) | (_, []) -> raise Not_found - in + in lookrec (1,sign) (* Constructs either [forall x:t, c] or [let x:=b:t in c] *) @@ -241,7 +241,7 @@ let mkProd_wo_LetIn (na,body,t) c = let it_mkProd ~init = List.fold_left (fun c (n,t) -> mkProd (n, t, c)) init let it_mkLambda ~init = List.fold_left (fun c (n,t) -> mkLambda (n, t, c)) init -let it_named_context_quantifier f ~init = +let it_named_context_quantifier f ~init = List.fold_left (fun c d -> f d c) init let it_mkProd_or_LetIn = it_named_context_quantifier mkProd_or_LetIn @@ -255,12 +255,12 @@ let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_Let (* strips head casts and flattens head applications *) let rec strip_head_cast c = match kind_of_term c with - | App (f,cl) -> + | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term f with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) | Cast (c,_,_) -> collapse_rec c cl2 | _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2) - in + in collapse_rec f cl | Cast (c,_,_) -> strip_head_cast c | _ -> c @@ -348,7 +348,7 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> cstr - | Cast (c,k, t) -> + | Cast (c,k, t) -> let c' = f l c in let t' = f l t in if c==c' && t==t' then cstr else mkCast (c', k, t') @@ -412,7 +412,7 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl - | Fix (_,(lna,tl,bl)) -> + | Fix (_,(lna,tl,bl)) -> let n' = iterate g (Array.length tl) n in let fd = array_map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd @@ -436,7 +436,7 @@ let iter_constr_with_full_binders g f l c = match kind_of_term c with | App (c,args) -> f l c; Array.iter (f l) args | Evar (_,args) -> Array.iter (f l) args | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl - | Fix (_,(lna,tl,bl)) -> + | Fix (_,(lna,tl,bl)) -> let l' = array_fold_left2 (fun l na t -> g (na,None,t) l) l lna tl in Array.iter (f l) tl; Array.iter (f l') bl @@ -446,7 +446,7 @@ let iter_constr_with_full_binders g f l c = match kind_of_term c with Array.iter (f l') bl (***************************) -(* occurs check functions *) +(* occurs check functions *) (***************************) exception Occur @@ -457,42 +457,42 @@ let occur_meta c = | _ -> iter_constr occrec c in try occrec c; false with Occur -> true -let occur_existential c = +let occur_existential c = let rec occrec c = match kind_of_term c with | Evar _ -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur -> true -let occur_meta_or_existential c = +let occur_meta_or_existential c = let rec occrec c = match kind_of_term c with | Evar _ -> raise Occur | Meta _ -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur -> true -let occur_const s c = +let occur_const s c = let rec occur_rec c = match kind_of_term c with | Const sp when sp=s -> raise Occur | _ -> iter_constr occur_rec c - in + in try occur_rec c; false with Occur -> true -let occur_evar n c = +let occur_evar n c = let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when sp=n -> raise Occur | _ -> iter_constr occur_rec c - in + in try occur_rec c; false with Occur -> true let occur_in_global env id constr = let vars = vars_of_global env constr in if List.mem id vars then raise Occur -let occur_var env s c = +let occur_var env s c = let rec occur_rec c = occur_in_global env s c; iter_constr occur_rec c - in + in try occur_rec c; false with Occur -> true let occur_var_in_decl env hyp (_,c,typ) = @@ -504,17 +504,17 @@ let occur_var_in_decl env hyp (_,c,typ) = (* returns the list of free debruijn indices in a term *) -let free_rels m = +let free_rels m = let rec frec depth acc c = match kind_of_term c with | Rel n -> if n >= depth then Intset.add (n-depth+1) acc else acc | _ -> fold_constr_with_binders succ frec depth acc c - in + in frec 1 Intset.empty m (* collects all metavar occurences, in left-to-right order, preserving * repetitions and all. *) -let collect_metas c = +let collect_metas c = let rec collrec acc c = match kind_of_term c with | Meta mv -> list_add_set mv acc @@ -534,12 +534,12 @@ let dependent_main noevar m t = | App (fm,lm), App (ft,lt) when Array.length lm < Array.length lt -> deprec m (mkApp (ft,Array.sub lt 0 (Array.length lm))); Array.iter (deprec m) - (Array.sub lt + (Array.sub lt (Array.length lm) ((Array.length lt) - (Array.length lm))) | _, Cast (c,_,_) when noevar & isMeta c -> () | _, Evar _ when noevar -> () | _ -> iter_constr_with_binders (lift 1) deprec m t - in + in try deprec m t; false with Occur -> true let dependent = dependent_main false @@ -551,21 +551,21 @@ let occur_term = dependent let pop t = lift (-1) t (***************************) -(* bindings functions *) +(* bindings functions *) (***************************) -type meta_type_map = (metavariable * types) list +type meta_type_map = (metavariable * types) list -type meta_value_map = (metavariable * constr) list +type meta_value_map = (metavariable * constr) list -let rec subst_meta bl c = +let rec subst_meta bl c = match kind_of_term c with | Meta i -> (try List.assoc i bl with Not_found -> c) | _ -> map_constr (subst_meta bl) c (* First utilities for avoiding telescope computation for subst_term *) -let prefix_application eq_fun (k,c) (t : constr) = +let prefix_application eq_fun (k,c) (t : constr) = let c' = collapse_appl c and t' = collapse_appl t in match kind_of_term c', kind_of_term t' with | App (f1,cl1), App (f2,cl2) -> @@ -574,11 +574,11 @@ let prefix_application eq_fun (k,c) (t : constr) = if l1 <= l2 && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) - else + else None | _ -> None -let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) = +let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) = let c' = collapse_appl c and t' = collapse_appl t in match kind_of_term c', kind_of_term t' with | App (f1,cl1), App (f2,cl2) -> @@ -587,7 +587,7 @@ let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) = if l1 <= l2 && eq_fun c' (mkApp (f2, Array.sub cl2 0 l1)) then Some (mkApp ((lift k by_c), Array.sub cl2 l1 (l2 - l1))) - else + else None | _ -> None @@ -596,7 +596,7 @@ let my_prefix_application eq_fun (k,c) (by_c : constr) (t : constr) = term [c] in a term [t] *) (*i Bizarre : si on cherche un sous terme clos, pourquoi le lifter ? i*) -let subst_term_gen eq_fun c t = +let subst_term_gen eq_fun c t = let rec substrec (k,c as kc) t = match prefix_application eq_fun kc t with | Some x -> x @@ -604,7 +604,7 @@ let subst_term_gen eq_fun c t = if eq_fun c t then mkRel k else map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t - in + in substrec (1,c) t (* Recognizing occurrences of a given (closed) subterm in a term : @@ -612,7 +612,7 @@ let subst_term_gen eq_fun c t = term [c1] in a term [t] *) (*i Meme remarque : a priori [c] n'est pas forcement clos i*) -let replace_term_gen eq_fun c by_c in_t = +let replace_term_gen eq_fun c by_c in_t = let rec substrec (k,c as kc) t = match my_prefix_application eq_fun kc by_c t with | Some x -> x @@ -620,7 +620,7 @@ let replace_term_gen eq_fun c by_c in_t = (if eq_fun c t then (lift k by_c) else map_constr_with_binders (fun (k,c) -> (k+1,lift 1 c)) substrec kc t) - in + in substrec (0,c) in_t let subst_term = subst_term_gen eq_constr @@ -639,7 +639,7 @@ let no_occurrences_in_set = (true,[]) let error_invalid_occurrence l = let l = list_uniquize (List.sort Pervasives.compare l) in errorlabstrm "" - (str ("Invalid occurrence " ^ plural (List.length l) "number" ^": ") ++ + (str ("Invalid occurrence " ^ plural (List.length l) "number" ^": ") ++ prlist_with_sep spc int l ++ str ".") let subst_term_occ_gen (nowhere_except_in,locs) occ c t = @@ -650,10 +650,10 @@ let subst_term_occ_gen (nowhere_except_in,locs) occ c t = if nowhere_except_in & !pos > maxocc then t else if eq_constr c t then - let r = + let r = if nowhere_except_in then if List.mem !pos locs then (mkRel k) else t - else + else if List.mem !pos locs then t else (mkRel k) in incr pos; r else @@ -664,9 +664,9 @@ let subst_term_occ_gen (nowhere_except_in,locs) occ c t = let t' = substrec (1,c) t in (!pos, t') -let subst_term_occ (nowhere_except_in,locs as plocs) c t = +let subst_term_occ (nowhere_except_in,locs as plocs) c t = if locs = [] then if nowhere_except_in then t else subst_term c t - else + else let (nbocc,t') = subst_term_occ_gen plocs 1 c t in let rest = List.filter (fun o -> o >= nbocc) locs in if rest <> [] then error_invalid_occurrence rest; @@ -687,7 +687,7 @@ let subst_term_occ_decl ((nowhere_except_in,locs as plocs),hloc) c (id,bodyopt,t if locs = [] then if nowhere_except_in then d else (id,Some (subst_term c body),subst_term c typ) - else + else let (nbocc,body') = subst_term_occ_gen plocs 1 c body in let (nbocc',t') = subst_term_occ_gen plocs nbocc c typ in let rest = List.filter (fun o -> o >= nbocc') locs in @@ -700,7 +700,7 @@ let lowercase_first_char id = lowercase_first_char_utf8 (string_of_id id) let vars_of_env env = - let s = + let s = Sign.fold_named_context (fun (id,_,_) s -> Idset.add id s) (named_context env) ~init:Idset.empty in Sign.fold_rel_context @@ -717,7 +717,7 @@ let sort_hdchar = function | Prop(_) -> "P" | Type(_) -> "T" -let hdchar env c = +let hdchar env c = let rec hdrec k c = match kind_of_term c with | Prod (_,_,c) -> hdrec (k+1) c @@ -728,9 +728,9 @@ let hdchar env c = | Const kn -> lowercase_first_char (id_of_label (con_label kn)) | Ind ((kn,i) as x) -> - if i=0 then + if i=0 then lowercase_first_char (id_of_label (label kn)) - else + else lowercase_first_char (basename_of_global (IndRef x)) | Construct ((sp,i) as x) -> lowercase_first_char (basename_of_global (ConstructRef x)) @@ -743,22 +743,22 @@ let hdchar env c = | (Name id,_,_) -> lowercase_first_char id | (Anonymous,_,t) -> hdrec 0 (lift (n-k) t) with Not_found -> "y") - | Fix ((_,i),(lna,_,_)) -> + | Fix ((_,i),(lna,_,_)) -> let id = match lna.(i) with Name id -> id | _ -> assert false in lowercase_first_char id - | CoFix (i,(lna,_,_)) -> + | CoFix (i,(lna,_,_)) -> let id = match lna.(i) with Name id -> id | _ -> assert false in lowercase_first_char id | Meta _|Evar _|Case (_, _, _, _) -> "y" - in + in hdrec 0 c let id_of_name_using_hdchar env a = function - | Anonymous -> id_of_string (hdchar env a) + | Anonymous -> id_of_string (hdchar env a) | Name id -> id let named_hd env a = function - | Anonymous -> Name (id_of_string (hdchar env a)) + | Anonymous -> Name (id_of_string (hdchar env a)) | x -> x let mkProd_name env (n,a,b) = mkProd (named_hd env a n, a, b) @@ -778,11 +778,11 @@ let name_assumption env (na,c,t) = let name_context env hyps = snd (List.fold_left - (fun (env,hyps) d -> + (fun (env,hyps) d -> let d' = name_assumption env d in (push_rel d' env, d' :: hyps)) (env,[]) (List.rev hyps)) -let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b +let mkProd_or_LetIn_name env b d = mkProd_or_LetIn (name_assumption env d) b let mkLambda_or_LetIn_name env b d = mkLambda_or_LetIn (name_assumption env d)b let it_mkProd_or_LetIn_name env b hyps = @@ -798,12 +798,12 @@ let add_name n nl = n::nl let lookup_name_of_rel p names = try List.nth names (p-1) with Invalid_argument _ | Failure _ -> raise Not_found -let rec lookup_rel_of_name id names = +let rec lookup_rel_of_name id names = let rec lookrec n = function | Anonymous :: l -> lookrec (n+1) l | (Name id') :: l -> if id' = id then n else lookrec (n+1) l | [] -> raise Not_found - in + in lookrec 1 names let empty_names_context = [] @@ -815,7 +815,7 @@ let ids_of_rel_context sign = let ids_of_named_context sign = Sign.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[] -let ids_of_context env = +let ids_of_context env = (ids_of_rel_context (rel_context env)) @ (ids_of_named_context (named_context env)) @@ -838,42 +838,42 @@ let is_imported_ref = function let (mp,_,_) = repr_con kn in is_imported_modpath mp let is_global id = - try + try let ref = locate (qualid_of_ident id) in not (is_imported_ref ref) - with Not_found -> + with Not_found -> false let is_constructor id = - try - match locate (qualid_of_ident id) with + try + match locate (qualid_of_ident id) with | ConstructRef _ as ref -> not (is_imported_ref ref) | _ -> false - with Not_found -> + with Not_found -> false let is_section_variable id = try let _ = Global.lookup_named id in true with Not_found -> false -let next_global_ident_from allow_secvar id avoid = +let next_global_ident_from allow_secvar id avoid = let rec next_rec id = let id = next_ident_away_from id avoid in if (allow_secvar && is_section_variable id) || not (is_global id) then id - else + else next_rec (lift_ident id) - in + in next_rec id let next_global_ident_away allow_secvar id avoid = let id = next_ident_away id avoid in if (allow_secvar && is_section_variable id) || not (is_global id) then id - else + else next_global_ident_from allow_secvar (lift_ident id) avoid -let isGlobalRef c = +let isGlobalRef c = match kind_of_term c with | Const _ | Ind _ | Construct _ | Var _ -> true | _ -> false @@ -884,23 +884,23 @@ let has_polymorphic_type c = | _ -> false (* nouvelle version de renommage des variables (DEC 98) *) -(* This is the algorithm to display distinct bound variables +(* This is the algorithm to display distinct bound variables - Règle 1 : un nom non anonyme, même non affiché, contribue à la liste - des noms à éviter + des noms à éviter - Règle 2 : c'est la dépendance qui décide si on affiche ou pas - Exemple : + Exemple : si bool_ind = (P:bool->Prop)(f:(P true))(f:(P false))(b:bool)(P b), alors il est affiché (P:bool->Prop)(P true)->(P false)->(b:bool)(P b) - mais f et f0 contribue à la liste des variables à éviter (en supposant + mais f et f0 contribue à la liste des variables à éviter (en supposant que les noms f et f0 ne sont pas déjà pris) Intérêt : noms homogènes dans un but avant et après Intro *) type used_idents = identifier list -let occur_rel p env id = +let occur_rel p env id = try lookup_name_of_rel p env = Name id with Not_found -> false (* Unbound indice : may happen in debug *) @@ -916,7 +916,7 @@ let occur_id nenv id0 c = raise Occur | Rel p when p>n & occur_rel (p-n) nenv id0 -> raise Occur | _ -> iter_constr_with_binders succ occur n c - in + in try occur 1 c; false with Occur -> true | Not_found -> false (* Case when a global is not in the env *) @@ -925,7 +925,7 @@ type avoid_flags = bool option let next_name_not_occuring avoid_flags name l env_names t = let rec next id = - if List.mem id l or occur_id env_names id t or + if List.mem id l or occur_id env_names id t or (* Further restrictions ? *) match avoid_flags with None -> false | Some not_only_cstr -> (if not_only_cstr then @@ -936,10 +936,10 @@ let next_name_not_occuring avoid_flags name l env_names t = is_constructor id) then next (lift_ident id) else id - in + in match name with | Name id -> next id - | Anonymous -> + | Anonymous -> (* Normally, an anonymous name is not dependent and will not be *) (* taken into account by the function concrete_name; just in case *) (* invent a valid name *) @@ -953,10 +953,10 @@ let base_sort_cmp pb s0 s1 = | _ -> false (* eq_constr extended with universe erasure *) -let compare_constr_univ f cv_pb t1 t2 = +let compare_constr_univ f cv_pb t1 t2 = match kind_of_term t1, kind_of_term t2 with Sort s1, Sort s2 -> base_sort_cmp cv_pb s1 s2 - | Prod (_,t1,c1), Prod (_,t2,c2) -> + | Prod (_,t1,c1), Prod (_,t2,c2) -> f Reduction.CONV t1 t2 & f cv_pb c1 c2 | _ -> compare_constr (f Reduction.CONV) t1 t2 @@ -967,7 +967,7 @@ let eq_constr = constr_cmp Reduction.CONV (* App(c,[t1,...tn]) -> ([c,t1,...,tn-1],tn) App(c,[||]) -> ([],c) *) let split_app c = match kind_of_term c with - App(c,l) -> + App(c,l) -> let len = Array.length l in if len=0 then ([],c) else let last = Array.get l (len-1) in @@ -983,16 +983,16 @@ exception CannotFilter let filtering env cv_pb c1 c2 = let evm = ref Intmap.empty in - let define cv_pb e1 ev c1 = + let define cv_pb e1 ev c1 = try let (e2,c2) = Intmap.find ev !evm in let shift = List.length e1 - List.length e2 in if constr_cmp cv_pb c1 (lift shift c2) then () else raise CannotFilter - with Not_found -> + with Not_found -> evm := Intmap.add ev (e1,c1) !evm in let rec aux env cv_pb c1 c2 = match kind_of_term c1, kind_of_term c2 with - | App _, App _ -> + | App _, App _ -> let ((p1,l1),(p2,l2)) = (split_app c1),(split_app c2) in aux env cv_pb l1 l2; if p1=[] & p2=[] then () else aux env cv_pb (applist (hdtl p1)) (applist (hdtl p2)) @@ -1001,15 +1001,15 @@ let filtering env cv_pb c1 c2 = aux ((n,None,t1)::env) cv_pb c1 c2 | _, Evar (ev,_) -> define cv_pb env ev c1 | Evar (ev,_), _ -> define cv_pb env ev c2 - | _ -> - if compare_constr_univ - (fun pb c1 c2 -> aux env pb c1 c2; true) cv_pb c1 c2 then () + | _ -> + if compare_constr_univ + (fun pb c1 c2 -> aux env pb c1 c2; true) cv_pb c1 c2 then () else raise CannotFilter (* TODO: le reste des binders *) in aux env cv_pb c1 c2; !evm -let decompose_prod_letin : constr -> int * rel_context * constr = +let decompose_prod_letin : constr -> int * rel_context * constr = let rec prodec_rec i l c = match kind_of_term c with | Prod (n,t,c) -> prodec_rec (succ i) ((n,None,t)::l) c | LetIn (n,d,t,c) -> prodec_rec (succ i) ((n,Some d,t)::l) c @@ -1023,7 +1023,7 @@ let align_prod_letin c a : rel_context * constr = if not (la >= lc) then invalid_arg "align_prod_letin"; let (l1,l2) = Util.list_chop lc l in l2,it_mkProd_or_LetIn a l1 - + (* On reduit une serie d'eta-redex de tete ou rien du tout *) (* [x1:c1;...;xn:cn]@(f;a1...an;x1;...;xn) --> @(f;a1...an) *) (* Remplace 2 versions précédentes buggées *) @@ -1033,7 +1033,7 @@ let rec eta_reduce_head c = | Lambda (_,c1,c') -> (match kind_of_term (eta_reduce_head c') with | App (f,cl) -> - let lastn = (Array.length cl) - 1 in + let lastn = (Array.length cl) - 1 in if lastn < 1 then anomaly "application without arguments" else (match kind_of_term cl.(lastn) with @@ -1107,7 +1107,7 @@ let smash_rel_context sign = let adjust_subst_to_rel_context sign l = let rec aux subst sign l = - match sign, l with + match sign, l with | (_,None,_)::sign', a::args' -> aux (a::subst) sign' args' | (_,Some c,_)::sign', args' -> aux (substl (List.rev subst) c :: subst) sign' args' @@ -1125,7 +1125,7 @@ let rec mem_named_context id = function let make_all_name_different env = let avoid = ref (ids_of_named_context (named_context env)) in process_rel_context - (fun (na,c,t) newenv -> + (fun (na,c,t) newenv -> let id = next_name_away na !avoid in avoid := id::!avoid; push_rel (Name id,c,t) newenv) @@ -1195,7 +1195,7 @@ let on_judgment f j = { uj_val = f j.uj_val; uj_type = f j.uj_type } let on_judgment_value f j = { j with uj_val = f j.uj_val } let on_judgment_type f j = { j with uj_type = f j.uj_type } -(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k +(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k variables *) let context_chop k ctx = let rec chop_aux acc = function diff --git a/pretyping/termops.mli b/pretyping/termops.mli index 3d167ebb03..f28fee9517 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -69,7 +69,7 @@ val map_constr_with_named_binders : (name -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_binders_left_to_right : - (rel_declaration -> 'a -> 'a) -> + (rel_declaration -> 'a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr val map_constr_with_full_binders : @@ -87,7 +87,7 @@ val fold_constr_with_binders : ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b val iter_constr_with_full_binders : - (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> + (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit (**********************************************************************) @@ -113,11 +113,11 @@ val collect_metas : constr -> int list val occur_term : constr -> constr -> bool (* Synonymous of dependent *) (* Substitution of metavariables *) -type meta_value_map = (metavariable * constr) list +type meta_value_map = (metavariable * constr) list val subst_meta : meta_value_map -> constr -> constr (* Type assignment for metavariables *) -type meta_type_map = (metavariable * types) list +type meta_type_map = (metavariable * types) list (* [pop c] lifts by -1 the positive indexes in [c] *) val pop : constr -> constr @@ -149,7 +149,7 @@ val no_occurrences_in_set : occurrences (* [subst_term_occ_gen occl n c d] replaces occurrences of [c] at positions [occl], counting from [n], by [Rel 1] in [d] *) -val subst_term_occ_gen : +val subst_term_occ_gen : occurrences -> int -> constr -> types -> int * types (* [subst_term_occ occl c d] replaces occurrences of [c] at @@ -165,7 +165,7 @@ type hyp_location_flag = (* To distinguish body and type of local defs *) | InHypValueOnly val subst_term_occ_decl : - occurrences * hyp_location_flag -> constr -> named_declaration -> + occurrences * hyp_location_flag -> constr -> named_declaration -> named_declaration val error_invalid_occurrence : int list -> 'a @@ -183,7 +183,7 @@ val eta_eq_constr : constr -> constr -> bool exception CannotFilter (* Lightweight first-order filtering procedure. Unification - variables ar represented by (untyped) Evars. + variables ar represented by (untyped) Evars. [filtering c1 c2] returns the substitution n'th evar -> (context,term), or raises [CannotFilter]. Warning: Outer-kernel sort subtyping are taken into account: c1 has @@ -245,20 +245,20 @@ val occur_rel : int -> name list -> identifier -> bool val occur_id : name list -> identifier -> constr -> bool type avoid_flags = bool option - (* Some true = avoid all globals (as in intro); + (* Some true = avoid all globals (as in intro); Some false = avoid only global constructors; None = don't avoid globals *) -val next_name_away_in_cases_pattern : +val next_name_away_in_cases_pattern : name -> identifier list -> identifier -val next_global_ident_away : +val next_global_ident_away : (*allow section vars:*) bool -> identifier -> identifier list -> identifier val next_name_not_occuring : avoid_flags -> name -> identifier list -> name list -> constr -> identifier val concrete_name : - avoid_flags -> identifier list -> name list -> name -> constr -> + avoid_flags -> identifier list -> name list -> name -> constr -> name * identifier list val concrete_let_name : - avoid_flags -> identifier list -> name list -> name -> constr -> + avoid_flags -> identifier list -> name list -> name -> constr -> name * identifier list val rename_bound_var : env -> identifier list -> types -> types @@ -271,7 +271,7 @@ val smash_rel_context : rel_context -> rel_context (* expand lets in context *) val adjust_subst_to_rel_context : rel_context -> constr list -> constr list val map_rel_context_in_env : (env -> constr -> constr) -> env -> rel_context -> rel_context -val map_rel_context_with_binders : +val map_rel_context_with_binders : (int -> constr -> constr) -> rel_context -> rel_context val fold_named_context_both_sides : ('a -> named_declaration -> named_declaration list -> 'a) -> diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 2e4f978f5e..097cba5909 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -33,14 +33,14 @@ type rels = constr list (* This module defines type-classes *) type typeclass = { (* The class implementation *) - cl_impl : global_reference; + cl_impl : global_reference; (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. *) - cl_context : (global_reference * bool) option list * rel_context; + cl_context : (global_reference * bool) option list * rel_context; (* Context of definitions and properties on defs, will not be shared *) cl_props : rel_context; - + (* The method implementaions as projections. *) cl_projs : (identifier * constant option) list; } @@ -50,20 +50,20 @@ type typeclasses = (global_reference, typeclass) Gmap.t type instance = { is_class: global_reference; is_pri: int option; - (* Sections where the instance should be redeclared, - -1 for discard, 0 for none, mutable to avoid redeclarations + (* Sections where the instance should be redeclared, + -1 for discard, 0 for none, mutable to avoid redeclarations when multiple rebuild_object happen. *) is_global: int ref; - is_impl: constant; + is_impl: constant; } type instances = (global_reference, instance Cmap.t) Gmap.t let instance_impl is = is.is_impl -let new_instance cl pri glob impl = +let new_instance cl pri glob impl = let global = - if Lib.sections_are_opened () then + if Lib.sections_are_opened () then if glob then Lib.sections_depth () else -1 else 0 @@ -76,22 +76,22 @@ let new_instance cl pri glob impl = (* * states management *) - + let classes : typeclasses ref = ref Gmap.empty let instances : instances ref = ref Gmap.empty - + let freeze () = !classes, !instances -let unfreeze (cl,is) = +let unfreeze (cl,is) = classes:=cl; instances:=is - + let init () = - classes:= Gmap.empty; + classes:= Gmap.empty; instances:= Gmap.empty - -let _ = + +let _ = Summary.declare_summary "classes_and_instances" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; @@ -115,10 +115,10 @@ let subst_class (_,subst,cl) = let do_subst_con c = fst (Mod_subst.subst_con subst c) and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in - let do_subst_ctx ctx = list_smartmap + let do_subst_ctx ctx = list_smartmap (fun (na, b, t) -> (na, Option.smartmap do_subst b, do_subst t)) ctx in - let do_subst_context (grs,ctx) = + let do_subst_context (grs,ctx) = list_smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, do_subst_ctx ctx in let do_subst_projs projs = list_smartmap (fun (x, y) -> (x, Option.smartmap do_subst_con y)) projs in @@ -128,15 +128,15 @@ let subst_class (_,subst,cl) = cl_projs = do_subst_projs cl.cl_projs; } let discharge_class (_,cl) = - let rel_of_variable_context ctx = List.fold_right + let rel_of_variable_context ctx = List.fold_right ( fun (n,_,b,t) (ctx', subst) -> let decl = (Name n, Option.map (substn_vars 1 subst) b, substn_vars 1 subst t) in - (decl :: ctx', n :: subst) + (decl :: ctx', n :: subst) ) ctx ([], []) in let discharge_rel_context subst n rel = let ctx, _ = List.fold_right - (fun (id, b, t) (ctx, k) -> + (fun (id, b, t) (ctx, k) -> (id, Option.smartmap (substn_vars k subst) b, substn_vars k subst t) :: ctx, succ k) rel ([], n) in ctx in @@ -146,7 +146,7 @@ let discharge_class (_,cl) = | ConstRef cst -> Lib.section_segment_of_constant cst | IndRef (ind,_) -> Lib.section_segment_of_mutual_inductive ind in let discharge_context ctx' subst (grs, ctx) = - let grs' = List.map (fun _ -> None) subst @ + let grs' = List.map (fun _ -> None) subst @ list_smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in @@ -160,7 +160,7 @@ let discharge_class (_,cl) = let rebuild_class cl = cl -let (class_input,class_output) = +let (class_input,class_output) = declare_object { (default_object "type classes state") with cache_function = cache_class; @@ -180,31 +180,31 @@ let add_class cl = * instances persistent object *) -let load_instance (_,inst) = - let insts = - try Gmap.find inst.is_class !instances +let load_instance (_,inst) = + let insts = + try Gmap.find inst.is_class !instances with Not_found -> Cmap.empty in let insts = Cmap.add inst.is_impl inst insts in instances := Gmap.add inst.is_class insts !instances let cache_instance = load_instance -let subst_instance (_,subst,inst) = - { inst with +let subst_instance (_,subst,inst) = + { inst with is_class = fst (subst_global subst inst.is_class); is_impl = fst (Mod_subst.subst_con subst inst.is_impl) } -let discharge_instance (_,inst) = - { inst with +let discharge_instance (_,inst) = + { inst with is_class = Lib.discharge_global inst.is_class; is_impl = Lib.discharge_con inst.is_impl} -let rebuild_instance inst = +let rebuild_instance inst = match !(inst.is_global) with | -1 | 0 -> inst (* TODO : probably a bug here *) | n -> add_instance_hint inst.is_impl inst.is_pri; inst.is_global := pred n; inst -let (instance_input,instance_output) = +let (instance_input,instance_output) = declare_object { (default_object "type classes instances state") with cache_function = cache_instance; @@ -224,18 +224,18 @@ let add_instance i = * interface functions *) -let class_info c = +let class_info c = try Gmap.find c !classes with _ -> not_a_class (Global.env()) (constr_of_global c) -let instance_constructor cl args = +let instance_constructor cl args = let pars = fst (list_chop (List.length (fst cl.cl_context)) args) in match cl.cl_impl with | IndRef ind -> applistc (mkConstruct (ind, 1)) args, applistc (mkInd ind) pars | ConstRef cst -> list_last args, applistc (mkConst cst) pars | _ -> assert false - + let typeclasses () = Gmap.fold (fun _ l c -> l :: c) !classes [] let cmapl_add x y m = @@ -247,19 +247,19 @@ let cmapl_add x y m = let cmap_elements c = Cmap.fold (fun k v acc -> v :: acc) c [] -let instances_of c = +let instances_of c = try cmap_elements (Gmap.find c.cl_impl !instances) with Not_found -> [] -let all_instances () = - Gmap.fold (fun k v acc -> +let all_instances () = + Gmap.fold (fun k v acc -> Cmap.fold (fun k v acc -> v :: acc) v acc) !instances [] -let instances r = +let instances r = let cl = class_info r in instances_of cl - - -let is_class gr = + + +let is_class gr = Gmap.fold (fun k v acc -> acc || v.cl_impl = gr) !classes false let is_instance = function @@ -273,16 +273,16 @@ let is_instance = function | _ -> false) | _ -> false -let is_implicit_arg k = +let is_implicit_arg k = match k with ImplicitArg (ref, (n, id), b) -> true | InternalHole -> true | _ -> false -let global_class_of_constr env c = +let global_class_of_constr env c = try class_info (global_of_constr c) with Not_found -> not_a_class env c - + let dest_class_app env c = let cl, args = decompose_app c in global_class_of_constr env cl, args @@ -290,40 +290,40 @@ let dest_class_app env c = let class_of_constr c = try Some (fst (dest_class_app (Global.env ()) c)) with _ -> None (* To embed a boolean for resolvability status. - This is essentially a hack to mark which evars correspond to - goals and do not need to be resolved when we have nested [resolve_all_evars] + This is essentially a hack to mark which evars correspond to + goals and do not need to be resolved when we have nested [resolve_all_evars] calls (e.g. when doing apply in an External hint in typeclass_instances). Would be solved by having real evars-as-goals. *) let ((bool_in : bool -> Dyn.t), (bool_out : Dyn.t -> bool)) = Dyn.create "bool" - + let bool_false = bool_in false let is_resolvable evi = match evi.evar_extra with Some t -> if Dyn.tag t = "bool" then bool_out t else true | None -> true - -let mark_unresolvable evi = + +let mark_unresolvable evi = { evi with evar_extra = Some bool_false } - + let mark_unresolvables sigma = Evd.fold (fun ev evi evs -> Evd.add evs ev (mark_unresolvable evi)) sigma Evd.empty - + let rec is_class_type evd c = match kind_of_term c with | Prod (_, _, t) -> is_class_type evd t | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c) | _ -> class_of_constr c <> None -let is_class_evar evd evi = +let is_class_evar evd evi = is_class_type evd evi.Evd.evar_concl - + let has_typeclasses evd = - Evd.fold (fun ev evi has -> has || + Evd.fold (fun ev evi has -> has || (evi.evar_body = Evar_empty && is_class_evar evd evi && is_resolvable evi)) evd false diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index c2f046440e..c9ee9adf0f 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -24,19 +24,19 @@ open Util (* This module defines type-classes *) type typeclass = { - (* The class implementation: a record parameterized by the context with defs in it or a definition if + (* The class implementation: a record parameterized by the context with defs in it or a definition if the class is a singleton. This acts as the class' global identifier. *) - cl_impl : global_reference; + cl_impl : global_reference; - (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. + (* Context in which the definitions are typed. Includes both typeclass parameters and superclasses. The boolean indicates if the typeclass argument is a direct superclass and the global reference gives a direct link to the class itself. *) - cl_context : (global_reference * bool) option list * rel_context; + cl_context : (global_reference * bool) option list * rel_context; (* Context of definitions and properties on defs, will not be shared *) cl_props : rel_context; - (* The methods implementations of the typeclass as projections. Some may be undefinable due to + (* The methods implementations of the typeclass as projections. Some may be undefinable due to sorting restrictions. *) cl_projs : (identifier * constant option) list; } @@ -60,7 +60,7 @@ val dest_class_app : env -> constr -> typeclass * constr list (* Just return None if not a class *) val class_of_constr : constr -> typeclass option - + val instance_impl : instance -> constant val is_class : global_reference -> bool @@ -82,7 +82,7 @@ val mark_unresolvable : evar_info -> evar_info val mark_unresolvables : evar_map -> evar_map val is_class_evar : evar_map -> evar_info -> bool -val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> +val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> env -> evar_defs -> evar_defs val resolve_one_typeclass : env -> evar_map -> types -> open_constr diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index cec46d780d..ae9dec97f3 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -24,7 +24,7 @@ open Libnames type contexts = Parameters | Properties -type typeclass_error = +type typeclass_error = | NotAClass of constr | UnboundMethod of global_reference * identifier located (* Class name, method *) | NoInstance of identifier located * constr list @@ -41,7 +41,7 @@ let unbound_method env cid id = typeclass_error env (UnboundMethod (cid, id)) let no_instance env id args = typeclass_error env (NoInstance (id, args)) -let unsatisfiable_constraints env evd ev = +let unsatisfiable_constraints env evd ev = match ev with | None -> raise (TypeClassError (env, UnsatisfiableConstraints (evd, None))) @@ -49,7 +49,7 @@ let unsatisfiable_constraints env evd ev = let loc, kind = Evd.evar_source ev evd in raise (Stdpp.Exc_located (loc, TypeClassError (env, UnsatisfiableConstraints (evd, Some (ev, kind))))) - + let mismatched_ctx_inst env c n m = typeclass_error env (MismatchedContextInstance (c, n, m)) let rec unsatisfiable_exception exn = diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index 4af1333e90..5cf8508901 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -24,7 +24,7 @@ open Libnames type contexts = Parameters | Properties -type typeclass_error = +type typeclass_error = | NotAClass of constr | UnboundMethod of global_reference * identifier located (* Class name, method *) | NoInstance of identifier located * constr list diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 4347366676..f4d032bf17 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -51,20 +51,20 @@ let rec execute env evd cstr = let jty = execute env evd (nf_evar evd ty) in let jty = assumption_of_judgment env jty in { uj_val = cstr; uj_type = jty } - - | Rel n -> + + | Rel n -> j_nf_evar evd (judge_of_relative env n) - | Var id -> + | Var id -> j_nf_evar evd (judge_of_variable env id) - + | Const c -> make_judge cstr (nf_evar evd (type_of_constant env c)) - + | Ind ind -> make_judge cstr (nf_evar evd (type_of_inductive env ind)) - - | Construct cstruct -> + + | Construct cstruct -> make_judge cstr (nf_evar evd (type_of_constructor env cstruct)) @@ -74,25 +74,25 @@ let rec execute env evd cstr = let lfj = execute_array env evd lf in let (j,_) = judge_of_case env ci pj cj lfj in j - + | Fix ((vn,i as vni),recdef) -> let (_,tys,_ as recdef') = execute_recdef env evd recdef in let fix = (vni,recdef') in check_fix env fix; make_judge (mkFix fix) tys.(i) - + | CoFix (i,recdef) -> let (_,tys,_ as recdef') = execute_recdef env evd recdef in let cofix = (i,recdef') in check_cofix env cofix; make_judge (mkCoFix cofix) tys.(i) - - | Sort (Prop c) -> + + | Sort (Prop c) -> judge_of_prop_contents c | Sort (Type u) -> judge_of_type u - + | App (f,args) -> let jl = execute_array env evd args in let j = @@ -102,23 +102,23 @@ let rec execute env evd cstr = make_judge f (inductive_type_knowing_parameters env ind (jv_nf_evar evd jl)) - | Const cst -> + | Const cst -> (* Sort-polymorphism of inductive types *) make_judge f (constant_type_knowing_parameters env cst (jv_nf_evar evd jl)) - | _ -> + | _ -> execute env evd f in fst (judge_of_apply env j jl) - - | Lambda (name,c1,c2) -> + + | Lambda (name,c1,c2) -> let j = execute env evd c1 in let var = type_judgment env j in let env1 = push_rel (name,None,var.utj_val) env in - let j' = execute env1 evd c2 in + let j' = execute env1 evd c2 in judge_of_abstraction env1 name var j' - + | Prod (name,c1,c2) -> let j = execute env evd c1 in let varj = type_judgment env j in @@ -135,7 +135,7 @@ let rec execute env evd cstr = let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in let j3 = execute env1 evd c3 in judge_of_letin env name j1 j2 j3 - + | Cast (c,k,t) -> let cj = execute env evd c in let tj = execute env evd t in @@ -163,7 +163,7 @@ let mcheck env evd c t = error_actual_type env j (nf_evar sigma t) (* Type of a constr *) - + let mtype_of env evd c = let j = execute env evd (nf_evar evd c) in (* We are outside the kernel: we take fresh universes *) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index dbb416beed..0aa65bef38 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -23,12 +23,12 @@ val type_of : env -> evar_map -> constr -> types val sort_of : env -> evar_map -> types -> sorts (* Typecheck a term has a given type (assuming the type is OK *) val check : env -> evar_map -> constr -> types -> unit - + (* The same but with metas... *) val mtype_of : env -> evar_defs -> constr -> types val msort_of : env -> evar_defs -> types -> sorts val mcheck : env -> evar_defs -> constr -> types -> unit val meta_type : evar_defs -> metavariable -> types - + (* unused typing function... *) val mtype_of_type : env -> evar_defs -> types -> types diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 92c1765930..fe18a0d192 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -31,7 +31,7 @@ open Recordops gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *) let abstract_scheme env c l lname_typ = - List.fold_left2 + List.fold_left2 (fun t (locc,a) (na,_,ta) -> let na = match kind_of_term a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences @@ -46,8 +46,8 @@ let abstract_scheme env c l lname_typ = let abstract_list_all env evd typ c l = let ctxt,_ = splay_prod_n env evd (List.length l) typ in let l_with_all_occs = List.map (function a -> (all_occurrences,a)) l in - let p = abstract_scheme env c l_with_all_occs ctxt in - try + let p = abstract_scheme env c l_with_all_occs ctxt in + try if is_conv_leq env evd (Typing.mtype_of env evd p) typ then p else error "abstract_list_all" with UserError _ | Type_errors.TypeError _ -> @@ -89,7 +89,7 @@ let rec subst_meta_instances bl c = let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) = match kind_of_term f with - | Meta k -> + | Meta k -> let c = solve_pattern_eqn env (Array.to_list l) c in let n = Array.length l - List.length (fst (decompose_lam c)) in let pb = (ConvUpToEta n,TypeNotProcessed) in @@ -127,14 +127,14 @@ let global_evars_pattern_unification_flag = ref true open Goptions let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "pattern-unification for existential variables in tactics"; optkey = ["Tactic";"Evars";"Pattern";"Unification"]; optread = (fun () -> !global_evars_pattern_unification_flag); optwrite = (:=) global_evars_pattern_unification_flag } -type unify_flags = { +type unify_flags = { modulo_conv_on_closed_terms : Names.transparent_state option; use_metas_eagerly : bool; modulo_delta : Names.transparent_state; @@ -159,35 +159,35 @@ let default_no_delta_unify_flags = { } let use_evars_pattern_unification flags = - !global_evars_pattern_unification_flag && flags.use_evars_pattern_unification + !global_evars_pattern_unification_flag && flags.use_evars_pattern_unification let expand_key env = function | Some (ConstKey cst) -> constant_opt_value env cst | Some (VarKey id) -> named_body id env | Some (RelKey _) -> None | None -> None - + let key_of flags f = match kind_of_term f with | Const cst when is_transparent (ConstKey cst) && Cpred.mem cst (snd flags.modulo_delta) -> - Some (ConstKey cst) + Some (ConstKey cst) | Var id when is_transparent (VarKey id) && Idpred.mem id (fst flags.modulo_delta) -> Some (VarKey id) | _ -> None - + let oracle_order env cf1 cf2 = match cf1 with | None -> - (match cf2 with + (match cf2 with | None -> None | Some k2 -> Some false) - | Some k1 -> + | Some k1 -> match cf2 with | None -> Some true | Some k2 -> Some (Conv_oracle.oracle_order k1 k2) - + let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flags m n = let trivial_unify curenv pb (sigma,metasubst,_) m n = let subst = if flags.use_metas_eagerly then metasubst else ms in @@ -203,15 +203,15 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag | _ -> false in let rec unirec_rec (curenv,nb as curenvnb) pb b ((sigma,metasubst,evarsubst) as substn) curm curn = let cM = Evarutil.whd_castappevar sigma curm - and cN = Evarutil.whd_castappevar sigma curn in + and cN = Evarutil.whd_castappevar sigma curn in match (kind_of_term cM,kind_of_term cN) with | Meta k1, Meta k2 -> let stM,stN = extract_instance_status pb in - if k1 < k2 + if k1 < k2 then sigma,(k1,cN,stN)::metasubst,evarsubst else if k1 = k2 then substn else sigma,(k2,cM,stM)::metasubst,evarsubst - | Meta k, _ when not (dependent cM cN) -> + | Meta k, _ when not (dependent cM cN) -> (* Here we check that [cN] does not contain any local variables *) if nb = 0 then sigma,(k,cN,snd (extract_instance_status pb))::metasubst,evarsubst @@ -220,7 +220,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst, evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) - | _, Meta k when not (dependent cN cM) -> + | _, Meta k when not (dependent cN cM) -> (* Here we check that [cM] does not contain any local variables *) if nb = 0 then (sigma,(k,cM,fst (extract_instance_status pb))::metasubst,evarsubst) @@ -239,7 +239,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (unirec_rec curenvnb topconv true substn t1 t2) c1 c2 | LetIn (_,a,_,c), _ -> unirec_rec curenvnb pb b substn (subst1 a c) cN | _, LetIn (_,a,_,c) -> unirec_rec curenvnb pb b substn cM (subst1 a c) - + | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> array_fold_left2 (unirec_rec curenvnb topconv true) (unirec_rec curenvnb topconv true @@ -264,10 +264,10 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag let (f1,l1,f2,l2) = if len1 = len2 then (f1,l1,f2,l2) else if len1 < len2 then - let extras,restl2 = array_chop (len2-len1) l2 in + let extras,restl2 = array_chop (len2-len1) l2 in (f1, l1, appvect (f2,extras), restl2) - else - let extras,restl1 = array_chop (len1-len2) l1 in + else + let extras,restl1 = array_chop (len1-len2) l1 in (appvect (f1,extras), restl1, f2, l2) in let pb = ConvUnderApp (len1,len2) in array_fold_left2 (unirec_rec curenvnb topconv true) @@ -276,12 +276,12 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag try expand curenvnb pb b substn cM f1 l1 cN f2 l2 with ex when precatchable_exception ex -> canonical_projections curenvnb pb b cM cN substn) - + | _ -> try canonical_projections curenvnb pb b cM cN substn with ex when precatchable_exception ex -> if constr_cmp (conv_pb_of cv_pb) cM cN then substn else - let (f1,l1) = + let (f1,l1) = match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in let (f2,l2) = match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in @@ -289,12 +289,12 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag and expand (curenv,_ as curenvnb) pb b (sigma, _, _ as substn) cM f1 l1 cN f2 l2 = if trivial_unify curenv pb substn cM cN then substn - else + else if b then let cf1 = key_of flags f1 and cf2 = key_of flags f2 in match oracle_order curenv cf1 cf2 with | None -> error_cannot_unify curenv sigma (cM,cN) - | Some true -> + | Some true -> (match expand_key curenv cf1 with | Some c -> unirec_rec curenvnb pb b substn @@ -331,10 +331,10 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) in - if flags.modulo_conv_on_closed_terms = None then + if flags.modulo_conv_on_closed_terms = None then error_cannot_unify (fst curenvnb) sigma (cM,cN) else - try f1 () with e when precatchable_exception e -> + try f1 () with e when precatchable_exception e -> if isApp cN then let f2l2 = decompose_app cN in if is_open_canonical_projection sigma f2l2 then @@ -357,15 +357,15 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (evd', mkMeta mv :: ks, m - 1)) (sigma,[],List.length bs - 1) bs in - let unilist2 f substn l l' = - try List.fold_left2 f substn l l' + let unilist2 f substn l l' = + try List.fold_left2 f substn l l' with Invalid_argument "List.fold_left2" -> error_cannot_unify (fst curenvnb) sigma (cM,cN) in - let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b s u1 (substl ks u)) + let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b s u1 (substl ks u)) (evd,ms,es) us2 us in - let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b s u1 (substl ks u)) - substn params1 params in - let substn = unilist2 (unirec_rec curenvnb pb b) substn ts ts1 in + let substn = unilist2 (fun s u1 u -> unirec_rec curenvnb pb b s u1 (substl ks u)) + substn params1 params in + let substn = unilist2 (unirec_rec curenvnb pb b) substn ts ts1 in unirec_rec curenvnb pb b substn c1 (applist (c,(List.rev ks))) in @@ -381,9 +381,9 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag Idpred.subset dl_id cv_id && Cpred.subset dl_k cv_k | None,(dl_id, dl_k) -> Idpred.is_empty dl_id && Cpred.is_empty dl_k) - then error_cannot_unify env sigma (m, n) else false) + then error_cannot_unify env sigma (m, n) else false) then subst - else + else unirec_rec (env,0) cv_pb conv_at_top subst m n let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env @@ -406,12 +406,12 @@ let rec unify_with_eta keptside flags env sigma k1 k2 c1 c2 = | (Lambda (na,t,c1'),_) when k2 > 0 -> let env' = push_rel_assum (na,t) env in let side = left in (* expansion on the right: we keep the left side *) - unify_with_eta side flags env' sigma (pop k1) (k2-1) + unify_with_eta side flags env' sigma (pop k1) (k2-1) c1' (mkApp (lift 1 c2,[|mkRel 1|])) | (_,Lambda (na,t,c2')) when k1 > 0 -> let env' = push_rel_assum (na,t) env in let side = right in (* expansion on the left: we keep the right side *) - unify_with_eta side flags env' sigma (k1-1) (pop k2) + unify_with_eta side flags env' sigma (k1-1) (pop k2) (mkApp (lift 1 c1,[|mkRel 1|])) c2' | _ -> (keptside,ConvUpToEta(min k1 k2), @@ -501,18 +501,18 @@ let merge_instances env sigma flags st1 st2 c1 c2 = * close it off. But this might not always work, * since other metavars might also need to be resolved. *) -let applyHead env evd n c = +let applyHead env evd n c = let rec apprec n c cty evd = - if n = 0 then + if n = 0 then (evd, c) - else + else match kind_of_term (whd_betadeltaiota env evd cty) with | Prod (_,c1,c2) -> - let (evd',evar) = + let (evd',evar) = Evarutil.new_evar evd env ~src:(dummy_loc,GoalEvar) c1 in apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd' | _ -> error "Apply_Head_Then" - in + in apprec n c (Typing.type_of env evd c) evd let is_mimick_head f = @@ -553,7 +553,7 @@ let w_coerce_to_type env evd c cty mvty = let tycon = mk_tycon_type mvty in try try_to_coerce env evd c cty tycon with e when precatchable_exception e -> - (* inh_conv_coerce_rigid_to should have reasoned modulo reduction + (* inh_conv_coerce_rigid_to should have reasoned modulo reduction but there are cases where it though it was not rigid (like in fst (nat,nat)) and stops while it could have seen that it is rigid *) let cty = Tacred.hnf_constr env evd cty in @@ -569,18 +569,18 @@ let unify_to_type env sigma flags c status u = let t = get_type_of env sigma c in let t = Tacred.hnf_constr env sigma (nf_betaiota sigma (nf_meta sigma t)) in let u = Tacred.hnf_constr env sigma u in - try + try if status = IsSuperType then unify_0 env sigma Cumul flags u t else if status = IsSubType then unify_0 env sigma Cumul flags t u - else + else try unify_0 env sigma Cumul flags t u with e when precatchable_exception e -> unify_0 env sigma Cumul flags u t with e when precatchable_exception e -> (sigma,[],[]) - + let unify_type env sigma flags mv status c = let mvty = Typing.meta_type sigma mv in if occur_meta_or_existential mvty or is_arity env sigma mvty then @@ -633,7 +633,7 @@ let w_merge env with_types flags (evd,metas,evars) = w_merge_rec (solve_simple_evar_eqn env evd ev rhs') metas evars' eqns end - | [] -> + | [] -> (* Process metas *) match metas with @@ -646,30 +646,30 @@ let w_merge env with_types flags (evd,metas,evars) = else (* No coercion needed: delay the unification of types *) ((evd,c),([],[])),(mv,status,c)::eqns - else + else ((evd,c),([],[])),eqns in if meta_defined evd mv then let {rebus=c'},(status',_) = meta_fvalue evd mv in let (take_left,st,(evd,metas',evars')) = merge_instances env evd flags status' status c' c in - let evd' = - if take_left then evd - else meta_reassign mv (c,(st,TypeProcessed)) evd + let evd' = + if take_left then evd + else meta_reassign mv (c,(st,TypeProcessed)) evd in w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns else let evd' = meta_assign mv (c,(status,TypeProcessed)) evd in w_merge_rec evd' (metas@metas'') evars'' eqns - | [] -> + | [] -> (* Process type eqns *) match eqns with | (mv,status,c)::eqns -> - let (evd,metas,evars) = unify_type env evd flags mv status c in + let (evd,metas,evars) = unify_type env evd flags mv status c in w_merge_rec evd metas evars eqns | [] -> evd - + and mimick_evar evd flags hdc nargs sp = let ev = Evd.find evd sp in let sp_env = Global.env_of_context ev.evar_hyps in @@ -719,7 +719,7 @@ let w_unify_core_0 env with_types cv_pb flags m n evd = unify_0_with_initial_metas (evd',ms,es) true env cv_pb flags m n in let evd = w_merge env with_types flags subst2 in - if flags.resolve_evars then + if flags.resolve_evars then try Typeclasses.resolve_typeclasses ~onlyargs:false ~split:false ~fail:true env evd with e when Typeclasses_errors.unsatisfiable_exception e -> @@ -734,11 +734,11 @@ let w_typed_unify env = w_unify_core_0 env true FAIL because we cannot find a binding *) let iter_fail f a = - let n = Array.length a in + let n = Array.length a in let rec ffail i = - if i = n then error "iter_fail" + if i = n then error "iter_fail" else - try f a.(i) + try f a.(i) with ex when precatchable_exception ex -> ffail (i+1) in ffail 0 @@ -748,56 +748,56 @@ let iter_fail f a = let w_unify_to_subterm env ?(flags=default_unify_flags) (op,cl) evd = let rec matchrec cl = let cl = strip_outer_cast cl in - (try - if closed0 cl + (try + if closed0 cl then w_typed_unify env topconv flags op cl evd,cl else error "Bound 1" with ex when precatchable_exception ex -> - (match kind_of_term cl with + (match kind_of_term cl with | App (f,args) -> let n = Array.length args in assert (n>0); let c1 = mkApp (f,Array.sub args 0 (n-1)) in let c2 = args.(n-1) in - (try + (try matchrec c1 - with ex when precatchable_exception ex -> + with ex when precatchable_exception ex -> matchrec c2) | Case(_,_,c,lf) -> (* does not search in the predicate *) - (try + (try matchrec c - with ex when precatchable_exception ex -> + with ex when precatchable_exception ex -> iter_fail matchrec lf) - | LetIn(_,c1,_,c2) -> - (try + | LetIn(_,c1,_,c2) -> + (try matchrec c1 - with ex when precatchable_exception ex -> + with ex when precatchable_exception ex -> matchrec c2) - | Fix(_,(_,types,terms)) -> - (try + | Fix(_,(_,types,terms)) -> + (try iter_fail matchrec types - with ex when precatchable_exception ex -> + with ex when precatchable_exception ex -> iter_fail matchrec terms) - - | CoFix(_,(_,types,terms)) -> - (try + + | CoFix(_,(_,types,terms)) -> + (try iter_fail matchrec types - with ex when precatchable_exception ex -> + with ex when precatchable_exception ex -> iter_fail matchrec terms) | Prod (_,t,c) -> - (try - matchrec t - with ex when precatchable_exception ex -> + (try + matchrec t + with ex when precatchable_exception ex -> matchrec c) | Lambda (_,t,c) -> - (try - matchrec t - with ex when precatchable_exception ex -> + (try + matchrec t + with ex when precatchable_exception ex -> matchrec c) - | _ -> error "Match_subterm")) - in + | _ -> error "Match_subterm")) + in try matchrec cl with ex when precatchable_exception ex -> raise (PretypeError (env,NoOccurrenceFound (op, None))) @@ -808,10 +808,10 @@ let w_unify_to_subterm env ?(flags=default_unify_flags) (op,cl) evd = let w_unify_to_subterm_all env ?(flags=default_unify_flags) (op,cl) evd = let return a b = let (evd,c as a) = a () in - if List.exists (fun (evd',c') -> eq_constr c c') b then b else a :: b + if List.exists (fun (evd',c') -> eq_constr c c') b then b else a :: b in let fail str _ = error str in - let bind f g a = + let bind f g a = let a1 = try f a with ex when precatchable_exception ex -> a @@ -820,7 +820,7 @@ let w_unify_to_subterm_all env ?(flags=default_unify_flags) (op,cl) evd = when precatchable_exception ex -> a1 in let bind_iter f a = - let n = Array.length a in + let n = Array.length a in let rec ffail i = if i = n then fun a -> a else bind (f a.(i)) (ffail (i+1)) @@ -828,11 +828,11 @@ let w_unify_to_subterm_all env ?(flags=default_unify_flags) (op,cl) evd = in let rec matchrec cl = let cl = strip_outer_cast cl in - (bind - (if closed0 cl + (bind + (if closed0 cl then return (fun () -> w_typed_unify env topconv flags op cl evd,cl) else fail "Bound 1") - (match kind_of_term cl with + (match kind_of_term cl with | App (f,args) -> let n = Array.length args in assert (n>0); @@ -843,42 +843,42 @@ let w_unify_to_subterm_all env ?(flags=default_unify_flags) (op,cl) evd = | Case(_,_,c,lf) -> (* does not search in the predicate *) bind (matchrec c) (bind_iter matchrec lf) - | LetIn(_,c1,_,c2) -> + | LetIn(_,c1,_,c2) -> bind (matchrec c1) (matchrec c2) | Fix(_,(_,types,terms)) -> bind (bind_iter matchrec types) (bind_iter matchrec terms) - - | CoFix(_,(_,types,terms)) -> + + | CoFix(_,(_,types,terms)) -> bind (bind_iter matchrec types) (bind_iter matchrec terms) | Prod (_,t,c) -> bind (matchrec t) (matchrec c) - + | Lambda (_,t,c) -> bind (matchrec t) (matchrec c) - | _ -> fail "Match_subterm")) - in + | _ -> fail "Match_subterm")) + in let res = matchrec cl [] in if res = [] then raise (PretypeError (env,NoOccurrenceFound (op, None))) else res -let w_unify_to_subterm_list env flags allow_K oplist t evd = - List.fold_right +let w_unify_to_subterm_list env flags allow_K oplist t evd = + List.fold_right (fun op (evd,l) -> if isMeta op then if allow_K then (evd,op::l) else error "Unify_to_subterm_list" else if occur_meta_or_existential op then let (evd',cl) = - try + try (* This is up to delta for subterms w/o metas ... *) w_unify_to_subterm env ~flags (strip_outer_cast op,t) evd with PretypeError (env,NoOccurrenceFound _) when allow_K -> (evd,op) - in + in if not allow_K && (* ensure we found a different instance *) List.exists (fun op -> eq_constr op cl) l then error "Unify_to_subterm_list" @@ -888,7 +888,7 @@ let w_unify_to_subterm_list env flags allow_K oplist t evd = else (* This is not up to delta ... *) raise (PretypeError (env,NoOccurrenceFound (op, None)))) - oplist + oplist (evd,[]) let secondOrderAbstraction env flags allow_K typ (p, oplist) evd = @@ -907,13 +907,13 @@ let w_unify2 env flags allow_K cv_pb ty1 ty2 evd = | Meta p1, _ -> (* Find the predicate *) let evd' = - secondOrderAbstraction env flags allow_K ty2 (p1,oplist1) evd in + secondOrderAbstraction env flags allow_K ty2 (p1,oplist1) evd in (* Resume first order unification *) w_unify_0 env cv_pb flags (nf_meta evd' ty1) ty2 evd' | _, Meta p2 -> (* Find the predicate *) let evd' = - secondOrderAbstraction env flags allow_K ty1 (p2, oplist2) evd in + secondOrderAbstraction env flags allow_K ty1 (p2, oplist2) evd in (* Resume first order unification *) w_unify_0 env cv_pb flags ty1 (nf_meta evd' ty2) evd' | _ -> error "w_unify2" @@ -946,23 +946,23 @@ let w_unify allow_K env cv_pb ?(flags=default_unify_flags) ty1 ty2 evd = (* Pattern case *) | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true) when List.length l1 = List.length l2 -> - (try + (try w_typed_unify env cv_pb flags ty1 ty2 evd - with ex when precatchable_exception ex -> - try + with ex when precatchable_exception ex -> + try w_unify2 env flags allow_K cv_pb ty1 ty2 evd with PretypeError (env,NoOccurrenceFound _) as e -> raise e) - + (* Second order case *) - | (Meta _, true, _, _ | _, _, Meta _, true) -> - (try + | (Meta _, true, _, _ | _, _, Meta _, true) -> + (try w_unify2 env flags allow_K cv_pb ty1 ty2 evd with PretypeError (env,NoOccurrenceFound _) as e -> raise e - | ex when precatchable_exception ex -> - try + | ex when precatchable_exception ex -> + try w_typed_unify env cv_pb flags ty1 ty2 evd with ex' when precatchable_exception ex' -> raise ex) - + (* General case: try first order *) | _ -> w_typed_unify env cv_pb flags ty1 ty2 evd diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 43c9dd2e9b..2df1c648a4 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -14,8 +14,8 @@ open Environ open Evd (*i*) -type unify_flags = { - modulo_conv_on_closed_terms : Names.transparent_state option; +type unify_flags = { + modulo_conv_on_closed_terms : Names.transparent_state option; use_metas_eagerly : bool; modulo_delta : Names.transparent_state; resolve_evars : bool; diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 6eb7302f02..c894d2b519 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -13,14 +13,14 @@ open Declarations open Term open Environ open Inductive -open Reduction +open Reduction open Vm (*******************************************) (* Calcul de la forme normal d'un terme *) (*******************************************) -let crazy_type = mkSet +let crazy_type = mkSet let decompose_prod env t = let (name,dom,codom as res) = destProd (whd_betadeltaiota env t) in @@ -33,18 +33,18 @@ exception Find_at of int [cst] = true si c'est un constructeur constant *) let invert_tag cst tag reloc_tbl = - try + try for j = 0 to Array.length reloc_tbl - 1 do let tagj,arity = reloc_tbl.(j) in if tag = tagj && (cst && arity = 0 || not(cst || arity = 0)) then raise (Find_at j) else () - done;raise Not_found - with Find_at j -> (j+1) + done;raise Not_found + with Find_at j -> (j+1) (* Argggg, ces constructeurs de ... qui commencent a 1*) let find_rectype_a env c = - let (t, l) = + let (t, l) = let t = whd_betadeltaiota env c in try destApp t with _ -> (t,[||]) in match kind_of_term t with @@ -53,13 +53,13 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib typ params = +let type_constructor mind mib typ params = let s = ind_subst mind mib in let ctyp = substl s typ in let nparams = Array.length params in if nparams = 0 then ctyp else - let _,ctyp = decompose_prod_n nparams ctyp in + let _,ctyp = decompose_prod_n nparams ctyp in substl (List.rev (Array.to_list params)) ctyp @@ -85,7 +85,7 @@ let construct_of_constr const env tag typ = let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in (mkApp(mkConstruct(ind,i), params), ctyp) -let construct_of_constr_const env tag typ = +let construct_of_constr_const env tag typ = fst (construct_of_constr true env tag typ) let construct_of_constr_block = construct_of_constr false @@ -94,15 +94,15 @@ let constr_type_of_idkey env idkey = match idkey with | ConstKey cst -> mkConst cst, Typeops.type_of_constant env cst - | VarKey id -> - let (_,_,ty) = lookup_named id env in + | VarKey id -> + let (_,_,ty) = lookup_named id env in mkVar id, ty - | RelKey i -> + | RelKey i -> let n = (nb_rel env - i) in let (_,_,ty) = lookup_rel n env in mkRel n, lift n ty -let type_of_ind env ind = +let type_of_ind env ind = type_of_inductive env (Inductive.lookup_mind_specif env ind) let build_branches_type env (mind,_ as _ind) mib mip params dep p = @@ -116,7 +116,7 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = let nparams = Array.length params in let carity = snd (rtbl.(i)) in let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in - let codom = + let codom = let papp = mkApp(p,crealargs) in if dep then let cstr = ith_constructor_of_inductive ind (i+1) in @@ -124,17 +124,17 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in mkApp(papp,[|dep_cstr|]) else papp - in + in decl, codom in Array.mapi build_one_branch mip.mind_nf_lc -let build_case_type dep p realargs c = +let build_case_type dep p realargs c = if dep then mkApp(mkApp(p, realargs), [|c|]) else mkApp(p, realargs) (* La fonction de normalisation *) -let rec nf_val env v t = nf_whd env (whd_val v) t +let rec nf_val env v t = nf_whd env (whd_val v) t and nf_vtype env v = nf_val env v crazy_type @@ -145,18 +145,18 @@ and nf_whd env whd typ = let dom = nf_vtype env (dom p) in let name = Name (id_of_string "x") in let vc = body_of_vfun (nb_rel env) (codom p) in - let codom = nf_vtype (push_rel (name,None,dom) env) vc in - mkProd(name,dom,codom) + let codom = nf_vtype (push_rel (name,None,dom) env) vc in + mkProd(name,dom,codom) | Vfun f -> nf_fun env f typ | Vfix(f,None) -> nf_fix env f | Vfix(f,Some vargs) -> fst (nf_fix_app env f vargs) - | Vcofix(cf,_,None) -> nf_cofix env cf - | Vcofix(cf,_,Some vargs) -> + | Vcofix(cf,_,None) -> nf_cofix env cf + | Vcofix(cf,_,Some vargs) -> let cfd = nf_cofix env cf in let i,(_,ta,_) = destCoFix cfd in let t = ta.(i) in let _, args = nf_args env vargs t in - mkApp(cfd,args) + mkApp(cfd,args) | Vconstr_const n -> construct_of_constr_const env n typ | Vconstr_block b -> let capp,ctyp = construct_of_constr_block env (btag b) typ in @@ -168,24 +168,24 @@ and nf_whd env whd typ = | Vatom_stk(Aiddef(idkey,v), stk) -> nf_whd env (whd_stack v stk) typ | Vatom_stk(Aind ind, stk) -> - nf_stk env (mkInd ind) (type_of_ind env ind) stk - + nf_stk env (mkInd ind) (type_of_ind env ind) stk + and nf_stk env c t stk = match stk with | [] -> c | Zapp vargs :: stk -> let t, args = nf_args env vargs t in - nf_stk env (mkApp(c,args)) t stk - | Zfix (f,vargs) :: stk -> + nf_stk env (mkApp(c,args)) t stk + | Zfix (f,vargs) :: stk -> let fa, typ = nf_fix_app env f vargs in let _,_,codom = try decompose_prod env typ with _ -> exit 120 in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk - | Zswitch sw :: stk -> + | Zswitch sw :: stk -> let (mind,_ as ind),allargs = find_rectype_a env t in let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params,realargs = Util.array_chop nparams allargs in - let pT = + let pT = hnf_prod_applist env (type_of_ind env ind) (Array.to_list params) in let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params (type_of_switch sw) pT in @@ -195,12 +195,12 @@ and nf_stk env c t stk = let bsw = branch_of_switch (nb_rel env) sw in let mkbranch i (n,v) = let decl,codom = btypes.(i) in - let env = - List.fold_right + let env = + List.fold_right (fun (name,t) env -> push_rel (name,None,t) env) decl env in let b = nf_val env v codom in - compose_lam decl b - in + compose_lam decl b + in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type dep p realargs c in let ci = case_info sw in @@ -212,10 +212,10 @@ and nf_predicate env ind mip params v pT = let k = nb_rel env in let vb = body_of_vfun k f in let name,dom,codom = try decompose_prod env pT with _ -> exit 121 in - let dep,body = + let dep,body = nf_predicate (push_rel (name,None,dom) env) ind mip params vb codom in dep, mkLambda(name,dom,body) - | Vfun f, _ -> + | Vfun f, _ -> let k = nb_rel env in let vb = body_of_vfun k f in let name = Name (id_of_string "c") in @@ -226,12 +226,12 @@ and nf_predicate env ind mip params v pT = let body = nf_vtype (push_rel (name,None,dom) env) vb in true, mkLambda(name,dom,body) | _, _ -> false, nf_val env v crazy_type - + and nf_args env vargs t = let t = ref t in let len = nargs vargs in - let args = - Array.init len + let args = + Array.init len (fun i -> let _,dom,codom = try decompose_prod env !t with _ -> exit 123 in let c = nf_val env (arg vargs i) dom in @@ -242,8 +242,8 @@ and nf_bargs env b t = let t = ref t in let len = bsize b in let args = - Array.init len - (fun i -> + Array.init len + (fun i -> let _,dom,codom = try decompose_prod env !t with _ -> exit 124 in let c = nf_val env (bfield b i) dom in t := subst1 c codom; c) in @@ -252,7 +252,7 @@ and nf_bargs env b t = and nf_fun env f typ = let k = nb_rel env in let vb = body_of_vfun k f in - let name,dom,codom = + let name,dom,codom = try decompose_prod env typ with _ -> raise (Type_errors.TypeError(env,Type_errors.ReferenceVariables typ)) @@ -268,17 +268,17 @@ and nf_fix env f = let ndef = Array.length vt in let ft = Array.map (fun v -> nf_val env v crazy_type) vt in let name = Array.init ndef (fun _ -> (Name (id_of_string "Ffix"))) in - let env = push_rec_types (name,ft,ft) env in + let env = push_rec_types (name,ft,ft) env in let fb = Util.array_map2 (fun v t -> nf_fun env v t) vb ft in mkFix ((rec_args,init),(name,ft,fb)) - + and nf_fix_app env f vargs = let fd = nf_fix env f in let (_,i),(_,ta,_) = destFix fd in let t = ta.(i) in let t, args = nf_args env vargs t in mkApp(fd,args),t - + and nf_cofix env cf = let init = current_cofix cf in let k = nb_rel env in @@ -286,15 +286,15 @@ and nf_cofix env cf = let ndef = Array.length vt in let cft = Array.map (fun v -> nf_val env v crazy_type) vt in let name = Array.init ndef (fun _ -> (Name (id_of_string "Fcofix"))) in - let env = push_rec_types (name,cft,cft) env in + let env = push_rec_types (name,cft,cft) env in let cfb = Util.array_map2 (fun v t -> nf_val env v t) vb cft in mkCoFix (init,(name,cft,cfb)) - + let cbv_vm env c t = let transp = transp_values () in - if not transp then set_transp_values true; + if not transp then set_transp_values true; let v = Vconv.val_of_constr env c in let c = nf_val env v t in - if not transp then set_transp_values false; + if not transp then set_transp_values false; c - + diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 87dd26779e..bdc1f6b660 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -30,24 +30,24 @@ open Pattern open Tacexpr open Clenv - + (* This function put casts around metavariables whose type could not be * infered by the refiner, that is head of applications, predicates and * subject of Cases. * Does check that the casted type is closed. Anyway, the refiner would * fail in this case... *) -let clenv_cast_meta clenv = +let clenv_cast_meta clenv = let rec crec u = match kind_of_term u with | App _ | Case _ -> crec_hd u | Cast (c,_,_) when isMeta c -> u | _ -> map_constr crec u - + and crec_hd u = match kind_of_term (strip_outer_cast u) with | Meta mv -> - (try + (try let b = Typing.meta_type clenv.evd mv in assert (not (occur_meta b)); if occur_meta b then u @@ -57,7 +57,7 @@ let clenv_cast_meta clenv = | Case(ci,p,c,br) -> mkCase (ci, crec_hd p, crec_hd c, Array.map crec br) | _ -> u - in + in crec let clenv_value_cast_meta clenv = @@ -73,14 +73,14 @@ let clenv_pose_dependent_evars with_evars clenv = let clenv_refine with_evars ?(with_classes=true) clenv gls = let clenv = clenv_pose_dependent_evars with_evars clenv in - let evd' = - if with_classes then - Typeclasses.resolve_typeclasses ~fail:(not with_evars) - clenv.env clenv.evd + let evd' = + if with_classes then + Typeclasses.resolve_typeclasses ~fail:(not with_evars) + clenv.env clenv.evd else clenv.evd in tclTHEN - (tclEVARS evd') + (tclEVARS evd') (refine (clenv_cast_meta clenv (clenv_value clenv))) gls @@ -105,7 +105,7 @@ let e_res_pf clenv = res_pf clenv ~with_evars:true ~allow_K:false ~flags:dft open Unification let fail_quick_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; + modulo_conv_on_closed_terms = Some full_transparent_state; use_metas_eagerly = false; modulo_delta = empty_transparent_state; resolve_evars = false; @@ -113,7 +113,7 @@ let fail_quick_unif_flags = { } (* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *) -let unifyTerms ?(flags=fail_quick_unif_flags) m n gls = +let unifyTerms ?(flags=fail_quick_unif_flags) m n gls = let env = pf_env gls in let evd = create_goal_evar_defs (project gls) in let evd' = w_unify false env CONV ~flags m n evd in diff --git a/proofs/decl_expr.mli b/proofs/decl_expr.mli index d02060fc0a..20a95dabff 100644 --- a/proofs/decl_expr.mli +++ b/proofs/decl_expr.mli @@ -12,7 +12,7 @@ open Names open Util open Tacexpr -type 'it statement = +type 'it statement = {st_label:name; st_it:'it} @@ -41,12 +41,12 @@ type ('it,'constr,'tac) cut = cut_by: 'constr list option; cut_using: 'tac option} -type ('var,'constr) hyp = - Hvar of 'var +type ('var,'constr) hyp = + Hvar of 'var | Hprop of 'constr statement -type ('constr,'tac) casee = - Real of 'constr +type ('constr,'tac) casee = + Real of 'constr | Virtual of ('constr statement,'constr,'tac) cut type ('hyp,'constr,'pat,'tac) bare_proof_instr = @@ -64,9 +64,9 @@ type ('hyp,'constr,'pat,'tac) bare_proof_instr = | Pfocus of 'constr statement | Pdefine of identifier * 'hyp list * 'constr | Pcast of identifier or_thesis * 'constr - | Psuppose of ('hyp,'constr) hyp list - | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list) - | Ptake of 'constr list + | Psuppose of ('hyp,'constr) hyp list + | Pcase of 'hyp list*'pat*(('hyp,'constr or_thesis) hyp list) + | Ptake of 'constr list | Pper of elim_type * ('constr,'tac) casee | Pend of block_type | Pescape @@ -86,11 +86,11 @@ type raw_proof_instr = type glob_proof_instr = ((identifier*(Genarg.rawconstr_and_expr option)) located, - Genarg.rawconstr_and_expr, + Genarg.rawconstr_and_expr, Topconstr.cases_pattern_expr, Tacexpr.glob_tactic_expr) gen_proof_instr -type proof_pattern = +type proof_pattern = {pat_vars: Term.types statement list; pat_aliases: (Term.constr*Term.types) statement list; pat_constr: Term.constr; @@ -100,6 +100,6 @@ type proof_pattern = type proof_instr = (Term.constr statement, - Term.constr, + Term.constr, proof_pattern, Tacexpr.glob_tactic_expr) gen_proof_instr diff --git a/proofs/decl_mode.ml b/proofs/decl_mode.ml index cdb7b0675e..a32b9777ba 100644 --- a/proofs/decl_mode.ml +++ b/proofs/decl_mode.ml @@ -15,9 +15,9 @@ open Util let daimon_flag = ref false -let set_daimon_flag () = daimon_flag:=true +let set_daimon_flag () = daimon_flag:=true let clear_daimon_flag () = daimon_flag:=false -let get_daimon_flag () = !daimon_flag +let get_daimon_flag () = !daimon_flag type command_mode = Mode_tactic @@ -27,12 +27,12 @@ type command_mode = let mode_of_pftreestate pts = let goal = sig_it (Refiner.top_goal_of_pftreestate pts) in if goal.evar_extra = None then - Mode_tactic + Mode_tactic else Mode_proof - + let get_current_mode () = - try + try mode_of_pftreestate (Pfedit.get_pftreestate ()) with _ -> Mode_none @@ -42,7 +42,7 @@ let check_not_proof_mode str = type split_tree= Skip_patt of Idset.t * split_tree - | Split_patt of Idset.t * inductive * + | Split_patt of Idset.t * inductive * (bool array * (Idset.t * split_tree) option) array | Close_patt of split_tree | End_patt of (identifier * int) @@ -54,7 +54,7 @@ type elim_kind = type recpath = int option*Declarations.wf_paths -type per_info = +type per_info = {per_casee:constr; per_ctype:types; per_ind:inductive; @@ -64,7 +64,7 @@ type per_info = per_nparams:int; per_wf:recpath} -type stack_info = +type stack_info = Per of Decl_expr.elim_type * per_info * elim_kind * identifier list | Suppose_case | Claim @@ -73,7 +73,7 @@ type stack_info = type pm_info = { pm_stack : stack_info list} -let pm_in,pm_out = Dyn.create "pm_info" +let pm_in,pm_out = Dyn.create "pm_info" let get_info gl= match gl.evar_extra with @@ -81,30 +81,30 @@ let get_info gl= | Some extra -> try pm_out extra with _ -> invalid_arg "get_info" -let get_stack pts = +let get_stack pts = let info = get_info (sig_it (Refiner.nth_goal_of_pftreestate 1 pts)) in info.pm_stack -let get_top_stack pts = +let get_top_stack pts = let info = get_info (sig_it (Refiner.top_goal_of_pftreestate pts)) in info.pm_stack let get_end_command pts = - match mode_of_pftreestate pts with + match mode_of_pftreestate pts with Mode_proof -> - Some + Some begin match get_top_stack pts with [] -> "\"end proof\"" | Claim::_ -> "\"end claim\"" | Focus_claim::_-> "\"end focus\"" - | (Suppose_case :: Per (et,_,_,_) :: _ - | Per (et,_,_,_) :: _ ) -> + | (Suppose_case :: Per (et,_,_,_) :: _ + | Per (et,_,_,_) :: _ ) -> begin match et with - Decl_expr.ET_Case_analysis -> + Decl_expr.ET_Case_analysis -> "\"end cases\" or start a new case" - | Decl_expr.ET_Induction -> + | Decl_expr.ET_Induction -> "\"end induction\" or start a new case" end | _ -> anomaly "lonely suppose" @@ -112,7 +112,7 @@ let get_end_command pts = | Mode_tactic -> begin try - ignore + ignore (Refiner.up_until_matching_rule Proof_trees.is_proof_instr pts); Some "\"return\"" with Not_found -> None @@ -120,7 +120,7 @@ let get_end_command pts = | Mode_none -> error "no proof in progress" -let get_last env = - try +let get_last env = + try let (id,_,_) = List.hd (Environ.named_context env) in id with Invalid_argument _ -> error "no previous statement to use" diff --git a/proofs/decl_mode.mli b/proofs/decl_mode.mli index 6be3abdfe3..e225c828d2 100644 --- a/proofs/decl_mode.mli +++ b/proofs/decl_mode.mli @@ -23,7 +23,7 @@ type command_mode = | Mode_none val mode_of_pftreestate : pftreestate -> command_mode - + val get_current_mode : unit -> command_mode val check_not_proof_mode : string -> unit @@ -42,7 +42,7 @@ type elim_kind = type recpath = int option*Declarations.wf_paths -type per_info = +type per_info = {per_casee:constr; per_ctype:types; per_ind:inductive; @@ -52,7 +52,7 @@ type per_info = per_nparams:int; per_wf:recpath} -type stack_info = +type stack_info = Per of Decl_expr.elim_type * per_info * elim_kind * Names.identifier list | Suppose_case | Claim diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index d7a1232ad0..25c668f5dd 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -29,7 +29,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = (Pretyping.OfType (Some evi.evar_concl)) rawc with _ -> let loc = Rawterm.loc_of_rawconstr rawc in - user_err_loc + user_err_loc (loc,"",Pp.str ("Instance is not well-typed in the environment of " ^ string_of_existential evk)) in @@ -37,10 +37,10 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = (* vernac command Existential *) -let instantiate_pf_com n com pfts = +let instantiate_pf_com n com pfts = let gls = top_goal_of_pftreestate pfts in - let sigma = gls.sigma in - let (evk,evi) = + let sigma = gls.sigma in + let (evk,evi) = let evl = Evarutil.non_instantiated sigma in if (n <= 0) then error "incorrect existential variable index" @@ -48,8 +48,8 @@ let instantiate_pf_com n com pfts = error "not so many uninstantiated existential variables" else List.nth evl (n-1) - in + in let env = Evd.evar_env evi in - let rawc = Constrintern.intern_constr sigma env com in + let rawc = Constrintern.intern_constr sigma env com in let sigma' = w_refine (evk,evi) (([],[]),rawc) sigma in change_constraints_pftreestate sigma' pfts diff --git a/proofs/evar_refiner.mli b/proofs/evar_refiner.mli index a35a9b58b0..ab0fdf8314 100644 --- a/proofs/evar_refiner.mli +++ b/proofs/evar_refiner.mli @@ -20,10 +20,10 @@ open Rawterm (* Refinement of existential variables. *) -val w_refine : evar * evar_info -> +val w_refine : evar * evar_info -> (var_map * unbound_ltac_var_map) * rawconstr -> evar_defs -> evar_defs val instantiate_pf_com : int -> Topconstr.constr_expr -> pftreestate -> pftreestate -(* the instantiate tactic was moved to [tactics/evar_tactics.ml] *) +(* the instantiate tactic was moved to [tactics/evar_tactics.ml] *) diff --git a/proofs/logic.ml b/proofs/logic.ml index f1f33930e9..eddf387f9a 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -28,7 +28,7 @@ open Type_errors open Retyping open Evarutil open Tacexpr - + type refiner_error = (* Errors raised by the refiner *) @@ -50,7 +50,7 @@ open Pretype_errors let rec catchable_exception = function | Stdpp.Exc_located(_,e) -> catchable_exception e | LtacLocated(_,e) -> catchable_exception e - | Util.UserError _ | TypeError _ + | Util.UserError _ | TypeError _ | RefinerError _ | Indrec.RecursionSchemeError _ | Nametab.GlobalizationError _ | PretypeError (_,VarNotFound _) (* unification errors *) @@ -58,7 +58,7 @@ let rec catchable_exception = function |NoOccurrenceFound _|CannotUnifyBindingType _|NotClean _ |CannotFindWellTypedAbstraction _ |UnsolvableImplicit _)) -> true - | Typeclasses_errors.TypeClassError + | Typeclasses_errors.TypeClassError (_, Typeclasses_errors.UnsatisfiableConstraints _) -> true | _ -> false @@ -73,19 +73,19 @@ let with_check = Flags.with_option check (* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and returns [tail::(f head (id,_,_) (rev tail))] *) let apply_to_hyp sign id f = - try apply_to_hyp sign id f - with Hyp_not_found -> + try apply_to_hyp sign id f + with Hyp_not_found -> if !check then error "No such assumption." else sign let apply_to_hyp_and_dependent_on sign id f g = - try apply_to_hyp_and_dependent_on sign id f g - with Hyp_not_found -> + try apply_to_hyp_and_dependent_on sign id f g + with Hyp_not_found -> if !check then error "No such assumption." else sign let check_typability env sigma c = - if !check then let _ = type_of env sigma c in () + if !check then let _ = type_of env sigma c in () (************************************************************************) (************************************************************************) @@ -111,7 +111,7 @@ let recheck_typability (what,id) env sigma t = | Some id -> "hypothesis "^(string_of_id id) in error ("The correctness of "^s^" relies on the body of "^(string_of_id id)) - + let remove_hyp_body env sigma id = let sign = apply_to_hyp_and_dependent_on (named_context_val env) id @@ -121,7 +121,7 @@ let remove_hyp_body env sigma id = | Some c ->(id,None,t)) (fun (id',c,t as d) sign -> (if !check then - begin + begin let env = reset_with_named_context sign env in match c with | None -> recheck_typability (Some id',id) env sigma t @@ -130,7 +130,7 @@ let remove_hyp_body env sigma id = recheck_typability (Some id',id) env sigma b' end;d)) in - reset_with_named_context sign env + reset_with_named_context sign env (* Reordering of the context *) @@ -138,7 +138,7 @@ let remove_hyp_body env sigma id = (* sous-ordre du resultat. Par exemple, 2 hyps non mentionnee ne sont *) (* pas echangees. Choix: les hyps mentionnees ne peuvent qu'etre *) (* reculees par rapport aux autres (faire le contraire!) *) - + let mt_q = (Idmap.empty,[]) let push_val y = function (_,[] as q) -> q @@ -211,8 +211,8 @@ let check_decl_position env sign (x,_,_ as d) = (* Auxiliary functions for primitive MOVE tactic * * [move_hyp with_dep toleft (left,(hfrom,typfrom),right) hto] moves - * hyp [hfrom] at location [hto] which belongs to the hyps on the - * left side [left] of the full signature if [toleft=true] or to the hyps + * hyp [hfrom] at location [hto] which belongs to the hyps on the + * left side [left] of the full signature if [toleft=true] or to the hyps * on the right side [right] if [toleft=false]. * If [with_dep] then dependent hypotheses are moved accordingly. *) @@ -228,17 +228,17 @@ let split_sign hfrom hto l = let rec splitrec left toleft = function | [] -> error_no_such_hypothesis hfrom | (hyp,c,typ) as d :: right -> - if hyp = hfrom then + if hyp = hfrom then (left,right,d, toleft or hto = MoveToEnd true) else - splitrec (d::left) + splitrec (d::left) (toleft or hto = MoveAfter hyp or hto = MoveBefore hyp) right - in + in splitrec [] false l let hyp_of_move_location = function - | MoveAfter id -> id + | MoveAfter id -> id | MoveBefore id -> id | _ -> assert false @@ -258,12 +258,12 @@ let move_hyp with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto = List.rev first @ List.rev middle @ right | (hyp,_,_) as d :: right -> let (first',middle') = - if List.exists (test_dep d) middle then - if with_dep & hto <> MoveAfter hyp then + if List.exists (test_dep d) middle then + if with_dep & hto <> MoveAfter hyp then (first, d::middle) - else + else errorlabstrm "" (str "Cannot move " ++ pr_id idfrom ++ - pr_move_location pr_id hto ++ + pr_move_location pr_id hto ++ str (if toleft then ": it occurs in " else ": it depends on ") ++ pr_id hyp ++ str ".") else @@ -271,16 +271,16 @@ let move_hyp with_dep toleft (left,(idfrom,_,_ as declfrom),right) hto = in if hto = MoveAfter hyp then List.rev first' @ List.rev middle' @ right - else + else moverec first' middle' right in - if toleft then - let right = + if toleft then + let right = List.fold_right push_named_context_val right empty_named_context_val in List.fold_left (fun sign d -> push_named_context_val d sign) - right (moverec [] [declfrom] left) - else - let right = + right (moverec [] [declfrom] left) + else + let right = List.fold_right push_named_context_val (moverec [] [declfrom] right) empty_named_context_val in List.fold_left (fun sign d -> push_named_context_val d sign) @@ -295,7 +295,7 @@ let rename_hyp id1 id2 sign = (************************************************************************) (* Implementation of the logical rules *) -(* Will only be used on terms given to the Refine rule which have meta +(* Will only be used on terms given to the Refine rule which have meta variables only in Application and Case *) let error_unsupported_deep_meta c = @@ -303,7 +303,7 @@ let error_unsupported_deep_meta c = strbrk "form contains metavariables deep inside the term is not " ++ strbrk "supported; try \"refine\" instead.") -let collect_meta_variables c = +let collect_meta_variables c = let rec collrec deep acc c = match kind_of_term c with | Meta mv -> if deep then error_unsupported_deep_meta () else mv::acc | Cast(c,_,_) -> collrec deep acc c @@ -312,12 +312,12 @@ let collect_meta_variables c = in List.rev (collrec false [] c) -let check_meta_variables c = +let check_meta_variables c = if not (list_distinct (collect_meta_variables c)) then raise (RefinerError (NonLinearProof c)) let check_conv_leq_goal env sigma arg ty conclty = - if !check & not (is_conv_leq env sigma ty conclty) then + if !check & not (is_conv_leq env sigma ty conclty) then raise (RefinerError (BadType (arg,ty,conclty))) let goal_type_of env sigma c = @@ -329,7 +329,7 @@ let rec mk_refgoals sigma goal goalacc conclty trm = let mk_goal hyps concl = mk_goal hyps concl goal.evar_extra in (* if not (occur_meta trm) then - let t'ty = (unsafe_machine env sigma trm).uj_type in + let t'ty = (unsafe_machine env sigma trm).uj_type in let _ = conv_leq_goal env sigma trm t'ty conclty in (goalacc,t'ty) else @@ -352,9 +352,9 @@ let rec mk_refgoals sigma goal goalacc conclty trm = | Ind _ | Const _ when (isInd f or has_polymorphic_type (destConst f)) -> (* Sort-polymorphism of definition and inductive types *) - goalacc, + goalacc, type_of_global_reference_knowing_conclusion env sigma f conclty - | _ -> + | _ -> mk_hdgoals sigma goal goalacc f in let (acc'',conclty') = @@ -365,14 +365,14 @@ let rec mk_refgoals sigma goal goalacc conclty trm = | Case (_,p,c,lf) -> let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in check_conv_leq_goal env sigma trm conclty' conclty; - let acc'' = + let acc'' = array_fold_left2 (fun lacc ty fi -> fst (mk_refgoals sigma goal lacc ty fi)) - acc' lbrty lf + acc' lbrty lf in (acc'',conclty') - | _ -> + | _ -> if occur_meta trm then anomaly "refiner called with a meta in non app/case subterm"; @@ -397,8 +397,8 @@ and mk_hdgoals sigma goal goalacc trm = mk_refgoals sigma goal goalacc ty t | App (f,l) -> - let (acc',hdty) = - if isInd f or isConst f + let (acc',hdty) = + if isInd f or isConst f & not (array_exists occur_meta l) (* we could be finer *) then (goalacc,type_of_global_reference_knowing_parameters env sigma f l) @@ -408,10 +408,10 @@ and mk_hdgoals sigma goal goalacc trm = | Case (_,p,c,lf) -> let (acc',lbrty,conclty') = mk_casegoals sigma goal goalacc p c in - let acc'' = + let acc'' = array_fold_left2 (fun lacc ty fi -> fst (mk_refgoals sigma goal lacc ty fi)) - acc' lbrty lf + acc' lbrty lf in (acc'',conclty') @@ -434,7 +434,7 @@ and mk_arggoals sigma goal goalacc funty = function and mk_casegoals sigma goal goalacc p c = let env = evar_env goal in - let (acc',ct) = mk_hdgoals sigma goal goalacc c in + let (acc',ct) = mk_hdgoals sigma goal goalacc c in let (acc'',pt) = mk_hdgoals sigma goal acc' p in let indspec = try find_mrectype env sigma ct @@ -466,7 +466,7 @@ let norm_goal sigma gl = let red_fun = Evarutil.nf_evar sigma in let ncl = red_fun gl.evar_concl in let ngl = - { gl with + { gl with evar_concl = ncl; evar_hyps = map_named_val red_fun gl.evar_hyps } in if Evd.eq_evar_info ngl gl then None else Some ngl @@ -499,7 +499,7 @@ let prim_refiner r sigma goal = ([sg], sigma) | _ -> raise (RefinerError IntroNeedsProduct)) - + | Cut (b,replace,id,t) -> let sg1 = mk_goal sign (nf_betaiota sigma t) in let sign,cl,sigma = @@ -517,52 +517,52 @@ let prim_refiner r sigma goal = if b then ([sg1;sg2],sigma) else ([sg2;sg1],sigma) | FixRule (f,n,rest,j) -> - let rec check_ind env k cl = - match kind_of_term (strip_outer_cast cl) with - | Prod (na,c1,b) -> - if k = 1 then - try + let rec check_ind env k cl = + match kind_of_term (strip_outer_cast cl) with + | Prod (na,c1,b) -> + if k = 1 then + try fst (find_inductive env sigma c1) - with Not_found -> + with Not_found -> error "Cannot do a fixpoint on a non inductive type." - else + else check_ind (push_rel (na,None,c1) env) (k-1) b | _ -> error "Not enough products." in let (sp,_) = check_ind env n cl in let firsts,lasts = list_chop j rest in let all = firsts@(f,n,cl)::lasts in - let rec mk_sign sign = function + let rec mk_sign sign = function | (f,n,ar)::oth -> - let (sp',_) = check_ind env n ar in - if not (sp=sp') then - error ("Fixpoints should be on the same " ^ + let (sp',_) = check_ind env n ar in + if not (sp=sp') then + error ("Fixpoints should be on the same " ^ "mutual inductive declaration."); if !check && mem_named_context f (named_context_of_val sign) then error ("Name "^string_of_id f^" already used in the environment"); mk_sign (push_named_context_val (f,None,ar) sign) oth - | [] -> + | [] -> List.map (fun (_,_,c) -> mk_goal sign c) all - in + in (mk_sign sign all, sigma) - + | Cofix (f,others,j) -> - let rec check_is_coind env cl = + let rec check_is_coind env cl = let b = whd_betadeltaiota env sigma cl in match kind_of_term b with | Prod (na,c1,b) -> check_is_coind (push_rel (na,None,c1) env) b - | _ -> - try + | _ -> + try let _ = find_coinductive env sigma b in () - with Not_found -> + with Not_found -> error ("All methods must construct elements " ^ "in coinductive types.") in let firsts,lasts = list_chop j others in let all = firsts@(f,cl)::lasts in List.iter (fun (_,c) -> check_is_coind env c) all; - let rec mk_sign sign = function + let rec mk_sign sign = function | (f,ar)::oth -> (try (let _ = lookup_named_val f sign in @@ -571,7 +571,7 @@ let prim_refiner r sigma goal = | Not_found -> mk_sign (push_named_context_val (f,None,ar) sign) oth) | [] -> List.map (fun (_,c) -> mk_goal sign c) all - in + in (mk_sign sign all, sigma) | Refine c -> @@ -586,17 +586,17 @@ let prim_refiner r sigma goal = if (not !check) || is_conv_leq env sigma cl' cl then let sg = mk_goal sign cl' in ([sg], sigma) - else + else error "convert-concl rule passed non-converting term" | Convert_hyp (id,copt,ty) -> ([mk_goal (convert_hyp sign sigma (id,copt,ty)) cl], sigma) (* And now the structural rules *) - | Thin ids -> + | Thin ids -> let (hyps,concl,nsigma) = clear_hyps sigma ids sign cl in ([mk_goal hyps concl], nsigma) - + | ThinBody ids -> let clear_aux env id = let env' = remove_hyp_body env sigma id in @@ -608,9 +608,9 @@ let prim_refiner r sigma goal = ([sg], sigma) | Move (withdep, hfrom, hto) -> - let (left,right,declfrom,toleft) = + let (left,right,declfrom,toleft) = split_sign hfrom hto (named_context_of_val sign) in - let hyps' = + let hyps' = move_hyp withdep toleft (left,declfrom,right) hto in ([mk_goal hyps' cl], sigma) @@ -641,7 +641,7 @@ type variable_proof_status = ProofVar | SectionVar of identifier type proof_variable = name * variable_proof_status -let subst_proof_vars = +let subst_proof_vars = let rec aux p vars = let _,subst = List.fold_left (fun (n,l) var -> @@ -652,22 +652,22 @@ let subst_proof_vars = (n+1,t)) (p,[]) vars in replace_vars (List.rev subst) in aux 1 - + let rec rebind id1 id2 = function | [] -> [Name id2,SectionVar id1] - | (na,k as x)::l -> + | (na,k as x)::l -> if na = Name id1 then (Name id2,k)::l else let l' = rebind id1 id2 l in if na = Name id2 then (Anonymous,k)::l' else x::l' let add_proof_var id vl = (Name id,ProofVar)::vl -let proof_variable_index x = +let proof_variable_index x = let rec aux n = function | (Name id,ProofVar)::l when x = id -> n | _::l -> aux (n+1) l | [] -> raise Not_found - in + in aux 1 let prim_extractor subfun vl pft = @@ -683,7 +683,7 @@ let prim_extractor subfun vl pft = let cty = subst_proof_vars vl ty in mkLetIn (Name id, cb, cty, subfun (add_proof_var id vl) spf) | _ -> error "Incomplete proof!") - + | Some (Prim (Cut (b,_,id,t)),[spf1;spf2]) -> let spf1, spf2 = if b then spf1, spf2 else spf2, spf1 in mkLetIn (Name id,subfun vl spf1,subst_proof_vars vl t, @@ -698,7 +698,7 @@ let prim_extractor subfun vl pft = let newvl = List.fold_left (fun vl (id,_,_) -> add_proof_var id vl) (add_proof_var f vl) others in let lfix = Array.map (subfun newvl) (Array.of_list spfl) in - mkFix ((vn,j),(names,lcty,lfix)) + mkFix ((vn,j),(names,lcty,lfix)) | Some (Prim (Cofix (f,others,j)),spfl) -> let firsts,lasts = list_chop j others in @@ -706,14 +706,14 @@ let prim_extractor subfun vl pft = let lcty = Array.map (fun (_,ar) -> subst_proof_vars vl ar) all in let names = Array.map (fun (f,_) -> Name f) all in let newvl = List.fold_left (fun vl (id,_)-> add_proof_var id vl) - (add_proof_var f vl) others in + (add_proof_var f vl) others in let lfix = Array.map (subfun newvl) (Array.of_list spfl) in mkCoFix (j,(names,lcty,lfix)) - + | Some (Prim (Refine c),spfl) -> let mvl = collect_meta_variables c in let metamap = List.combine mvl (List.map (subfun vl) spfl) in - let cc = subst_proof_vars vl c in + let cc = subst_proof_vars vl c in plain_instance metamap cc (* Structural and conversion rules do not produce any proof *) @@ -726,10 +726,10 @@ let prim_extractor subfun vl pft = | Some (Prim (Thin _),[pf]) -> (* No need to make ids Anon in vl: subst_proof_vars take the most recent*) subfun vl pf - + | Some (Prim (ThinBody _),[pf]) -> subfun vl pf - + | Some (Prim (Move _|Order _),[pf]) -> subfun vl pf @@ -742,4 +742,4 @@ let prim_extractor subfun vl pft = | Some _ -> anomaly "prim_extractor" | None-> error "prim_extractor handed incomplete proof" - + diff --git a/proofs/logic.mli b/proofs/logic.mli index 8bc48ed54f..0d56da382a 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -26,9 +26,9 @@ val with_check : tactic -> tactic [Intro]: no check that the name does not exist\\ [Intro_after]: no check that the name does not exist and that variables in its type does not escape their scope\\ - [Intro_replacing]: no check that the name does not exist and that + [Intro_replacing]: no check that the name does not exist and that variables in its type does not escape their scope\\ - [Convert_hyp]: + [Convert_hyp]: no check that the name exist and that its type is convertible\\ *) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 62668f7f3e..11324ede96 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -81,26 +81,26 @@ let get_current_goal_context () = get_goal_context 1 let set_current_proof = Edit.focus proof_edits -let resume_proof (loc,id) = - try +let resume_proof (loc,id) = + try Edit.focus proof_edits id with Invalid_argument "Edit.focus" -> user_err_loc(loc,"Pfedit.set_proof",str"No such proof" ++ msg_proofs false) let suspend_proof () = - try + try Edit.unfocus proof_edits with Invalid_argument "Edit.unfocus" -> errorlabstrm "Pfedit.suspend_current_proof" (str"No active proof" ++ (msg_proofs true)) - + let resume_last_proof () = match (Edit.last_focused proof_edits) with | None -> errorlabstrm "resume_last" (str"No proof-editing in progress.") - | Some p -> + | Some p -> Edit.focus proof_edits p - + let get_current_proof_name () = match Edit.read proof_edits with | None -> @@ -114,14 +114,14 @@ let add_proof (na,pfs,ts) = let delete_proof_gen = Edit.delete proof_edits let delete_proof (loc,id) = - try + try delete_proof_gen id with (UserError ("Edit.delete",_)) -> user_err_loc (loc,"Pfedit.delete_proof",str"No such proof" ++ msg_proofs false) - + let mutate f = - try + try Edit.mutate proof_edits (fun _ pfs -> f pfs) with Invalid_argument "Edit.mutate" -> errorlabstrm "Pfedit.mutate" @@ -131,31 +131,31 @@ let start (na,ts) = let pfs = mk_pftreestate ts.top_goal in let pfs = Option.fold_right solve_pftreestate ts.top_init_tac pfs in add_proof(na,pfs,ts) - + let restart_proof () = match Edit.read proof_edits with - | None -> + | None -> errorlabstrm "Pfedit.restart" (str"No focused proof to restart" ++ msg_proofs true) - | Some(na,_,ts) -> + | Some(na,_,ts) -> delete_proof_gen na; start (na,ts); set_current_proof na let proof_term () = extract_pftreestate (get_pftreestate()) - + (* Detect is one has completed a subtree of the initial goal *) -let subtree_solved () = +let subtree_solved () = let pts = get_pftreestate () in - is_complete_proof (proof_of_pftreestate pts) & + is_complete_proof (proof_of_pftreestate pts) & not (is_top_pftreestate pts) -let tree_solved () = +let tree_solved () = let pts = get_pftreestate () in is_complete_proof (proof_of_pftreestate pts) -let top_tree_solved () = +let top_tree_solved () = let pts = get_pftreestate () in is_complete_proof (proof_of_pftreestate (top_of_tree pts)) @@ -165,19 +165,19 @@ let top_tree_solved () = let set_undo = function | None -> undo_limit := undo_default - | Some n -> - if n>=0 then + | Some n -> + if n>=0 then undo_limit := n - else + else error "Cannot set a negative undo limit" let get_undo () = Some !undo_limit let undo n = - try - Edit.undo proof_edits n; - (* needed because the resolution of a subtree is done in 2 steps - then a sequence of undo can lead to a focus on a completely solved + try + Edit.undo proof_edits n; + (* needed because the resolution of a subtree is done in 2 steps + then a sequence of undo can lead to a focus on a completely solved subtree - this solution only works properly if undoing one step *) if subtree_solved() then Edit.undo proof_edits 1 with (Invalid_argument "Edit.undo") -> @@ -186,14 +186,14 @@ let undo n = (* Undo current focused proof to reach depth [n]. This is used in [vernac_backtrack]. *) let undo_todepth n = - try + try Edit.undo_todepth proof_edits n with (Invalid_argument "Edit.undo") -> errorlabstrm "Pfedit.undo" (str"No focused proof" ++ msg_proofs true) (* Return the depth of the current focused proof stack, this is used to put informations in coq prompt (in emacs mode). *) -let current_proof_depth() = +let current_proof_depth() = try Edit.depth proof_edits with (Invalid_argument "Edit.depth") -> -1 @@ -206,7 +206,7 @@ let xml_cook_proof = ref (fun _ -> ()) let set_xml_cook_proof f = xml_cook_proof := f let cook_proof k = - let (pfs,ts) = get_state() + let (pfs,ts) = get_state() and ident = get_current_proof_name () in let {evar_concl=concl} = ts.top_goal and strength = ts.top_strength in @@ -220,19 +220,19 @@ let cook_proof k = const_entry_boxed = false}, ts.top_compute_guard, strength, ts.top_hook)) -let current_proof_statement () = +let current_proof_statement () = let ts = get_topstate() in - (get_current_proof_name (), ts.top_strength, + (get_current_proof_name (), ts.top_strength, ts.top_goal.evar_concl, ts.top_hook) (*********************************************************************) (* Abort functions *) (*********************************************************************) - + let refining () = [] <> (Edit.dom proof_edits) let check_no_pending_proofs () = - if refining () then + if refining () then errorlabstrm "check_no_pending_proofs" (str"Proof editing in progress" ++ (msg_proofs false) ++ fnl() ++ str"Use \"Abort All\" first or complete proof(s).") @@ -254,7 +254,7 @@ let set_end_tac tac = let start_proof na str sign concl ?init_tac ?(compute_guard=false) hook = let top_goal = mk_goal sign concl None in - let ts = { + let ts = { top_end_tac = None; top_init_tac = init_tac; top_compute_guard = compute_guard; @@ -269,7 +269,7 @@ let solve_nth k tac = let pft = get_pftreestate () in if not (List.mem (-1) (cursor_of_pftreestate pft)) then mutate (solve_nth_pftreestate k tac) - else + else error "cannot apply a tactic when we are descended behind a tactic-node" let by tac = mutate (solve_pftreestate tac) @@ -278,7 +278,7 @@ let instantiate_nth_evar_com n c = mutate (Evar_refiner.instantiate_pf_com n c) let traverse n = mutate (traverse n) - + (* [traverse_to path] Traverses the current proof to get to the location specified by @@ -296,7 +296,7 @@ let common_ancestor l1 l2 = | _, _ -> List.rev l1, List.length l2 in common_aux (List.rev l1) (List.rev l2) - + let rec traverse_up = function | 0 -> (function pf -> pf) | n -> (function pf -> Refiner.traverse 0 (traverse_up (n - 1) pf)) @@ -326,11 +326,11 @@ let make_focus n = focus_n := n let focus () = !focus_n let focused_goal () = let n = !focus_n in if n=0 then 1 else n -let reset_top_of_tree () = +let reset_top_of_tree () = mutate top_of_tree - -let reset_top_of_script () = - mutate (fun pts -> + +let reset_top_of_script () = + mutate (fun pts -> try up_until_matching_rule is_proof_instr pts with Not_found -> top_of_tree pts) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 9a40ba319a..8dcd8edc2b 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -78,7 +78,7 @@ val get_undo : unit -> int option systematically apply at initialization time (e.g. to start the proof of mutually dependent theorems) *) -val start_proof : +val start_proof : identifier -> goal_kind -> named_context_val -> constr -> ?init_tac:tactic -> ?compute_guard:bool -> declaration_hook -> unit @@ -107,7 +107,7 @@ val suspend_proof : unit -> unit it fails if there is no current proof of if it is not completed; it also tells if the guardness condition has to be inferred. *) -val cook_proof : (Refiner.pftreestate -> unit) -> +val cook_proof : (Refiner.pftreestate -> unit) -> identifier * (Entries.definition_entry * bool * goal_kind * declaration_hook) (* To export completed proofs to xml *) diff --git a/proofs/proof_trees.ml b/proofs/proof_trees.ml index 2e2f23065a..b5f46d7887 100644 --- a/proofs/proof_trees.ml +++ b/proofs/proof_trees.ml @@ -33,8 +33,8 @@ let is_bind = function (* Functions on goals *) -let mk_goal hyps cl extra = - { evar_hyps = hyps; evar_concl = cl; +let mk_goal hyps cl extra = + { evar_hyps = hyps; evar_concl = cl; evar_filter = List.map (fun _ -> true) (named_context_of_val hyps); evar_body = Evar_empty; evar_extra = extra } @@ -48,9 +48,9 @@ let ref_of_proof pf = let rule_of_proof pf = let (r,_) = ref_of_proof pf in r -let children_of_proof pf = +let children_of_proof pf = let (_,cl) = ref_of_proof pf in cl - + let goal_of_proof pf = pf.goal let subproof_of_proof pf = match pf.ref with @@ -74,7 +74,7 @@ let pf_lookup_name_as_renamed env ccl s = let pf_lookup_index_as_renamed env ccl n = Detyping.lookup_index_as_renamed env ccl n -(* Functions on rules (Proof mode) *) +(* Functions on rules (Proof mode) *) let is_dem_rule = function Decl_proof _ -> true @@ -85,9 +85,9 @@ let is_proof_instr = function | _ -> false let is_focussing_command = function - Decl_proof b -> b - | Nested (Proof_instr (b,_),_) -> b - | _ -> false + Decl_proof b -> b + | Nested (Proof_instr (b,_),_) -> b + | _ -> false (*********************************************************************) diff --git a/proofs/proof_type.ml b/proofs/proof_type.ml index 8a466d8df5..29417e8b64 100644 --- a/proofs/proof_type.ml +++ b/proofs/proof_type.ml @@ -48,11 +48,11 @@ type proof_tree = { and rule = | Prim of prim_rule - | Nested of compound_rule * proof_tree + | Nested of compound_rule * proof_tree | Decl_proof of bool | Daimon -and compound_rule= +and compound_rule= | Tactic of tactic_expr * bool | Proof_instr of bool*proof_instr (* the boolean is for focus restrictions *) @@ -92,7 +92,7 @@ and tactic_arg = glob_tactic_expr) Tacexpr.gen_tactic_arg -type ltac_call_kind = +type ltac_call_kind = | LtacNotationCall of string | LtacNameCall of ltac_constant | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index 9db87d22e1..4a7cb2f939 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -32,7 +32,7 @@ type prim_rule = | FixRule of identifier * int * (identifier * int * constr) list * int | Cofix of identifier * (identifier * constr) list * int | Refine of constr - | Convert_concl of types * cast_kind + | Convert_concl of types * cast_kind | Convert_hyp of named_declaration | Thin of identifier list | ThinBody of identifier list @@ -58,7 +58,7 @@ type prim_rule = lc : [Set of evars occurring in the type of evar] } }; ... - number of last evar, + number of last evar, it = { evar_concl = [the type of evar] evar_hyps = [the context of the evar] evar_body = [the body of the Evar if any] @@ -69,11 +69,11 @@ type prim_rule = \end{verbatim} *) -(*s Proof trees. - [ref] = [None] if the goal has still to be proved, +(*s Proof trees. + [ref] = [None] if the goal has still to be proved, and [Some (r,l)] if the rule [r] was applied to the goal - and gave [l] as subproofs to be completed. - if [ref = (Some(Nested(Tactic t,p),l))] then [p] is the proof + and gave [l] as subproofs to be completed. + if [ref = (Some(Nested(Tactic t,p),l))] then [p] is the proof that the goal can be proven if the goals in [l] are solved. *) type proof_tree = { open_subgoals : int; @@ -82,11 +82,11 @@ type proof_tree = { and rule = | Prim of prim_rule - | Nested of compound_rule * proof_tree + | Nested of compound_rule * proof_tree | Decl_proof of bool | Daimon -and compound_rule= +and compound_rule= (* the boolean of Tactic tells if the default tactic is used *) | Tactic of tactic_expr * bool | Proof_instr of bool * proof_instr @@ -127,7 +127,7 @@ and tactic_arg = glob_tactic_expr) Tacexpr.gen_tactic_arg -type ltac_call_kind = +type ltac_call_kind = | LtacNotationCall of string | LtacNameCall of ltac_constant | LtacAtomCall of glob_atomic_tactic_expr * atomic_tactic_expr option ref diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 8efc266318..880efc2d04 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -40,14 +40,14 @@ let set_strategy_one ref l = let cb = Global.lookup_constant sp in if cb.const_body <> None & cb.const_opaque then errorlabstrm "set_transparent_const" - (str "Cannot make" ++ spc () ++ + (str "Cannot make" ++ spc () ++ Nametab.pr_global_env Idset.empty (ConstRef sp) ++ spc () ++ str "transparent because it was declared opaque."); Csymtable.set_transparent_const sp | _ -> () let cache_strategy (_,str) = - List.iter + List.iter (fun (lev,ql) -> List.iter (fun q -> set_strategy_one q lev) ql) str @@ -62,7 +62,7 @@ let subst_strategy (_,subs,(local,obj)) = let map_strategy f l = let l' = List.fold_right - (fun (lev,ql) str -> + (fun (lev,ql) str -> let ql' = List.fold_right (fun q ql -> match f q with @@ -77,12 +77,12 @@ let export_strategy (local,obj) = EvalVarRef _ -> None | EvalConstRef _ as q -> Some q) obj -let classify_strategy (local,_ as obj) = +let classify_strategy (local,_ as obj) = if local then Dispose else Substitute obj let disch_ref ref = match ref with - EvalConstRef c -> + EvalConstRef c -> let c' = Lib.discharge_con c in if c==c' then Some ref else Some (EvalConstRef c') | _ -> Some ref @@ -104,7 +104,7 @@ let (inStrategy,outStrategy) = let set_strategy local str = Lib.add_anonymous_leaf (inStrategy (local,str)) -let _ = +let _ = Summary.declare_summary "Transparent constants and variables" { Summary.freeze_function = Conv_oracle.freeze; Summary.unfreeze_function = Conv_oracle.unfreeze; @@ -139,13 +139,13 @@ let make_flag f = f.rConst red in red -let is_reference c = +let is_reference c = try let _ref = global_of_constr c in true with _ -> false let red_expr_tab = ref Stringmap.empty let declare_red_expr s f = - try + try let _ = Stringmap.find s !red_expr_tab in error ("There is already a reduction expression of name "^s) with Not_found -> @@ -159,8 +159,8 @@ let out_with_occurrences ((b,l),c) = ((b,List.map out_arg l), c) let reduction_of_red_expr = function - | Red internal -> - if internal then (try_red_product,DEFAULTcast) + | Red internal -> + if internal then (try_red_product,DEFAULTcast) else (red_product,DEFAULTcast) | Hnf -> (hnf_constr,DEFAULTcast) | Simpl (Some (_,c as lp)) -> diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 8b3789c3bb..c66e9c84bb 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -49,7 +49,7 @@ let descend n p = | None -> error "It is a leaf." | Some(r,pfl) -> if List.length pfl >= n then - (match list_chop (n-1) pfl with + (match list_chop (n-1) pfl with | left,(wanted::right) -> (wanted, (fun pfl' -> @@ -58,11 +58,11 @@ let descend n p = let pf' = List.hd pfl' in let spfl = left@(pf'::right) in let newstatus = and_status (List.map pf_status spfl) in - { p with + { p with open_subgoals = newstatus; ref = Some(r,spfl) })) | _ -> assert false) - else + else error "Too few subproofs" @@ -72,28 +72,28 @@ let descend n p = (vk [ p_(l1+...+l(k-1)+1) ... p_(l1+...lk) ]) ] *) -let rec mapshape nl (fl : (proof_tree list -> proof_tree) list) +let rec mapshape nl (fl : (proof_tree list -> proof_tree) list) (l : proof_tree list) = match nl with | [] -> [] | h::t -> - let m,l = list_chop h l in + let m,l = list_chop h l in (List.hd fl m) :: (mapshape t (List.tl fl) l) (* [frontier : proof_tree -> goal list * validation] given a proof [p], [frontier p] gives [(l,v)] where [l] is the list of goals - to be solved to complete the proof, and [v] is the corresponding + to be solved to complete the proof, and [v] is the corresponding validation *) - + let rec frontier p = match p.ref with - | None -> + | None -> ([p.goal], - (fun lp' -> + (fun lp' -> let p' = List.hd lp' in - if Evd.eq_evar_info p'.goal p.goal then + if Evd.eq_evar_info p'.goal p.goal then p' - else + else errorlabstrm "Refiner.frontier" (str"frontier was handed back a ill-formed proof."))) | Some(r,pfl) -> @@ -115,14 +115,14 @@ let set_solve_hook = (:=) solve_hook let rec frontier_map_rec f n p = if n < 1 || n > p.open_subgoals then p else match p.ref with - | None -> + | None -> let p' = f p in if Evd.eq_evar_info p'.goal p.goal then begin !solve_hook p'; p' end - else + else errorlabstrm "Refiner.frontier_map" (str"frontier_map was handed back a ill-formed proof.") | Some(r,pfl) -> @@ -139,20 +139,20 @@ let frontier_map f n p = let nmax = p.open_subgoals in let n = if n < 0 then nmax + n + 1 else n in if n < 1 || n > nmax then - errorlabstrm "Refiner.frontier_map" (str "No such subgoal"); + errorlabstrm "Refiner.frontier_map" (str "No such subgoal"); frontier_map_rec f n p let rec frontier_mapi_rec f i p = if p.open_subgoals = 0 then p else match p.ref with - | None -> + | None -> let p' = f i p in if Evd.eq_evar_info p'.goal p.goal then begin !solve_hook p'; p' end - else + else errorlabstrm "Refiner.frontier_mapi" (str"frontier_mapi was handed back a ill-formed proof.") | Some(r,pfl) -> @@ -161,7 +161,7 @@ let rec frontier_mapi_rec f i p = (fun (n,acc) p -> (n+p.open_subgoals,frontier_mapi_rec f n p::acc)) (i,[]) pfl in let pfl' = List.rev rpfl' in - { p with + { p with open_subgoals = and_status (List.map pf_status pfl'); ref = Some(r,pfl')} @@ -176,7 +176,7 @@ let rec nb_unsolved_goals pf = pf.open_subgoals (* leaf g is the canonical incomplete proof of a goal g *) -let leaf g = +let leaf g = { open_subgoals = 1; goal = g; ref = None } @@ -197,20 +197,20 @@ let abstract_operation syntax semantics gls = ref = Some(Nested(syntax,hidden_proof),spfl)}) let abstract_tactic_expr ?(dflt=false) te tacfun gls = - abstract_operation (Tactic(te,dflt)) tacfun gls + abstract_operation (Tactic(te,dflt)) tacfun gls let abstract_tactic ?(dflt=false) te = !abstract_tactic_box := Some te; abstract_tactic_expr ~dflt (Tacexpr.TacAtom (dummy_loc,te)) -let abstract_extended_tactic ?(dflt=false) s args = +let abstract_extended_tactic ?(dflt=false) s args = abstract_tactic ~dflt (Tacexpr.TacExtend (dummy_loc, s, args)) let refiner = function | Prim pr as r -> let prim_fun = prim_refiner pr in (fun goal_sigma -> - let (sgl,sigma') = prim_fun goal_sigma.sigma goal_sigma.it in + let (sgl,sigma') = prim_fun goal_sigma.sigma goal_sigma.it in ({it=sgl; sigma = sigma'}, (fun spfl -> assert (check_subproof_connection sgl spfl); @@ -219,15 +219,15 @@ let refiner = function ref = Some(r,spfl) }))) - | Nested (_,_) | Decl_proof _ -> + | Nested (_,_) | Decl_proof _ -> failwith "Refiner: should not occur" - + (* Daimon is a canonical unfinished proof *) - | Daimon -> - fun gls -> - ({it=[];sigma=gls.sigma}, - fun spfl -> + | Daimon -> + fun gls -> + ({it=[];sigma=gls.sigma}, + fun spfl -> assert (spfl=[]); { open_subgoals = 0; goal = gls.it; @@ -250,10 +250,10 @@ let norm_evar_proof sigma pf = Their proof should be completed in order to complete the initial proof *) let extract_open_proof sigma pf = - let next_meta = + let next_meta = let meta_cnt = ref 0 in let rec f () = - incr meta_cnt; + incr meta_cnt; if Evd.mem sigma (existential_of_int !meta_cnt) then f () else !meta_cnt in f @@ -261,14 +261,14 @@ let extract_open_proof sigma pf = let open_obligations = ref [] in let rec proof_extractor vl = function | {ref=Some(Prim _,_)} as pf -> prim_extractor proof_extractor vl pf - + | {ref=Some(Nested(_,hidden_proof),spfl)} -> let sgl,v = frontier hidden_proof in let flat_proof = v spfl in proof_extractor vl flat_proof - + | {ref=Some(Decl_proof _,[pf])} -> (proof_extractor vl) pf - + | {ref=(None|Some(Daimon,[]));goal=goal} -> let visible_rels = map_succeed @@ -287,13 +287,13 @@ let extract_open_proof sigma pf = let inst = List.filter (fun (_,(_,b,_)) -> b = None) sorted_env in let meta = next_meta () in open_obligations := (meta,abs_concl):: !open_obligations; - applist (mkMeta meta, List.map (fun (n,_) -> mkRel n) inst) - + applist (mkMeta meta, List.map (fun (n,_) -> mkRel n) inst) + | _ -> anomaly "Bug: a case has been forgotten in proof_extractor" in let pfterm = proof_extractor [] pf in (pfterm, List.rev !open_obligations) - + (*********************) (* Tacticals *) (*********************) @@ -301,7 +301,7 @@ let extract_open_proof sigma pf = (* unTAC : tactic -> goal sigma -> proof sigma *) let unTAC tac g = - let (gl_sigma,v) = tac g in + let (gl_sigma,v) = tac g in { it = v (List.map leaf gl_sigma.it); sigma = gl_sigma.sigma } let unpackage glsig = (ref (glsig.sigma)),glsig.it @@ -309,8 +309,8 @@ let unpackage glsig = (ref (glsig.sigma)),glsig.it let repackage r v = {it=v;sigma = !r} let apply_sig_tac r tac g = - check_for_interrupt (); (* Breakpoint *) - let glsigma,v = tac (repackage r g) in + check_for_interrupt (); (* Breakpoint *) + let glsigma,v = tac (repackage r g) in r := glsigma.sigma; (glsigma.it,v) @@ -328,7 +328,7 @@ let tclNORMEVAR = norm_evar_tac let tclIDTAC gls = (goal_goal_list gls, idtac_valid) (* the message printing identity tactic *) -let tclIDTAC_MESSAGE s gls = +let tclIDTAC_MESSAGE s gls = msg (hov 0 s); tclIDTAC gls (* General failure tactic *) @@ -356,7 +356,7 @@ let thens3parts_tac tacfi tac tacli (sigr,gs,p) = if ng + (list_map_i (fun i -> apply_sig_tac sigr (if i=ng-nl then tacli.(nl-ng+i) else tac)) 0 gs) in (sigr, List.flatten gll, @@ -390,7 +390,7 @@ let theni_tac i tac ((_,gl,_) as subgoals) = thensf_tac (Array.init k (fun i -> if i+1 = k then tac else tclIDTAC)) tclIDTAC subgoals - else non_existent_goal k + else non_existent_goal k (* [tclTHENS3PARTS tac1 [|t1 ; ... ; tn|] tac2 [|t'1 ; ... ; t'm|] gls] applies the tactic [tac1] to [gls] then, applies [t1], ..., [tn] to @@ -448,17 +448,17 @@ let rec tclTHENLIST = function | t1::tacl -> tclTHEN t1 (tclTHENLIST tacl) (* [tclMAP f [x1..xn]] builds [(f x1);(f x2);...(f xn)] *) -let tclMAP tacfun l = +let tclMAP tacfun l = List.fold_right (fun x -> (tclTHEN (tacfun x))) l tclIDTAC (* various progress criterions *) -let same_goal gl subgoal = +let same_goal gl subgoal = eq_constr (conclusion subgoal) (conclusion gl) && eq_named_context_val (hypotheses subgoal) (hypotheses gl) let weak_progress gls ptree = - (List.length gls.it <> 1) || + (List.length gls.it <> 1) || (not (same_goal (List.hd gls.it) ptree.it)) let progress gls ptree = @@ -473,7 +473,7 @@ let tclPROGRESS tac ptree = if progress (fst rslt) ptree then rslt else errorlabstrm "Refiner.PROGRESS" (str"Failed to progress.") -(* weak_PROGRESS tac ptree applies tac to the goal ptree and fails +(* weak_PROGRESS tac ptree applies tac to the goal ptree and fails if tac leaves the goal unchanged, possibly modifying sigma *) let tclWEAK_PROGRESS tac ptree = let rslt = tac ptree in @@ -487,14 +487,14 @@ let tclNOTSAMEGOAL (tac : tactic) goal = let rslt = tac goal in let gls = (fst rslt).it in if List.exists (same_goal goal.it) gls - then errorlabstrm "Refiner.tclNOTSAMEGOAL" + then errorlabstrm "Refiner.tclNOTSAMEGOAL" (str"Tactic generated a subgoal identical to the original goal.") else rslt let catch_failerror e = if catchable_exception e then check_for_interrupt () else match e with - | FailError (0,_) | Stdpp.Exc_located(_, FailError (0,_)) + | FailError (0,_) | Stdpp.Exc_located(_, FailError (0,_)) | Stdpp.Exc_located(_, LtacLocated (_,FailError (0,_))) -> check_for_interrupt () | FailError (lvl,s) -> raise (FailError (lvl - 1, s)) @@ -507,18 +507,18 @@ let catch_failerror e = (* ORELSE0 t1 t2 tries to apply t1 and if it fails, applies t2 *) let tclORELSE0 t1 t2 g = - try + try t1 g with (* Breakpoint *) | e -> catch_failerror e; t2 g -(* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress, +(* ORELSE t1 t2 tries to apply t1 and if it fails or does not progress, then applies t2 *) let tclORELSE t1 t2 = tclORELSE0 (tclPROGRESS t1) t2 (* applies t1;t2then if t1 succeeds or t2else if t1 fails t2* are called in terminal position (unless t1 produces more than - 1 subgoal!) *) + 1 subgoal!) *) let tclORELSE_THEN t1 t2then t2else gls = match try Some(tclPROGRESS t1 gls) @@ -526,7 +526,7 @@ let tclORELSE_THEN t1 t2then t2else gls = with | None -> t2else gls | Some (sgl,v) -> - let (sigr,gl) = unpackage sgl in + let (sigr,gl) = unpackage sgl in finish_tac (then_tac t2then (sigr,gl,v)) (* TRY f tries to apply f, and if it fails, leave the goal unchanged *) @@ -546,16 +546,16 @@ let ite_gen tcal tac_if continue tac_else gl= let result=tac_if gl in success:=true;result in let tac_else0 e gl= - if !success then - raise e - else + if !success then + raise e + else tac_else gl in - try + try tcal tac_if0 continue gl with (* Breakpoint *) | e -> catch_failerror e; tac_else0 e gl -(* Try the first tactic and, if it succeeds, continue with +(* Try the first tactic and, if it succeeds, continue with the second one, and if it fails, use the third one *) let tclIFTHENELSE=ite_gen tclTHEN @@ -566,7 +566,7 @@ let tclIFTHENSELSE=ite_gen tclTHENS let tclIFTHENSVELSE=ite_gen tclTHENSV -let tclIFTHENTRYELSEMUST tac1 tac2 gl = +let tclIFTHENTRYELSEMUST tac1 tac2 gl = tclIFTHENELSE tac1 (tclTRY tac2) tac2 gl (* Fails if a tactic did not solve the goal *) @@ -575,17 +575,17 @@ let tclCOMPLETE tac = tclTHEN tac (tclFAIL_s "Proof is not complete.") (* Try the first thats solves the current goal *) let tclSOLVE tacl = tclFIRST (List.map tclCOMPLETE tacl) - + (* Iteration tacticals *) -let tclDO n t = - let rec dorec k = +let tclDO n t = + let rec dorec k = if k < 0 then errorlabstrm "Refiner.tclDO" (str"Wrong argument : Do needs a positive integer."); if k = 0 then tclIDTAC else if k = 1 then t else (tclTHEN t (dorec (k-1))) - in - dorec n + in + dorec n (* Beware: call by need of CAML, g is needed *) @@ -612,52 +612,52 @@ let tclIDTAC_list gls = (gls, fun x -> x) (* first_goal : goal list sigma -> goal sigma *) -let first_goal gls = - let gl = gls.it and sig_0 = gls.sigma in - if gl = [] then error "first_goal"; +let first_goal gls = + let gl = gls.it and sig_0 = gls.sigma in + if gl = [] then error "first_goal"; { it = List.hd gl; sigma = sig_0 } (* goal_goal_list : goal sigma -> goal list sigma *) -let goal_goal_list gls = +let goal_goal_list gls = let gl = gls.it and sig_0 = gls.sigma in { it = [gl]; sigma = sig_0 } (* tactic -> tactic_list : Apply a tactic to the first goal in the list *) -let apply_tac_list tac glls = +let apply_tac_list tac glls = let (sigr,lg) = unpackage glls in match lg with | (g1::rest) -> let (gl,p) = apply_sig_tac sigr tac g1 in - let n = List.length gl in - (repackage sigr (gl@rest), + let n = List.length gl in + (repackage sigr (gl@rest), fun pfl -> let (pfg,pfrest) = list_chop n pfl in (p pfg)::pfrest) | _ -> error "apply_tac_list" - -let then_tactic_list tacl1 tacl2 glls = + +let then_tactic_list tacl1 tacl2 glls = let (glls1,pl1) = tacl1 glls in let (glls2,pl2) = tacl2 glls1 in (glls2, compose pl1 pl2) (* Transform a tactic_list into a tactic *) -let tactic_list_tactic tac gls = +let tactic_list_tactic tac gls = let (glres,vl) = tac (goal_goal_list gls) in (glres, compose idtac_valid vl) -(* The type of proof-trees state and a few utilities +(* The type of proof-trees state and a few utilities A proof-tree state is built from a proof-tree, a set of global constraints, and a stack which allows to navigate inside the proof-tree remembering how to rebuild the global proof-tree possibly after modification of one of the focused children proof-tree. - The number in the stack corresponds to + The number in the stack corresponds to either the selected subtree and the validation is a function from a proof-tree list consisting only of one proof-tree to the global - proof-tree + proof-tree or -1 when the move is done behind a registered tactic in which - case the validation corresponds to a constant function giving back + case the validation corresponds to a constant function giving back the original proof-tree. *) type pftreestate = { @@ -666,11 +666,11 @@ type pftreestate = { tstack : (int * validation) list } let proof_of_pftreestate pts = pts.tpf -let is_top_pftreestate pts = pts.tstack = [] +let is_top_pftreestate pts = pts.tstack = [] let cursor_of_pftreestate pts = List.map fst pts.tstack let evc_of_pftreestate pts = pts.tpfsigma -let top_goal_of_pftreestate pts = +let top_goal_of_pftreestate pts = { it = goal_of_proof pts.tpf; sigma = pts.tpfsigma } let nth_goal_of_pftreestate n pts = @@ -678,7 +678,7 @@ let nth_goal_of_pftreestate n pts = try {it = List.nth goals (n-1); sigma = pts.tpfsigma } with Invalid_argument _ | Failure _ -> non_existent_goal n -let traverse n pts = match n with +let traverse n pts = match n with | 0 -> (* go to the parent *) (match pts.tstack with | [] -> error "traverse: no ancestors" @@ -691,13 +691,13 @@ let traverse n pts = match n with | -1 -> (* go to the hidden tactic-proof, if any, otherwise fail *) (match pts.tpf.ref with | Some (Nested (_,spf),_) -> - let v = (fun pfl -> pts.tpf) in + let v = (fun pfl -> pts.tpf) in { tpf = spf; tstack = (-1,v)::pts.tstack; tpfsigma = pts.tpfsigma } | _ -> error "traverse: not a tactic-node") | n -> (* when n>0, go to the nth child *) - let (npf,v) = descend n pts.tpf in + let (npf,v) = descend n pts.tpf in { tpf = npf; tpfsigma = pts.tpfsigma; tstack = (n,v):: pts.tstack } @@ -723,9 +723,9 @@ let map_pftreestate f pts = (* solve the nth subgoal with tactic tac *) let solve_nth_pftreestate n tac = - map_pftreestate + map_pftreestate (fun sigr pt -> frontier_map (app_tac sigr tac) n pt) - + let solve_pftreestate = solve_nth_pftreestate 1 (* This function implements a poor man's undo at the current goal. @@ -771,78 +771,78 @@ let extract_pftreestate pts = (* Focus on the first leaf proof in a proof-tree state *) let rec first_unproven pts = - let pf = (proof_of_pftreestate pts) in + let pf = (proof_of_pftreestate pts) in if is_complete_proof pf then errorlabstrm "first_unproven" (str"No unproven subgoals"); if is_leaf_proof pf then pts else let childnum = - list_try_find_i - (fun n pf -> + list_try_find_i + (fun n pf -> if not(is_complete_proof pf) then n else failwith "caught") 1 (children_of_proof pf) - in + in first_unproven (traverse childnum pts) (* Focus on the last leaf proof in a proof-tree state *) let rec last_unproven pts = - let pf = proof_of_pftreestate pts in + let pf = proof_of_pftreestate pts in if is_complete_proof pf then errorlabstrm "last_unproven" (str"No unproven subgoals"); if is_leaf_proof pf then pts - else + else let children = (children_of_proof pf) in let nchilds = List.length children in let childnum = - list_try_find_i + list_try_find_i (fun n pf -> if not(is_complete_proof pf) then n else failwith "caught") 1 (List.rev children) - in + in last_unproven (traverse (nchilds-childnum+1) pts) - + let rec nth_unproven n pts = - let pf = proof_of_pftreestate pts in + let pf = proof_of_pftreestate pts in if is_complete_proof pf then errorlabstrm "nth_unproven" (str"No unproven subgoals"); if is_leaf_proof pf then - if n = 1 then - pts + if n = 1 then + pts else errorlabstrm "nth_unproven" (str"Not enough unproven subgoals") - else + else let children = children_of_proof pf in let rec process i k = function - | [] -> + | [] -> errorlabstrm "nth_unproven" (str"Not enough unproven subgoals") - | pf1::rest -> - let k1 = nb_unsolved_goals pf1 in - if k1 < k then + | pf1::rest -> + let k1 = nb_unsolved_goals pf1 in + if k1 < k then process (i+1) (k-k1) rest - else + else nth_unproven k (traverse i pts) - in + in process 1 n children let rec node_prev_unproven loc pts = - let pf = proof_of_pftreestate pts in + let pf = proof_of_pftreestate pts in match cursor_of_pftreestate pts with | [] -> last_unproven pts | n::l -> if is_complete_proof pf or loc = 1 then node_prev_unproven n (traverse 0 pts) - else + else let child = List.nth (children_of_proof pf) (loc - 2) in if is_complete_proof child then node_prev_unproven (loc - 1) pts - else + else first_unproven (traverse (loc - 1) pts) let rec node_next_unproven loc pts = - let pf = proof_of_pftreestate pts in + let pf = proof_of_pftreestate pts in match cursor_of_pftreestate pts with | [] -> first_unproven pts | n::l -> @@ -851,35 +851,35 @@ let rec node_next_unproven loc pts = node_next_unproven n (traverse 0 pts) else if is_complete_proof (List.nth (children_of_proof pf) loc) then node_next_unproven (loc + 1) pts - else + else last_unproven(traverse (loc + 1) pts) let next_unproven pts = - let pf = proof_of_pftreestate pts in + let pf = proof_of_pftreestate pts in if is_leaf_proof pf then match cursor_of_pftreestate pts with | [] -> error "next_unproven" | n::_ -> node_next_unproven n (traverse 0 pts) - else + else node_next_unproven (List.length (children_of_proof pf)) pts let prev_unproven pts = - let pf = proof_of_pftreestate pts in + let pf = proof_of_pftreestate pts in if is_leaf_proof pf then match cursor_of_pftreestate pts with | [] -> error "prev_unproven" | n::_ -> node_prev_unproven n (traverse 0 pts) - else + else node_prev_unproven 1 pts -let rec top_of_tree pts = +let rec top_of_tree pts = if is_top_pftreestate pts then pts else top_of_tree(traverse 0 pts) (* FIXME: cette fonction n'est (as of October 2007) appelée nulle part *) let change_rule f pts = let mark_top _ pt = match pt.ref with - Some (oldrule,l) -> + Some (oldrule,l) -> {pt with ref=Some (f oldrule,l)} | _ -> invalid_arg "change_rule" in map_pftreestate mark_top pts @@ -889,21 +889,21 @@ let match_rule p pts = Some (r,_) -> p r | None -> false -let rec up_until_matching_rule p pts = - if is_top_pftreestate pts then +let rec up_until_matching_rule p pts = + if is_top_pftreestate pts then raise Not_found else let one_up = traverse 0 pts in - if match_rule p one_up then + if match_rule p one_up then pts else up_until_matching_rule p one_up -let rec up_to_matching_rule p pts = - if match_rule p pts then +let rec up_to_matching_rule p pts = + if match_rule p pts then pts else - if is_top_pftreestate pts then + if is_top_pftreestate pts then raise Not_found else let one_up = traverse 0 pts in @@ -917,14 +917,14 @@ let tclEVARS sigma gls = tclIDTAC {gls with sigma=sigma} let pp_info = ref (fun _ _ _ -> assert false) let set_info_printer f = pp_info := f -let tclINFO (tac : tactic) gls = - let (sgl,v) as res = tac gls in - begin try +let tclINFO (tac : tactic) gls = + let (sgl,v) as res = tac gls in + begin try let pf = v (List.map leaf (sig_it sgl)) in let sign = named_context_of_val (sig_it gls).evar_hyps in msgnl (hov 0 (str" == " ++ !pp_info (project gls) sign pf)) - with e when catchable_exception e -> + with e when catchable_exception e -> msgnl (hov 0 (str "Info failed to apply validation")) end; res @@ -935,7 +935,7 @@ let set_proof_printer f = pp_proof := f let print_pftreestate {tpf = pf; tpfsigma = sigma; tstack = stack } = (if stack = [] then str "Rooted proof tree is:" - else (str "Proof tree at occurrence [" ++ + else (str "Proof tree at occurrence [" ++ prlist_with_sep (fun () -> str ";") (fun (n,_) -> int n) (List.rev stack) ++ str "] is:")) ++ fnl() ++ !pp_proof sigma (Global.named_context()) pf ++ diff --git a/proofs/refiner.mli b/proofs/refiner.mli index 9a587a9650..ff902d880b 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -159,14 +159,14 @@ val tclNOTSAMEGOAL : tactic -> tactic val tclINFO : tactic -> tactic (* [tclIFTHENELSE tac1 tac2 tac3 gls] first applies [tac1] to [gls] then, - if it succeeds, applies [tac2] to the resulting subgoals, + if it succeeds, applies [tac2] to the resulting subgoals, and if not applies [tac3] to the initial goal [gls] *) val tclIFTHENELSE : tactic -> tactic -> tactic -> tactic val tclIFTHENSELSE : tactic -> tactic list -> tactic ->tactic val tclIFTHENSVELSE : tactic -> tactic array -> tactic ->tactic (* [tclIFTHENTRYELSEMUST tac1 tac2 gls] applies [tac1] then [tac2]. If [tac1] - has been successful, then [tac2] may fail. Otherwise, [tac2] must succeed. + has been successful, then [tac2] may fail. Otherwise, [tac2] must succeed. Equivalent to [(tac1;try tac2)||tac2] *) val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic @@ -199,7 +199,7 @@ val top_goal_of_pftreestate : pftreestate -> goal sigma val nth_goal_of_pftreestate : int -> pftreestate -> goal sigma val traverse : int -> pftreestate -> pftreestate -val map_pftreestate : +val map_pftreestate : (evar_map ref -> proof_tree -> proof_tree) -> pftreestate -> pftreestate val solve_nth_pftreestate : int -> tactic -> pftreestate -> pftreestate val solve_pftreestate : tactic -> pftreestate -> pftreestate @@ -221,12 +221,12 @@ val next_unproven : pftreestate -> pftreestate val prev_unproven : pftreestate -> pftreestate val top_of_tree : pftreestate -> pftreestate val match_rule : (rule -> bool) -> pftreestate -> bool -val up_until_matching_rule : (rule -> bool) -> +val up_until_matching_rule : (rule -> bool) -> pftreestate -> pftreestate -val up_to_matching_rule : (rule -> bool) -> +val up_to_matching_rule : (rule -> bool) -> pftreestate -> pftreestate val change_rule : (rule -> rule) -> pftreestate -> pftreestate -val change_constraints_pftreestate +val change_constraints_pftreestate : evar_map -> pftreestate -> pftreestate diff --git a/proofs/tacexpr.ml b/proofs/tacexpr.ml index f53327249c..ba3c27e635 100644 --- a/proofs/tacexpr.ml +++ b/proofs/tacexpr.ml @@ -51,12 +51,12 @@ let make_red_flag = if red.rConst <> [] & not red.rDelta then error "Cannot set both constants to unfold and constants not to unfold"; - add_flag + add_flag { red with rConst = list_union red.rConst l; rDelta = true } lf in add_flag - {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []} + {rBeta = false; rIota = false; rZeta = false; rDelta = false; rConst = []} type 'a raw_hyp_location = 'a with_occurrences * Termops.hyp_location_flag @@ -85,7 +85,7 @@ type inversion_kind = | FullInversionClear type ('c,'id) inversion_strength = - | NonDepInversion of + | NonDepInversion of inversion_kind * 'id list * intro_pattern_expr located option | DepInversion of inversion_kind * 'c option * intro_pattern_expr located option @@ -115,12 +115,12 @@ let goal_location_of = function | _ -> error "Not a simple \"in\" clause (one hypothesis or the conclusion)" -type ('constr,'id) induction_clause = - ('constr with_bindings induction_arg list * 'constr with_bindings option * +type ('constr,'id) induction_clause = + ('constr with_bindings induction_arg list * 'constr with_bindings option * (intro_pattern_expr located option * intro_pattern_expr located option) * 'id gclause option) -type multi = +type multi = | Precisely of int | UpTo of int | RepeatStar @@ -150,15 +150,15 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr = | TacExact of 'constr | TacExactNoCheck of 'constr | TacVmCastNoCheck of 'constr - | TacApply of advanced_flag * evars_flag * 'constr with_bindings list * + | TacApply of advanced_flag * evars_flag * 'constr with_bindings list * ('id * intro_pattern_expr located option) option - | TacElim of evars_flag * 'constr with_bindings * + | TacElim of evars_flag * 'constr with_bindings * 'constr with_bindings option | TacElimType of 'constr | TacCase of evars_flag * 'constr with_bindings | TacCaseType of 'constr | TacFix of identifier option * int - | TacMutualFix of hidden_flag * identifier * int * (identifier * int * + | TacMutualFix of hidden_flag * identifier * int * (identifier * int * 'constr) list | TacCofix of identifier option | TacMutualCofix of hidden_flag * identifier * (identifier * 'constr) list @@ -211,10 +211,10 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr = | TacTransitivity of 'constr option (* Equality and inversion *) - | TacRewrite of + | TacRewrite of evars_flag * (bool * multi * 'constr with_bindings) list * 'id gclause * 'tac option | TacInversion of ('constr,'id) inversion_strength * quantified_hypothesis - + (* For ML extensions *) | TacExtend of loc * string * 'constr generic_argument list @@ -225,11 +225,11 @@ type ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr = and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr = | TacAtom of loc * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_atomic_tactic_expr - | TacThen of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * + | TacThen of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr array * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr array - | TacThens of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * + | TacThens of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr list | TacFirst of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr list | TacComplete of ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_expr @@ -263,7 +263,7 @@ and ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg = | Integer of int | TacCall of loc * 'ref * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg list - | TacExternal of loc * string * string * + | TacExternal of loc * string * string * ('constr,'pat,'cst,'ind,'ref,'id,'tac) gen_tactic_arg list | TacFreshId of string or_var list | Tacexp of 'tac diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 40917b0854..0faba52eae 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -55,10 +55,10 @@ let pf_nth_hyp_id gls n = let (id,c,t) = List.nth (pf_hyps gls) (n-1) in id let pf_last_hyp gl = List.hd (pf_hyps gl) -let pf_get_hyp gls id = - try +let pf_get_hyp gls id = + try Sign.lookup_named id (pf_hyps gls) - with Not_found -> + with Not_found -> error ("No such hypothesis: " ^ (string_of_id id)) let pf_get_hyp_typ gls id = @@ -67,7 +67,7 @@ let pf_get_hyp_typ gls id = let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls) -let pf_get_new_id id gls = +let pf_get_new_id id gls = next_ident_away id (pf_ids_of_hyps gls) let pf_get_new_ids ids gls = @@ -77,19 +77,19 @@ let pf_get_new_ids ids gls = ids [] let pf_interp_constr gls c = - let evc = project gls in + let evc = project gls in Constrintern.interp_constr evc (pf_env gls) c let pf_interp_type gls c = - let evc = project gls in + let evc = project gls in Constrintern.interp_type evc (pf_env gls) c let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id let pf_parse_const gls = compose (pf_global gls) id_of_string -let pf_reduction_of_red_expr gls re c = - (fst (reduction_of_red_expr re)) (pf_env gls) (project gls) c +let pf_reduction_of_red_expr gls re c = + (fst (reduction_of_red_expr re)) (pf_env gls) (project gls) c let pf_apply f gls = f (pf_env gls) (project gls) let pf_reduce = pf_apply @@ -113,7 +113,7 @@ let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind let pf_hnf_type_of gls = compose (pf_whd_betadeltaiota gls) (pf_get_type_of gls) -let pf_check_type gls c1 c2 = +let pf_check_type gls c1 c2 = ignore (pf_type_of gls (mkCast (c1, DEFAULTcast, c2))) let pf_is_matching = pf_apply Matching.is_matching_conv @@ -179,16 +179,16 @@ let refiner = refiner let introduction_no_check id = refiner (Prim (Intro id)) -let internal_cut_no_check replace id t gl = +let internal_cut_no_check replace id t gl = refiner (Prim (Cut (true,replace,id,t))) gl -let internal_cut_rev_no_check replace id t gl = +let internal_cut_rev_no_check replace id t gl = refiner (Prim (Cut (false,replace,id,t))) gl -let refine_no_check c gl = +let refine_no_check c gl = refiner (Prim (Refine c)) gl -let convert_concl_no_check c sty gl = +let convert_concl_no_check c sty gl = refiner (Prim (Convert_concl (c,sty))) gl let convert_hyp_no_check d gl = @@ -202,16 +202,16 @@ let thin_no_check ids gl = let thin_body_no_check ids gl = if ids = [] then tclIDTAC gl else refiner (Prim (ThinBody ids)) gl -let move_hyp_no_check with_dep id1 id2 gl = +let move_hyp_no_check with_dep id1 id2 gl = refiner (Prim (Move (with_dep,id1,id2))) gl let order_hyps idl gl = refiner (Prim (Order idl)) gl -let rec rename_hyp_no_check l gl = match l with - | [] -> tclIDTAC gl - | (id1,id2)::l -> - tclTHEN (refiner (Prim (Rename (id1,id2)))) +let rec rename_hyp_no_check l gl = match l with + | [] -> tclIDTAC gl + | (id1,id2)::l -> + tclTHEN (refiner (Prim (Rename (id1,id2)))) (rename_hyp_no_check l) gl let mutual_fix f n others j gl = @@ -219,10 +219,10 @@ let mutual_fix f n others j gl = let mutual_cofix f others j gl = with_check (refiner (Prim (Cofix (f,others,j)))) gl - + (* Versions with consistency checks *) -let introduction id = with_check (introduction_no_check id) +let introduction id = with_check (introduction_no_check id) let internal_cut b d t = with_check (internal_cut_no_check b d t) let internal_cut_rev b d t = with_check (internal_cut_rev_no_check b d t) let refine c = with_check (refine_no_check c) @@ -230,7 +230,7 @@ let convert_concl d sty = with_check (convert_concl_no_check d sty) let convert_hyp d = with_check (convert_hyp_no_check d) let thin c = with_check (thin_no_check c) let thin_body c = with_check (thin_body_no_check c) -let move_hyp b id id' = with_check (move_hyp_no_check b id id') +let move_hyp b id id' = with_check (move_hyp_no_check b id id') let rename_hyp l = with_check (rename_hyp_no_check l) (* Pretty-printers *) @@ -249,4 +249,4 @@ let pr_gls gls = let pr_glls glls = hov 0 (pr_evar_defs (sig_sig glls) ++ fnl () ++ prlist_with_sep pr_fnl db_pr_goal (sig_it glls)) - + diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 581933c830..a808ca4190 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -67,12 +67,12 @@ val pf_reduction_of_red_expr : goal sigma -> red_expr -> constr -> constr val pf_apply : (env -> evar_map -> 'a) -> goal sigma -> 'a -val pf_reduce : +val pf_reduce : (env -> evar_map -> constr -> constr) -> goal sigma -> constr -> constr val pf_whd_betadeltaiota : goal sigma -> constr -> constr -val pf_whd_betadeltaiota_stack : goal sigma -> constr -> constr * constr list +val pf_whd_betadeltaiota_stack : goal sigma -> constr -> constr * constr list val pf_hnf_constr : goal sigma -> constr -> constr val pf_red_product : goal sigma -> constr -> constr val pf_nf : goal sigma -> constr -> constr diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 6674d04ea9..ea8ab5b625 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -68,11 +68,11 @@ let skip = ref 0 (* Prints the run counter *) let run ini = - if not ini then + if not ini then for i=1 to 2 do print_char (Char.chr 8);print_char (Char.chr 13) done; - msg (str "Executed expressions: " ++ int (!allskip - !skip) ++ + msg (str "Executed expressions: " ++ int (!allskip - !skip) ++ fnl() ++ fnl()) (* Prints the prompt *) @@ -168,7 +168,7 @@ let db_matching_failure debug = let db_eval_failure debug s = if debug <> DebugOff & !skip = 0 then let s = str "message \"" ++ s ++ str "\"" in - msgnl + msgnl (str "This rule has failed due to \"Fail\" tactic (" ++ s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") diff --git a/scripts/coqc.ml b/scripts/coqc.ml index 64a3dcf915..6281f01eb9 100644 --- a/scripts/coqc.ml +++ b/scripts/coqc.ml @@ -9,7 +9,7 @@ (* $Id$ *) (* Afin de rendre Coq plus portable, ce programme Caml remplace le script - coqc. + coqc. Ici, on trie la ligne de commande pour en extraire les fichiers à compiler, puis on les compile un par un en passant le reste de la ligne de commande @@ -46,12 +46,12 @@ let check_module_name s = else (output_string stderr"'"; output_char stderr c; output_string stderr"'"); output_string stderr " is not allowed in module names\n"; - exit 1 + exit 1 in - match String.get s 0 with - | 'a' .. 'z' | 'A' .. 'Z' -> + match String.get s 0 with + | 'a' .. 'z' | 'A' .. 'Z' -> for i = 1 to (String.length s)-1 do - match String.get s i with + match String.get s i with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> () | c -> err c done @@ -59,7 +59,7 @@ let check_module_name s = let rec make_compilation_args = function | [] -> [] - | file :: fl -> + | file :: fl -> let dirname = Filename.dirname file in let basename = Filename.basename file in let modulename = @@ -78,14 +78,14 @@ let rec make_compilation_args = function let compile command args files = let args' = command :: args @ (make_compilation_args files) in match Sys.os_type with - | "Win32" -> - let pid = + | "Win32" -> + let pid = Unix.create_process_env command (Array.of_list args') environment - Unix.stdin Unix.stdout Unix.stderr + Unix.stdin Unix.stdout Unix.stderr in ignore (Unix.waitpid [] pid) | _ -> - Unix.execvpe command (Array.of_list args') environment + Unix.execvpe command (Array.of_list args') environment (* parsing of the command line * @@ -99,13 +99,13 @@ let usage () = let parse_args () = let rec parse (cfiles,args) = function - | [] -> + | [] -> List.rev cfiles, List.rev args - | "-i" :: rem -> + | "-i" :: rem -> specification := true ; parse (cfiles,args) rem - | "-t" :: rem -> + | "-t" :: rem -> keep := true ; parse (cfiles,args) rem - | ("-verbose" | "--verbose") :: rem -> + | ("-verbose" | "--verbose") :: rem -> verbose := true ; parse (cfiles,args) rem | "-boot" :: rem -> Flags.boot := true; @@ -142,11 +142,11 @@ let parse_args () = |"-batch"|"-nois"|"-noglob"|"-no-glob" |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit" - |"-dont-load-proofs"|"-impredicative-set"|"-vm" + |"-dont-load-proofs"|"-impredicative-set"|"-vm" |"-unboxed-values"|"-unboxed-definitions"|"-draw-vm-instr" as o) :: rem -> parse (cfiles,o::args) rem - - | ("-where") :: _ -> + + | ("-where") :: _ -> (try print_endline (Envars.coqlib ()) with Util.UserError(_,pps) -> Pp.msgerrnl (Pp.hov 0 pps)); exit 0 @@ -155,10 +155,10 @@ let parse_args () = | ("-v"|"--version") :: _ -> Usage.version () - | f :: rem -> + | f :: rem -> if Sys.file_exists f then parse (f::cfiles,args) rem - else + else let fv = f ^ ".v" in if Sys.file_exists fv then parse (fv::cfiles,args) rem @@ -178,11 +178,11 @@ let main () = prerr_endline "coqc: too few arguments" ; usage () end; - let coqtopname = - if !image <> "" then !image + let coqtopname = + if !image <> "" then !image else Filename.concat (Envars.coqbin ()) (!binary ^ Coq_config.exec_extension) in (* List.iter (compile coqtopname args) cfiles*) Unix.handle_unix_error (compile coqtopname args) cfiles - + let _ = Printexc.print main (); exit 0 diff --git a/scripts/coqmktop.ml b/scripts/coqmktop.ml index 50059ae17c..936e159dea 100644 --- a/scripts/coqmktop.ml +++ b/scripts/coqmktop.ml @@ -51,28 +51,28 @@ let searchisos = ref false let coqide = ref false let echo = ref false -let src_dirs () = +let src_dirs () = [ []; ["kernel";"byterun"]; [ "config" ]; [ "toplevel" ] ] @ if !coqide then [[ "ide" ]] else [] -let includes () = +let includes () = let coqlib = Envars.coqlib () in let camlp4lib = Envars.camlp4lib () in List.fold_right (fun d l -> "-I" :: ("\"" ^ List.fold_left Filename.concat coqlib d ^ "\"") :: l) (src_dirs ()) - (["-I"; "\"" ^ camlp4lib ^ "\""] @ + (["-I"; "\"" ^ camlp4lib ^ "\""] @ ["-I"; "\"" ^ coqlib ^ "\""] @ (if !coqide then ["-thread"; "-I"; "+lablgtk2"] else [])) (* Transform bytecode object file names in native object file names *) let native_suffix f = - if Filename.check_suffix f ".cmo" then + if Filename.check_suffix f ".cmo" then (Filename.chop_suffix f ".cmo") ^ ".cmx" - else if Filename.check_suffix f ".cma" then + else if Filename.check_suffix f ".cma" then (Filename.chop_suffix f ".cma") ^ ".cmxa" - else - if Filename.check_suffix f ".a" then f + else + if Filename.check_suffix f ".a" then f else failwith ("File "^f^" has not extension .cmo, .cma or .a") @@ -112,8 +112,8 @@ let all_subdirs dir = let l = ref [dir] in let add f = l := f :: !l in let rec traverse dir = - let dirh = - try opendir dir with Unix_error _ -> invalid_arg "all_subdirs" + let dirh = + try opendir dir with Unix_error _ -> invalid_arg "all_subdirs" in try while true do @@ -152,13 +152,13 @@ Flags are: let parse_args () = let rec parse (op,fl) = function | [] -> List.rev op, List.rev fl - | "-coqlib" :: d :: rem -> + | "-coqlib" :: d :: rem -> Flags.coqlib_spec := true; Flags.coqlib := d ; parse (op,fl) rem | "-coqlib" :: _ -> usage () - | "-camlbin" :: d :: rem -> + | "-camlbin" :: d :: rem -> Flags.camlbin_spec := true; Flags.camlbin := d ; parse (op,fl) rem | "-camlbin" :: _ -> usage () - | "-camlp4bin" :: d :: rem -> + | "-camlp4bin" :: d :: rem -> Flags.camlp4bin_spec := true; Flags.camlp4bin := d ; parse (op,fl) rem | "-camlp4bin" :: _ -> usage () | "-boot" :: rem -> Flags.boot := true; parse (op,fl) rem @@ -167,7 +167,7 @@ let parse_args () = | "-top" :: rem -> top := true ; parse (op,fl) rem | "-ide" :: rem -> coqide := true; parse (op,fl) rem - | "-v8" :: rem -> + | "-v8" :: rem -> Printf.eprintf "warning: option -v8 deprecated"; parse (op,fl) rem | "-echo" :: rem -> echo := true ; parse (op,fl) rem @@ -185,8 +185,8 @@ let parse_args () = parse (o::op,fl) rem | ("-h"|"--help") :: _ -> usage () | f :: rem -> - if Filename.check_suffix f ".ml" - or Filename.check_suffix f ".cmx" + if Filename.check_suffix f ".ml" + or Filename.check_suffix f ".cmx" or Filename.check_suffix f ".cmo" or Filename.check_suffix f ".cmxa" or Filename.check_suffix f ".cma" then @@ -243,14 +243,14 @@ let create_tmp_main_file modules = let main_name = Filename.temp_file "coqmain" ".ml" in let oc = open_out main_name in try - (* Add the pre-linked modules *) + (* Add the pre-linked modules *) output_string oc "List.iter Mltop.add_known_module [\""; output_string oc (String.concat "\";\"" modules); output_string oc "\"];;\n"; (* Initializes the kind of loading *) output_string oc (declare_loading_string()); (* Start the right toplevel loop: Coq or Coq_searchisos *) - if !searchisos then + if !searchisos then output_string oc "Cmd_searchisos_line.start();;\n" else if !coqide then output_string oc "Coqide.start();;\n" @@ -258,7 +258,7 @@ let create_tmp_main_file modules = output_string oc "Coqtop.start();;\n"; close_out oc; main_name - with e -> + with e -> clean main_name; raise e (* main part *) @@ -298,19 +298,19 @@ let main () = let args = if !top then args @ [ "topstart.cmo" ] else args in (* Now, with the .cma, we MUST use the -linkall option *) let command = String.concat " " (prog::"-rectypes"::args) in - if !echo then - begin - print_endline command; - print_endline - ("(command length is " ^ + if !echo then + begin + print_endline command; + print_endline + ("(command length is " ^ (string_of_int (String.length command)) ^ " characters)"); - flush Pervasives.stdout + flush Pervasives.stdout end; let retcode = Sys.command command in clean main_file; (* command gives the exit code in HSB, and signal in LSB !!! *) - if retcode > 255 then retcode lsr 8 else retcode - with e -> + if retcode > 255 then retcode lsr 8 else retcode + with e -> clean main_file; raise e let retcode = diff --git a/tactics/auto.ml b/tactics/auto.ml index 547ad2a772..8b68fa09b2 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -47,15 +47,15 @@ open Mod_subst (* The Type of Constructions Autotactic Hints *) (****************************************************************************) -type auto_tactic = +type auto_tactic = | Res_pf of constr * clausenv (* Hint Apply *) | ERes_pf of constr * clausenv (* Hint EApply *) - | Give_exact of constr + | Give_exact of constr | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) - | Extern of glob_tactic_expr (* Hint Extern *) + | Extern of glob_tactic_expr (* Hint Extern *) -type pri_auto_tactic = { +type pri_auto_tactic = { pri : int; (* A number between 0 and 4, 4 = lower priority *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) code : auto_tactic (* the tactic to apply when the concl matches pat *) @@ -65,15 +65,15 @@ type hint_entry = global_reference option * pri_auto_tactic let pri_order {pri=pri1} {pri=pri2} = pri1 <= pri2 -let insert v l = +let insert v l = let rec insrec = function | [] -> [v] | h::tl -> if pri_order v h then v::h::tl else h::(insrec tl) - in + in insrec l (* Nov 98 -- Papageno *) -(* Les Hints sont ré-organisés en plusieurs databases. +(* Les Hints sont ré-organisés en plusieurs databases. La table impérative "searchtable", de type "hint_db_table", associe une database (hint_db) à chaque nom. @@ -101,15 +101,15 @@ let add_tac pat t st (l,l',dn) = let rebuild_dn st (l,l',dn) = (l, l', List.fold_left (fun dn t -> Btermdn.add (Some st) dn (Option.get t.pat, t)) (Btermdn.create ()) l') - + let lookup_tacs (hdc,c) st (l,l',dn) = let l' = List.map snd (Btermdn.lookup st dn c) in let sl' = Sort.list pri_order l' in Sort.merge pri_order l sl' -module Constr_map = Map.Make(struct +module Constr_map = Map.Make(struct type t = global_reference - let compare = Pervasives.compare + let compare = Pervasives.compare end) let is_transparent_gr (ids, csts) = function @@ -119,7 +119,7 @@ let is_transparent_gr (ids, csts) = function module Hint_db = struct - type t = { + type t = { hintdb_state : Names.transparent_state; use_dn : bool; hintdb_map : search_entry Constr_map.t; @@ -132,14 +132,14 @@ module Hint_db = struct use_dn = use_dn; hintdb_map = Constr_map.empty; hintdb_nopat = [] } - + let find key db = try Constr_map.find key db.hintdb_map with Not_found -> empty_se - - let map_none db = + + let map_none db = Sort.merge pri_order (List.map snd db.hintdb_nopat) [] - + let map_all k db = let (l,l',_) = find k db in Sort.merge pri_order (List.map snd db.hintdb_nopat @ l) l' @@ -148,12 +148,12 @@ module Hint_db = struct let st = if db.use_dn then Some db.hintdb_state else None in let l' = lookup_tacs (k,c) st (find k db) in Sort.merge pri_order (List.map snd db.hintdb_nopat) l' - - let is_exact = function + + let is_exact = function | Give_exact _ -> true | _ -> false - let addkv gr v db = + let addkv gr v db = let k = match gr with | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr then None else Some gr | None -> None @@ -170,12 +170,12 @@ module Hint_db = struct { db with hintdb_map = Constr_map.add gr (add_tac pat v dnst oval) db.hintdb_map } let rebuild_db st' db = - let db' = + let db' = { db with hintdb_map = Constr_map.map (rebuild_dn st') db.hintdb_map; hintdb_state = st'; hintdb_nopat = [] } - in + in List.fold_left (fun db (gr,v) -> addkv gr v db) db' db.hintdb_nopat - + let add_one (k,v) db = let st',rebuild = match v.code with @@ -188,38 +188,38 @@ module Hint_db = struct in let db = if db.use_dn && rebuild then rebuild_db st' db else db in addkv k v db - + let add_list l db = List.fold_right add_one l db - - let iter f db = + + let iter f db = f None (List.map snd db.hintdb_nopat); Constr_map.iter (fun k (l,l',_) -> f (Some k) (l@l')) db.hintdb_map - + let transparent_state db = db.hintdb_state let set_transparent_state db st = - if db.use_dn then rebuild_db st db + if db.use_dn then rebuild_db st db else { db with hintdb_state = st } let use_dn db = db.use_dn - + end module Hintdbmap = Gmap type hint_db = Hint_db.t -type frozen_hint_db_table = (string,hint_db) Hintdbmap.t +type frozen_hint_db_table = (string,hint_db) Hintdbmap.t type hint_db_table = (string,hint_db) Hintdbmap.t ref type hint_db_name = string let searchtable = (ref Hintdbmap.empty : hint_db_table) - -let searchtable_map name = + +let searchtable_map name = Hintdbmap.find name !searchtable -let searchtable_add (name,db) = +let searchtable_add (name,db) = searchtable := Hintdbmap.add name db !searchtable let current_db_names () = Hintdbmap.dom !searchtable @@ -229,7 +229,7 @@ let current_db_names () = (**************************************************************************) let auto_init : (unit -> unit) ref = ref (fun () -> ()) - + let init () = searchtable := Hintdbmap.empty; !auto_init () let freeze () = !searchtable let unfreeze fs = searchtable := fs @@ -239,29 +239,29 @@ let _ = Summary.declare_summary "search" Summary.unfreeze_function = unfreeze; Summary.init_function = init } - + (**************************************************************************) (* Auxiliary functions to prepare AUTOHINT objects *) (**************************************************************************) let rec nb_hyp c = match kind_of_term c with | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2 - | _ -> 0 + | _ -> 0 (* adding and removing tactics in the search table *) -let try_head_pattern c = +let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable." -let dummy_goal = +let dummy_goal = {it = make_evar empty_named_context_val mkProp; sigma = empty} let make_exact_entry pri (c,cty) = let cty = strip_outer_cast cty in match kind_of_term cty with - | Prod (_,_,_) -> + | Prod (_,_,_) -> failwith "make_exact_entry" | _ -> let ce = mk_clenv_from dummy_goal (c,cty) in @@ -280,7 +280,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) = let hd = (try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry") in let nmiss = List.length (clenv_missing ce) in - if nmiss = 0 then + if nmiss = 0 then (Some hd, { pri = (match pri with None -> nb_hyp cty | Some p -> p); pat = Some pat; @@ -296,31 +296,31 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri (c,cty) = code = ERes_pf(c,{ce with env=empty_env}) }) end | _ -> failwith "make_apply_entry" - -(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose + +(* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose c is a constr cty is the type of constr *) let make_resolves env sigma flags pri c = let cty = type_of env sigma c in - let ents = - map_succeed - (fun f -> f (c,cty)) + let ents = + map_succeed + (fun f -> f (c,cty)) [make_exact_entry pri; make_apply_entry env sigma flags pri] - in + in if ents = [] then - errorlabstrm "Hint" - (pr_lconstr c ++ spc() ++ + errorlabstrm "Hint" + (pr_lconstr c ++ spc() ++ (if pi1 flags then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); ents (* used to add an hypothesis to the local hint database *) -let make_resolve_hyp env sigma (hname,_,htyp) = +let make_resolve_hyp env sigma (hname,_,htyp) = try [make_apply_entry env sigma (true, true, false) None (mkVar hname, htyp)] - with + with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly "make_resolve_hyp" @@ -331,8 +331,8 @@ let make_unfold eref = pat = None; code = Unfold_nth eref }) -let make_extern pri pat tacast = - let hdconstr = Option.map try_head_pattern pat in +let make_extern pri pat tacast = + let hdconstr = Option.map try_head_pattern pat in (hdconstr, { pri=pri; pat = pat; @@ -354,44 +354,44 @@ open Vernacexpr (* If the database does not exist, it is created *) (* TODO: should a warning be printed in this case ?? *) -let add_hint dbname hintlist = - try +let add_hint dbname hintlist = + try let db = searchtable_map dbname in let db' = Hint_db.add_list hintlist db in searchtable_add (dbname,db') - with Not_found -> + with Not_found -> let db = Hint_db.add_list hintlist (Hint_db.empty empty_transparent_state false) in searchtable_add (dbname,db) let add_transparency dbname grs b = let db = searchtable_map dbname in let st = Hint_db.transparent_state db in - let st' = - List.fold_left (fun (ids, csts) gr -> + let st' = + List.fold_left (fun (ids, csts) gr -> match gr with | EvalConstRef c -> (ids, (if b then Cpred.add else Cpred.remove) c csts) | EvalVarRef v -> (if b then Idpred.add else Idpred.remove) v ids, csts) st grs in searchtable_add (dbname, Hint_db.set_transparent_state db st') - + type hint_action = | CreateDB of bool * transparent_state | AddTransparency of evaluable_global_reference list * bool | AddTactic of (global_reference option * pri_auto_tactic) list -let cache_autohint (_,(local,name,hints)) = +let cache_autohint (_,(local,name,hints)) = match hints with | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) | AddTransparency (grs, b) -> add_transparency name grs b | AddTactic hints -> add_hint name hints -let forward_subst_tactic = +let forward_subst_tactic = ref (fun _ -> failwith "subst_tactic is not installed for auto") let set_extern_subst_tactic f = forward_subst_tactic := f -let subst_autohint (_,subst,(local,name,hintlist as obj)) = +let subst_autohint (_,subst,(local,name,hintlist as obj)) = let trans_clenv clenv = Clenv.subst_clenv subst clenv in - let trans_data data code = + let trans_data data code = { data with pat = Option.smartmap (subst_pattern subst) data.pat ; code = code ; @@ -399,7 +399,7 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) = in let subst_key gr = let (lab'', elab') = subst_global subst gr in - let gr' = + let gr' = (try head_of_constr_reference (fst (head_constr_bound elab')) with Tactics.Bound -> lab'') in if gr' == gr then gr else gr' @@ -424,7 +424,7 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) = if c==c' then data else let code' = Res_pf_THEN_trivial_fail (c', trans_clenv clenv) in trans_data data code' - | Unfold_nth ref -> + | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in if ref==ref' then data else trans_data data (Unfold_nth ref') @@ -438,14 +438,14 @@ let subst_autohint (_,subst,(local,name,hintlist as obj)) = in match hintlist with | CreateDB _ -> obj - | AddTransparency (grs, b) -> + | AddTransparency (grs, b) -> let grs' = list_smartmap (subst_evaluable_reference subst) grs in if grs==grs' then obj else (local, name, AddTransparency (grs', b)) | AddTactic hintlist -> let hintlist' = list_smartmap subst_hint hintlist in if hintlist' == hintlist then obj else (local,name,AddTactic hintlist') - + let classify_autohint ((local,name,hintlist) as obj) = if local or hintlist = (AddTactic []) then Dispose else Substitute obj @@ -461,9 +461,9 @@ let (inAutoHint,_) = export_function = export_autohint } -let create_hint_db l n st b = +let create_hint_db l n st b = Lib.add_anonymous_leaf (inAutoHint (l,n,CreateDB (b, st))) - + (**************************************************************************) (* The "Hint" vernacular command *) (**************************************************************************) @@ -479,14 +479,14 @@ let add_resolves env sigma clist local dbnames = let add_unfolds l local dbnames = - List.iter - (fun dbname -> Lib.add_anonymous_leaf + List.iter + (fun dbname -> Lib.add_anonymous_leaf (inAutoHint (local,dbname, AddTactic (List.map make_unfold l)))) dbnames let add_transparency l b local dbnames = - List.iter - (fun dbname -> Lib.add_anonymous_leaf + List.iter + (fun dbname -> Lib.add_anonymous_leaf (inAutoHint (local,dbname, AddTransparency (l, b)))) dbnames @@ -498,16 +498,16 @@ let add_extern pri pat tacast local dbname = | Some (patmetas,pat) -> (match (list_subtract tacmetas patmetas) with | i::_ -> - errorlabstrm "add_extern" + errorlabstrm "add_extern" (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound.") | [] -> Lib.add_anonymous_leaf (inAutoHint(local,dbname, AddTactic [make_extern pri (Some pat) tacast]))) - | None -> + | None -> Lib.add_anonymous_leaf (inAutoHint(local,dbname, AddTactic [make_extern pri None tacast])) -let add_externs pri pat tacast local dbnames = +let add_externs pri pat tacast local dbnames = List.iter (add_extern pri pat tacast local) dbnames let add_trivials env sigma l local dbnames = @@ -517,7 +517,7 @@ let add_trivials env sigma l local dbnames = inAutoHint(local,dbname, AddTactic (List.map (make_trivial env sigma) l)))) dbnames -let forward_intern_tac = +let forward_intern_tac = ref (fun _ -> failwith "intern_tac is not installed for auto") let set_extern_intern_tac f = forward_intern_tac := f @@ -527,9 +527,9 @@ type hints_entry = | HintsImmediateEntry of constr list | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool - | HintsExternEntry of + | HintsExternEntry of int * (patvar list * constr_pattern) option * glob_tactic_expr - | HintsDestructEntry of identifier * int * (bool,unit) location * + | HintsDestructEntry of identifier * int * (bool,unit) location * (patvar list * constr_pattern) * glob_tactic_expr let interp_hints h = @@ -585,10 +585,10 @@ let pr_autotactic = | Res_pf (c,clenv) -> (str"apply " ++ pr_lconstr c) | ERes_pf (c,clenv) -> (str"eapply " ++ pr_lconstr c) | Give_exact c -> (str"exact " ++ pr_lconstr c) - | Res_pf_THEN_trivial_fail (c,clenv) -> + | Res_pf_THEN_trivial_fail (c,clenv) -> (str"apply " ++ pr_lconstr c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) - | Extern tac -> + | Extern tac -> (str "(external) " ++ Pptactic.pr_glob_tactic (Global.env()) tac) let pr_hint v = @@ -603,17 +603,17 @@ let pr_hints_db (name,db,hintlist) = else (fnl () ++ pr_hint_list hintlist)) (* Print all hints associated to head c in any database *) -let pr_hint_list_for_head c = +let pr_hint_list_for_head c = let dbs = Hintdbmap.to_list !searchtable in - let valid_dbs = - map_succeed - (fun (name,db) -> (name,db,Hint_db.map_all c db)) - dbs + let valid_dbs = + map_succeed + (fun (name,db) -> (name,db,Hint_db.map_all c db)) + dbs in - if valid_dbs = [] then + if valid_dbs = [] then (str "No hint declared for :" ++ pr_global c) - else - hov 0 + else + hov 0 (str"For " ++ pr_global c ++ str" -> " ++ fnl () ++ hov 0 (prlist pr_hints_db valid_dbs)) @@ -622,11 +622,11 @@ let pr_hint_ref ref = pr_hint_list_for_head ref (* Print all hints associated to head id in any database *) let print_hint_ref ref = ppnl(pr_hint_ref ref) -let pr_hint_term cl = - try +let pr_hint_term cl = + try let dbs = Hintdbmap.to_list !searchtable in - let valid_dbs = - let fn = try + let valid_dbs = + let fn = try let (hdc,args) = head_constr_bound cl in let hd = head_of_constr_reference hdc in if occur_existential cl then @@ -636,50 +636,50 @@ let pr_hint_term cl = in map_succeed (fun (name, db) -> (name, db, fn db)) dbs in - if valid_dbs = [] then + if valid_dbs = [] then (str "No hint applicable for current goal") else (str "Applicable Hints :" ++ fnl () ++ hov 0 (prlist pr_hints_db valid_dbs)) - with Match_failure _ | Failure _ -> + with Match_failure _ | Failure _ -> (str "No hint applicable for current goal") let error_no_such_hint_database x = error ("No such Hint database: "^x^".") - + let print_hint_term cl = ppnl (pr_hint_term cl) (* print all hints that apply to the concl of the current goal *) -let print_applicable_hint () = - let pts = get_pftreestate () in - let gl = nth_goal_of_pftreestate 1 pts in +let print_applicable_hint () = + let pts = get_pftreestate () in + let gl = nth_goal_of_pftreestate 1 pts in print_hint_term (pf_concl gl) - + (* displays the whole hint database db *) let print_hint_db db = let (ids, csts) = Hint_db.transparent_state db in msg (hov 0 (str"Unfoldable variable definitions: " ++ pr_idpred ids ++ fnl () ++ str"Unfoldable constant definitions: " ++ pr_cpred csts ++ fnl ())); - Hint_db.iter + Hint_db.iter (fun head hintlist -> match head with | Some head -> - msg (hov 0 + msg (hov 0 (str "For " ++ pr_global head ++ str " -> " ++ pr_hint_list hintlist)) | None -> - msg (hov 0 + msg (hov 0 (str "For any goal -> " ++ pr_hint_list hintlist))) db let print_hint_db_by_name dbname = - try + try let db = searchtable_map dbname in print_hint_db db - with Not_found -> + with Not_found -> error_no_such_hint_database dbname - + (* displays all the hints of all databases *) let print_searchtable () = Hintdbmap.iter @@ -704,7 +704,7 @@ let priority l = List.filter (fun (_,hint) -> hint.pri = 0) l open Unification let auto_unif_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; + modulo_conv_on_closed_terms = Some full_transparent_state; use_metas_eagerly = false; modulo_delta = empty_transparent_state; resolve_evars = true; @@ -713,14 +713,14 @@ let auto_unif_flags = { (* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve_nodelta (c,clenv) gl = +let unify_resolve_nodelta (c,clenv) gl = let clenv' = connect_clenv gl clenv in - let _ = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in + let _ = clenv_unique_resolver false ~flags:auto_unif_flags clenv' gl in h_simplest_apply c gl -let unify_resolve flags (c,clenv) gl = +let unify_resolve flags (c,clenv) gl = let clenv' = connect_clenv gl clenv in - let _ = clenv_unique_resolver false ~flags clenv' gl in + let _ = clenv_unique_resolver false ~flags clenv' gl in h_apply true false [dummy_loc,(inj_open c,NoBindings)] gl let unify_resolve_gen = function @@ -742,7 +742,7 @@ let expand_constructor_hints lems = let add_hint_lemmas eapply lems hint_db gl = let lems = expand_constructor_hints lems in - let hintlist' = + let hintlist' = list_map_append (pf_apply make_resolves gl (eapply,true,false) None) lems in Hint_db.add_list hintlist' hint_db @@ -757,21 +757,21 @@ let make_local_hint_db eapply lems gl = terme pour l'affichage ? (HH) *) (* Si on enlève le dernier argument (gl) conclPattern est calculé une -fois pour toutes : en particulier si Pattern.somatch produit une UserError +fois pour toutes : en particulier si Pattern.somatch produit une UserError Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même si après Intros la conclusion matche le pattern. *) (* conclPattern doit échouer avec error car il est rattraper par tclFIRST *) -let forward_interp_tactic = +let forward_interp_tactic = ref (fun _ -> failwith "interp_tactic is not installed for auto") let set_extern_interp f = forward_interp_tactic := f let conclPattern concl pat tac gl = - let constr_bindings = - match pat with + let constr_bindings = + match pat with | None -> [] | Some pat -> try matches pat concl @@ -787,7 +787,7 @@ let conclPattern concl pat tac gl = de Hint impérative a été remplacée par plusieurs bases fonctionnelles *) let flags_of_state st = - {auto_unif_flags with + {auto_unif_flags with modulo_conv_on_closed_terms = Some st; modulo_delta = st} let hintmap_of hdc concl = @@ -796,34 +796,34 @@ let hintmap_of hdc concl = | Some hdc -> if occur_existential concl then Hint_db.map_all hdc else Hint_db.map_auto (hdc,concl) - + let rec trivial_fail_db mod_delta db_list local_db gl = - let intro_tac = - tclTHEN intro + let intro_tac = + tclTHEN intro (fun g'-> let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') in trivial_fail_db mod_delta db_list (Hint_db.add_list hintl local_db) g') in - tclFIRST + tclFIRST (assumption::intro_tac:: - (List.map tclCOMPLETE + (List.map tclCOMPLETE (trivial_resolve mod_delta db_list local_db (pf_concl gl)))) gl and my_find_search_nodelta db_list local_db hdc concl = - List.map (fun hint -> (None,hint)) + List.map (fun hint -> (None,hint)) (list_map_append (hintmap_of hdc concl) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta else my_find_search_nodelta - + and my_find_search_delta db_list local_db hdc concl = let flags = {auto_unif_flags with use_metas_eagerly = true} in let f = hintmap_of hdc concl in - if occur_existential concl then + if occur_existential concl then list_map_append - (fun db -> - if Hint_db.use_dn db then + (fun db -> + if Hint_db.use_dn db then let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags,x)) (f db) else @@ -831,8 +831,8 @@ and my_find_search_delta db_list local_db hdc concl = List.map (fun x -> (Some flags,x)) (f db)) (local_db::db_list) else - list_map_append (fun db -> - if Hint_db.use_dn db then + list_map_append (fun db -> + if Hint_db.use_dn db then let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (Some flags, x)) (f db) else @@ -853,37 +853,37 @@ and tac_of_hint db_list local_db concl (flags, {pat=p; code=t}) = | Res_pf (term,cl) -> unify_resolve_gen flags (term,cl) | ERes_pf (_,c) -> (fun gl -> error "eres_pf") | Give_exact c -> exact_check c - | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN + | Res_pf_THEN_trivial_fail (term,cl) -> + tclTHEN (unify_resolve_gen flags (term,cl)) (trivial_fail_db (flags <> None) db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] | Extern tacast -> conclPattern concl p tacast - -and trivial_resolve mod_delta db_list local_db cl = - try - let head = + +and trivial_resolve mod_delta db_list local_db cl = + try + let head = try let hdconstr,_ = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None in List.map (tac_of_hint db_list local_db cl) - (priority + (priority (my_find_search mod_delta db_list local_db head cl)) with Not_found -> [] let trivial lems dbnames gl = - let db_list = + let db_list = List.map - (fun x -> - try + (fun x -> + try searchtable_map x - with Not_found -> + with Not_found -> error_no_such_hint_database x) - ("core"::dbnames) + ("core"::dbnames) in - tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl - + tclTRY (trivial_fail_db false db_list (make_local_hint_db false lems gl)) gl + let full_trivial lems gl = let dbnames = Hintdbmap.dom !searchtable in let dbnames = list_subtract dbnames ["v62"] in @@ -905,8 +905,8 @@ let h_trivial lems l = (**************************************************************************) let possible_resolve mod_delta db_list local_db cl = - try - let head = + try + let head = try let hdconstr,_ = head_constr_bound cl in Some (head_of_constr_reference hdconstr) with Bound -> None @@ -925,18 +925,18 @@ let decomp_unary_term_then (id,_,typc) kont1 kont2 gl = kont2 gl with UserError _ -> kont2 gl -let decomp_empty_term (id,_,typc) gl = - if Hipattern.is_empty_type typc then - simplest_case (mkVar id) gl - else +let decomp_empty_term (id,_,typc) gl = + if Hipattern.is_empty_type typc then + simplest_case (mkVar id) gl + else errorlabstrm "Auto.decomp_empty_term" (str "Not an empty type.") let extend_local_db gl decl db = Hint_db.add_list (make_resolve_hyp (pf_env gl) (project gl) decl) db -(* Try to decompose hypothesis [decl] into atomic components of a - conjunction with maximum depth [p] (or solve the goal from an - empty type) then call the continuation tactic with hint db extended +(* Try to decompose hypothesis [decl] into atomic components of a + conjunction with maximum depth [p] (or solve the goal from an + empty type) then call the continuation tactic with hint db extended with the obtained not-further-decomposable hypotheses *) let rec decomp_and_register_decl p kont (id,_,_ as decl) db gl = @@ -967,7 +967,7 @@ and decomp_and_register_decls p kont decls = List.fold_left (decomp_and_register_decl p) kont decls -(* decomp is an natural number giving an indication on decomposition +(* decomp is an natural number giving an indication on decomposition of conjunction in hypotheses, 0 corresponds to no decomposition *) (* n is the max depth of search *) (* local_db contains the local Hypotheses *) @@ -980,7 +980,7 @@ let rec search_gen p n mod_delta db_list local_db = tclFIRST (assumption :: intros_decomp p (search n) [] local_db 1 :: - List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db)) + List.map (fun ntac -> tclTHEN ntac (search (n-1) local_db)) (possible_resolve mod_delta db_list local_db (pf_concl gl))) gl in search n local_db @@ -990,14 +990,14 @@ let search = search_gen 0 let default_search_depth = ref 5 let delta_auto mod_delta n lems dbnames gl = - let db_list = + let db_list = List.map - (fun x -> - try + (fun x -> + try searchtable_map x - with Not_found -> + with Not_found -> error_no_such_hint_database x) - ("core"::dbnames) + ("core"::dbnames) in tclTRY (search n mod_delta db_list (make_local_hint_db false lems gl)) gl @@ -1007,7 +1007,7 @@ let new_auto = delta_auto true let default_auto = auto !default_search_depth [] [] -let delta_full_auto mod_delta n lems gl = +let delta_full_auto mod_delta n lems gl = let dbnames = Hintdbmap.dom !searchtable in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map (fun x -> searchtable_map x) dbnames in @@ -1034,18 +1034,18 @@ let h_auto n lems l = (* The "destructing Auto" from Eduardo *) (**************************************************************************) -(* Depth of search after decomposition of hypothesis, by default - one look for an immediate solution *) +(* Depth of search after decomposition of hypothesis, by default + one look for an immediate solution *) let default_search_decomp = ref 20 -let destruct_auto p lems n gl = +let destruct_auto p lems n gl = decomp_and_register_decls p (fun local_db gl -> search_gen p n false (List.map searchtable_map ["core";"extcore"]) (add_hint_lemmas false lems local_db gl) gl) (pf_hyps gl) (Hint_db.empty empty_transparent_state false) gl - + let dautomatic des_opt lems n = tclTRY (destruct_auto des_opt lems n) let dauto (n,p) lems = @@ -1064,35 +1064,35 @@ let h_dauto (n,p) lems = (***************************************) let make_resolve_any_hyp env sigma (id,_,ty) = - let ents = + let ents = map_succeed - (fun f -> f (mkVar id,ty)) + (fun f -> f (mkVar id,ty)) [make_exact_entry None; make_apply_entry env sigma (true,true,false) None] - in + in ents type autoArguments = - | UsingTDB - | Destructing + | UsingTDB + | Destructing let compileAutoArg contac = function - | Destructing -> - (function g -> - let ctx = pf_hyps g in - tclFIRST - (List.map - (fun (id,_,typ) -> + | Destructing -> + (function g -> + let ctx = pf_hyps g in + tclFIRST + (List.map + (fun (id,_,typ) -> let cl = (strip_prod_assum typ) in if Hipattern.is_conjunction cl - then - tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac] - else + then + tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac] + else tclFAIL 0 (pr_id id ++ str" is not a conjunction")) ctx) g) - | UsingTDB -> - (tclTHEN - (Tacticals.tryAllHypsAndConcl - (function + | UsingTDB -> + (tclTHEN + (Tacticals.tryAllHypsAndConcl + (function | Some id -> Dhyp.h_destructHyp false id | None -> Dhyp.h_destructConcl)) contac) @@ -1104,20 +1104,20 @@ let rec super_search n db_list local_db argl gl = tclFIRST (assumption :: - tclTHEN intro - (fun g -> + tclTHEN intro + (fun g -> let hintl = pf_apply make_resolve_any_hyp g (pf_last_hyp g) in super_search n db_list (Hint_db.add_list hintl local_db) argl g) :: - List.map (fun ntac -> - tclTHEN ntac + List.map (fun ntac -> + tclTHEN ntac (super_search (n-1) db_list local_db argl)) (possible_resolve false db_list local_db (pf_concl gl)) @ compileAutoArgList (super_search (n-1) db_list local_db argl) argl) gl -let search_superauto n to_add argl g = +let search_superauto n to_add argl g = let sigma = List.fold_right (fun (id,c) -> add_named_decl (id, None, pf_type_of g c)) @@ -1126,7 +1126,7 @@ let search_superauto n to_add argl g = let db = Hint_db.add_list db0 (make_local_hint_db false [] g) in super_search n [Hintdbmap.find "core" !searchtable] db argl g -let superauto n to_add argl = +let superauto n to_add argl = tclTRY (tclCOMPLETE (search_superauto n to_add argl)) let interp_to_add gl r = diff --git a/tactics/auto.mli b/tactics/auto.mli index 982a4e68ec..007a116d19 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -23,24 +23,24 @@ open Libnames open Vernacexpr open Mod_subst (*i*) - -type auto_tactic = + +type auto_tactic = | Res_pf of constr * clausenv (* Hint Apply *) | ERes_pf of constr * clausenv (* Hint EApply *) - | Give_exact of constr + | Give_exact of constr | Res_pf_THEN_trivial_fail of constr * clausenv (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) open Rawterm -type pri_auto_tactic = { +type pri_auto_tactic = { pri : int; (* A number between 0 and 4, 4 = lower priority *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) code : auto_tactic; (* the tactic to apply when the concl matches pat *) } -type stored_data = pri_auto_tactic +type stored_data = pri_auto_tactic type search_entry = stored_data list * stored_data list * stored_data Btermdn.t @@ -74,18 +74,18 @@ type hints_entry = | HintsImmediateEntry of constr list | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool - | HintsExternEntry of + | HintsExternEntry of int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr - | HintsDestructEntry of identifier * int * (bool,unit) Tacexpr.location * + | HintsDestructEntry of identifier * int * (bool,unit) Tacexpr.location * (patvar list * constr_pattern) * Tacexpr.glob_tactic_expr val searchtable_map : hint_db_name -> hint_db val searchtable_add : (hint_db_name * hint_db) -> unit -(* [create_hint_db local name st use_dn]. +(* [create_hint_db local name st use_dn]. [st] is a transparency state for unification using this db - [use_dn] switches the use of the discrimination net for all hints + [use_dn] switches the use of the discrimination net for all hints and patterns. *) val create_hint_db : bool -> hint_db_name -> transparent_state -> bool -> unit @@ -104,7 +104,7 @@ val print_hint_ref : global_reference -> unit val print_hint_db_by_name : hint_db_name -> unit -(* [make_exact_entry pri (c, ctyp)]. +(* [make_exact_entry pri (c, ctyp)]. [c] is the term given as an exact proof to solve the goal; [ctyp] is the type of [c]. *) @@ -112,11 +112,11 @@ val make_exact_entry : int option -> constr * constr -> hint_entry (* [make_apply_entry (eapply,verbose) pri (c,cty)]. [eapply] is true if this hint will be used only with EApply; - [hnf] should be true if we should expand the head of cty before searching for + [hnf] should be true if we should expand the head of cty before searching for products; [c] is the term given as an exact proof to solve the goal; [cty] is the type of [c]. *) - + val make_apply_entry : env -> evar_map -> bool * bool * bool -> int option -> constr * constr -> hint_entry @@ -129,7 +129,7 @@ val make_apply_entry : has missing arguments. *) val make_resolves : - env -> evar_map -> bool * bool * bool -> int option -> constr -> + env -> evar_map -> bool * bool * bool -> int option -> constr -> hint_entry list (* [make_resolve_hyp hname htyp]. @@ -137,7 +137,7 @@ val make_resolves : Never raises a user exception; If the hyp cannot be used as a Hint, the empty list is returned. *) -val make_resolve_hyp : +val make_resolve_hyp : env -> evar_map -> named_declaration -> hint_entry list (* [make_extern pri pattern tactic_expr] *) @@ -175,7 +175,7 @@ val unify_resolve_nodelta : (constr * clausenv) -> tactic val unify_resolve : Unification.unify_flags -> (constr * clausenv) -> tactic (* [ConclPattern concl pat tacast]: - if the term concl matches the pattern pat, (in sense of + if the term concl matches the pattern pat, (in sense of [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the right values to build a tactic *) @@ -199,7 +199,7 @@ val full_auto : int -> constr list -> tactic and doing delta *) val new_full_auto : int -> constr list -> tactic -(* auto with default search depth and with all hint databases +(* auto with default search depth and with all hint databases except the "v62" compatibility database *) val default_full_auto : tactic @@ -228,8 +228,8 @@ val h_dauto : int option * int option -> constr list -> tactic (* SuperAuto *) type autoArguments = - | UsingTDB - | Destructing + | UsingTDB + | Destructing (* val superauto : int -> (identifier * constr) list -> autoArguments list -> tactic diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 0d5a4ba25b..dbaedeefc8 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -37,14 +37,14 @@ let subst_hint subst hint = let pat' = subst_mps subst hint.rew_pat in let t' = Tacinterp.subst_tactic subst hint.rew_tac in if hint.rew_lemma == cst' && hint.rew_tac == t' then hint else - { hint with - rew_lemma = cst'; rew_type = typ'; + { hint with + rew_lemma = cst'; rew_type = typ'; rew_pat = pat'; rew_tac = t' } -module HintIdent = +module HintIdent = struct type t = int * rew_rule - + let compare (i,t) (i',t') = Pervasives.compare i i' (* Pervasives.compare t.rew_lemma t'.rew_lemma *) @@ -66,7 +66,7 @@ module HintDN = Term_dnet.Make(HintIdent)(HintOpt) let rewtab = ref (Stringmap.empty : HintDN.t Stringmap.t) -let _ = +let _ = let init () = rewtab := Stringmap.empty in let freeze () = !rewtab in let unfreeze fs = rewtab := fs in @@ -78,11 +78,11 @@ let _ = let find_base bas = try Stringmap.find bas !rewtab with - Not_found -> - errorlabstrm "AutoRewrite" + Not_found -> + errorlabstrm "AutoRewrite" (str ("Rewriting base "^(bas)^" does not exist.")) -let find_rewrites bas = +let find_rewrites bas = List.rev_map snd (HintDN.find_all (find_base bas)) let find_matches bas pat = @@ -96,10 +96,10 @@ let print_rewrite_hintdb bas = (fun h -> str (if h.rew_l2r then "rewrite -> " else "rewrite <- ") ++ Printer.pr_lconstr h.rew_lemma ++ str " of type " ++ Printer.pr_lconstr h.rew_type ++ - str " then use tactic " ++ + str " then use tactic " ++ Pptactic.pr_glob_tactic (Global.env()) h.rew_tac) (find_rewrites bas)) - + type raw_rew_rule = loc * constr * bool * raw_tactic_expr (* Applies all the rules of one base *) @@ -108,14 +108,14 @@ let one_base general_rewrite_maybe_in tac_main bas = let lrul = List.map (fun h -> (h.rew_lemma,h.rew_l2r,Tacinterp.eval_tactic h.rew_tac)) lrul in tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) -> tclTHEN tac - (tclREPEAT_MAIN + (tclREPEAT_MAIN (tclTHENFIRST (general_rewrite_maybe_in dir csr tc) tac_main))) tclIDTAC lrul)) (* The AutoRewrite tactic *) let autorewrite ?(conds=Naive) tac_main lbas = tclREPEAT_MAIN (tclPROGRESS - (List.fold_left (fun tac bas -> + (List.fold_left (fun tac bas -> tclTHEN tac (one_base (fun dir c tac -> let tac = tac, conds in @@ -124,7 +124,7 @@ let autorewrite ?(conds=Naive) tac_main lbas = tclIDTAC lbas)) let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic = - fun gl -> + fun gl -> (* let's check at once if id exists (to raise the appropriate error) *) let _ = List.map (Tacmach.pf_get_hyp gl) idl in let general_rewrite_in id = @@ -161,35 +161,35 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas : tactic = | _ -> assert false) (* there must be at least an hypothesis *) | _ -> assert false (* rewriting cannot complete a proof *) in - tclMAP (fun id -> + tclMAP (fun id -> tclREPEAT_MAIN (tclPROGRESS - (List.fold_left (fun tac bas -> + (List.fold_left (fun tac bas -> tclTHEN tac (one_base (general_rewrite_in id) tac_main bas)) tclIDTAC lbas))) idl gl let autorewrite_in ?(conds=Naive) id = autorewrite_multi_in ~conds [id] -let gen_auto_multi_rewrite conds tac_main lbas cl = - let try_do_hyps treat_id l = +let gen_auto_multi_rewrite conds tac_main lbas cl = + let try_do_hyps treat_id l = autorewrite_multi_in ~conds (List.map treat_id l) tac_main lbas - in + in if cl.concl_occs <> all_occurrences_expr & cl.concl_occs <> no_occurrences_expr - then + then error "The \"at\" syntax isn't available yet for the autorewrite tactic." - else - let compose_tac t1 t2 = - match cl.onhyps with - | Some [] -> t1 + else + let compose_tac t1 t2 = + match cl.onhyps with + | Some [] -> t1 | _ -> tclTHENFIRST t1 t2 in compose_tac (if cl.concl_occs <> no_occurrences_expr then autorewrite ~conds tac_main lbas else tclIDTAC) - (match cl.onhyps with + (match cl.onhyps with | Some l -> try_do_hyps (fun ((_,id),_) -> id) l - | None -> - fun gl -> - (* try to rewrite in all hypothesis + | None -> + fun gl -> + (* try to rewrite in all hypothesis (except maybe the rewritten one) *) let ids = Tacmach.pf_ids_of_hyps gl in try_do_hyps (fun id -> id) ids gl) @@ -198,14 +198,14 @@ let auto_multi_rewrite ?(conds=Naive) = gen_auto_multi_rewrite conds Refiner.tcl let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl gl = let onconcl = cl.Tacexpr.concl_occs <> no_occurrences_expr in - match onconcl,cl.Tacexpr.onhyps with - | false,Some [_] | true,Some [] | false,Some [] -> - (* autorewrite with .... in clause using tac n'est sur que - si clause represente soit le but soit UNE hypothese + match onconcl,cl.Tacexpr.onhyps with + | false,Some [_] | true,Some [] | false,Some [] -> + (* autorewrite with .... in clause using tac n'est sur que + si clause represente soit le but soit UNE hypothese *) gen_auto_multi_rewrite conds tac_main lbas cl gl - | _ -> - Util.errorlabstrm "autorewrite" + | _ -> + Util.errorlabstrm "autorewrite" (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") (* Functions necessary to the library object declaration *) @@ -217,11 +217,11 @@ let cache_hintrewrite (_,(rbase,lrl)) = let export_hintrewrite x = Some x -let subst_hintrewrite (_,subst,(rbase,list as node)) = +let subst_hintrewrite (_,subst,(rbase,list as node)) = let list' = HintDN.subst subst list in if list' == list then node else (rbase,list') - + let classify_hintrewrite x = Libobject.Substitute x @@ -249,13 +249,13 @@ type hypinfo = { } let evd_convertible env evd x y = - try ignore(Evarconv.the_conv_x env x y evd); true + try ignore(Evarconv.the_conv_x env x y evd); true with _ -> false - + let decompose_applied_relation metas env sigma c ctype left2right = - let find_rel ty = + let find_rel ty = let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in - let eqclause = + let eqclause = if metas then eqclause else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) in @@ -266,9 +266,9 @@ let decompose_applied_relation metas env sigma c ctype left2right = let l,res = split_last_two (y::z) in x::l, res | _ -> raise Not_found in - try + try let others,(c1,c2) = split_last_two args in - let ty1, ty2 = + let ty1, ty2 = Typing.mtype_of env eqclause.evd c1, Typing.mtype_of env eqclause.evd c2 in if not (evd_convertible env eqclause.evd ty1 ty2) then None @@ -280,7 +280,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = in match find_rel ctype with | Some c -> Some c - | None -> + | None -> let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) match find_rel (it_mkProd_or_LetIn t' ctx) with | Some c -> Some c @@ -290,11 +290,11 @@ let find_applied_relation metas loc env sigma c left2right = let ctype = Typing.type_of env sigma c in match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c - | None -> - user_err_loc (loc, "decompose_applied_relation", + | None -> + user_err_loc (loc, "decompose_applied_relation", str"The type" ++ spc () ++ Printer.pr_constr_env env ctype ++ spc () ++ str"of this term does not end with an applied relation.") - + (* To add rewriting rules to a base *) let add_rew_rules base lrul = let counter = ref 0 in @@ -309,4 +309,4 @@ let add_rew_rules base lrul = in incr counter; HintDN.add pat (!counter, rul) dn) HintDN.empty lrul in Lib.add_anonymous_leaf (inHintRewrite (base,lrul)) - + diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index 17777084d8..cf0d58ccb4 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -23,7 +23,7 @@ val add_rew_rules : string -> raw_rew_rule list -> unit (* The AutoRewrite tactic. The optional conditions tell rewrite how to handle matching and side-condition solving. - Default is Naive: first match in the clause, don't look at the side-conditions to + Default is Naive: first match in the clause, don't look at the side-conditions to tell if the rewrite succeeded. *) val autorewrite : ?conds:conditions -> tactic -> string list -> tactic val autorewrite_in : ?conds:conditions -> Names.identifier -> tactic -> string list -> tactic diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 379949f462..b409fc9b8d 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -19,18 +19,18 @@ open Libnames Eduardo (5/8/97). *) let dnet_depth = ref 8 - + let bounded_constr_pat_discr_st st (t,depth) = - if depth = 0 then - None + if depth = 0 then + None else match constr_pat_discr_st st t with | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) - + let bounded_constr_val_discr_st st (t,depth) = - if depth = 0 then - Dn.Nothing + if depth = 0 then + Dn.Nothing else match constr_val_discr_st st t with | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) @@ -38,16 +38,16 @@ let bounded_constr_val_discr_st st (t,depth) = | Dn.Everything -> Dn.Everything let bounded_constr_pat_discr (t,depth) = - if depth = 0 then - None + if depth = 0 then + None else match constr_pat_discr t with | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) - + let bounded_constr_val_discr (t,depth) = - if depth = 0 then - Dn.Nothing + if depth = 0 then + Dn.Nothing else match constr_val_discr t with | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) @@ -55,35 +55,35 @@ let bounded_constr_val_discr (t,depth) = | Dn.Everything -> Dn.Everything type 'a t = (global_reference,constr_pattern * int,'a) Dn.t - + let create = Dn.create - + let add = function - | None -> - (fun dn (c,v) -> + | None -> + (fun dn (c,v) -> Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> + | Some st -> + (fun dn (c,v) -> Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) let rmv = function - | None -> - (fun dn (c,v) -> + | None -> + (fun dn (c,v) -> Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> + | Some st -> + (fun dn (c,v) -> Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) let lookup = function - | None -> + | None -> (fun dn t -> - List.map - (fun ((c,_),v) -> (c,v)) + List.map + (fun ((c,_),v) -> (c,v)) (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth))) - | Some st -> + | Some st -> (fun dn t -> - List.map - (fun ((c,_),v) -> (c,v)) + List.map + (fun ((c,_),v) -> (c,v)) (Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth))) let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index 86107641d0..b41ecbf77c 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -22,7 +22,7 @@ val create : unit -> 'a t val add : transparent_state option -> 'a t -> (constr_pattern * 'a) -> 'a t val rmv : transparent_state option -> 'a t -> (constr_pattern * 'a) -> 'a t - + val lookup : transparent_state option -> 'a t -> constr -> (constr_pattern * 'a) list val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index e9dfce78b0..be8b0fb805 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -43,20 +43,20 @@ open Evd let default_eauto_depth = 100 let typeclasses_db = "typeclass_instances" -let _ = Auto.auto_init := (fun () -> +let _ = Auto.auto_init := (fun () -> Auto.create_hint_db false typeclasses_db full_transparent_state true) exception Found of evar_map -let is_dependent ev evm = - Evd.fold (fun ev' evi dep -> +let is_dependent ev evm = + Evd.fold (fun ev' evi dep -> if ev = ev' then dep else dep || occur_evar ev evi.evar_concl) evm false -let valid goals p res_sigma l = - let evm = - List.fold_left2 +let valid goals p res_sigma l = + let evm = + List.fold_left2 (fun sigma (ev, evi) prf -> let cstr, obls = Refiner.extract_open_proof !res_sigma prf in if not (Evd.is_defined sigma ev) then @@ -66,13 +66,13 @@ let valid goals p res_sigma l = in raise (Found evm) let evars_to_goals p evm = - let goals, evm' = + let goals, evm' = Evd.fold (fun ev evi (gls, evm') -> - if evi.evar_body = Evar_empty + if evi.evar_body = Evar_empty && Typeclasses.is_resolvable evi (* && not (is_dependent ev evm) *) - && p ev evi then ((ev,evi) :: gls, Evd.add evm' ev (Typeclasses.mark_unresolvable evi)) else + && p ev evi then ((ev,evi) :: gls, Evd.add evm' ev (Typeclasses.mark_unresolvable evi)) else (gls, Evd.add evm' ev evi)) evm ([], Evd.empty) in @@ -88,9 +88,9 @@ let intersects s t = open Auto -let e_give_exact flags c gl = - let t1 = (pf_type_of gl c) and t2 = pf_concl gl in - if occur_existential t1 or occur_existential t2 then +let e_give_exact flags c gl = + let t1 = (pf_type_of gl c) and t2 = pf_concl gl in + if occur_existential t1 or occur_existential t2 then tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) gl else exact_check c gl (* let t1 = (pf_type_of gl c) in *) @@ -107,12 +107,12 @@ let auto_unif_flags = { use_evars_pattern_unification = true; } -let unify_e_resolve flags (c,clenv) gls = +let unify_e_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in let clenv' = clenv_unique_resolver false ~flags clenv' gls in Clenvtac.clenv_refine true ~with_classes:false clenv' gls -let unify_resolve flags (c,clenv) gls = +let unify_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in let clenv' = clenv_unique_resolver false ~flags clenv' gls in Clenvtac.clenv_refine false ~with_classes:false clenv' gls @@ -120,64 +120,64 @@ let unify_resolve flags (c,clenv) gls = (** Hack to properly solve dependent evars that are typeclasses *) let flags_of_state st = - {auto_unif_flags with + {auto_unif_flags with modulo_conv_on_closed_terms = Some st; modulo_delta = st} let rec e_trivial_fail_db db_list local_db goal = - let tacl = + let tacl = Eauto.registered_e_assumption :: - (tclTHEN Tactics.intro + (tclTHEN Tactics.intro (function g'-> let d = pf_last_hyp g' in let hintl = make_resolve_hyp (pf_env g') (project g') d in (e_trivial_fail_db db_list (Hint_db.add_list hintl local_db) g'))) :: (List.map pi1 (e_trivial_resolve db_list local_db (pf_concl goal)) ) - in - tclFIRST (List.map tclCOMPLETE tacl) goal + in + tclFIRST (List.map tclCOMPLETE tacl) goal -and e_my_find_search db_list local_db hdc concl = +and e_my_find_search db_list local_db hdc concl = let hdc = head_of_constr_reference hdc in let hintl = list_map_append - (fun db -> - if Hint_db.use_dn db then + (fun db -> + if Hint_db.use_dn db then let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (flags, x)) (Hint_db.map_auto (hdc,concl) db) else let flags = flags_of_state (Hint_db.transparent_state db) in List.map (fun x -> (flags, x)) (Hint_db.map_all hdc db)) (local_db::db_list) - in - let tac_of_hint = - fun (flags, {pri=b; pat = p; code=t}) -> + in + let tac_of_hint = + fun (flags, {pri=b; pat = p; code=t}) -> let tac = match t with | Res_pf (term,cl) -> unify_resolve flags (term,cl) | ERes_pf (term,cl) -> unify_e_resolve flags (term,cl) | Give_exact (c) -> e_give_exact flags c | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve flags (term,cl)) + tclTHEN (unify_e_resolve flags (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] | Extern tacast -> conclPattern concl p tacast - in + in (tac,b,pr_autotactic t) - in + in List.map tac_of_hint hintl -and e_trivial_resolve db_list local_db gl = - try - e_my_find_search db_list local_db +and e_trivial_resolve db_list local_db gl = + try + e_my_find_search db_list local_db (fst (head_constr_bound gl)) gl with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = - try - e_my_find_search db_list local_db + try + e_my_find_search db_list local_db (fst (head_constr_bound gl)) gl with Bound | Not_found -> [] - + let rec catchable = function | Refiner.FailError _ -> true | Stdpp.Exc_located (_, e) -> catchable e @@ -188,17 +188,17 @@ let is_dep gl gls = if evs = Intset.empty then false else List.fold_left - (fun b gl -> - if b then b + (fun b gl -> + if b then b else let evs' = Evarutil.evars_of_term gl.evar_concl in intersects evs evs') false gls -let is_ground gl = +let is_ground gl = Evarutil.is_ground_term (project gl) (pf_concl gl) -let nb_empty_evars s = +let nb_empty_evars s = Evd.fold (fun ev evi acc -> if evi.evar_body = Evar_empty then succ acc else acc) s 0 let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) @@ -214,7 +214,7 @@ type autogoal = goal * autoinfo type 'ans fk = unit -> 'ans type ('a,'ans) sk = 'a -> 'ans fk -> 'ans type 'a tac = { skft : 'ans. ('a,'ans) sk -> 'ans fk -> autogoal sigma -> 'ans } - + type auto_result = autogoal list sigma * validation type atac = auto_result tac @@ -225,9 +225,9 @@ let lift_tactic tac (f : goal list sigma -> autoinfo -> autogoal list sigma) : ' match res with | Some (gls,v) -> sk (f gls hints, fun _ -> v) fk | None -> fk () } - -let intro_tac : atac = - lift_tactic Tactics.intro + +let intro_tac : atac = + lift_tactic Tactics.intro (fun {it = gls; sigma = s} info -> let gls' = List.map (fun g' -> @@ -237,8 +237,8 @@ let intro_tac : atac = (g', { info with hints = ldb; auto_last_tac = str"intro" })) gls in {it = gls'; sigma = s}) -let id_tac : atac = - { skft = fun sk fk {it = gl; sigma = s} -> +let id_tac : atac = + { skft = fun sk fk {it = gl; sigma = s} -> sk ({it = [gl]; sigma = s}, fun _ pfs -> List.hd pfs) fk } (* Ordering of states is lexicographic on the number of remaining goals. *) @@ -250,13 +250,13 @@ let compare (pri, _, (res, _)) (pri', _, (res', _)) = if pri <> 0 then pri else nbgoals res - nbgoals res' -let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = +let or_tac (x : 'a tac) (y : 'a tac) : 'a tac = { skft = fun sk fk gls -> x.skft sk (fun () -> y.skft sk fk gls) gls } let solve_tac (x : 'a tac) : 'a tac = { skft = fun sk fk gls -> x.skft (fun ({it = gls},_ as res) fk -> if gls = [] then sk res fk else fk ()) fk gls } - -let hints_tac hints = + +let hints_tac hints = { skft = fun sk fk {it = gl,info; sigma = s} -> (* if !typeclasses_debug then msgnl (str"depth=" ++ int info.auto_depth ++ str": " ++ info.auto_last_tac *) (* ++ spc () ++ str "->" ++ spc () ++ pr_ev s gl); *) @@ -272,7 +272,7 @@ let hints_tac hints = poss in if l = [] && !typeclasses_debug then - msgnl (pr_depth info.auto_depth ++ str": no match for " ++ + msgnl (pr_depth info.auto_depth ++ str": no match for " ++ Printer.pr_constr_env (Evd.evar_env gl) concl ++ int (List.length poss) ++ str" possibilities"); List.map possible_resolve l in @@ -283,24 +283,24 @@ let hints_tac hints = ++ str" on" ++ spc () ++ pr_ev s gl); let fk = (fun () -> (* if !typeclasses_debug then msgnl (str"backtracked after " ++ pp); *) - aux (succ i) tl) + aux (succ i) tl) in - let glsv = {it = list_map_i (fun j g -> g, - { info with auto_depth = j :: i :: info.auto_depth; + let glsv = {it = list_map_i (fun j g -> g, + { info with auto_depth = j :: i :: info.auto_depth; auto_last_tac = pp }) 1 gls; sigma = s}, fun _ -> v in sk glsv fk | [] -> fk () in aux 1 tacs } - + let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = let rec aux s (acc : (autogoal list * validation) list) fk = function | (gl,info) :: gls -> - second.skft (fun ({it=gls';sigma=s'},v') fk' -> - let fk'' = if gls' = [] && Evarutil.is_ground_term s gl.evar_concl then + second.skft (fun ({it=gls';sigma=s'},v') fk' -> + let fk'' = if gls' = [] && Evarutil.is_ground_term s gl.evar_concl then (if !typeclasses_debug then msgnl (str"no backtrack on" ++ pr_ev s gl); fk) else fk' in aux s' ((gls',v')::acc) fk'' gls) fk {it = (gl,info); sigma = s} | [] -> Some (List.rev acc, s, fk) - in fun ({it = gls; sigma = s},v) fk -> + in fun ({it = gls; sigma = s},v) fk -> let rec aux' = function | None -> fk () | Some (res, s', fk') -> @@ -316,19 +316,19 @@ let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk let then_tac (first : atac) (second : atac) : atac = { skft = fun sk fk -> first.skft (then_list second sk) fk } - -let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = + +let run_tac (t : 'a tac) (gl : autogoal sigma) : auto_result option = t.skft (fun x _ -> Some x) (fun _ -> None) gl -let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : auto_result option = - (then_list t (fun x _ -> Some x)) +let run_list_tac (t : 'a tac) p goals (gl : autogoal list sigma) : auto_result option = + (then_list t (fun x _ -> Some x)) (gl, fun s pfs -> valid goals p (ref s) pfs) (fun _ -> None) - -let rec fix (t : 'a tac) : 'a tac = + +let rec fix (t : 'a tac) : 'a tac = then_tac t { skft = fun sk fk -> (fix t).skft sk fk } - + (* A special one for getting everything into a dnet. *) let is_transparent_gr (ids, csts) = function @@ -339,15 +339,15 @@ let is_transparent_gr (ids, csts) = function let make_resolve_hyp env sigma st flags pri (id, _, cty) = let cty = Evarutil.nf_evar sigma cty in let ctx, ar = decompose_prod cty in - let keep = + let keep = match kind_of_term (fst (decompose_app ar)) with | Const c -> is_class (ConstRef c) | Ind i -> is_class (IndRef i) | _ -> false in if keep then let c = mkVar id in - map_succeed - (fun f -> f (c,cty)) + map_succeed + (fun f -> f (c,cty)) [make_exact_entry pri; make_apply_entry env sigma flags pri] else [] @@ -356,9 +356,9 @@ let make_autogoal ?(st=full_transparent_state) g = let hintlist = list_map_append (pf_apply make_resolve_hyp g st (true,false,false) None) sign in let hints = Hint_db.add_list hintlist (Hint_db.empty st true) in (g.it, { hints = hints ; auto_depth = []; auto_last_tac = mt() }) - + let make_autogoals ?(st=full_transparent_state) gs evm' = - { it = list_map_i (fun i g -> + { it = list_map_i (fun i g -> let (gl, auto) = make_autogoal ~st {it = snd g; sigma = evm'} in (gl, { auto with auto_depth = [i]})) 1 gs; sigma = evm' } @@ -368,9 +368,9 @@ let run_on_evars ?(st=full_transparent_state) p evm tac = | Some (goals, evm') -> match run_list_tac tac p goals (make_autogoals ~st goals evm') with | None -> raise Not_found - | Some (gls, v) -> - try ignore(v (sig_sig gls) []); assert(false) - with Found evm' -> + | Some (gls, v) -> + try ignore(v (sig_sig gls) []); assert(false) + with Found evm' -> Some (Evd.evars_reset_evd evm' evm) let eauto hints g = @@ -378,7 +378,7 @@ let eauto hints g = let gl = { it = make_autogoal g; sigma = project g } in match run_tac tac gl with | None -> raise Not_found - | Some ({it = goals; sigma = s}, valid) -> + | Some ({it = goals; sigma = s}, valid) -> {it = List.map fst goals; sigma = s}, valid s let real_eauto st hints p evd = @@ -404,24 +404,24 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl = let term = Evarutil.nf_evar evd term in evd, term -let _ = +let _ = Typeclasses.solve_instanciation_problem := (fun x y z -> resolve_one_typeclass x ~sigma:y z) let has_undefined p oevd evd = Evd.fold (fun ev evi has -> has || - (evi.evar_body = Evar_empty && p ev evi && + (evi.evar_body = Evar_empty && p ev evi && (try Typeclasses.is_resolvable (Evd.find oevd ev) with _ -> true))) evd false let rec merge_deps deps = function | [] -> [deps] - | hd :: tl -> - if intersects deps hd then + | hd :: tl -> + if intersects deps hd then merge_deps (Intset.union deps hd) tl else hd :: merge_deps deps tl - + let evars_of_evi evi = - Intset.union (Evarutil.evars_of_term evi.evar_concl) + Intset.union (Evarutil.evars_of_term evi.evar_concl) (match evi.evar_body with | Evar_defined b -> Evarutil.evars_of_term b | Evar_empty -> Intset.empty) @@ -440,9 +440,9 @@ let select_evars evs evm = let resolve_all_evars debug m env p oevd do_split fail = let oevm = oevd in let split = if do_split then split_evars oevd else [Intset.empty] in - let p = if do_split then + let p = if do_split then fun comp ev evi -> (Intset.mem ev comp || not (Evd.mem oevm ev)) && p ev evi - else fun _ -> p + else fun _ -> p in let rec aux n p evd = if has_undefined p oevm evd then @@ -451,23 +451,23 @@ let resolve_all_evars debug m env p oevd do_split fail = aux (pred n) p evd' else None else Some evd - in + in let rec docomp evd = function | [] -> evd | comp :: comps -> let res = try aux 1 (p comp) evd with Not_found -> None in match res with - | None -> + | None -> if fail then let evd = Evarutil.nf_evars evd in - (* Unable to satisfy the constraints. *) + (* Unable to satisfy the constraints. *) let evm = if do_split then select_evars comp evd else evd in - let _, ev = Evd.fold - (fun ev evi (b,acc) -> + let _, ev = Evd.fold + (fun ev evi (b,acc) -> (* focus on one instance if only one was searched for *) if class_of_constr evi.evar_concl <> None then if not b (* || do_split *) then - true, Some ev + true, Some ev else b, None else b, acc) evm (false, None) in @@ -477,28 +477,28 @@ let resolve_all_evars debug m env p oevd do_split fail = in docomp oevd split let resolve_typeclass_evars d p env evd onlyargs split fail = - let pred = - if onlyargs then + let pred = + if onlyargs then (fun ev evi -> Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) && Typeclasses.is_class_evar evd evi) else (fun ev evi -> Typeclasses.is_class_evar evd evi) in resolve_all_evars d p env pred evd split fail - + let solve_inst debug mode depth env evd onlyargs split fail = resolve_typeclass_evars debug (mode, depth) env evd onlyargs split fail -let _ = +let _ = Typeclasses.solve_instanciations_problem := solve_inst false true default_eauto_depth - + VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings | [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ add_hints false [typeclasses_db] (interp_hints (Vernacexpr.HintsTransparency (cl, true))) ] END - + VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings | [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ add_hints false [typeclasses_db] @@ -520,9 +520,9 @@ END let pr_mode _prc _prlc _prt m = match m with Some b -> - if b then Pp.str "depth-first" else Pp.str "breadth-fist" + if b then Pp.str "depth-first" else Pp.str "breadth-fist" | None -> Pp.mt() - + ARGUMENT EXTEND search_mode TYPED AS bool option PRINTED BY pr_mode | [ "dfs" ] -> [ Some true ] | [ "bfs" ] -> [ Some false ] @@ -532,13 +532,13 @@ END let pr_depth _prc _prlc _prt = function Some i -> Util.pr_int i | None -> Pp.mt() - + ARGUMENT EXTEND depth TYPED AS int option PRINTED BY pr_depth | [ int_or_var_opt(v) ] -> [ match v with Some (ArgArg i) -> Some i | _ -> None ] END - + VERNAC COMMAND EXTEND Typeclasses_Settings - | [ "Typeclasses" "eauto" ":=" debug(d) search_mode(s) depth(depth) ] -> [ + | [ "Typeclasses" "eauto" ":=" debug(d) search_mode(s) depth(depth) ] -> [ typeclasses_debug := d; let mode = match s with Some t -> t | None -> true in let depth = match depth with Some i -> i | None -> default_eauto_depth in @@ -560,11 +560,11 @@ let _ = Classes.refine_ref := Refine.refine let rec head_of_constr t = let t = strip_outer_cast(collapse_appl t) in match kind_of_term t with - | Prod (_,_,c2) -> head_of_constr c2 + | Prod (_,_,c2) -> head_of_constr c2 | LetIn (_,_,_,c2) -> head_of_constr c2 | App (f,args) -> head_of_constr f | _ -> t - + TACTIC EXTEND head_of_constr [ "head_of_constr" ident(h) constr(c) ] -> [ let c = head_of_constr c in @@ -584,7 +584,7 @@ let freevars c = let rec frec acc c = match kind_of_term c with | Var id -> Idset.add id acc | _ -> fold_constr frec acc c - in + in frec Idset.empty c let coq_zero = lazy (gen_constant ["Init"; "Datatypes"] "O") @@ -597,15 +597,15 @@ let rec coq_nat_of_int = function let varify_constr_list ty def varh c = let vars = Idset.elements (freevars c) in - let mkaccess i = + let mkaccess i = mkApp (Lazy.force coq_List_nth, [| ty; coq_nat_of_int i; varh; def |]) in - let l = List.fold_right (fun id acc -> + let l = List.fold_right (fun id acc -> mkApp (Lazy.force coq_List_cons, [| ty ; mkVar id; acc |])) vars (mkApp (Lazy.force coq_List_nil, [| ty |])) in - let subst = + let subst = list_map_i (fun i id -> (id, mkaccess i)) 0 vars in l, replace_vars subst c @@ -630,27 +630,27 @@ let rec mkidx i p = else mkApp (Lazy.force coq_index_left, [|mkidx (i - p) (2 * p)|]) else if i = 1 then mkApp (Lazy.force coq_index_right, [|Lazy.force coq_index_end|]) else mkApp (Lazy.force coq_index_right, [|mkidx (i - p) (2 * p)|]) - + let varify_constr_varmap ty def varh c = let vars = Idset.elements (freevars c) in - let mkaccess i = + let mkaccess i = mkApp (Lazy.force coq_varmap_lookup, [| ty; def; i; varh |]) in - let rec vmap_aux l cont = - match l with + let rec vmap_aux l cont = + match l with | [] -> [], mkApp (Lazy.force coq_varmap_empty, [| ty |]) - | hd :: tl -> + | hd :: tl -> let left, right = split_interleaved [] [] tl in let leftvars, leftmap = vmap_aux left (fun x -> cont (mkApp (Lazy.force coq_index_left, [| x |]))) in let rightvars, rightmap = vmap_aux right (fun x -> cont (mkApp (Lazy.force coq_index_right, [| x |]))) in - (hd, cont (Lazy.force coq_index_end)) :: leftvars @ rightvars, + (hd, cont (Lazy.force coq_index_end)) :: leftvars @ rightvars, mkApp (Lazy.force coq_varmap_node, [| ty; hd; leftmap ; rightmap |]) in let subst, vmap = vmap_aux (def :: List.map (fun x -> mkVar x) vars) (fun x -> x) in let subst = List.map (fun (id, x) -> (destVar id, mkaccess x)) (List.tl subst) in vmap, replace_vars subst c - + TACTIC EXTEND varify [ "varify" ident(varh) ident(h') constr(ty) constr(def) constr(c) ] -> [ @@ -661,7 +661,7 @@ TACTIC EXTEND varify END TACTIC EXTEND not_evar - [ "not_evar" constr(ty) ] -> [ + [ "not_evar" constr(ty) ] -> [ match kind_of_term ty with | Evar _ -> tclFAIL 0 (str"Evar") | _ -> tclIDTAC ] diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 4b48064b31..46ed2134d0 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -27,9 +27,9 @@ let absurd c gls = (Evd.create_goal_evar_defs sigma) (Retyping.get_judgment_of env sigma c) in let c = j.Environ.utj_val in (tclTHENS - (tclTHEN (elim_type (build_coq_False ())) (cut c)) + (tclTHEN (elim_type (build_coq_False ())) (cut c)) ([(tclTHENS - (cut (applist(build_coq_not (),[c]))) + (cut (applist(build_coq_not (),[c]))) ([(tclTHEN intros ((fun gl -> let ida = pf_nth_hyp_id gl 1 @@ -59,7 +59,7 @@ let contradiction_context gl = else match kind_of_term typ with | Prod (na,t,u) when is_empty_type u -> (try - filter_hyp (fun typ -> pf_conv_x_leq gl typ t) + filter_hyp (fun typ -> pf_conv_x_leq gl typ t) (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) gl with Not_found -> seek_neg rest gl) diff --git a/tactics/decl_interp.ml b/tactics/decl_interp.ml index 02dace8377..77357e3fa4 100644 --- a/tactics/decl_interp.ml +++ b/tactics/decl_interp.ml @@ -22,18 +22,18 @@ open Pp (* INTERN *) -let raw_app (loc,hd,args) = if args =[] then hd else RApp(loc,hd,args) +let raw_app (loc,hd,args) = if args =[] then hd else RApp(loc,hd,args) -let intern_justification_items globs = +let intern_justification_items globs = Option.map (List.map (intern_constr globs)) -let intern_justification_method globs = +let intern_justification_method globs = Option.map (intern_tactic globs) let intern_statement intern_it globs st = {st_label=st.st_label; st_it=intern_it globs st.st_it} - + let intern_no_bind intern_it globs x = globs,intern_it globs x @@ -41,22 +41,22 @@ let intern_constr_or_thesis globs = function Thesis n -> Thesis n | This c -> This (intern_constr globs c) -let add_var id globs= +let add_var id globs= let l1,l2=globs.ltacvars in {globs with ltacvars= (id::l1),(id::l2)} let add_name nam globs= - match nam with + match nam with Anonymous -> globs | Name id -> add_var id globs -let intern_hyp iconstr globs = function +let intern_hyp iconstr globs = function Hvar (loc,(id,topt)) -> add_var id globs, Hvar (loc,(id,Option.map (intern_constr globs) topt)) | Hprop st -> add_name st.st_label globs, Hprop (intern_statement iconstr globs st) -let intern_hyps iconstr globs hyps = +let intern_hyps iconstr globs hyps = snd (list_fold_map (intern_hyp iconstr) globs hyps) let intern_cut intern_it globs cut= @@ -65,32 +65,32 @@ let intern_cut intern_it globs cut= cut_by=intern_justification_items nglobs cut.cut_by; cut_using=intern_justification_method nglobs cut.cut_using} -let intern_casee globs = function +let intern_casee globs = function Real c -> Real (intern_constr globs c) - | Virtual cut -> Virtual - (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) + | Virtual cut -> Virtual + (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) let intern_hyp_list args globs = let intern_one globs (loc,(id,opttyp)) = (add_var id globs), (loc,(id,Option.map (intern_constr globs) opttyp)) in - list_fold_map intern_one globs args + list_fold_map intern_one globs args -let intern_suffices_clause globs (hyps,c) = +let intern_suffices_clause globs (hyps,c) = let nglobs,nhyps = list_fold_map (intern_hyp intern_constr) globs hyps in - nglobs,(nhyps,intern_constr_or_thesis nglobs c) + nglobs,(nhyps,intern_constr_or_thesis nglobs c) -let intern_fundecl args body globs= +let intern_fundecl args body globs= let nglobs,nargs = intern_hyp_list args globs in nargs,intern_constr nglobs body - + let rec add_vars_of_simple_pattern globs = function CPatAlias (loc,p,id) -> add_vars_of_simple_pattern (add_var id globs) p -(* Stdpp.raise_with_loc loc +(* Stdpp.raise_with_loc loc (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) | CPatOr (loc, _)-> - Stdpp.raise_with_loc loc + Stdpp.raise_with_loc loc (UserError ("simple_pattern",str "\"(_ | _)\" is not allowed here")) | CPatDelimiters (_,_,p) -> add_vars_of_simple_pattern globs p @@ -99,26 +99,26 @@ let rec add_vars_of_simple_pattern globs = function | CPatNotation(_,_,(pl,pll)) -> List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pll)) | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs - | _ -> globs + | _ -> globs let rec intern_bare_proof_instr globs = function Pthus i -> Pthus (intern_bare_proof_instr globs i) | Pthen i -> Pthen (intern_bare_proof_instr globs i) | Phence i -> Phence (intern_bare_proof_instr globs i) - | Pcut c -> Pcut - (intern_cut + | Pcut c -> Pcut + (intern_cut (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c) - | Psuffices c -> + | Psuffices c -> Psuffices (intern_cut intern_suffices_clause globs c) - | Prew (s,c) -> Prew - (s,intern_cut - (intern_no_bind (intern_statement intern_constr)) globs c) + | Prew (s,c) -> Prew + (s,intern_cut + (intern_no_bind (intern_statement intern_constr)) globs c) | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps) - | Pcase (params,pat,hyps) -> + | Pcase (params,pat,hyps) -> let nglobs,nparams = intern_hyp_list params globs in let nnglobs= add_vars_of_simple_pattern nglobs pat in let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in - Pcase (nparams,pat,nhyps) + Pcase (nparams,pat,nhyps) | Ptake witl -> Ptake (List.map (intern_constr globs) witl) | Pconsider (c,hyps) -> Pconsider (intern_constr globs c, intern_hyps intern_constr globs hyps) @@ -130,7 +130,7 @@ let rec intern_bare_proof_instr globs = function | Plet hyps -> Plet (intern_hyps intern_constr globs hyps) | Pclaim st -> Pclaim (intern_statement intern_constr globs st) | Pfocus st -> Pfocus (intern_statement intern_constr globs st) - | Pdefine (id,args,body) -> + | Pdefine (id,args,body) -> let nargs,nbody = intern_fundecl args body globs in Pdefine (id,nargs,nbody) | Pcast (id,typ) -> @@ -145,10 +145,10 @@ let rec intern_proof_instr globs instr= let interp_justification_items sigma env = Option.map (List.map (fun c ->understand sigma env (fst c))) -let interp_constr check_sort sigma env c = - if check_sort then - understand_type sigma env (fst c) - else +let interp_constr check_sort sigma env c = + if check_sort then + understand_type sigma env (fst c) + else understand sigma env (fst c) let special_whd env = @@ -162,13 +162,13 @@ let decompose_eq env id = let whd = special_whd env typ in match kind_of_term whd with App (f,args)-> - if eq_constr f _eq && (Array.length args)=3 + if eq_constr f _eq && (Array.length args)=3 then args.(0) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." let get_eq_typ info env = - let typ = decompose_eq env (get_last env) in + let typ = decompose_eq env (get_last env) in typ let interp_constr_in_type typ sigma env c = @@ -177,28 +177,28 @@ let interp_constr_in_type typ sigma env c = let interp_statement interp_it sigma env st = {st_label=st.st_label; st_it=interp_it sigma env st.st_it} - + let interp_constr_or_thesis check_sort sigma env = function Thesis n -> Thesis n | This c -> This (interp_constr check_sort sigma env c) -let abstract_one_hyp inject h raw = - match h with - Hvar (loc,(id,None)) -> +let abstract_one_hyp inject h raw = + match h with + Hvar (loc,(id,None)) -> RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw) - | Hvar (loc,(id,Some typ)) -> + | Hvar (loc,(id,Some typ)) -> RProd (dummy_loc,Name id, Explicit, fst typ, raw) - | Hprop st -> + | Hprop st -> RProd (dummy_loc,st.st_label, Explicit, inject st.st_it, raw) -let rawconstr_of_hyps inject hyps head = +let rawconstr_of_hyps inject hyps head = List.fold_right (abstract_one_hyp inject) hyps head let raw_prop = RSort (dummy_loc,RProp Null) - -let rec match_hyps blend names constr = function + +let rec match_hyps blend names constr = function [] -> [],substl names constr - | hyp::q -> + | hyp::q -> let (name,typ,body)=destProd constr in let st= {st_label=name;st_it=substl names typ} in let qnames= @@ -211,7 +211,7 @@ let rec match_hyps blend names constr = function let rhyps,head = match_hyps blend qnames body q in qhyp::rhyps,head -let interp_hyps_gen inject blend sigma env hyps head = +let interp_hyps_gen inject blend sigma env hyps head = let constr=understand sigma env (rawconstr_of_hyps inject hyps head) in match_hyps blend [] constr hyps @@ -219,42 +219,42 @@ let interp_hyps sigma env hyps = fst (interp_hyps_gen fst (fun x _ -> x) sigma e let dummy_prefix= id_of_string "__" -let rec deanonymize ids = - function - PatVar (loc,Anonymous) -> +let rec deanonymize ids = + function + PatVar (loc,Anonymous) -> let (found,known) = !ids in let new_id=Nameops.next_ident_away dummy_prefix known in let _= ids:= (loc,new_id) :: found , new_id :: known in PatVar (loc,Name new_id) - | PatVar (loc,Name id) as pat -> + | PatVar (loc,Name id) as pat -> let (found,known) = !ids in let _= ids:= (loc,id) :: found , known in pat - | PatCstr(loc,cstr,lpat,nam) -> + | PatCstr(loc,cstr,lpat,nam) -> PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam) let rec raw_of_pat = - function - PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" - | PatVar (loc,Name id) -> + function + PatVar (loc,Anonymous) -> anomaly "Anonymous pattern variable" + | PatVar (loc,Name id) -> RVar (loc,id) - | PatCstr(loc,((ind,_) as cstr),lpat,_) -> + | PatCstr(loc,((ind,_) as cstr),lpat,_) -> let mind= fst (Global.lookup_inductive ind) in let rec add_params n q = if n<=0 then q else add_params (pred n) (RHole(dummy_loc, Evd.TomatchTypeParameter(ind,n))::q) in - let args = List.map raw_of_pat lpat in + let args = List.map raw_of_pat lpat in raw_app(loc,RRef(dummy_loc,Libnames.ConstructRef cstr), - add_params mind.Declarations.mind_nparams args) - + add_params mind.Declarations.mind_nparams args) + let prod_one_hyp = function (loc,(id,None)) -> - (fun raw -> + (fun raw -> RProd (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw)) - | (loc,(id,Some typ)) -> - (fun raw -> + | (loc,(id,Some typ)) -> + (fun raw -> RProd (dummy_loc,Name id, Explicit, fst typ, raw)) let prod_one_id (loc,id) raw = @@ -265,13 +265,13 @@ let let_in_one_alias (id,pat) raw = RLetIn (dummy_loc,Name id, raw_of_pat pat, raw) let rec bind_primary_aliases map pat = - match pat with + match pat with PatVar (_,_) -> map | PatCstr(loc,_,lpat,nam) -> let map1 = - match nam with + match nam with Anonymous -> map - | Name id -> (id,pat)::map + | Name id -> (id,pat)::map in List.fold_left bind_primary_aliases map1 lpat @@ -283,17 +283,17 @@ let bind_aliases patvars subst patt = let map1 = bind_secondary_aliases map subst in List.rev map1 -let interp_pattern env pat_expr = +let interp_pattern env pat_expr = let patvars,pats = Constrintern.intern_pattern env pat_expr in - match pats with + match pats with [] -> anomaly "empty pattern list" | [subst,patt] -> (patvars,bind_aliases patvars subst patt,patt) | _ -> anomaly "undetected disjunctive pattern" -let rec match_args dest names constr = function +let rec match_args dest names constr = function [] -> [],names,substl names constr - | _::q -> + | _::q -> let (name,typ,body)=dest constr in let st={st_label=name;st_it=substl names typ} in let qnames= @@ -303,9 +303,9 @@ let rec match_args dest names constr = function let args,bnames,body = match_args dest qnames body q in st::args,bnames,body -let rec match_aliases names constr = function +let rec match_aliases names constr = function [] -> [],names,substl names constr - | _::q -> + | _::q -> let (name,c,typ,body)=destLetIn constr in let st={st_label=name;st_it=(substl names c,substl names typ)} in let qnames= @@ -324,21 +324,21 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = | _ -> error "No proof per cases/induction/inversion in progress." in let mib,oib=Global.lookup_inductive pinfo.per_ind in let num_params = pinfo.per_nparams in - let _ = + let _ = let expected = mib.Declarations.mind_nparams - num_params in if List.length params <> expected then - errorlabstrm "suppose it is" - (str "Wrong number of extra arguments: " ++ - (if expected = 0 then str "none" else int expected) ++ + errorlabstrm "suppose it is" + (str "Wrong number of extra arguments: " ++ + (if expected = 0 then str "none" else int expected) ++ str "expected.") in let app_ind = let rind = RRef (dummy_loc,Libnames.IndRef pinfo.per_ind) in - let rparams = List.map detype_ground pinfo.per_params in - let rparams_rec = - List.map - (fun (loc,(id,_)) -> - RVar (loc,id)) params in - let dum_args= + let rparams = List.map detype_ground pinfo.per_params in + let rparams_rec = + List.map + (fun (loc,(id,_)) -> + RVar (loc,id)) params in + let dum_args= list_tabulate (fun _ -> RHole (dummy_loc,Evd.QuestionMark (Evd.Define false))) oib.Declarations.mind_nrealargs in raw_app(dummy_loc,rind,rparams@rparams_rec@dum_args) in @@ -346,22 +346,22 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let inject = function Thesis (Plain) -> Rawterm.RSort(dummy_loc,RProp Null) | Thesis (For rec_occ) -> - if not (List.mem rec_occ pat_vars) then - errorlabstrm "suppose it is" - (str "Variable " ++ Nameops.pr_id rec_occ ++ + if not (List.mem rec_occ pat_vars) then + errorlabstrm "suppose it is" + (str "Variable " ++ Nameops.pr_id rec_occ ++ str " does not occur in pattern."); Rawterm.RSort(dummy_loc,RProp Null) | This (c,_) -> c in let term1 = rawconstr_of_hyps inject hyps raw_prop in let loc_ids,npatt = let rids=ref ([],pat_vars) in - let npatt= deanonymize rids patt in + let npatt= deanonymize rids patt in List.rev (fst !rids),npatt in let term2 = RLetIn(dummy_loc,Anonymous, RCast(dummy_loc,raw_of_pat npatt, CastConv (DEFAULTcast,app_ind)),term1) in - let term3=List.fold_right let_in_one_alias aliases term2 in + let term3=List.fold_right let_in_one_alias aliases term2 in let term4=List.fold_right prod_one_id loc_ids term3 in let term5=List.fold_right prod_one_hyp params term4 in let constr = understand sigma env term5 in @@ -370,8 +370,8 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in let blend st st' = - match st'.st_it with - Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} + match st'.st_it with + Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} | This _ -> {st_it = This st.st_it;st_label=st.st_label} in let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in tparams,{pat_vars=tpatvars; @@ -383,7 +383,7 @@ let interp_cases info sigma env params (pat:cases_pattern_expr) hyps = let interp_cut interp_it sigma env cut= let nenv,nstat = interp_it sigma env cut.cut_stat in - {cut with + {cut with cut_stat=nstat; cut_by=interp_justification_items sigma nenv cut.cut_by} @@ -393,7 +393,7 @@ let interp_no_bind interp_it sigma env x = let interp_suffices_clause sigma env (hyps,cot)= let (locvars,_) as res = match cot with - This (c,_) -> + This (c,_) -> let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) sigma env hyps c in nhyps,This nc | Thesis Plain as th -> interp_hyps sigma env hyps,th @@ -404,26 +404,26 @@ let interp_suffices_clause sigma env (hyps,cot)= match st.st_label with Name id -> Environ.push_named (id,None,st.st_it) env0 | _ -> env in - let nenv = List.fold_right push_one locvars env in - nenv,res - -let interp_casee sigma env = function + let nenv = List.fold_right push_one locvars env in + nenv,res + +let interp_casee sigma env = function Real c -> Real (understand sigma env (fst c)) - | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) + | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) sigma env cut) let abstract_one_arg = function (loc,(id,None)) -> - (fun raw -> - RLambda (dummy_loc,Name id, Explicit, + (fun raw -> + RLambda (dummy_loc,Name id, Explicit, RHole (loc,Evd.BinderType (Name id)), raw)) - | (loc,(id,Some typ)) -> - (fun raw -> + | (loc,(id,Some typ)) -> + (fun raw -> RLambda (dummy_loc,Name id, Explicit, fst typ, raw)) -let rawconstr_of_fun args body = +let rawconstr_of_fun args body = List.fold_right abstract_one_arg args (fst body) -let interp_fun sigma env args body = +let interp_fun sigma env args body = let constr=understand sigma env (rawconstr_of_fun args body) in match_args destLambda [] constr args @@ -431,22 +431,22 @@ let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = fu Pthus i -> Pthus (interp_bare_proof_instr info sigma env i) | Pthen i -> Pthen (interp_bare_proof_instr info sigma env i) | Phence i -> Phence (interp_bare_proof_instr info sigma env i) - | Pcut c -> Pcut (interp_cut - (interp_no_bind (interp_statement - (interp_constr_or_thesis true))) - sigma env c) - | Psuffices c -> + | Pcut c -> Pcut (interp_cut + (interp_no_bind (interp_statement + (interp_constr_or_thesis true))) + sigma env c) + | Psuffices c -> Psuffices (interp_cut interp_suffices_clause sigma env c) - | Prew (s,c) -> Prew (s,interp_cut - (interp_no_bind (interp_statement + | Prew (s,c) -> Prew (s,interp_cut + (interp_no_bind (interp_statement (interp_constr_in_type (get_eq_typ info env)))) - sigma env c) + sigma env c) | Psuppose hyps -> Psuppose (interp_hyps sigma env hyps) - | Pcase (params,pat,hyps) -> - let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in + | Pcase (params,pat,hyps) -> + let tparams,tpat,thyps = interp_cases info sigma env params pat hyps in Pcase (tparams,tpat,thyps) - | Ptake witl -> + | Ptake witl -> Ptake (List.map (fun c -> understand sigma env (fst c)) witl) | Pconsider (c,hyps) -> Pconsider (interp_constr false sigma env c, interp_hyps sigma env hyps) @@ -458,15 +458,15 @@ let rec interp_bare_proof_instr info (sigma:Evd.evar_map) (env:Environ.env) = fu | Plet hyps -> Plet (interp_hyps sigma env hyps) | Pclaim st -> Pclaim (interp_statement (interp_constr true) sigma env st) | Pfocus st -> Pfocus (interp_statement (interp_constr true) sigma env st) - | Pdefine (id,args,body) -> + | Pdefine (id,args,body) -> let nargs,_,nbody = interp_fun sigma env args body in Pdefine (id,nargs,nbody) - | Pcast (id,typ) -> + | Pcast (id,typ) -> Pcast(id,interp_constr true sigma env typ) let rec interp_proof_instr info sigma env instr= {emph = instr.emph; instr = interp_bare_proof_instr info sigma env instr.instr} - + diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml index 515b184daf..c2a32471e1 100644 --- a/tactics/decl_proof_instr.ml +++ b/tactics/decl_proof_instr.ml @@ -36,27 +36,27 @@ open Goptions let get_its_info gls = get_info gls.it -let get_strictness,set_strictness = +let get_strictness,set_strictness = let strictness = ref false in (fun () -> (!strictness)),(fun b -> strictness:=b) let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "strict mode"; optkey = ["Strict";"Proofs"]; optread = get_strictness; optwrite = set_strictness } -let tcl_change_info_gen info_gen = +let tcl_change_info_gen info_gen = (fun gls -> - let gl =sig_it gls in - {it=[{gl with evar_extra=info_gen}];sigma=sig_sig gls}, - function + let gl =sig_it gls in + {it=[{gl with evar_extra=info_gen}];sigma=sig_sig gls}, + function [pftree] -> {pftree with goal=gl; - ref=Some (Prim Change_evars,[pftree])} + ref=Some (Prim Change_evars,[pftree])} | _ -> anomaly "change_info : Wrong number of subtrees") let tcl_change_info info gls = tcl_change_info_gen (Some (pm_in info)) gls @@ -78,27 +78,27 @@ let is_good_inductive env ind = let check_not_per pts = if not (Proof_trees.is_complete_proof (proof_of_pftreestate pts)) then match get_stack pts with - Per (_,_,_,_)::_ -> + Per (_,_,_,_)::_ -> error "You are inside a proof per cases/induction.\n\ Please \"suppose\" something or \"end\" it now." | _ -> () let mk_evd metalist gls = let evd0= create_goal_evar_defs (sig_sig gls) in - let add_one (meta,typ) evd = + let add_one (meta,typ) evd = meta_declare meta typ evd in List.fold_right add_one metalist evd0 -let is_tmp id = (string_of_id id).[0] = '_' +let is_tmp id = (string_of_id id).[0] = '_' -let tmp_ids gls = +let tmp_ids gls = let ctx = pf_hyps gls in - match ctx with + match ctx with [] -> [] - | _::q -> List.filter is_tmp (ids_of_named_context q) + | _::q -> List.filter is_tmp (ids_of_named_context q) -let clean_tmp gls = - let clean_id id0 gls0 = +let clean_tmp gls = + let clean_id id0 gls0 = tclTRY (clear [id0]) gls0 in let rec clean_all = function [] -> tclIDTAC @@ -114,30 +114,30 @@ let assert_postpone id t = let start_proof_tac gls= let gl=sig_it gls in let info={pm_stack=[]} in - {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls}, - function + {it=[{gl with evar_extra=Some (pm_in info)}];sigma=sig_sig gls}, + function [pftree] -> {pftree with goal=gl; - ref=Some (Decl_proof true,[pftree])} + ref=Some (Decl_proof true,[pftree])} | _ -> anomaly "Dem : Wrong number of subtrees" -let go_to_proof_mode () = - Pfedit.mutate +let go_to_proof_mode () = + Pfedit.mutate (fun pts -> nth_unproven 1 (solve_pftreestate start_proof_tac pts)) (* closing gaps *) let daimon_tac gls = set_daimon_flag (); - ({it=[];sigma=sig_sig gls}, - function + ({it=[];sigma=sig_sig gls}, + function [] -> {open_subgoals=0; goal=sig_it gls; - ref=Some (Daimon,[])} + ref=Some (Daimon,[])} | _ -> anomaly "Daimon: Wrong number of subtrees") - + let daimon _ pftree = set_daimon_flag (); {pftree with @@ -150,7 +150,7 @@ let daimon_subtree = map_pftreestate (fun _ -> frontier_mapi daimon ) let rec is_focussing_instr = function Pthus i | Pthen i | Phence i -> is_focussing_instr i - | Pescape | Pper _ | Pclaim _ | Pfocus _ + | Pescape | Pper _ | Pclaim _ | Pfocus _ | Psuppose _ | Pcase (_,_,_) -> true | _ -> false @@ -158,7 +158,7 @@ let mark_rule_as_done = function Decl_proof true -> Decl_proof false | Decl_proof false -> anomaly "already marked as done" - | Nested(Proof_instr (lock_focus,instr),spfl) -> + | Nested(Proof_instr (lock_focus,instr),spfl) -> if lock_focus then Nested(Proof_instr (false,instr),spfl) else @@ -168,34 +168,34 @@ let mark_rule_as_done = function let mark_proof_tree_as_done pt = match pt.ref with None -> anomaly "mark_proof_tree_as_done" - | Some (r,spfl) -> + | Some (r,spfl) -> {pt with ref= Some (mark_rule_as_done r,spfl)} -let mark_as_done pts = - map_pftreestate - (fun _ -> mark_proof_tree_as_done) +let mark_as_done pts = + map_pftreestate + (fun _ -> mark_proof_tree_as_done) (up_to_matching_rule is_focussing_command pts) (* post-instruction focus management *) let goto_current_focus pts = up_until_matching_rule is_focussing_command pts -let goto_current_focus_or_top pts = - try +let goto_current_focus_or_top pts = + try up_until_matching_rule is_focussing_command pts with Not_found -> top_of_tree pts (* return *) let close_tactic_mode pts = - let pts1= - try goto_current_focus pts - with Not_found -> + let pts1= + try goto_current_focus pts + with Not_found -> error "\"return\" cannot be used outside of Declarative Proof Mode." in let pts2 = daimon_subtree pts1 in - let pts3 = mark_as_done pts2 in - goto_current_focus pts3 - + let pts3 = mark_as_done pts2 in + goto_current_focus pts3 + let return_from_tactic_mode () = Pfedit.mutate close_tactic_mode (* end proof/claim *) @@ -207,11 +207,11 @@ let close_block bt pts = else get_stack pts in match bt,stack with - B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> + B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> daimon_subtree (goto_current_focus pts) - | _, Claim::_ -> + | _, Claim::_ -> error "\"end claim\" expected." - | _, Focus_claim::_ -> + | _, Focus_claim::_ -> error "\"end focus\" expected." | _, [] -> error "\"end proof\" expected." @@ -225,18 +225,18 @@ let close_block bt pts = (* utility for suppose / suppose it is *) -let close_previous_case pts = - if - Proof_trees.is_complete_proof (proof_of_pftreestate pts) +let close_previous_case pts = + if + Proof_trees.is_complete_proof (proof_of_pftreestate pts) then match get_top_stack pts with - Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..." - | Suppose_case :: Per (et,_,_,_) :: _ -> + Per (et,_,_,_) :: _ -> anomaly "Weird case occured ..." + | Suppose_case :: Per (et,_,_,_) :: _ -> goto_current_focus (mark_as_done pts) - | _ -> error "Not inside a proof per cases or induction." + | _ -> error "Not inside a proof per cases or induction." else match get_stack pts with - Per (et,_,_,_) :: _ -> pts + Per (et,_,_,_) :: _ -> pts | Suppose_case :: Per (et,_,_,_) :: _ -> goto_current_focus (mark_as_done (daimon_subtree pts)) | _ -> error "Not inside a proof per cases or induction." @@ -246,10 +246,10 @@ let close_previous_case pts = (* automation *) let filter_hyps f gls = - let filter_aux (id,_,_) = - if f id then + let filter_aux (id,_,_) = + if f id then tclIDTAC - else + else tclTRY (clear [id]) in tclMAP filter_aux (Environ.named_context_of_val gls.it.evar_hyps) gls @@ -257,16 +257,16 @@ let local_hyp_prefix = id_of_string "___" let add_justification_hyps keep items gls = let add_aux c gls= - match kind_of_term c with - Var id -> + match kind_of_term c with + Var id -> keep:=Idset.add id !keep; - tclIDTAC gls - | _ -> - let id=pf_get_new_id local_hyp_prefix gls in - keep:=Idset.add id !keep; + tclIDTAC gls + | _ -> + let id=pf_get_new_id local_hyp_prefix gls in + keep:=Idset.add id !keep; tclTHEN (letin_tac None (Names.Name id) c None Tacexpr.nowhere) - (thin_body [id]) gls in - tclMAP add_aux items gls + (thin_body [id]) gls in + tclMAP add_aux items gls let prepare_goal items gls = let tokeep = ref Idset.empty in @@ -275,18 +275,18 @@ let prepare_goal items gls = [ (fun _ -> auxres); filter_hyps (let keep = !tokeep in fun id -> Idset.mem id keep)] gls -let my_automation_tac = ref +let my_automation_tac = ref (fun gls -> anomaly "No automation registered") let register_automation_tac tac = my_automation_tac:= tac let automation_tac gls = !my_automation_tac gls -let justification tac gls= - tclORELSE - (tclSOLVE [tclTHEN tac assumption]) - (fun gls -> - if get_strictness () then +let justification tac gls= + tclORELSE + (tclSOLVE [tclTHEN tac assumption]) + (fun gls -> + if get_strictness () then error "Insufficient justification." else begin @@ -340,44 +340,44 @@ let enstack_subsubgoals env se stack gls= Inductive.lookup_mind_specif env ind in let gentypes= Inductive.arities_of_constructors ind (mib,oib) in - let process i gentyp = - let constructor = mkConstruct(ind,succ i) + let process i gentyp = + let constructor = mkConstruct(ind,succ i) (* constructors numbering*) in let appterm = applist (constructor,params) in let apptype = Term.prod_applist gentyp params in let rc,_ = Reduction.dest_prod env apptype in - let rec meta_aux last lenv = function + let rec meta_aux last lenv = function [] -> (last,lenv,[]) | (nam,_,typ)::q -> let nlast=succ last in let (llast,holes,metas) = meta_aux nlast (mkMeta nlast :: lenv) q in (llast,holes,(nlast,special_nf gls (substl lenv typ))::metas) in - let (nlast,holes,nmetas) = + let (nlast,holes,nmetas) = meta_aux se.se_last_meta [] (List.rev rc) in let refiner = applist (appterm,List.rev holes) in - let evd = meta_assign se.se_meta + let evd = meta_assign se.se_meta (refiner,(ConvUpToEta 0,TypeProcessed (* ? *))) se.se_evd in - let ncreated = replace_in_list + let ncreated = replace_in_list se.se_meta nmetas se.se_meta_list in - let evd0 = List.fold_left - (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in - List.iter (fun (m,typ) -> - Stack.push + let evd0 = List.fold_left + (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in + List.iter (fun (m,typ) -> + Stack.push {se_meta=m; se_type=typ; se_evd=evd0; se_meta_list=ncreated; - se_last_meta=nlast} stack) (List.rev nmetas) + se_last_meta=nlast} stack) (List.rev nmetas) in Array.iteri process gentypes | _ -> () -let rec nf_list evd = +let rec nf_list evd = function - [] -> [] - | (m,typ)::others -> - if meta_defined evd m then + [] -> [] + | (m,typ)::others -> + if meta_defined evd m then nf_list evd others else (m,nf_meta evd typ)::nf_list evd others @@ -387,29 +387,29 @@ let find_subsubgoal c ctyp skip submetas gls = let concl = pf_concl gls in let evd = mk_evd ((0,concl)::submetas) gls in let stack = Stack.create () in - let max_meta = + let max_meta = List.fold_left (fun a (m,_) -> max a m) 0 submetas in - let _ = Stack.push + let _ = Stack.push {se_meta=0; se_type=concl; se_last_meta=max_meta; se_meta_list=[0,concl]; se_evd=evd} stack in - let rec dfs n = + let rec dfs n = let se = Stack.pop stack in - try - let unifier = - Unification.w_unify true env Reduction.CUMUL + try + let unifier = + Unification.w_unify true env Reduction.CUMUL ctyp se.se_type se.se_evd in - if n <= 0 then - {se with + if n <= 0 then + {se with se_evd=meta_assign se.se_meta (c,(ConvUpToEta 0,TypeNotProcessed (* ?? *))) unifier; - se_meta_list=replace_in_list + se_meta_list=replace_in_list se.se_meta submetas se.se_meta_list} else dfs (pred n) - with _ -> + with _ -> begin enstack_subsubgoals env se stack gls; dfs n @@ -421,20 +421,20 @@ let concl_refiner metas body gls = let concl = pf_concl gls in let evd = sig_sig gls in let env = pf_env gls in - let sort = family_of_sort (Typing.sort_of env evd concl) in + let sort = family_of_sort (Typing.sort_of env evd concl) in let rec aux env avoid subst = function [] -> anomaly "concl_refiner: cannot happen" | (n,typ)::rest -> - let _A = subst_meta subst typ in - let x = id_of_name_using_hdchar env _A Anonymous in + let _A = subst_meta subst typ in + let x = id_of_name_using_hdchar env _A Anonymous in let _x = fresh_id avoid x gls in let nenv = Environ.push_named (_x,None,_A) env in let asort = family_of_sort (Typing.sort_of nenv evd _A) in let nsubst = (n,mkVar _x)::subst in - if rest = [] then + if rest = [] then asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) else - let bsort,_B,nbody = + let bsort,_B,nbody = aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in let body = mkNamedLambda _x _A nbody in if occur_term (mkVar _x) _B then @@ -450,7 +450,7 @@ let concl_refiner metas body gls = let _P0 = mkLambda(Anonymous,_AxB,concl) in InType,_AxB, mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|]) - | _,_ -> + | _,_ -> let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in let _P0 = mkLambda(Anonymous,_AxB,concl) in InType,_AxB, @@ -473,23 +473,23 @@ let concl_refiner metas body gls = let (_,_,prf) = aux env [] [] metas in mkApp(prf,[|mkMeta 1|]) -let thus_tac c ctyp submetas gls = - let list,proof = +let thus_tac c ctyp submetas gls = + let list,proof = try find_subsubgoal c ctyp 0 submetas gls - with Not_found -> + with Not_found -> error "I could not relate this statement to the thesis." in if list = [] then - exact_check proof gls + exact_check proof gls else let refiner = concl_refiner list proof gls in Tactics.refine refiner gls (* general forward step *) -let mk_stat_or_thesis info gls = function +let mk_stat_or_thesis info gls = function This c -> c - | Thesis (For _ ) -> + | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> pf_concl gls @@ -497,34 +497,34 @@ let just_tac _then cut info gls0 = let items_tac gls = match cut.cut_by with None -> tclIDTAC gls - | Some items -> - let items_ = - if _then then + | Some items -> + let items_ = + if _then then let last_id = get_last (pf_env gls) in (mkVar last_id)::items - else items + else items in prepare_goal items_ gls in - let method_tac gls = + let method_tac gls = match cut.cut_using with - None -> + None -> automation_tac gls - | Some tac -> + | Some tac -> (Tacinterp.eval_tactic tac) gls in justification (tclTHEN items_tac method_tac) gls0 - -let instr_cut mkstat _thus _then cut gls0 = - let info = get_its_info gls0 in + +let instr_cut mkstat _thus _then cut gls0 = + let info = get_its_info gls0 in let stat = cut.cut_stat in - let (c_id,_) = match stat.st_label with - Anonymous -> - pf_get_new_id (id_of_string "_fact") gls0,false + let (c_id,_) = match stat.st_label with + Anonymous -> + pf_get_new_id (id_of_string "_fact") gls0,false | Name id -> id,true in let c_stat = mkstat info gls0 stat.st_it in - let thus_tac gls= - if _thus then + let thus_tac gls= + if _thus then thus_tac (mkVar c_id) c_stat [] gls else tclIDTAC gls in - tclTHENS (assert_postpone c_id c_stat) + tclTHENS (assert_postpone c_id c_stat) [tclTHEN tcl_erase_info (just_tac _then cut info); thus_tac] gls0 @@ -538,162 +538,162 @@ let decompose_eq id gls = let whd = (special_whd gls typ) in match kind_of_term whd with App (f,args)-> - if eq_constr f _eq && (Array.length args)=3 + if eq_constr f _eq && (Array.length args)=3 then (args.(0), - args.(1), - args.(2)) + args.(1), + args.(2)) else error "Previous step is not an equality." | _ -> error "Previous step is not an equality." - -let instr_rew _thus rew_side cut gls0 = - let last_id = + +let instr_rew _thus rew_side cut gls0 = + let last_id = try get_last (pf_env gls0) with _ -> error "No previous equality." in - let typ,lhs,rhs = decompose_eq last_id gls0 in + let typ,lhs,rhs = decompose_eq last_id gls0 in let items_tac gls = match cut.cut_by with None -> tclIDTAC gls | Some items -> prepare_goal items gls in - let method_tac gls = + let method_tac gls = match cut.cut_using with - None -> + None -> automation_tac gls - | Some tac -> + | Some tac -> (Tacinterp.eval_tactic tac) gls in let just_tac gls = justification (tclTHEN items_tac method_tac) gls in - let (c_id,_) = match cut.cut_stat.st_label with - Anonymous -> - pf_get_new_id (id_of_string "_eq") gls0,false + let (c_id,_) = match cut.cut_stat.st_label with + Anonymous -> + pf_get_new_id (id_of_string "_eq") gls0,false | Name id -> id,true in - let thus_tac new_eq gls= - if _thus then + let thus_tac new_eq gls= + if _thus then thus_tac (mkVar c_id) new_eq [] gls else tclIDTAC gls in - match rew_side with + match rew_side with Lhs -> let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in - tclTHENS (assert_postpone c_id new_eq) - [tclTHEN tcl_erase_info - (tclTHENS (transitivity lhs) + tclTHENS (assert_postpone c_id new_eq) + [tclTHEN tcl_erase_info + (tclTHENS (transitivity lhs) [just_tac;exact_check (mkVar last_id)]); thus_tac new_eq] gls0 | Rhs -> let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in - tclTHENS (assert_postpone c_id new_eq) - [tclTHEN tcl_erase_info - (tclTHENS (transitivity rhs) + tclTHENS (assert_postpone c_id new_eq) + [tclTHEN tcl_erase_info + (tclTHENS (transitivity rhs) [exact_check (mkVar last_id);just_tac]); thus_tac new_eq] gls0 - + (* tactics for claim/focus *) -let instr_claim _thus st gls0 = - let info = get_its_info gls0 in - let (id,_) = match st.st_label with - Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false +let instr_claim _thus st gls0 = + let info = get_its_info gls0 in + let (id,_) = match st.st_label with + Anonymous -> pf_get_new_id (id_of_string "_claim") gls0,false | Name id -> id,true in - let thus_tac gls= - if _thus then + let thus_tac gls= + if _thus then thus_tac (mkVar id) st.st_it [] gls else tclIDTAC gls in let ninfo1 = {pm_stack= (if _thus then Focus_claim else Claim)::info.pm_stack} in - tclTHENS (assert_postpone id st.st_it) + tclTHENS (assert_postpone id st.st_it) [tcl_change_info ninfo1; thus_tac] gls0 (* tactics for assume *) -let push_intro_tac coerce nam gls = +let push_intro_tac coerce nam gls = let (hid,_) = - match nam with - Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false + match nam with + Anonymous -> pf_get_new_id (id_of_string "_hyp") gls,false | Name id -> id,true in - tclTHENLIST + tclTHENLIST [intro_mustbe_force hid; coerce hid] - gls - -let assume_tac hyps gls = - List.fold_right - (fun (Hvar st | Hprop st) -> - tclTHEN - (push_intro_tac - (fun id -> + gls + +let assume_tac hyps gls = + List.fold_right + (fun (Hvar st | Hprop st) -> + tclTHEN + (push_intro_tac + (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) - hyps tclIDTAC gls - -let assume_hyps_or_theses hyps gls = - List.fold_right - (function - (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> - tclTHEN - (push_intro_tac - (fun id -> + hyps tclIDTAC gls + +let assume_hyps_or_theses hyps gls = + List.fold_right + (function + (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> + tclTHEN + (push_intro_tac + (fun id -> convert_hyp (id,None,c)) nam) - | Hprop {st_label=nam;st_it=Thesis (tk)} -> - tclTHEN - (push_intro_tac + | Hprop {st_label=nam;st_it=Thesis (tk)} -> + tclTHEN + (push_intro_tac (fun id -> tclIDTAC) nam)) - hyps tclIDTAC gls + hyps tclIDTAC gls -let assume_st hyps gls = - List.fold_right - (fun st -> - tclTHEN - (push_intro_tac +let assume_st hyps gls = + List.fold_right + (fun st -> + tclTHEN + (push_intro_tac (fun id -> convert_hyp (id,None,st.st_it)) st.st_label)) - hyps tclIDTAC gls - -let assume_st_letin hyps gls = - List.fold_right - (fun st -> - tclTHEN - (push_intro_tac - (fun id -> + hyps tclIDTAC gls + +let assume_st_letin hyps gls = + List.fold_right + (fun st -> + tclTHEN + (push_intro_tac + (fun id -> convert_hyp (id,Some (fst st.st_it),snd st.st_it)) st.st_label)) - hyps tclIDTAC gls + hyps tclIDTAC gls (* suffices *) -let rec metas_from n hyps = +let rec metas_from n hyps = match hyps with _ :: q -> n :: metas_from (succ n) q | [] -> [] - + let rec build_product args body = - match args with - (Hprop st| Hvar st )::rest -> + match args with + (Hprop st| Hvar st )::rest -> let pprod= lift 1 (build_product rest body) in let lbody = match st.st_label with Anonymous -> pprod | Name id -> subst_term (mkVar id) pprod in mkProd (st.st_label, st.st_it, lbody) - | [] -> body + | [] -> body let rec build_applist prod = function [] -> [],prod - | n::q -> + | n::q -> let (_,typ,_) = destProd prod in let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in (n,typ)::ctx,head -let instr_suffices _then cut gls0 = - let info = get_its_info gls0 in - let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in +let instr_suffices _then cut gls0 = + let info = get_its_info gls0 in + let c_id = pf_get_new_id (id_of_string "_cofact") gls0 in let ctx,hd = cut.cut_stat in let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in let metas = metas_from 1 ctx in let c_ctx,c_head = build_applist c_stat metas in - let c_term = applist (mkVar c_id,List.map mkMeta metas) in - let thus_tac gls= + let c_term = applist (mkVar c_id,List.map mkMeta metas) in + let thus_tac gls= thus_tac c_term c_head c_ctx gls in - tclTHENS (assert_postpone c_id c_stat) - [tclTHENLIST - [ assume_tac ctx; + tclTHENS (assert_postpone c_id c_stat) + [tclTHENLIST + [ assume_tac ctx; tcl_erase_info; just_tac _then cut info]; thus_tac] gls0 @@ -703,7 +703,7 @@ let instr_suffices _then cut gls0 = let conjunction_arity id gls = let typ = pf_get_hyp_typ gls id in let hd,params = decompose_app (special_whd gls typ) in - let env =pf_env gls in + let env =pf_env gls in match kind_of_term hd with Ind ind when is_good_inductive env ind -> let mib,oib= @@ -716,70 +716,70 @@ let conjunction_arity id gls = List.length rc | _ -> raise Not_found -let rec intron_then n ids ltac gls = - if n<=0 then +let rec intron_then n ids ltac gls = + if n<=0 then ltac ids gls - else - let id = pf_get_new_id (id_of_string "_tmp") gls in - tclTHEN - (intro_mustbe_force id) - (intron_then (pred n) (id::ids) ltac) gls + else + let id = pf_get_new_id (id_of_string "_tmp") gls in + tclTHEN + (intro_mustbe_force id) + (intron_then (pred n) (id::ids) ltac) gls let rec consider_match may_intro introduced available expected gls = - match available,expected with + match available,expected with [],[] -> tclIDTAC gls | _,[] -> error "Last statements do not match a complete hypothesis." (* should tell which ones *) - | [],hyps -> + | [],hyps -> if may_intro then begin let id = pf_get_new_id (id_of_string "_tmp") gls in - tclIFTHENELSE + tclIFTHENELSE (intro_mustbe_force id) - (consider_match true [] [id] hyps) - (fun _ -> + (consider_match true [] [id] hyps) + (fun _ -> error "Not enough sub-hypotheses to match statements.") - gls - end + gls + end else error "Not enough sub-hypotheses to match statements." (* should tell which ones *) | id::rest_ids,(Hvar st | Hprop st)::rest -> tclIFTHENELSE (convert_hyp (id,None,st.st_it)) begin - match st.st_label with - Anonymous -> + match st.st_label with + Anonymous -> consider_match may_intro ((id,false)::introduced) rest_ids rest - | Name hid -> - tclTHENLIST + | Name hid -> + tclTHENLIST [rename_hyp [id,hid]; consider_match may_intro ((hid,true)::introduced) rest_ids rest] end begin - (fun gls -> + (fun gls -> let nhyps = - try conjunction_arity id gls with - Not_found -> error "Matching hypothesis not found." in - tclTHENLIST + try conjunction_arity id gls with + Not_found -> error "Matching hypothesis not found." in + tclTHENLIST [general_case_analysis false (mkVar id,NoBindings); intron_then nhyps [] - (fun l -> consider_match may_intro introduced + (fun l -> consider_match may_intro introduced (List.rev_append l rest_ids) expected)] gls) end gls - + let consider_tac c hyps gls = match kind_of_term (strip_outer_cast c) with Var id -> - consider_match false [] [id] hyps gls - | _ -> + consider_match false [] [id] hyps gls + | _ -> let id = pf_get_new_id (id_of_string "_tmp") gls in - tclTHEN + tclTHEN (forward None (Some (dummy_loc, Genarg.IntroIdentifier id)) c) - (consider_match false [] [id] hyps) gls - + (consider_match false [] [id] hyps) gls + let given_tac hyps gls = consider_match true [] [] hyps gls @@ -789,22 +789,22 @@ let given_tac hyps gls = let rec take_tac wits gls = match wits with [] -> tclIDTAC gls - | wit::rest -> - let typ = pf_type_of gls wit in + | wit::rest -> + let typ = pf_type_of gls wit in tclTHEN (thus_tac wit typ []) (take_tac rest) gls (* tactics for define *) let rec build_function args body = - match args with - st::rest -> + match args with + st::rest -> let pfun= lift 1 (build_function rest body) in let id = match st.st_label with Anonymous -> assert false | Name id -> id in mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun) - | [] -> body + | [] -> body let define_tac id args body gls = let t = build_function args body in @@ -812,37 +812,37 @@ let define_tac id args body gls = (* tactics for reconsider *) -let cast_tac id_or_thesis typ gls = +let cast_tac id_or_thesis typ gls = match id_or_thesis with This id -> let (_,body,_) = pf_get_hyp gls id in convert_hyp (id,body,typ) gls - | Thesis (For _ ) -> + | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." - | Thesis Plain -> + | Thesis Plain -> convert_concl typ DEFAULTcast gls - + (* per cases *) let is_rec_pos (main_ind,wft) = match main_ind with None -> false - | Some index -> + | Some index -> match fst (Rtree.dest_node wft) with Mrec i when i = index -> true | _ -> false let rec constr_trees (main_ind,wft) ind = match Rtree.dest_node wft with - Norec,_ -> - let itree = - (snd (Global.lookup_inductive ind)).mind_recargs in + Norec,_ -> + let itree = + (snd (Global.lookup_inductive ind)).mind_recargs in constr_trees (None,itree) ind | _,constrs -> main_ind,constrs let ind_args rp ind = let main_ind,constrs = constr_trees rp ind in - let args ctree = + let args ctree = Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in Array.map args constrs @@ -853,7 +853,7 @@ let init_tree ids ind rp nexti = let map_tree_rp rp id_fun mapi = function Split_patt (ids,ind,branches) -> - let indargs = ind_args rp ind in + let indargs = ind_args rp ind in let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in Split_patt (id_fun ids,ind,Array.mapi do_i branches) | _ -> failwith "map_tree_rp: not a splitting node" @@ -865,19 +865,19 @@ let map_tree id_fun mapi = function | _ -> failwith "map_tree: not a splitting node" -let start_tree env ind rp = +let start_tree env ind rp = init_tree Idset.empty ind rp (fun _ _ -> None) -let build_per_info etype casee gls = +let build_per_info etype casee gls = let concl=pf_concl gls in let env=pf_env gls in let ctyp=pf_type_of gls casee in - let is_dep = dependent casee concl in + let is_dep = dependent casee concl in let hd,args = decompose_app (special_whd gls ctyp) in - let ind = + let ind = try - destInd hd - with _ -> + destInd hd + with _ -> error "Case analysis must be done on an inductive object." in let mind,oind = Global.lookup_inductive ind in let nparams,index = @@ -885,10 +885,10 @@ let build_per_info etype casee gls = ET_Induction -> mind.mind_nparams_rec,Some (snd ind) | _ -> mind.mind_nparams,None in let params,real_args = list_chop nparams args in - let abstract_obj c body = - let typ=pf_type_of gls c in + let abstract_obj c body = + let typ=pf_type_of gls c in lambda_create env (typ,subst_term c body) in - let pred= List.fold_right abstract_obj + let pred= List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in is_dep, {per_casee=casee; @@ -897,7 +897,7 @@ let build_per_info etype casee gls = per_pred=pred; per_args=real_args; per_params=params; - per_nparams=nparams; + per_nparams=nparams; per_wf=index,oind.mind_recargs} let per_tac etype casee gls= @@ -906,25 +906,25 @@ let per_tac etype casee gls= match casee with Real c -> let is_dep,per_info = build_per_info etype c gls in - let ek = + let ek = if is_dep then EK_dep (start_tree env per_info.per_ind per_info.per_wf) else EK_unknown in - tcl_change_info + tcl_change_info {pm_stack= Per(etype,per_info,ek,[])::info.pm_stack} gls | Virtual cut -> assert (cut.cut_stat.st_label=Anonymous); let id = pf_get_new_id (id_of_string "anonymous_matched") gls in let c = mkVar id in - let modified_cut = + let modified_cut = {cut with cut_stat={cut.cut_stat with st_label=Name id}} in - tclTHEN + tclTHEN (instr_cut (fun _ _ c -> c) false false modified_cut) (fun gls0 -> let is_dep,per_info = build_per_info etype c gls0 in assert (not is_dep); - tcl_change_info + tcl_change_info {pm_stack= Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0) gls @@ -941,7 +941,7 @@ let register_nodep_subcase id= function end | _ -> anomaly "wrong stack state" -let suppose_tac hyps gls0 = +let suppose_tac hyps gls0 = let info = get_its_info gls0 in let thesis = pf_concl gls0 in let id = pf_get_new_id (id_of_string "subcase_") gls0 in @@ -949,13 +949,13 @@ let suppose_tac hyps gls0 = let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let old_clauses,stack = register_nodep_subcase id info.pm_stack in let ninfo2 = {pm_stack=stack} in - tclTHENS (assert_postpone id clause) + tclTHENS (assert_postpone id clause) [tclTHENLIST [tcl_change_info ninfo1; assume_tac hyps; clear old_clauses]; tcl_change_info ninfo2] gls0 -(* suppose it is ... *) +(* suppose it is ... *) (* pattern matching compiling *) @@ -966,20 +966,20 @@ let rec skip_args rest ids n = Skip_patt (ids,skip_args rest ids (pred n)) let rec tree_of_pats ((id,_) as cpl) pats = - match pats with + match pats with [] -> End_patt cpl | args::stack -> match args with [] -> Close_patt (tree_of_pats cpl stack) | (patt,rp) :: rest_args -> match patt with - PatVar (_,v) -> + PatVar (_,v) -> Skip_patt (Idset.singleton id, tree_of_pats cpl (rest_args::stack)) | PatCstr (_,(ind,cnum),args,nam) -> let nexti i ati = - if i = pred cnum then - let nargs = + if i = pred cnum then + let nargs = list_map_i (fun j a -> (a,ati.(j))) 0 args in Some (Idset.singleton id, tree_of_pats cpl (nargs::rest_args::stack)) @@ -987,49 +987,49 @@ let rec tree_of_pats ((id,_) as cpl) pats = in init_tree Idset.empty ind rp nexti let rec add_branch ((id,_) as cpl) pats tree= - match pats with - [] -> + match pats with + [] -> begin match tree with - End_patt cpl0 -> End_patt cpl0 - (* this ensures precedence for overlapping patterns *) + End_patt cpl0 -> End_patt cpl0 + (* this ensures precedence for overlapping patterns *) | _ -> anomaly "tree is expected to end here" end | args::stack -> - match args with + match args with [] -> begin match tree with - Close_patt t -> + Close_patt t -> Close_patt (add_branch cpl stack t) - | _ -> anomaly "we should pop here" + | _ -> anomaly "we should pop here" end | (patt,rp) :: rest_args -> match patt with PatVar (_,v) -> begin - match tree with - Skip_patt (ids,t) -> + match tree with + Skip_patt (ids,t) -> Skip_patt (Idset.add id ids, add_branch cpl (rest_args::stack) t) | Split_patt (_,_,_) -> map_tree (Idset.add id) - (fun i bri -> - append_branch cpl 1 (rest_args::stack) bri) + (fun i bri -> + append_branch cpl 1 (rest_args::stack) bri) tree - | _ -> anomaly "No pop/stop expected here" + | _ -> anomaly "No pop/stop expected here" end | PatCstr (_,(ind,cnum),args,nam) -> match tree with Skip_patt (ids,t) -> let nexti i ati = - if i = pred cnum then - let nargs = + if i = pred cnum then + let nargs = list_map_i (fun j a -> (a,ati.(j))) 0 args in Some (Idset.add id ids, add_branch cpl (nargs::rest_args::stack) (skip_args t ids (Array.length ati))) - else + else Some (ids, skip_args t ids (Array.length ati)) in init_tree ids ind rp nexti @@ -1038,30 +1038,30 @@ let rec add_branch ((id,_) as cpl) pats tree= (* this can happen with coercions *) "Case pattern belongs to wrong inductive type."; let mapi i ati bri = - if i = pred cnum then - let nargs = + if i = pred cnum then + let nargs = list_map_i (fun j a -> (a,ati.(j))) 0 args in - append_branch cpl 0 + append_branch cpl 0 (nargs::rest_args::stack) bri else bri in map_tree_rp rp (fun ids -> ids) mapi tree | _ -> anomaly "No pop/stop expected here" and append_branch ((id,_) as cpl) depth pats = function - Some (ids,tree) -> + Some (ids,tree) -> Some (Idset.add id ids,append_tree cpl depth pats tree) | None -> Some (Idset.singleton id,tree_of_pats cpl pats) and append_tree ((id,_) as cpl) depth pats tree = if depth<=0 then add_branch cpl pats tree else match tree with - Close_patt t -> + Close_patt t -> Close_patt (append_tree cpl (pred depth) pats t) - | Skip_patt (ids,t) -> + | Skip_patt (ids,t) -> Skip_patt (Idset.add id ids,append_tree cpl depth pats t) | End_patt _ -> anomaly "Premature end of branch" - | Split_patt (_,_,_) -> - map_tree (Idset.add id) - (fun i bri -> append_branch cpl (succ depth) pats bri) tree + | Split_patt (_,_,_) -> + map_tree (Idset.add id) + (fun i bri -> append_branch cpl (succ depth) pats bri) tree (* suppose it is *) @@ -1075,22 +1075,22 @@ let thesis_for obj typ per_info env= let cind,all_args=decompose_app typ in let ind = destInd cind in let _ = if ind <> per_info.per_ind then - errorlabstrm "thesis_for" - ((Printer.pr_constr_env env obj) ++ spc () ++ - str"cannot give an induction hypothesis (wrong inductive type).") in + errorlabstrm "thesis_for" + ((Printer.pr_constr_env env obj) ++ spc () ++ + str"cannot give an induction hypothesis (wrong inductive type).") in let params,args = list_chop per_info.per_nparams all_args in let _ = if not (List.for_all2 eq_constr params per_info.per_params) then - errorlabstrm "thesis_for" - ((Printer.pr_constr_env env obj) ++ spc () ++ + errorlabstrm "thesis_for" + ((Printer.pr_constr_env env obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in compose_prod rc (whd_beta Evd.empty hd2) let rec build_product_dep pat_info per_info args body gls = - match args with - (Hprop {st_label=nam;st_it=This c} - | Hvar {st_label=nam;st_it=c})::rest -> - let pprod= + match args with + (Hprop {st_label=nam;st_it=This c} + | Hvar {st_label=nam;st_it=c})::rest -> + let pprod= lift 1 (build_product_dep pat_info per_info rest body gls) in let lbody = match nam with @@ -1098,7 +1098,7 @@ let rec build_product_dep pat_info per_info args body gls = | Name id -> subst_var id pprod in mkProd (nam,c,lbody) | Hprop ({st_it=Thesis tk} as st)::rest -> - let pprod= + let pprod= lift 1 (build_product_dep pat_info per_info rest body gls) in let lbody = match st.st_label with @@ -1108,14 +1108,14 @@ let rec build_product_dep pat_info per_info args body gls = match tk with For id -> let obj = mkVar id in - let typ = - try st_assoc (Name id) pat_info.pat_vars - with Not_found -> + let typ = + try st_assoc (Name id) pat_info.pat_vars + with Not_found -> snd (st_assoc (Name id) pat_info.pat_aliases) in thesis_for obj typ per_info (pf_env gls) | Plain -> pf_concl gls in mkProd (st.st_label,ptyp,lbody) - | [] -> body + | [] -> body let build_dep_clause params pat_info per_info hyps gls = let concl= @@ -1129,35 +1129,35 @@ let build_dep_clause params pat_info per_info hyps gls = let let_one_in st body = match st.st_label with Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body) - | Name id -> + | Name id -> mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in - let aliased_clause = + let aliased_clause = List.fold_right let_one_in pat_info.pat_aliases open_clause in List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause let rec register_dep_subcase id env per_info pat = function EK_nodep -> error "Only \"suppose it is\" can be used here." - | EK_unknown -> + | EK_unknown -> register_dep_subcase id env per_info pat (EK_dep (start_tree env per_info.per_ind per_info.per_wf)) | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree) - + let case_tac params pat_info hyps gls0 = let info = get_its_info gls0 in let id = pf_get_new_id (id_of_string "subcase_") gls0 in let et,per_info,ek,old_clauses,rest = match info.pm_stack with - Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) + Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) | _ -> anomaly "wrong place for cases" in let clause = build_dep_clause params pat_info per_info hyps gls0 in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in - let nek = - register_dep_subcase (id,List.length hyps) (pf_env gls0) per_info - pat_info.pat_pat ek in + let nek = + register_dep_subcase (id,List.length hyps) (pf_env gls0) per_info + pat_info.pat_pat ek in let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in - tclTHENS (assert_postpone id clause) - [tclTHENLIST - [tcl_change_info ninfo1; + tclTHENS (assert_postpone id clause) + [tclTHENLIST + [tcl_change_info ninfo1; assume_st (params@pat_info.pat_vars); assume_st_letin pat_info.pat_aliases; assume_hyps_or_theses hyps; @@ -1172,23 +1172,23 @@ type instance_stack = let initial_instance_stack ids = List.map (fun id -> id,[None,[]]) ids -let push_one_arg arg = function +let push_one_arg arg = function [] -> anomaly "impossible" - | (head,args) :: ctx -> + | (head,args) :: ctx -> ((head,(arg::args)) :: ctx) let push_arg arg stacks = List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks - -let push_one_head c ids (id,stack) = + +let push_one_head c ids (id,stack) = let head = if Idset.mem id ids then Some c else None in id,(head,[]) :: stack let push_head c ids stacks = List.map (push_one_head c ids) stacks -let pop_one (id,stack) = +let pop_one (id,stack) = let nstack= match stack with [] -> anomaly "impossible" @@ -1209,30 +1209,30 @@ let hrec_for fix_id per_info gls obj_id = let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in let ind = destInd cind in assert (ind=per_info.per_ind); - let params,args= list_chop per_info.per_nparams all_args in + let params,args= list_chop per_info.per_nparams all_args in assert begin - try List.for_all2 eq_constr params per_info.per_params with + try List.for_all2 eq_constr params per_info.per_params with Invalid_argument _ -> false end; - let hd2 = applist (mkVar fix_id,args@[obj]) in + let hd2 = applist (mkVar fix_id,args@[obj]) in compose_lam rc (whd_beta gls.sigma hd2) let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = match tree, objs with - Close_patt t,_ -> - let args0 = pop_stacks args in + Close_patt t,_ -> + let args0 = pop_stacks args in execute_cases fix_name per_info tacnext args0 objs nhrec t gls - | Skip_patt (_,t),skipped::next_objs -> + | Skip_patt (_,t),skipped::next_objs -> let args0 = push_arg skipped args in execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls - | End_patt (id,nhyps),[] -> + | End_patt (id,nhyps),[] -> begin match List.assoc id args with - [None,br_args] -> - let metas = + [None,br_args] -> + let metas = list_tabulate (fun n -> mkMeta (succ n)) nhyps in tclTHEN (tclDO nhrec introf) - (tacnext + (tacnext (applist (mkVar id,List.rev_append br_args metas))) gls | _ -> anomaly "wrong stack size" end @@ -1245,111 +1245,111 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let hd,all_args = decompose_app (special_whd gls ctyp) in let _ = assert (destInd hd = ind) in (* just in case *) let params,real_args = list_chop nparams all_args in - let abstract_obj c body = - let typ=pf_type_of gls c in + let abstract_obj c body = + let typ=pf_type_of gls c in lambda_create env (typ,subst_term c body) in - let elim_pred = List.fold_right abstract_obj + let elim_pred = List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in let case_info = Inductiveops.make_case_info env ind RegularStyle in let gen_arities = Inductive.arities_of_constructors ind spec in - let f_ids typ = - let sign = + let f_ids typ = + let sign = (prod_assum (Term.prod_applist typ params)) in find_intro_names sign gls in let constr_args_ids = Array.map f_ids gen_arities in - let case_term = + let case_term = mkCase(case_info,elim_pred,casee, Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in let branch_tac i (recargs,bro) gls0 = let args_ids = constr_args_ids.(i) in let rec aux n = function - [] -> - assert (n=Array.length recargs); + [] -> + assert (n=Array.length recargs); next_objs,[],nhrec - | id :: q -> + | id :: q -> let objs,recs,nrec = aux (succ n) q in - if recargs.(n) - then (mkVar id::objs),(id::recs),succ nrec + if recargs.(n) + then (mkVar id::objs),(id::recs),succ nrec else (mkVar id::objs),recs,nrec in let objs,recs,nhrec = aux 0 args_ids in tclTHENLIST [tclMAP intro_mustbe_force args_ids; begin - fun gls1 -> - let hrecs = - List.map - (fun id -> - hrec_for (out_name fix_name) per_info gls1 id) + fun gls1 -> + let hrecs = + List.map + (fun id -> + hrec_for (out_name fix_name) per_info gls1 id) recs in generalize hrecs gls1 end; match bro with - None -> + None -> msg_warning (str "missing case"); tacnext (mkMeta 1) | Some (sub_ids,tree) -> let br_args = - List.filter - (fun (id,_) -> Idset.mem id sub_ids) args in - let construct = + List.filter + (fun (id,_) -> Idset.mem id sub_ids) args in + let construct = applist (mkConstruct(ind,succ i),params) in - let p_args = + let p_args = push_head construct ids br_args in - execute_cases fix_name per_info tacnext + execute_cases fix_name per_info tacnext p_args objs nhrec tree] gls0 in - tclTHENSV + tclTHENSV (refine case_term) (Array.mapi branch_tac br) gls - | Split_patt (_, _, _) , [] -> + | Split_patt (_, _, _) , [] -> anomaly "execute_cases : Nothing to split" - | Skip_patt _ , [] -> + | Skip_patt _ , [] -> anomaly "execute_cases : Nothing to skip" - | End_patt (_,_) , _ :: _ -> + | End_patt (_,_) , _ :: _ -> anomaly "execute_cases : End of branch with garbage left" (* end focus/claim *) - + let end_tac et2 gls = let info = get_its_info gls in - let et1,pi,ek,clauses = + let et1,pi,ek,clauses = match info.pm_stack with - Suppose_case::_ -> + Suppose_case::_ -> anomaly "This case should already be trapped" - | Claim::_ -> + | Claim::_ -> error "\"end claim\" expected." | Focus_claim::_ -> error "\"end focus\" expected." - | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) - | [] -> + | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) + | [] -> anomaly "This case should already be trapped" in - let et = + let et = if et1 <> et2 then - match et1 with - ET_Case_analysis -> + match et1 with + ET_Case_analysis -> error "\"end cases\" expected." | ET_Induction -> error "\"end induction\" expected." else et1 in - tclTHEN + tclTHEN tcl_erase_info begin match et,ek with - _,EK_unknown -> - tclSOLVE [simplest_elim pi.per_casee] + _,EK_unknown -> + tclSOLVE [simplest_elim pi.per_casee] | ET_Case_analysis,EK_nodep -> - tclTHEN + tclTHEN (general_case_analysis false (pi.per_casee,NoBindings)) (default_justification (List.map mkVar clauses)) | ET_Induction,EK_nodep -> tclTHENLIST - [generalize (pi.per_args@[pi.per_casee]); + [generalize (pi.per_args@[pi.per_casee]); simple_induct (AnonHyp (succ (List.length pi.per_args))); default_justification (List.map mkVar clauses)] | ET_Case_analysis,EK_dep tree -> - execute_cases Anonymous pi - (fun c -> tclTHENLIST + execute_cases Anonymous pi + (fun c -> tclTHENLIST [refine c; clear clauses; justification assumption]) @@ -1358,25 +1358,25 @@ let end_tac et2 gls = let nargs = (List.length pi.per_args) in tclTHEN (generalize (pi.per_args@[pi.per_casee])) begin - fun gls0 -> - let fix_id = + fun gls0 -> + let fix_id = pf_get_new_id (id_of_string "_fix") gls0 in - let c_id = + let c_id = pf_get_new_id (id_of_string "_main_arg") gls0 in tclTHENLIST [fix (Some fix_id) (succ nargs); tclDO nargs introf; intro_mustbe_force c_id; - execute_cases (Name fix_id) pi + execute_cases (Name fix_id) pi (fun c -> - tclTHENLIST + tclTHENLIST [clear [fix_id]; refine c; clear clauses; justification assumption]) - (initial_instance_stack clauses) + (initial_instance_stack clauses) [mkVar c_id] 0 tree] gls0 - end + end end gls (* escape *) @@ -1385,21 +1385,21 @@ let escape_tac gls = tcl_erase_info gls (* General instruction engine *) -let rec do_proof_instr_gen _thus _then instr = - match instr with - Pthus i -> +let rec do_proof_instr_gen _thus _then instr = + match instr with + Pthus i -> assert (not _thus); do_proof_instr_gen true _then i - | Pthen i -> + | Pthen i -> assert (not _then); do_proof_instr_gen _thus true i - | Phence i -> + | Phence i -> assert (not (_then || _thus)); do_proof_instr_gen true true i | Pcut c -> instr_cut mk_stat_or_thesis _thus _then c | Psuffices c -> - instr_suffices _then c + instr_suffices _then c | Prew (s,c) -> assert (not _then); instr_rew _thus s c @@ -1407,75 +1407,75 @@ let rec do_proof_instr_gen _thus _then instr = | Pgiven hyps -> given_tac hyps | Passume hyps -> assume_tac hyps | Plet hyps -> assume_tac hyps - | Pclaim st -> instr_claim false st + | Pclaim st -> instr_claim false st | Pfocus st -> instr_claim true st | Ptake witl -> take_tac witl | Pdefine (id,args,body) -> define_tac id args body - | Pcast (id,typ) -> cast_tac id typ - | Pper (et,cs) -> per_tac et cs + | Pcast (id,typ) -> cast_tac id typ + | Pper (et,cs) -> per_tac et cs | Psuppose hyps -> suppose_tac hyps | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps | Pend (B_elim et) -> end_tac et | Pend _ -> anomaly "Not applicable" | Pescape -> escape_tac - + let eval_instr {instr=instr} = - do_proof_instr_gen false false instr + do_proof_instr_gen false false instr let rec preprocess pts instr = match instr with Phence i |Pthus i | Pthen i -> preprocess pts i - | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ - | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ + | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ + | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Pper _ | Prew _ -> check_not_per pts; true,pts - | Pescape -> + | Pescape -> check_not_per pts; true,pts - | Pcase _ | Psuppose _ | Pend (B_elim _) -> + | Pcase _ | Psuppose _ | Pend (B_elim _) -> true,close_previous_case pts - | Pend bt -> - false,close_block bt pts - -let rec postprocess pts instr = + | Pend bt -> + false,close_block bt pts + +let rec postprocess pts instr = match instr with Phence i | Pthus i | Pthen i -> postprocess pts i | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> pts - | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ + | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ | Pescape -> nth_unproven 1 pts | Pend (B_elim ET_Induction) -> begin let pf = proof_of_pftreestate pts in let (pfterm,_) = extract_open_pftreestate pts in let env = Evd.evar_env (goal_of_proof pf) in - try + try Inductiveops.control_only_guard env pfterm; goto_current_focus_or_top (mark_as_done pts) - with + with Type_errors.TypeError(env, Type_errors.IllFormedRecBody(_,_,_,_,_)) -> anomaly "\"end induction\" generated an ill-formed fixpoint" end - | Pend _ -> + | Pend _ -> goto_current_focus_or_top (mark_as_done pts) let do_instr raw_instr pts = let has_tactic,pts1 = preprocess pts raw_instr.instr in - let pts2 = + let pts2 = if has_tactic then let gl = nth_goal_of_pftreestate 1 pts1 in let env= pf_env gl in let sigma= project gl in - let ist = {ltacvars = ([],[]); ltacrecvars = []; + let ist = {ltacvars = ([],[]); ltacrecvars = []; gsigma = sigma; genv = env} in let glob_instr = intern_proof_instr ist raw_instr in - let instr = + let instr = interp_proof_instr (get_its_info gl) sigma env glob_instr in let lock_focus = is_focussing_instr instr.instr in let marker= Proof_instr (lock_focus,instr) in - solve_nth_pftreestate 1 + solve_nth_pftreestate 1 (abstract_operation marker (tclTHEN (eval_instr instr) clean_tmp)) pts1 else pts1 in postprocess pts2 raw_instr.instr @@ -1486,8 +1486,8 @@ let proof_instr raw_instr = (* (* STUFF FOR ITERATED RELATIONS *) -let decompose_bin_app t= - let hd,args = destApp +let decompose_bin_app t= + let hd,args = destApp let identify_transitivity_lemma c = let varx,tx,c1 = destProd c in @@ -1498,4 +1498,4 @@ let identify_transitivity_lemma c = let p2=pop lp2 in let p3=pop lp3 in *) - + diff --git a/tactics/decl_proof_instr.mli b/tactics/decl_proof_instr.mli index fa1a703b95..a05c36e93a 100644 --- a/tactics/decl_proof_instr.mli +++ b/tactics/decl_proof_instr.mli @@ -23,7 +23,7 @@ val automation_tac : tactic val daimon_subtree: pftreestate -> pftreestate -val concl_refiner: +val concl_refiner: Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr val do_instr: Decl_expr.raw_proof_instr -> pftreestate -> pftreestate @@ -42,11 +42,11 @@ val execute_cases : (Names.Idset.elt * (Term.constr option * Term.constr list) list) list -> Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic -val tree_of_pats : +val tree_of_pats : identifier * int -> (Rawterm.cases_pattern*recpath) list list -> split_tree -val add_branch : +val add_branch : identifier * int -> (Rawterm.cases_pattern*recpath) list list -> split_tree -> split_tree @@ -65,7 +65,7 @@ val build_dep_clause : Term.types Decl_expr.statement list -> (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis) Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types -val register_dep_subcase : +val register_dep_subcase : Names.identifier * int -> Environ.env -> Decl_mode.per_info -> @@ -77,27 +77,27 @@ val thesis_for : Term.constr -> val close_previous_case : pftreestate -> pftreestate val pop_stacks : - (Names.identifier * - (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Names.identifier * + (Term.constr option * Term.constr list) list) list -> + (Names.identifier * (Term.constr option * Term.constr list) list) list val push_head : Term.constr -> Names.Idset.t -> - (Names.identifier * + (Names.identifier * (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Names.identifier * (Term.constr option * Term.constr list) list) list val push_arg : Term.constr -> - (Names.identifier * + (Names.identifier * (Term.constr option * Term.constr list) list) list -> - (Names.identifier * + (Names.identifier * (Term.constr option * Term.constr list) list) list -val hrec_for: +val hrec_for: Names.identifier -> - Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> + Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> Names.identifier -> Term.constr val consider_match : diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml index c28a87f0e7..e3dddacb0f 100644 --- a/tactics/dhyp.ml +++ b/tactics/dhyp.ml @@ -9,7 +9,7 @@ (* $Id$ *) (* Chet's comments about this tactic : - + Programmable destruction of hypotheses and conclusions. The idea here is that we are going to store patterns. These @@ -136,7 +136,7 @@ open Libnames (* two patterns - one for the type, and one for the type of the type *) type destructor_pattern = { - d_typ: constr_pattern; + d_typ: constr_pattern; d_sort: constr_pattern } let subst_destructor_pattern subst { d_typ = t; d_sort = s } = @@ -151,7 +151,7 @@ type located_destructor_pattern = destructor_pattern) location let subst_located_destructor_pattern subst = function - | HypLocation (b,d,d') -> + | HypLocation (b,d,d') -> HypLocation (b,subst_destructor_pattern subst d, subst_destructor_pattern subst d') | ConclLocation d -> @@ -179,29 +179,29 @@ let add (na,dd) = let pat = match dd.d_pat with | HypLocation(_,p,_) -> p.d_typ | ConclLocation p -> p.d_typ - in + in if Nbtermdn.in_dn tactab na then begin - msgnl (str "Warning [Overriding Destructor Entry " ++ + msgnl (str "Warning [Overriding Destructor Entry " ++ str (string_of_id na) ++ str"]"); Nbtermdn.remap tactab na (pat,dd) - end else + end else Nbtermdn.add tactab (na,(pat,dd)) -let _ = +let _ = Summary.declare_summary "destruct-hyp-concl" { Summary.freeze_function = freeze; Summary.unfreeze_function = unfreeze; Summary.init_function = init } -let forward_subst_tactic = +let forward_subst_tactic = ref (fun _ -> failwith "subst_tactic is not installed for DHyp") let cache_dd (_,(_,na,dd)) = - try + try add (na,dd) - with _ -> + with _ -> anomalylabstrm "Dhyp.add" - (str"The code which adds destructor hints broke;" ++ spc () ++ + (str"The code which adds destructor hints broke;" ++ spc () ++ str"this is not supposed to happen") let classify_dd (local,_,_ as o) = @@ -212,7 +212,7 @@ let export_dd (local,_,_ as x) = if local then None else Some x let subst_dd (_,subst,(local,na,dd)) = (local,na, { d_pat = subst_located_destructor_pattern subst dd.d_pat; - d_pri = dd.d_pri; + d_pri = dd.d_pri; d_code = !forward_subst_tactic subst dd.d_code }) let (inDD,_) = @@ -225,7 +225,7 @@ let (inDD,_) = let catch_all_sort_pattern = PMeta(Some (id_of_string "SORT")) let catch_all_type_pattern = PMeta(Some (id_of_string "TYPE")) - + let add_destructor_hint local na loc (_,pat) pri code = let code = begin match loc, code with @@ -273,7 +273,7 @@ let match_dpat dp cls gls = then error "No match." | _ -> error "ApplyDestructor" -let forward_interp_tactic = +let forward_interp_tactic = ref (fun _ -> failwith "interp_tactic is not installed for DHyp") let set_extern_interp f = forward_interp_tactic := f @@ -284,7 +284,7 @@ let applyDestructor cls discard dd gls = let tacl = List.map (fun cl -> match cl, dd.d_code with - | Some id, (Some x, tac) -> + | Some id, (Some x, tac) -> let arg = ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in TacLetIn (false, [(dummy_loc, x), arg], tac) @@ -337,15 +337,15 @@ let rec search n = tclFIRST [intros; assumption; - (tclTHEN - (Tacticals.tryAllHypsAndConcl - (function + (tclTHEN + (Tacticals.tryAllHypsAndConcl + (function | Some id -> (dHyp id) | None -> dConcl )) (search (n-1)))] - + let auto_tdb n = tclTRY (tclCOMPLETE (search n)) - + let search_depth_tdb = ref(5) let depth_tdb = function diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli index 3277fd2e67..41fd497f7a 100644 --- a/tactics/dhyp.mli +++ b/tactics/dhyp.mli @@ -28,5 +28,5 @@ val h_auto_tdb : int option -> tactic val add_destructor_hint : Vernacexpr.locality_flag -> identifier -> (bool,unit) Tacexpr.location -> - Rawterm.patvar list * Pattern.constr_pattern -> int -> + Rawterm.patvar list * Pattern.constr_pattern -> int -> glob_tactic_expr -> unit diff --git a/tactics/dn.ml b/tactics/dn.ml index 0809c80ebb..359e3fe7fb 100644 --- a/tactics/dn.ml +++ b/tactics/dn.ml @@ -16,7 +16,7 @@ then the associated tactic is applied. Discrimination nets are used (only) to implement the tactics Auto, DHyp and Point. - A discrimination net is a tries structure, that is, a tree structure + A discrimination net is a tries structure, that is, a tree structure specially conceived for searching patterns, like for example strings --see the file Tlm.ml in the directory lib/util--. Here the tries structure are used for looking for term patterns. @@ -34,67 +34,67 @@ type ('lbl,'pat) decompose_fun = 'pat -> ('lbl * 'pat list) option type 'res lookup_res = Label of 'res | Nothing | Everything - + type ('lbl,'tree) lookup_fun = 'tree -> ('lbl * 'tree list) lookup_res type ('lbl,'pat,'inf) t = (('lbl * int) option,'pat * 'inf) Tlm.t let create () = Tlm.empty -(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in +(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in prefix ordering, [dna] is the function returning the main node of a pattern *) let path_of dna = let rec path_of_deferred = function | [] -> [] | h::tl -> pathrec tl h - + and pathrec deferred t = match dna t with - | None -> + | None -> None :: (path_of_deferred deferred) | Some (lbl,[]) -> (Some (lbl,0))::(path_of_deferred deferred) | Some (lbl,(h::def_subl as v)) -> (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h) - in + in pathrec [] - + let tm_of tm lbl = try [Tlm.map tm lbl, true] with Not_found -> [] - + let rec skip_arg n tm = if n = 0 then [tm,true] else - List.flatten - (List.map + List.flatten + (List.map (fun a -> match a with | None -> skip_arg (pred n) (Tlm.map tm a) - | Some (lbl,m) -> - skip_arg (pred n + m) (Tlm.map tm a)) + | Some (lbl,m) -> + skip_arg (pred n + m) (Tlm.map tm a)) (Tlm.dom tm)) - + let lookup tm dna t = let rec lookrec t tm = match dna t with | Nothing -> tm_of tm None | Label(lbl,v) -> tm_of tm None@ - (List.fold_left - (fun l c -> + (List.fold_left + (fun l c -> List.flatten(List.map (fun (tm, b) -> if b then lookrec c tm else [tm,b]) l)) (tm_of tm (Some(lbl,List.length v))) v) | Everything -> skip_arg 1 tm - in + in List.flatten (List.map (fun (tm,b) -> Tlm.xtract tm) (lookrec t tm)) let add tm dna (pat,inf) = let p = path_of dna pat in Tlm.add tm (p,(pat,inf)) - + let rmv tm dna (pat,inf) = let p = path_of dna pat in Tlm.rmv tm (p,(pat,inf)) - + let app f tm = Tlm.app (fun (_,p) -> f p) tm diff --git a/tactics/dn.mli b/tactics/dn.mli index e37ed9af3f..b4b2e6c891 100644 --- a/tactics/dn.mli +++ b/tactics/dn.mli @@ -25,11 +25,11 @@ val create : unit -> ('lbl,'pat,'inf) t val add : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf -> ('lbl,'pat,'inf) t -val rmv : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf +val rmv : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf -> ('lbl,'pat,'inf) t type 'res lookup_res = Label of 'res | Nothing | Everything - + type ('lbl,'tree) lookup_fun = 'tree -> ('lbl * 'tree list) lookup_res (* [lookup t f tree] looks for trees (and their associated diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 3a16cd7935..25efd5a050 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -33,14 +33,14 @@ open Hiddentac let eauto_unif_flags = { auto_unif_flags with Unification.modulo_delta = full_transparent_state } -let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in - if occur_existential t1 or occur_existential t2 then +let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in + if occur_existential t1 or occur_existential t2 then tclTHEN (Clenvtac.unify ~flags t1) (exact_check c) gl else exact_check c gl let assumption id = e_give_exact (mkVar id) - -let e_assumption gl = + +let e_assumption gl = tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl TACTIC EXTEND eassumption @@ -51,8 +51,8 @@ TACTIC EXTEND eexact | [ "eexact" constr(c) ] -> [ e_give_exact c ] END -let registered_e_assumption gl = - tclFIRST (List.map (fun id gl -> e_give_exact (mkVar id) gl) +let registered_e_assumption gl = + tclFIRST (List.map (fun id gl -> e_give_exact (mkVar id) gl) (pf_ids_of_hyps gl)) gl (************************************************************************) @@ -93,116 +93,116 @@ open Unification let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l) -let unify_e_resolve flags (c,clenv) gls = +let unify_e_resolve flags (c,clenv) gls = let clenv' = connect_clenv gls clenv in let _ = clenv_unique_resolver false ~flags clenv' gls in h_simplest_eapply c gls let rec e_trivial_fail_db db_list local_db goal = - let tacl = + let tacl = registered_e_assumption :: - (tclTHEN Tactics.intro + (tclTHEN Tactics.intro (function g'-> let d = pf_last_hyp g' in let hintl = make_resolve_hyp (pf_env g') (project g') d in (e_trivial_fail_db db_list (Hint_db.add_list hintl local_db) g'))) :: (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) - in - tclFIRST (List.map tclCOMPLETE tacl) goal + in + tclFIRST (List.map tclCOMPLETE tacl) goal -and e_my_find_search db_list local_db hdc concl = +and e_my_find_search db_list local_db hdc concl = let hdc = head_of_constr_reference hdc in let hintl = - if occur_existential concl then - list_map_append (fun db -> + if occur_existential concl then + list_map_append (fun db -> let flags = {auto_unif_flags with modulo_delta = Hint_db.transparent_state db} in List.map (fun x -> flags, x) (Hint_db.map_all hdc db)) (local_db::db_list) - else - list_map_append (fun db -> + else + list_map_append (fun db -> let flags = {auto_unif_flags with modulo_delta = Hint_db.transparent_state db} in List.map (fun x -> flags, x) (Hint_db.map_auto (hdc,concl) db)) (local_db::db_list) - in - let tac_of_hint = - fun (st, {pri=b; pat = p; code=t}) -> - (b, + in + let tac_of_hint = + fun (st, {pri=b; pat = p; code=t}) -> + (b, let tac = match t with | Res_pf (term,cl) -> unify_resolve st (term,cl) | ERes_pf (term,cl) -> unify_e_resolve st (term,cl) | Give_exact (c) -> e_give_exact c | Res_pf_THEN_trivial_fail (term,cl) -> - tclTHEN (unify_e_resolve st (term,cl)) + tclTHEN (unify_e_resolve st (term,cl)) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> unfold_in_concl [all_occurrences,c] | Extern tacast -> conclPattern concl p tacast - in + in (tac,pr_autotactic t)) (*i - fun gls -> pPNL (pr_autotactic t); Format.print_flush (); + fun gls -> pPNL (pr_autotactic t); Format.print_flush (); try tac gls - with e when Logic.catchable_exception(e) -> - (Format.print_string "Fail\n"; - Format.print_flush (); + with e when Logic.catchable_exception(e) -> + (Format.print_string "Fail\n"; + Format.print_flush (); raise e) i*) - in + in List.map tac_of_hint hintl - -and e_trivial_resolve db_list local_db gl = - try - priority - (e_my_find_search db_list local_db + +and e_trivial_resolve db_list local_db gl = + try + priority + (e_my_find_search db_list local_db (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] let e_possible_resolve db_list local_db gl = - try List.map snd - (e_my_find_search db_list local_db + try List.map snd + (e_my_find_search db_list local_db (fst (head_constr_bound gl)) gl) with Bound | Not_found -> [] -let find_first_goal gls = +let find_first_goal gls = try first_goal gls with UserError _ -> assert false (*s The following module [SearchProblem] is used to instantiate the generic exploration functor [Explore.Make]. *) -type search_state = { +type search_state = { depth : int; (*r depth of search before failing *) tacres : goal list sigma * validation; last_tactic : std_ppcmds; dblist : Auto.hint_db list; localdb : Auto.hint_db list } - + module SearchProblem = struct - + type state = search_state let success s = (sig_it (fst s.tacres)) = [] let pr_ev evs ev = Printer.pr_constr_env (Evd.evar_env ev) (Evarutil.nf_evar evs ev.Evd.evar_concl) - + let pr_goals gls = let evars = Evarutil.nf_evars (Refiner.project gls) in prlist (pr_ev evars) (sig_it gls) - + let filter_tactics (glls,v) l = (* let _ = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* let evars = Evarutil.nf_evars (Refiner.project glls) in *) (* msg (str"Goal:" ++ pr_ev evars (List.hd (sig_it glls)) ++ str"\n"); *) let rec aux = function | [] -> [] - | (tac,pptac) :: tacl -> - try - let (lgls,ptl) = apply_tac_list tac glls in + | (tac,pptac) :: tacl -> + try + let (lgls,ptl) = apply_tac_list tac glls in let v' p = v (ptl p) in (* let gl = Proof_trees.db_pr_goal (List.hd (sig_it glls)) in *) (* msg (hov 1 (pptac ++ str" gives: \n" ++ pr_goals lgls ++ str"\n")); *) ((lgls,v'),pptac) :: aux tacl with e -> Refiner.catch_failerror e; aux tacl in aux l - + (* Ordering of states is lexicographic on depth (greatest first) then number of remaining goals. *) let compare s s' = @@ -210,18 +210,18 @@ module SearchProblem = struct let nbgoals s = List.length (sig_it (fst s.tacres)) in if d <> 0 then d else nbgoals s - nbgoals s' - let branching s = - if s.depth = 0 then + let branching s = + if s.depth = 0 then [] - else + else let lg = fst s.tacres in let nbgl = List.length (sig_it lg) in assert (nbgl > 0); let g = find_first_goal lg in - let assumption_tacs = - let l = + let assumption_tacs = + let l = filter_tactics s.tacres - (List.map + (List.map (fun id -> (e_give_exact (mkVar id), (str "exact" ++ spc () ++ pr_id id))) (pf_ids_of_hyps g)) @@ -230,40 +230,40 @@ module SearchProblem = struct last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb }) l in - let intro_tac = - List.map - (fun ((lgls,_) as res,pp) -> - let g' = first_goal lgls in - let hintl = + let intro_tac = + List.map + (fun ((lgls,_) as res,pp) -> + let g' = first_goal lgls in + let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') in let ldb = Hint_db.add_list hintl (List.hd s.localdb) in - { depth = s.depth; tacres = res; + { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = ldb :: List.tl s.localdb }) (filter_tactics s.tacres [Tactics.intro,(str "intro")]) in - let rec_tacs = - let l = + let rec_tacs = + let l = filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) in - List.map - (fun ((lgls,_) as res, pp) -> + List.map + (fun ((lgls,_) as res, pp) -> let nbgl' = List.length (sig_it lgls) in if nbgl' < nbgl then { depth = s.depth; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb } - else - { depth = pred s.depth; tacres = res; + else + { depth = pred s.depth; tacres = res; dblist = s.dblist; last_tactic = pp; - localdb = + localdb = list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb }) l in List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) - let pp s = - msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ + let pp s = + msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ s.last_tactic ++ str "\n")) end @@ -286,36 +286,36 @@ let e_depth_search debug p db_list local_db gl = let e_breadth_search debug n db_list local_db gl = try - let tac = - if debug then Search.debug_breadth_first else Search.breadth_first + let tac = + if debug then Search.debug_breadth_first else Search.breadth_first in let s = tac (make_initial_state n gl db_list local_db) in s.tacres with Not_found -> error "eauto: breadth first search failed." -let e_search_auto debug (in_depth,p) lems db_list gl = - let local_db = make_local_hint_db true lems gl in - if in_depth then +let e_search_auto debug (in_depth,p) lems db_list gl = + let local_db = make_local_hint_db true lems gl in + if in_depth then e_depth_search debug p db_list local_db gl - else + else e_breadth_search debug p db_list local_db gl open Evd -let eauto_with_bases debug np lems db_list = +let eauto_with_bases debug np lems db_list = tclTRY (e_search_auto debug np lems db_list) -let eauto debug np lems dbnames = +let eauto debug np lems dbnames = let db_list = List.map - (fun x -> + (fun x -> try searchtable_map x with Not_found -> error ("No such Hint database: "^x^".")) - ("core"::dbnames) + ("core"::dbnames) in tclTRY (e_search_auto debug np lems db_list) - -let full_eauto debug n lems gl = + +let full_eauto debug n lems gl = let dbnames = current_db_names () in let dbnames = list_subtract dbnames ["v62"] in let db_list = List.map searchtable_map dbnames in @@ -326,7 +326,7 @@ let gen_eauto d np lems = function | Some l -> eauto d np lems l let make_depth = function - | None -> !default_search_depth + | None -> !default_search_depth | Some (ArgArg d) -> d | _ -> error "eauto called with a non closed argument." @@ -368,39 +368,39 @@ ARGUMENT EXTEND auto_using END TACTIC EXTEND eauto -| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> [ gen_eauto false (make_dimension n p) lems db ] END TACTIC EXTEND new_eauto -| [ "new" "auto" int_or_var_opt(n) auto_using(lems) +| [ "new" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> [ match db with | None -> new_full_auto (make_depth n) lems | Some l -> new_auto (make_depth n) lems l ] END - + TACTIC EXTEND debug_eauto -| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> [ gen_eauto true (make_dimension n p) lems db ] END TACTIC EXTEND dfs_eauto -| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) +| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> [ gen_eauto false (true, make_depth p) lems db ] END let autosimpl db cl = let unfold_of_elts constr (b, elts) = - if not b then + if not b then List.map (fun c -> all_occurrences, constr c) elts else [] in - let unfolds = List.concat (List.map (fun dbname -> + let unfolds = List.concat (List.map (fun dbname -> let db = searchtable_map dbname in let (ids, csts) = Hint_db.transparent_state db in unfold_of_elts (fun x -> EvalConstRef x) (Cpred.elements csts) @ @@ -414,6 +414,6 @@ END TACTIC EXTEND unify | ["unify" constr(x) constr(y) ] -> [ unify x y ] -| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ +| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ unify ~state:(Hint_db.transparent_state (searchtable_map base)) x y ] END diff --git a/tactics/eauto.mli b/tactics/eauto.mli index d2ac36fe82..7359d070e0 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -27,7 +27,7 @@ val registered_e_assumption : tactic val e_give_exact : ?flags:Unification.unify_flags -> constr -> tactic -val gen_eauto : bool -> bool * int -> constr list -> +val gen_eauto : bool -> bool * int -> constr list -> hint_db_name list option -> tactic diff --git a/tactics/elim.ml b/tactics/elim.ml index fd5d65d853..935431bf93 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -28,12 +28,12 @@ open Genarg open Tacexpr let introElimAssumsThen tac ba = - let nassums = - List.fold_left - (fun acc b -> if b then acc+2 else acc+1) - 0 ba.branchsign - in - let introElimAssums = tclDO nassums intro in + let nassums = + List.fold_left + (fun acc b -> if b then acc+2 else acc+1) + 0 ba.branchsign + in + let introElimAssums = tclDO nassums intro in (tclTHEN introElimAssums (elim_on_ba tac ba)) let introCaseAssumsThen tac ba = @@ -41,12 +41,12 @@ let introCaseAssumsThen tac ba = List.flatten (List.map (function b -> if b then [false;true] else [false]) ba.branchsign) - in + in let n1 = List.length case_thin_sign in let n2 = List.length ba.branchnames in let (l1,l2),l3 = if n1 < n2 then list_chop n1 ba.branchnames, [] - else + else (ba.branchnames, []), if n1 > n2 then snd (list_chop n2 case_thin_sign) else [] in let introCaseAssums = @@ -93,9 +93,9 @@ and general_decompose_aux recognizer id = let tmphyp_name = id_of_string "_TmpHyp" let up_to_delta = ref false (* true *) -let general_decompose recognizer c gl = - let typc = pf_type_of gl c in - tclTHENSV (cut typc) +let general_decompose recognizer c gl = + let typc = pf_type_of gl c in + tclTHENSV (cut typc) [| tclTHEN (intro_using tmphyp_name) (onLastHypId (ifOnHyp recognizer (general_decompose_aux recognizer) @@ -110,7 +110,7 @@ let head_in gls indl t = else extract_mrectype t in List.mem ity indl with Not_found -> false - + let inductive_of = function | IndRef ity -> ity | r -> @@ -118,21 +118,21 @@ let inductive_of = function (Printer.pr_global r ++ str " is not an inductive type.") let decompose_these c l gls = - let indl = (*List.map inductive_of*) l in + let indl = (*List.map inductive_of*) l in general_decompose (fun (_,t) -> head_in gls indl t) c gls let decompose_nonrec c gls = - general_decompose + general_decompose (fun (_,t) -> is_non_recursive_type t) c gls -let decompose_and c gls = - general_decompose +let decompose_and c gls = + general_decompose (fun (_,t) -> is_record t) c gls -let decompose_or c gls = - general_decompose +let decompose_or c gls = + general_decompose (fun (_,t) -> is_disjunction t) c gls @@ -153,7 +153,7 @@ let simple_elimination c gls = simple_elimination_then (fun _ -> tclIDTAC) c gls let induction_trailer abs_i abs_j bargs = - tclTHEN + tclTHEN (tclDO (abs_j - abs_i) intro) (onLastHypId (fun id gls -> @@ -163,7 +163,7 @@ let induction_trailer abs_i abs_j bargs = (List.tl (nLastDecls (abs_j - abs_i) gls)) @ bargs.assums in let (hyps,_) = - List.fold_left + List.fold_left (fun (bring_ids,leave_ids) (cid,_,cidty as d) -> if not (List.mem cid leave_ids) then (d::bring_ids,leave_ids) @@ -172,7 +172,7 @@ let induction_trailer abs_i abs_j bargs = in let ids = List.rev (ids_of_named_context hyps) in (tclTHENSEQ - [bring_hyps hyps; tclTRY (clear ids); + [bring_hyps hyps; tclTRY (clear ids); simple_elimination (mkVar id)]) gls)) diff --git a/tactics/elim.mli b/tactics/elim.mli index 1fd8a9c2bd..25ae07000b 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -23,7 +23,7 @@ val introElimAssumsThen : (branch_assumptions -> tactic) -> branch_args -> tactic val introCaseAssumsThen : - (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) -> + (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) -> branch_args -> tactic val general_decompose : (identifier * constr -> bool) -> constr -> tactic diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4 index 7b0e5e0ef1..d535e56e10 100644 --- a/tactics/eqdecide.ml4 +++ b/tactics/eqdecide.ml4 @@ -49,8 +49,8 @@ open Coqlib then analyse one by one the corresponding pairs of arguments. If they are equal, rewrite one into the other. If they are not, derive a contradiction from the injectiveness of the - constructor. - 4. Once all the arguments have been rewritten, solve the remaining half + constructor. + 4. Once all the arguments have been rewritten, solve the remaining half of the disjunction by reflexivity. Eduardo Gimenez (30/3/98). @@ -58,12 +58,12 @@ open Coqlib let clear_last = (onLastHyp (fun c -> (clear [destVar c]))) -let choose_eq eqonleft = +let choose_eq eqonleft = if eqonleft then h_simplest_left else h_simplest_right let choose_noteq eqonleft = if eqonleft then h_simplest_right else h_simplest_left -let mkBranches c1 c2 = +let mkBranches c1 c2 = tclTHENSEQ [generalize [c2]; h_simplest_elim c1; @@ -72,18 +72,18 @@ let mkBranches c1 c2 = clear_last; intros] -let solveNoteqBranch side = +let solveNoteqBranch side = tclTHEN (choose_noteq side) (tclTHEN introf (onLastHypId (fun id -> Extratactics.h_discrHyp id))) let h_solveNoteqBranch side = - Refiner.abstract_extended_tactic "solveNoteqBranch" [] + Refiner.abstract_extended_tactic "solveNoteqBranch" [] (solveNoteqBranch side) (* Constructs the type {c1=c2}+{~c1=c2} *) -let mkDecideEqGoal eqonleft op rectype c1 c2 g = +let mkDecideEqGoal eqonleft op rectype c1 c2 g = let equality = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in let disequality = mkApp(build_coq_not (), [|equality|]) in if eqonleft then mkApp(op, [|equality; disequality |]) @@ -92,24 +92,24 @@ let mkDecideEqGoal eqonleft op rectype c1 c2 g = (* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *) -let mkGenDecideEqGoal rectype g = - let hypnames = pf_ids_of_hyps g in +let mkGenDecideEqGoal rectype g = + let hypnames = pf_ids_of_hyps g in let xname = next_ident_away (id_of_string "x") hypnames and yname = next_ident_away (id_of_string "y") hypnames in - (mkNamedProd xname rectype - (mkNamedProd yname rectype + (mkNamedProd xname rectype + (mkNamedProd yname rectype (mkDecideEqGoal true (build_coq_sumbool ()) rectype (mkVar xname) (mkVar yname) g))) -let eqCase tac = - (tclTHEN intro +let eqCase tac = + (tclTHEN intro (tclTHEN (onLastHyp Equality.rewriteLR) - (tclTHEN clear_last + (tclTHEN clear_last tac))) let diseqCase eqonleft = let diseq = id_of_string "diseq" in - let absurd = id_of_string "absurd" in + let absurd = id_of_string "absurd" in (tclTHEN (intro_using diseq) (tclTHEN (choose_noteq eqonleft) (tclTHEN red_in_concl @@ -118,11 +118,11 @@ let diseqCase eqonleft = (tclTHEN (Extratactics.h_injHyp absurd) (full_trivial []))))))) -let solveArg eqonleft op a1 a2 tac g = +let solveArg eqonleft op a1 a2 tac g = let rectype = pf_type_of g a1 in let decide = mkDecideEqGoal eqonleft op rectype a1 a2 g in - let subtacs = - if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto] + let subtacs = + if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto] else [diseqCase eqonleft;eqCase tac;default_auto] in (tclTHENS (h_elim_type decide) subtacs) g @@ -133,8 +133,8 @@ let solveEqBranch rectype g = let nparams = mib.mind_nparams in let getargs l = list_skipn nparams (snd (decompose_app l)) in let rargs = getargs rhs - and largs = getargs lhs in - List.fold_right2 + and largs = getargs lhs in + List.fold_right2 (solveArg eqonleft op) largs rargs (tclTHEN (choose_eq eqonleft) h_reflexivity) g with PatternMatchingFailure -> error "Unexpected conclusion!" @@ -163,19 +163,19 @@ let decideGralEquality g = let decideEqualityGoal = tclTHEN intros decideGralEquality -let decideEquality c1 c2 g = - let rectype = (pf_type_of g c1) in - let decide = mkGenDecideEqGoal rectype g in +let decideEquality c1 c2 g = + let rectype = (pf_type_of g c1) in + let decide = mkGenDecideEqGoal rectype g in (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) g (* The tactic Compare *) -let compare c1 c2 g = +let compare c1 c2 g = let rectype = pf_type_of g c1 in - let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in - (tclTHENS (cut decide) - [(tclTHEN intro + let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 g in + (tclTHENS (cut decide) + [(tclTHEN intro (tclTHEN (onLastHyp simplest_case) clear_last)); decideEquality c1 c2]) g diff --git a/tactics/equality.ml b/tactics/equality.ml index 20e32bea3b..1c9cae30e8 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -50,7 +50,7 @@ let discr_do_intro = ref true open Goptions let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "automatic introduction of hypotheses by discriminate"; optkey = ["Discriminate";"Introduction"]; @@ -61,11 +61,11 @@ let _ = type orientation = bool -type conditions = +type conditions = | Naive (* Only try the first occurence of the lemma (default) *) | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) - + (* Warning : rewriting from left to right only works if there exists in the context a theorem named __r with type (A:)(x:A)(P:A->Prop)(P x)->(y:A)(eqname A y x)->(P y). @@ -96,12 +96,12 @@ let instantiate_lemma_all env sigma gl c ty l l2r concl = let l,res = split_last_two (y::z) in x::l, res | _ -> error "The term provided is not an applied relation." in let others,(c1,c2) = split_last_two args in - let try_occ (evd', c') = + let try_occ (evd', c') = let cl' = {eqclause with evd = evd'} in let mvs = clenv_dependent false cl' in clenv_pose_metas_as_evars cl' mvs in - let occs = + let occs = Unification.w_unify_to_subterm_all ~flags:rewrite_unif_flags env ((if l2r then c1 else c2),concl) eqclause.evd in List.map try_occ occs @@ -121,10 +121,10 @@ let rewrite_elim_in with_evars id c e = (* Ad hoc asymmetric general_elim_clause *) let general_elim_clause with_evars cls rew elim = - try + try (match cls with | None -> - (* was tclWEAK_PROGRESS which only fails for tactics generating one + (* was tclWEAK_PROGRESS which only fails for tactics generating one subgoal and did not fail for useless conditional rewritings generating an extra condition *) tclNOTSAMEGOAL (rewrite_elim with_evars rew elim ~allow_K:false) @@ -135,14 +135,14 @@ let general_elim_clause with_evars cls rew elim = (env, (Pretype_errors.NoOccurrenceFound (c', cls)))) let general_elim_clause with_evars tac cls sigma c t l l2r elim gl = - let all, firstonly, tac = + let all, firstonly, tac = match tac with | None -> false, false, None | Some (tac, Naive) -> false, false, Some tac | Some (tac, FirstSolved) -> true, true, Some (tclCOMPLETE tac) | Some (tac, AllMatches) -> true, false, Some (tclCOMPLETE tac) in - let cs = + let cs = (if not all then instantiate_lemma else instantiate_lemma_all) (pf_env gl) sigma gl c t l l2r (match cls with None -> pf_concl gl | Some id -> pf_get_hyp_typ gl id) @@ -154,10 +154,10 @@ let general_elim_clause with_evars tac cls sigma c t l l2r elim gl = tclFIRST (List.map try_clause cs) gl else tclMAP try_clause cs gl -(* The next function decides in particular whether to try a regular - rewrite or a generalized rewrite. - Approach is to break everything, if [eq] appears in head position - then regular rewrite else try general rewrite. +(* The next function decides in particular whether to try a regular + rewrite or a generalized rewrite. + Approach is to break everything, if [eq] appears in head position + then regular rewrite else try general rewrite. If occurrences are set, use general rewrite. *) @@ -172,7 +172,7 @@ let register_is_applied_rewrite_relation = (:=) is_applied_rewrite_relation let find_elim hdcncl lft2rgt cls gl = let suffix = elimination_suffix (elimination_sort_of_clause cls gl) in - let hdcncls = string_of_inductive hdcncl ^ suffix in + let hdcncls = string_of_inductive hdcncl ^ suffix in let rwr_thm = if lft2rgt = (cls = None) then hdcncls^"_r" else hdcncls in try pf_global gl (id_of_string rwr_thm) with Not_found -> error ("Cannot find rewrite principle "^rwr_thm^".") @@ -200,16 +200,16 @@ let general_rewrite_ebindings_clause cls lft2rgt occs ?tac let env = pf_env gl in let sigma, c' = c in let sigma = Evd.merge sigma (project gl) in - let ctype = get_type_of env sigma c' in + let ctype = get_type_of env sigma c' in let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in match match_with_equality_type t with | Some (hdcncl,args) -> (* Fast path: direct leibniz rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in - leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c' (it_mkProd_or_LetIn t rels) + leibniz_rewrite_ebindings_clause cls lft2rgt tac sigma c' (it_mkProd_or_LetIn t rels) l with_evars gl hdcncl | None -> try - rewrite_side_tac (!general_rewrite_clause cls + rewrite_side_tac (!general_rewrite_clause cls lft2rgt occs (c,l) ~new_goals:[]) tac gl with e -> (* Try to see if there's an equality hidden *) let env' = push_rel_context rels env in @@ -221,11 +221,11 @@ let general_rewrite_ebindings_clause cls lft2rgt occs ?tac (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars gl hdcncl | None -> raise e (* error "The provided term does not end with an equality or a declared rewrite relation." *) - -let general_rewrite_ebindings = + +let general_rewrite_ebindings = general_rewrite_ebindings_clause None -let general_rewrite_bindings l2r occs ?tac (c,bl) = +let general_rewrite_bindings l2r occs ?tac (c,bl) = general_rewrite_ebindings_clause None l2r occs ?tac (inj_open c,inj_ebindings bl) let general_rewrite l2r occs ?tac c = @@ -237,55 +237,55 @@ let general_rewrite_ebindings_in l2r occs ?tac id = let general_rewrite_bindings_in l2r occs ?tac id (c,bl) = general_rewrite_ebindings_clause (Some id) l2r occs ?tac (inj_open c,inj_ebindings bl) -let general_rewrite_in l2r occs ?tac id c = +let general_rewrite_in l2r occs ?tac id c = general_rewrite_ebindings_clause (Some id) l2r occs ?tac (inj_open c,NoBindings) -let general_multi_rewrite l2r with_evars ?tac c cl = - let occs_of = on_snd (List.fold_left +let general_multi_rewrite l2r with_evars ?tac c cl = + let occs_of = on_snd (List.fold_left (fun acc -> function ArgArg x -> x :: acc | ArgVar _ -> acc) []) in - match cl.onhyps with - | Some l -> + match cl.onhyps with + | Some l -> (* If a precise list of locations is given, success is mandatory for each of these locations. *) - let rec do_hyps = function + let rec do_hyps = function | [] -> tclIDTAC - | ((occs,id),_) :: l -> + | ((occs,id),_) :: l -> tclTHENFIRST (general_rewrite_ebindings_in l2r (occs_of occs) ?tac id c with_evars) (do_hyps l) - in + in if cl.concl_occs = no_occurrences_expr then do_hyps l else tclTHENFIRST (general_rewrite_ebindings l2r (occs_of cl.concl_occs) ?tac c with_evars) (do_hyps l) - | None -> - (* Otherwise, if we are told to rewrite in all hypothesis via the - syntax "* |-", we fail iff all the different rewrites fail *) - let rec do_hyps_atleastonce = function + | None -> + (* Otherwise, if we are told to rewrite in all hypothesis via the + syntax "* |-", we fail iff all the different rewrites fail *) + let rec do_hyps_atleastonce = function | [] -> (fun gl -> error "Nothing to rewrite.") - | id :: l -> - tclIFTHENTRYELSEMUST + | id :: l -> + tclIFTHENTRYELSEMUST (general_rewrite_ebindings_in l2r all_occurrences ?tac id c with_evars) (do_hyps_atleastonce l) - in - let do_hyps gl = + in + let do_hyps gl = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) - let ids = + let ids = let ids_in_c = Environ.global_vars_set (Global.env()) (snd (fst c)) in Idset.fold (fun id l -> list_remove id l) ids_in_c (pf_ids_of_hyps gl) in do_hyps_atleastonce ids gl - in + in if cl.concl_occs = no_occurrences_expr then do_hyps else - tclIFTHENTRYELSEMUST + tclIFTHENTRYELSEMUST (general_rewrite_ebindings l2r (occs_of cl.concl_occs) ?tac c with_evars) do_hyps -let general_multi_multi_rewrite with_evars l cl tac = +let general_multi_multi_rewrite with_evars l cl tac = let do1 l2r c = general_multi_rewrite l2r with_evars ?tac c cl in - let rec doN l2r c = function + let rec doN l2r c = function | Precisely n when n <= 0 -> tclIDTAC | Precisely 1 -> do1 l2r c | Precisely n -> tclTHENFIRST (do1 l2r c) (doN l2r c (Precisely (n-1))) @@ -293,7 +293,7 @@ let general_multi_multi_rewrite with_evars l cl tac = | RepeatPlus -> tclTHENFIRST (do1 l2r c) (doN l2r c RepeatStar) | UpTo n when n<=0 -> tclIDTAC | UpTo n -> tclTHENFIRST (tclTRY (do1 l2r c)) (doN l2r c (UpTo (n-1))) - in + in let rec loop = function | [] -> tclIDTAC | (l2r,m,c)::l -> tclTHENFIRST (doN l2r c m) (loop l) @@ -307,24 +307,24 @@ let rewriteRL = general_rewrite false all_occurrences (* eq,sym_eq : equality on Type and its symmetry theorem c2 c1 : c1 is to be replaced by c2 unsafe : If true, do not check that c1 and c2 are convertible - tac : Used to prove the equality c1 = c2 + tac : Used to prove the equality c1 = c2 gl : goal *) -let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = - let try_prove_eq = - match try_prove_eq_opt with +let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = + let try_prove_eq = + match try_prove_eq_opt with | None -> tclIDTAC | Some tac -> tclCOMPLETE tac in - let t1 = pf_apply get_type_of gl c1 + let t1 = pf_apply get_type_of gl c1 and t2 = pf_apply get_type_of gl c2 in if unsafe or (pf_conv_x gl t1 t2) then let e = build_coq_eq () in let sym = build_coq_eq_sym () in let eq = applist (e, [t1;c1;c2]) in tclTHENS (assert_as false None eq) - [onLastHypId (fun id -> - tclTHEN + [onLastHypId (fun id -> + tclTHEN (tclTRY (general_multi_rewrite false false (inj_open (mkVar id),NoBindings) clause)) (clear [id])); tclFIRST @@ -335,7 +335,7 @@ let multi_replace clause c2 c1 unsafe try_prove_eq_opt gl = ] gl else error "Terms do not have convertible types." - + let replace c2 c1 gl = multi_replace onConcl c2 c1 false None gl @@ -345,7 +345,7 @@ let replace_by c2 c1 tac gl = multi_replace onConcl c2 c1 false (Some tac) gl let replace_in_by id c2 c1 tac gl = multi_replace (onHyp id) c2 c1 false (Some tac) gl -let replace_in_clause_maybe_by c2 c1 cl tac_opt gl = +let replace_in_clause_maybe_by c2 c1 cl tac_opt gl = multi_replace cl c2 c1 false tac_opt gl (* End of Eduardo's code. The rest of this file could be improved @@ -400,8 +400,8 @@ let find_positions env sigma t1 t2 = let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in match (kind_of_term hd1, kind_of_term hd2) with - - | Construct sp1, Construct sp2 + + | Construct sp1, Construct sp2 when List.length args1 = mis_constructor_nargs_env env sp1 -> let sorts = list_intersect sorts (allowed_sorts env (fst sp1)) in @@ -419,14 +419,14 @@ let find_positions env sigma t1 t2 = else [] | _ -> - let t1_0 = applist (hd1,args1) + let t1_0 = applist (hd1,args1) and t2_0 = applist (hd2,args2) in - if is_conv env sigma t1_0 t2_0 then + if is_conv env sigma t1_0 t2_0 then [] else let ty1_0 = get_type_of env sigma t1_0 in let s = get_sort_family_of env sigma ty1_0 in - if List.mem s sorts then [(List.rev posn,t1_0,t2_0)] else [] in + if List.mem s sorts then [(List.rev posn,t1_0,t2_0)] else [] in try (* Rem: to allow injection on proofs objects, just add InProp *) Inr (findrec [InSet;InType] [] t1 t2) @@ -438,7 +438,7 @@ let discriminable env sigma t1 t2 = | Inl _ -> true | _ -> false -let injectable env sigma t1 t2 = +let injectable env sigma t1 t2 = match find_positions env sigma t1 t2 with | Inl _ | Inr [] -> false | Inr _ -> true @@ -553,13 +553,13 @@ let construct_discriminator sigma env dirn c sort = let IndType(indf,_) = try find_rectype env sigma (get_type_of env sigma c) with Not_found -> - (* one can find Rel(k) in case of dependent constructors - like T := c : (A:Set)A->T and a discrimination + (* one can find Rel(k) in case of dependent constructors + like T := c : (A:Set)A->T and a discrimination on (c bool true) = (c bool false) CP : changed assert false in a more informative error *) errorlabstrm "Equality.construct_discriminator" - (str "Cannot discriminate on inductive constructors with + (str "Cannot discriminate on inductive constructors with dependent types.") in let (ind,_) = dest_ind_family indf in let (mib,mip) = lookup_mind_specif env ind in @@ -574,7 +574,7 @@ let construct_discriminator sigma env dirn c sort = List.map build_branch(interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in mkCase (ci, p, c, Array.of_list brl) - + let rec build_discriminator sigma env dirn c sort = function | [] -> construct_discriminator sigma env dirn c sort | ((sp,cnum),argnum)::l -> @@ -599,13 +599,13 @@ let gen_absurdity id gl = then simplest_elim (mkVar id) gl else - errorlabstrm "Equality.gen_absurdity" + errorlabstrm "Equality.gen_absurdity" (str "Not the negation of an equality.") (* Precondition: eq is leibniz equality - + returns ((eq_elim t t1 P i t2), absurd_term) - where P=[e:t]discriminator + where P=[e:t]discriminator absurd_term=False *) @@ -622,7 +622,7 @@ let eq_baseid = id_of_string "e" let apply_on_clause (f,t) clause = let sigma = clause.evd in let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in - let argmv = + let argmv = (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> errorlabstrm "" (str "Ill-formed clause applicator.")) in @@ -647,7 +647,7 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause gls = | Inr _ -> errorlabstrm "discr" (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> - let sort = pf_apply get_type_of gls (pf_concl gls) in + let sort = pf_apply get_type_of gls (pf_concl gls) in discr_positions env sigma u eq_clause cpath dirn sort gls let onEquality with_evars tac (c,lbindc) gls = @@ -658,7 +658,7 @@ let onEquality with_evars tac (c,lbindc) gls = let eqn = clenv_type eq_clause' in let eq,eq_args = find_this_eq_data_decompose gls eqn in tclTHEN - (Refiner.tclEVARS eq_clause'.evd) + (Refiner.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') gls let onNegatedEquality with_evars tac gls = @@ -666,9 +666,9 @@ let onNegatedEquality with_evars tac gls = match kind_of_term (hnf_constr (pf_env gls) (project gls) ccl) with | Prod (_,t,u) when is_empty_type u -> tclTHEN introf - (onLastHypId (fun id -> + (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) gls - | _ -> + | _ -> errorlabstrm "" (str "Not a negated primitive equality.") let discrSimpleClause with_evars = function @@ -679,18 +679,18 @@ let discr with_evars = onEquality with_evars discrEq let discrClause with_evars = onClause (discrSimpleClause with_evars) -let discrEverywhere with_evars = +let discrEverywhere with_evars = (* tclORELSE *) (if !discr_do_intro then (tclTHEN - (tclREPEAT introf) + (tclREPEAT introf) (Tacticals.tryAllHyps (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) else (* <= 8.2 compat *) Tacticals.tryAllHypsAndConcl (discrSimpleClause with_evars)) -(* (fun gls -> +(* (fun gls -> errorlabstrm "DiscrEverywhere" (str"No discriminable equalities.")) *) let discr_tac with_evars = function @@ -702,8 +702,8 @@ let discrHyp id gls = discrClause false (onHyp id) gls (* returns the sigma type (sigS, sigT) with the respective constructor depending on the sort *) -(* J.F.: correction du bug #1167 en accord avec Hugo. *) - +(* J.F.: correction du bug #1167 en accord avec Hugo. *) + let find_sigma_data s = build_sigma_type () (* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser @@ -746,8 +746,8 @@ let minimal_free_rels env sigma (c,cty) = (cty',rels') (* [sig_clausal_form siglen ty] - - Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the + + Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the type of ty), and return: (1) a pattern, with meta-variables in it for various arguments, @@ -761,9 +761,9 @@ let minimal_free_rels env sigma (c,cty) = (4) a typing for each patvar - WARNING: No checking is done to make sure that the + WARNING: No checking is done to make sure that the sigS(or sigT)'s are actually there. - - Only homogenious pairs are built i.e. pairs where all the + - Only homogenious pairs are built i.e. pairs where all the dependencies are of the same sort [sig_clausal_form] proceed as follows: the default tuple is @@ -782,7 +782,7 @@ let minimal_free_rels env sigma (c,cty) = *) let sig_clausal_form env sigma sort_of_ty siglen ty dflt = - let { intro = exist_term } = find_sigma_data sort_of_ty in + let { intro = exist_term } = find_sigma_data sort_of_ty in let evdref = ref (Evd.create_goal_evar_defs sigma) in let rec sigrec_clausal_form siglen p_i = if siglen = 0 then @@ -801,7 +801,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let rty = beta_applist(p_i_minus_1,[ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in match - Evd.existential_opt_value !evdref + Evd.existential_opt_value !evdref (destEvar ev) with | Some w -> applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) @@ -873,7 +873,7 @@ let make_iterated_tuple env sigma dflt (z,zty) = let sort_of_zty = get_sort_of env sigma zty in let sorted_rels = Sort.list (<) (Intset.elements rels) in let (tuple,tuplety) = - List.fold_left (make_tuple env sigma) (z,zty) sorted_rels + List.fold_left (make_tuple env sigma) (z,zty) sorted_rels in assert (closed0 tuplety); let n = List.length sorted_rels in @@ -898,22 +898,22 @@ let build_injector sigma env dflt c cpath = (* let try_delta_expand env sigma t = - let whdt = whd_betadeltaiota env sigma t in + let whdt = whd_betadeltaiota env sigma t in let rec hd_rec c = match kind_of_term c with | Construct _ -> whdt | App (f,_) -> hd_rec f | Cast (c,_,_) -> hd_rec c | _ -> t - in - hd_rec whdt + in + hd_rec whdt *) -(* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it +(* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it expands then only when the whdnf has a constructor of an inductive type in hd position, otherwise delta expansion is not done *) -let simplify_args env sigma t = +let simplify_args env sigma t = (* Quick hack to reduce in arguments of eq only *) match decompose_app t with | eq, [t;c1;c2] -> applist (eq,[t;nf env sigma c1;nf env sigma c2]) @@ -953,7 +953,7 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause = errorlabstrm "Inj" (str"Not a projectable equality but a discriminable one.") | Inr [] -> - errorlabstrm "Equality.inj" + errorlabstrm "Equality.inj" (str"Nothing to do, it is an equality between convertible terms.") | Inr posns -> (* Est-ce utile à partir du moment où les arguments projetés subissent "nf" ? @@ -964,7 +964,7 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause = (* fetch the informations of the pair *) let ceq = constr_of_global Coqlib.glob_eq in let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in - let eqTypeDest = fst (destApp t) in + let eqTypeDest = fst (destApp t) in let _,ar1 = destApp t1 and _,ar2 = destApp t2 in let ind = destInd ar1.(0) in @@ -977,11 +977,11 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause = if ( (eqTypeDest = sigTconstr()) && (Ind_tables.check_dec_proof ind=true) && (is_conv env sigma (ar1.(2)) (ar2.(2)) = true)) - then ( + then ( (* Require Import Eqdec_dec copied from vernac_require in vernacentries.ml*) - let qidl = qualid_of_reference + let qidl = qualid_of_reference (Ident (dummy_loc,id_of_string "Eqdep_dec")) in - Library.require_library [qidl] (Some false); + Library.require_library [qidl] (Some false); (* cut with the good equality and prove the requested goal *) tclTHENS (cut (mkApp (ceq,new_eq_args)) ) [tclIDTAC; tclTHEN (apply ( @@ -991,7 +991,7 @@ let injEq ipats (eq,_,(t,t1,t2) as u) eq_clause = )) (Auto.trivial [] []) ] (* not a dep eq or no decidable type found *) - ) else (raise Not_dep_pair) + ) else (raise Not_dep_pair) ) with _ -> tclTHEN (inject_at_positions env sigma u eq_clause posns) @@ -1007,9 +1007,9 @@ let injConcl gls = injClause [] false None gls let injHyp id gls = injClause [] false (Some (ElimOnIdent (dummy_loc,id))) gls let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause gls = - let sort = pf_apply get_type_of gls (pf_concl gls) in + let sort = pf_apply get_type_of gls (pf_concl gls) in let sigma = clause.evd in - let env = pf_env gls in + let env = pf_env gls in match find_positions env sigma t1 t2 with | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u clause cpath dirn sort gls @@ -1033,7 +1033,7 @@ let swap_equality_args = function | HeterogenousEq (t1,e1,t2,e2) -> [t2;e2;t1;e1] let swap_equands gls eqn = - let (lbeq,eq_args) = find_eq_data eqn in + let (lbeq,eq_args) = find_eq_data eqn in applist(lbeq.eq,swap_equality_args eq_args) let swapEquandsInConcl gls = @@ -1081,7 +1081,7 @@ let bareRevSubstInConcl lbeq body (t,e1,e2) gls = *) -let decomp_tuple_term env c t = +let decomp_tuple_term env c t = let rec decomprec inner_code ex exty = try let {proj1=p1; proj2=p2},(a,p,car,cdr) = find_sigma_data_decompose ex in @@ -1125,7 +1125,7 @@ let cutSubstInConcl_LR eqn gls = let cutSubstInConcl l2r =if l2r then cutSubstInConcl_LR else cutSubstInConcl_RL let cutSubstInHyp_LR eqn id gls = - let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in + let (lbeq,(t,e1,e2 as eq)) = find_eq_data_decompose gls eqn in let body = pf_apply subst_tuple_term gls e1 (pf_get_hyp_typ gls id) in if not (dependent (mkRel 1) body) then raise NothingToRewrite; cut_replacing id (subst1 e2 body) @@ -1139,12 +1139,12 @@ let cutSubstInHyp_RL eqn id gls = let cutSubstInHyp l2r = if l2r then cutSubstInHyp_LR else cutSubstInHyp_RL let try_rewrite tac gls = - try + try tac gls - with + with | PatternMatchingFailure -> errorlabstrm "try_rewrite" (str "Not a primitive equality here.") - | e when catchable_exception e -> + | e when catchable_exception e -> errorlabstrm "try_rewrite" (strbrk "Cannot find a well-typed generalization of the goal that makes the proof progress.") | NothingToRewrite -> @@ -1227,7 +1227,7 @@ let subst_one x gl = (* x is a variable: *) let varx = mkVar x in (* Find a non-recursive definition for x *) - let (hyp,rhs,dir) = + let (hyp,rhs,dir) = try let test hyp _ = is_eq_x gl varx hyp in Sign.fold_named_context test ~init:() hyps; @@ -1237,8 +1237,8 @@ let subst_one x gl = with FoundHyp res -> res in (* The set of hypotheses using x *) - let depdecls = - let test (id,_,c as dcl) = + let depdecls = + let test (id,_,c as dcl) = if id <> hyp && occur_var_in_decl (pf_env gl) x dcl then dcl else failwith "caught" in List.rev (map_succeed test hyps) in @@ -1261,7 +1261,7 @@ let subst_one x gl = (Some (replace_term varx rhs htyp)) nowhere in let need_rewrite = dephyps <> [] || depconcl in - tclTHENLIST + tclTHENLIST ((if need_rewrite then [generalize abshyps; (if dir then rewriteLR else rewriteRL) (mkVar hyp); @@ -1281,7 +1281,7 @@ let subst_all ?(strict=true) gl = if strict then restrict_to_eq_and_identity lbeq.eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if eq_constr x y then failwith "caught"; - match kind_of_term x with Var x -> x | _ -> + match kind_of_term x with Var x -> x | _ -> match kind_of_term y with Var y -> y | _ -> failwith "caught" with PatternMatchingFailure -> failwith "caught" in @@ -1290,7 +1290,7 @@ let subst_all ?(strict=true) gl = subst ids gl -(* Rewrite the first assumption for which the condition faildir does not fail +(* Rewrite the first assumption for which the condition faildir does not fail and gives the direction of the rewrite *) let cond_eq_term_left c t gl = @@ -1299,41 +1299,41 @@ let cond_eq_term_left c t gl = if pf_conv_x gl c x then true else failwith "not convertible" with PatternMatchingFailure -> failwith "not an equality" -let cond_eq_term_right c t gl = +let cond_eq_term_right c t gl = try let (_,_,x) = snd (find_eq_data_decompose gl t) in if pf_conv_x gl c x then false else failwith "not convertible" with PatternMatchingFailure -> failwith "not an equality" -let cond_eq_term c t gl = +let cond_eq_term c t gl = try let (_,x,y) = snd (find_eq_data_decompose gl t) in - if pf_conv_x gl c x then true + if pf_conv_x gl c x then true else if pf_conv_x gl c y then false else failwith "not convertible" with PatternMatchingFailure -> failwith "not an equality" -let rewrite_multi_assumption_cond cond_eq_term cl gl = - let rec arec = function +let rewrite_multi_assumption_cond cond_eq_term cl gl = + let rec arec = function | [] -> error "No such assumption." - | (id,_,t) ::rest -> - begin - try - let dir = cond_eq_term t gl in + | (id,_,t) ::rest -> + begin + try + let dir = cond_eq_term t gl in general_multi_rewrite dir false (inj_open (mkVar id),NoBindings) cl gl with | Failure _ | UserError _ -> arec rest end - in + in arec (pf_hyps gl) -let replace_multi_term dir_opt c = - let cond_eq_fun = - match dir_opt with +let replace_multi_term dir_opt c = + let cond_eq_fun = + match dir_opt with | None -> cond_eq_term c | Some true -> cond_eq_term_left c | Some false -> cond_eq_term_right c - in - rewrite_multi_assumption_cond cond_eq_fun + in + rewrite_multi_assumption_cond cond_eq_fun -let _ = Tactics.register_general_multi_rewrite +let _ = Tactics.register_general_multi_rewrite (fun b evars t cls -> general_multi_rewrite b evars t cls) diff --git a/tactics/equality.mli b/tactics/equality.mli index 9d5bcca7af..7b63099c74 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -29,14 +29,14 @@ open Genarg type orientation = bool -type conditions = +type conditions = | Naive (* Only try the first occurence of the lemma (default) *) | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) - -val general_rewrite_bindings : + +val general_rewrite_bindings : orientation -> occurrences -> ?tac:(tactic * conditions) -> constr with_bindings -> evars_flag -> tactic -val general_rewrite : +val general_rewrite : orientation -> occurrences -> ?tac:(tactic * conditions) -> constr -> tactic (* Equivalent to [general_rewrite l2r] *) @@ -50,18 +50,18 @@ val register_general_rewrite_clause : occurrences -> open_constr with_bindings -> new_goals:constr list -> tactic) -> unit val register_is_applied_rewrite_relation : (env -> evar_defs -> rel_context -> constr -> open_constr option) -> unit -val general_rewrite_ebindings_clause : identifier option -> +val general_rewrite_ebindings_clause : identifier option -> orientation -> occurrences -> ?tac:(tactic * conditions) -> open_constr with_bindings -> evars_flag -> tactic -val general_rewrite_bindings_in : +val general_rewrite_bindings_in : orientation -> occurrences -> ?tac:(tactic * conditions) -> identifier -> constr with_bindings -> evars_flag -> tactic val general_rewrite_in : orientation -> occurrences -> ?tac:(tactic * conditions) -> identifier -> constr -> evars_flag -> tactic val general_multi_rewrite : orientation -> evars_flag -> ?tac:(tactic * conditions) -> open_constr with_bindings -> clause -> tactic -val general_multi_multi_rewrite : - evars_flag -> (bool * multi * open_constr with_bindings) list -> clause -> +val general_multi_multi_rewrite : + evars_flag -> (bool * multi * open_constr with_bindings) list -> clause -> (tactic * conditions) option -> tactic val replace_in_clause_maybe_by : constr -> constr -> clause -> tactic option -> tactic @@ -75,11 +75,11 @@ val discrConcl : tactic val discrClause : evars_flag -> clause -> tactic val discrHyp : identifier -> tactic val discrEverywhere : evars_flag -> tactic -val discr_tac : evars_flag -> +val discr_tac : evars_flag -> constr with_ebindings induction_arg option -> tactic val inj : intro_pattern_expr located list -> evars_flag -> constr with_ebindings -> tactic -val injClause : intro_pattern_expr located list -> evars_flag -> +val injClause : intro_pattern_expr located list -> evars_flag -> constr with_ebindings induction_arg option -> tactic val injHyp : identifier -> tactic val injConcl : tactic @@ -87,7 +87,7 @@ val injConcl : tactic val dEq : evars_flag -> constr with_ebindings induction_arg option -> tactic val dEqThen : evars_flag -> (int -> tactic) -> constr with_ebindings induction_arg option -> tactic -val make_iterated_tuple : +val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> constr * constr * constr (* The family cutRewriteIn expect an equality statement *) @@ -132,7 +132,7 @@ val subst : identifier list -> tactic val subst_all : ?strict:bool -> tactic (* Replace term *) -(* [replace_multi_term dir_opt c cl] +(* [replace_multi_term dir_opt c cl] perfoms replacement of [c] by the first value found in context (according to [dir] if given to get the rewrite direction) in the clause [cl] *) diff --git a/tactics/evar_tactics.ml b/tactics/evar_tactics.ml index 0d08b72aae..ad392c7d84 100644 --- a/tactics/evar_tactics.ml +++ b/tactics/evar_tactics.ml @@ -21,31 +21,31 @@ open Termops (* The instantiate tactic *) -let evar_list evc c = +let evar_list evc c = let rec evrec acc c = match kind_of_term c with | Evar (n, _) when Evd.mem evc n -> c :: acc | _ -> fold_constr evrec acc c - in + in evrec [] c -let instantiate n (ist,rawc) ido gl = +let instantiate n (ist,rawc) ido gl = let sigma = gl.sigma in - let evl = + let evl = match ido with - ConclLocation () -> evar_list sigma gl.it.evar_concl + ConclLocation () -> evar_list sigma gl.it.evar_concl | HypLocation (id,hloc) -> let decl = Environ.lookup_named_val id gl.it.evar_hyps in match hloc with - InHyp -> - (match decl with + InHyp -> + (match decl with (_,None,typ) -> evar_list sigma typ - | _ -> error + | _ -> error "Please be more specific: in type or value?") | InHypTypeOnly -> let (_, _, typ) = decl in evar_list sigma typ | InHypValueOnly -> - (match decl with + (match decl with (_,Some body,_) -> evar_list sigma body | _ -> error "Not a defined hypothesis.") in if List.length evl < n then @@ -59,9 +59,9 @@ let instantiate n (ist,rawc) ido gl = (tclEVARS sigma') tclNORMEVAR gl - + let let_evar name typ gls = let sigma',evar = Evarutil.new_evar gls.sigma (pf_env gls) typ in Refiner.tclTHEN (Refiner.tclEVARS sigma') (Tactics.letin_tac None name evar None nowhere) gls - + diff --git a/tactics/evar_tactics.mli b/tactics/evar_tactics.mli index 7a305f2001..2e30cdfbee 100644 --- a/tactics/evar_tactics.mli +++ b/tactics/evar_tactics.mli @@ -13,7 +13,7 @@ open Names open Tacexpr open Termops -val instantiate : int -> Tacinterp.interp_sign * Rawterm.rawconstr -> +val instantiate : int -> Tacinterp.interp_sign * Rawterm.rawconstr -> (identifier * hyp_location_flag, unit) location -> tactic (*i diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4 index 4e3e04c67f..e6eefea8ab 100644 --- a/tactics/extraargs.ml4 +++ b/tactics/extraargs.ml4 @@ -41,9 +41,9 @@ let pr_int_list _prc _prlc _prt l = in aux l ARGUMENT EXTEND int_nelist - TYPED AS int list + TYPED AS int list PRINTED BY pr_int_list - RAW_TYPED AS int list + RAW_TYPED AS int list RAW_PRINTED BY pr_int_list GLOB_TYPED AS int list GLOB_PRINTED BY pr_int_list @@ -65,11 +65,11 @@ let coerce_to_int = function let int_list_of_VList = function | VList l -> List.map (fun n -> coerce_to_int n) l | _ -> raise Not_found - -let interp_occs ist gl l = + +let interp_occs ist gl l = match l with | ArgArg x -> x - | ArgVar (_,id as locid) -> + | ArgVar (_,id as locid) -> (try int_list_of_VList (List.assoc id ist.lfun) with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) @@ -111,14 +111,14 @@ let subst_raw = Tacinterp.subst_rawconstr_and_expr ARGUMENT EXTEND raw TYPED AS rawconstr PRINTED BY pr_rawc - - INTERPRETED BY interp_raw + + INTERPRETED BY interp_raw GLOBALIZED BY glob_raw SUBSTITUTED BY subst_raw - + RAW_TYPED AS constr_expr RAW_PRINTED BY pr_gen - + GLOB_TYPED AS rawconstr_and_expr GLOB_PRINTED BY pr_gen [ lconstr(c) ] -> [ c ] @@ -132,9 +132,9 @@ type place = identifier gen_place let pr_gen_place pr_id = function ConclLocation () -> Pp.mt () | HypLocation (id,InHyp) -> str "in " ++ pr_id id - | HypLocation (id,InHypTypeOnly) -> + | HypLocation (id,InHypTypeOnly) -> str "in (Type of " ++ pr_id id ++ str ")" - | HypLocation (id,InHypValueOnly) -> + | HypLocation (id,InHypValueOnly) -> str "in (Value of " ++ pr_id id ++ str ")" let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id) @@ -148,7 +148,7 @@ let interp_place ist gl = function ConclLocation () -> ConclLocation () | HypLocation (id,hl) -> HypLocation (interp_hyp ist gl id,hl) -let subst_place subst pl = pl +let subst_place subst pl = pl ARGUMENT EXTEND hloc TYPED AS place @@ -160,17 +160,17 @@ ARGUMENT EXTEND hloc RAW_PRINTED BY pr_loc_place GLOB_TYPED AS loc_place GLOB_PRINTED BY pr_loc_place - [ ] -> + [ ] -> [ ConclLocation () ] - | [ "in" "|-" "*" ] -> + | [ "in" "|-" "*" ] -> [ ConclLocation () ] | [ "in" ident(id) ] -> [ HypLocation ((Util.dummy_loc,id),InHyp) ] -| [ "in" "(" "Type" "of" ident(id) ")" ] -> +| [ "in" "(" "Type" "of" ident(id) ")" ] -> [ HypLocation ((Util.dummy_loc,id),InHypTypeOnly) ] -| [ "in" "(" "Value" "of" ident(id) ")" ] -> +| [ "in" "(" "Value" "of" ident(id) ")" ] -> [ HypLocation ((Util.dummy_loc,id),InHypValueOnly) ] - + END @@ -181,8 +181,8 @@ ARGUMENT EXTEND hloc (* Julien: Mise en commun des differentes version de replace with in by *) -let pr_by_arg_tac _prc _prlc prtac opt_c = - match opt_c with +let pr_by_arg_tac _prc _prlc prtac opt_c = + match opt_c with | None -> mt () | Some t -> spc () ++ hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) @@ -192,37 +192,37 @@ ARGUMENT EXTEND by_arg_tac | [ "by" tactic3(c) ] -> [ Some c ] | [ ] -> [ None ] END - -let pr_in_hyp pr_id (lo,concl) : Pp.std_ppcmds = - match lo,concl with + +let pr_in_hyp pr_id (lo,concl) : Pp.std_ppcmds = + match lo,concl with | Some [],true -> mt () | None,true -> str "in" ++ spc () ++ str "*" - | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-" - | Some l,_ -> - str "in" ++ spc () ++ - Util.prlist_with_sep spc pr_id l ++ - match concl with + | None,false -> str "in" ++ spc () ++ str "*" ++ spc () ++ str "|-" + | Some l,_ -> + str "in" ++ spc () ++ + Util.prlist_with_sep spc pr_id l ++ + match concl with | true -> spc () ++ str "|-" ++ spc () ++ str "*" | _ -> mt () let pr_in_arg_hyp _ _ _ = pr_in_hyp (fun (_,id) -> Ppconstr.pr_id id) -let pr_in_arg_hyp_typed _ _ _ = pr_in_hyp Ppconstr.pr_id +let pr_in_arg_hyp_typed _ _ _ = pr_in_hyp Ppconstr.pr_id -let pr_var_list_gen pr_id = Util.prlist_with_sep (fun () -> str ",") pr_id +let pr_var_list_gen pr_id = Util.prlist_with_sep (fun () -> str ",") pr_id -let pr_var_list_typed _ _ _ = pr_var_list_gen Ppconstr.pr_id +let pr_var_list_typed _ _ _ = pr_var_list_gen Ppconstr.pr_id let pr_var_list _ _ _ = pr_var_list_gen (fun (_,id) -> Ppconstr.pr_id id) -ARGUMENT EXTEND comma_var_lne - TYPED AS var list +ARGUMENT EXTEND comma_var_lne + TYPED AS var list PRINTED BY pr_var_list_typed - RAW_TYPED AS var list + RAW_TYPED AS var list RAW_PRINTED BY pr_var_list GLOB_TYPED AS var list GLOB_PRINTED BY pr_var_list @@ -230,10 +230,10 @@ ARGUMENT EXTEND comma_var_lne | [ var(x) "," comma_var_lne(l) ] -> [x::l] END -ARGUMENT EXTEND comma_var_l - TYPED AS var list +ARGUMENT EXTEND comma_var_l + TYPED AS var list PRINTED BY pr_var_list_typed - RAW_TYPED AS var list + RAW_TYPED AS var list RAW_PRINTED BY pr_var_list GLOB_TYPED AS var list GLOB_PRINTED BY pr_var_list @@ -241,10 +241,10 @@ ARGUMENT EXTEND comma_var_l | [] -> [ [] ] END -let pr_in_concl _ _ _ = function true -> str "|- " ++ spc () ++ str "*" | _ -> str "|-" +let pr_in_concl _ _ _ = function true -> str "|- " ++ spc () ++ str "*" | _ -> str "|-" -ARGUMENT EXTEND inconcl - TYPED AS bool +ARGUMENT EXTEND inconcl + TYPED AS bool PRINTED BY pr_in_concl | [ "|-" "*" ] -> [ true ] | [ "|-" ] -> [ false ] @@ -255,24 +255,24 @@ END ARGUMENT EXTEND in_arg_hyp TYPED AS var list option * bool PRINTED BY pr_in_arg_hyp_typed - RAW_TYPED AS var list option * bool + RAW_TYPED AS var list option * bool RAW_PRINTED BY pr_in_arg_hyp GLOB_TYPED AS var list option * bool GLOB_PRINTED BY pr_in_arg_hyp | [ "in" "*" ] -> [(None,true)] | [ "in" "*" inconcl_opt(b) ] -> [let onconcl = match b with Some b -> b | None -> true in (None,onconcl)] -| [ "in" comma_var_l(l) inconcl_opt(b) ] -> [ let onconcl = match b with Some b -> b | None -> false in +| [ "in" comma_var_l(l) inconcl_opt(b) ] -> [ let onconcl = match b with Some b -> b | None -> false in Some l, onconcl ] | [ ] -> [ (Some [],true) ] END -let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = +let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = {Tacexpr.onhyps= - Option.map - (fun l -> - List.map + Option.map + (fun l -> + List.map (fun id -> ( (all_occurrences_expr,trad_id id),InHyp)) l ) @@ -280,8 +280,8 @@ let gen_in_arg_hyp_to_clause trad_id (hyps ,concl) : Tacticals.clause = Tacexpr.concl_occs = if concl then all_occurrences_expr else no_occurrences_expr} -let raw_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause snd -let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x) +let raw_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause snd +let glob_in_arg_hyp_to_clause = gen_in_arg_hyp_to_clause (fun x -> x) (* spiwack argument for the commands of the retroknowledge *) @@ -297,7 +297,7 @@ let (wit_r_field, globwit_r_field, rawwit_r_field) = (* spiwack: the print functions are incomplete, but I don't know what they are used for *) -let pr_r_nat_field _ _ _ natf = +let pr_r_nat_field _ _ _ natf = str "nat " ++ match natf with | Retroknowledge.NatType -> str "type" @@ -327,7 +327,7 @@ let pr_r_int31_field _ _ _ i31f = | Retroknowledge.Int31PhiInv -> str "phi inv" | Retroknowledge.Int31Plus -> str "plus" | Retroknowledge.Int31Times -> str "times" - | _ -> assert false + | _ -> assert false let pr_retroknowledge_field _ _ _ f = match f with @@ -335,7 +335,7 @@ let pr_retroknowledge_field _ _ _ f = | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf | Retroknowledge.KN nf -> pr_r_n_field () () () nf *) | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field () () () i31f) ++ - str "in " ++ str group + str "in " ++ str group ARGUMENT EXTEND retroknowledge_nat TYPED AS r_nat_field @@ -347,7 +347,7 @@ END ARGUMENT EXTEND retroknowledge_binary_n -TYPED AS r_n_field +TYPED AS r_n_field PRINTED BY pr_r_n_field | [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] | [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] @@ -360,7 +360,7 @@ PRINTED BY pr_r_n_field END ARGUMENT EXTEND retroknowledge_int31 -TYPED AS r_int31_field +TYPED AS r_int31_field PRINTED BY pr_r_int31_field | [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] | [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] @@ -385,8 +385,8 @@ PRINTED BY pr_r_int31_field END -ARGUMENT EXTEND retroknowledge_field -TYPED AS r_field +ARGUMENT EXTEND retroknowledge_field +TYPED AS r_field PRINTED BY pr_retroknowledge_field (*| [ "equality" ] -> [ Retroknowledge.KEq ] | [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index f03084d4d0..c7c235cc0f 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -26,7 +26,7 @@ open Termops open Equality -TACTIC EXTEND replace +TACTIC EXTEND replace ["replace" constr(c1) "with" constr(c2) in_arg_hyp(in_hyp) by_arg_tac(tac) ] -> [ replace_in_clause_maybe_by c1 c2 (glob_in_arg_hyp_to_clause in_hyp) (Option.map Tacinterp.eval_tactic tac) ] END @@ -97,10 +97,10 @@ let h_discrHyp id = h_discriminate_main (Term.mkVar id,NoBindings) TACTIC EXTEND injection_main | [ "injection" constr_with_bindings(c) ] -> [ injClause [] false (Some (ElimOnConstr c)) ] -END +END TACTIC EXTEND injection | [ "injection" ] -> [ injClause [] false None ] -| [ "injection" quantified_hypothesis(h) ] -> +| [ "injection" quantified_hypothesis(h) ] -> [ injClause [] false (Some (induction_arg_of_quantified_hyp h)) ] END TACTIC EXTEND einjection_main @@ -110,21 +110,21 @@ END TACTIC EXTEND einjection | [ "einjection" ] -> [ injClause [] true None ] | [ "einjection" quantified_hypothesis(h) ] -> [ injClause [] true (Some (induction_arg_of_quantified_hyp h)) ] -END +END TACTIC EXTEND injection_as_main | [ "injection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> [ injClause ipat false (Some (ElimOnConstr c)) ] -END +END TACTIC EXTEND injection_as | [ "injection" "as" simple_intropattern_list(ipat)] -> [ injClause ipat false None ] | [ "injection" quantified_hypothesis(h) "as" simple_intropattern_list(ipat) ] -> [ injClause ipat false (Some (induction_arg_of_quantified_hyp h)) ] -END +END TACTIC EXTEND einjection_as_main | [ "einjection" constr_with_bindings(c) "as" simple_intropattern_list(ipat)] -> [ injClause ipat true (Some (ElimOnConstr c)) ] -END +END TACTIC EXTEND einjection_as | [ "einjection" "as" simple_intropattern_list(ipat)] -> [ injClause ipat true None ] @@ -160,7 +160,7 @@ END (* AutoRewrite *) open Autorewrite -(* J.F : old version +(* J.F : old version TACTIC EXTEND autorewrite [ "autorewrite" "with" ne_preident_list(l) ] -> [ autorewrite Refiner.tclIDTAC l ] @@ -177,8 +177,8 @@ TACTIC EXTEND autorewrite | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) ] -> [ auto_multi_rewrite l (glob_in_arg_hyp_to_clause cl) ] | [ "autorewrite" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] -> - [ - let cl = glob_in_arg_hyp_to_clause cl in + [ + let cl = glob_in_arg_hyp_to_clause cl in auto_multi_rewrite_with (snd t) l cl ] @@ -188,7 +188,7 @@ TACTIC EXTEND autorewrite_star | [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) ] -> [ auto_multi_rewrite ~conds:AllMatches l (glob_in_arg_hyp_to_clause cl) ] | [ "autorewrite" "*" "with" ne_preident_list(l) in_arg_hyp(cl) "using" tactic(t) ] -> - [ let cl = glob_in_arg_hyp_to_clause cl in + [ let cl = glob_in_arg_hyp_to_clause cl in auto_multi_rewrite_with ~conds:AllMatches (snd t) l cl ] END @@ -196,25 +196,25 @@ open Extraargs let rewrite_star clause orient occs c (tac : glob_tactic_expr option) = let tac' = Option.map (fun t -> Tacinterp.eval_tactic t, FirstSolved) tac in - general_rewrite_ebindings_clause clause orient occs ?tac:tac' (c,NoBindings) true + general_rewrite_ebindings_clause clause orient occs ?tac:tac' (c,NoBindings) true let occurrences_of = function | n::_ as nl when n < 0 -> (false,List.map abs nl) - | nl -> + | nl -> if List.exists (fun n -> n < 0) nl then error "Illegal negative occurrence number."; (true,nl) TACTIC EXTEND rewrite_star -| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> +| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> [ rewrite_star (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> +| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> [ rewrite_star (Some id) o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] -> +| [ "rewrite" "*" orient(o) open_constr(c) "in" hyp(id) by_arg_tac(tac) ] -> [ rewrite_star (Some id) o all_occurrences c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> +| [ "rewrite" "*" orient(o) open_constr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> [ rewrite_star None o (occurrences_of occ) c tac ] -| [ "rewrite" "*" orient(o) open_constr(c) by_arg_tac(tac) ] -> +| [ "rewrite" "*" orient(o) open_constr(c) by_arg_tac(tac) ] -> [ rewrite_star None o all_occurrences c tac ] END @@ -242,7 +242,7 @@ let project_hint pri l2r c = let env = Global.env() in let c = Constrintern.interp_constr Evd.empty env c in let t = Retyping.get_type_of env Evd.empty c in - let t = + let t = Tacred.reduce_to_quantified_ref env Evd.empty (Lazy.force coq_iff_ref) t in let sign,ccl = decompose_prod_assum t in let (a,b) = match snd (decompose_app ccl) with @@ -396,11 +396,11 @@ let step left x tac = (* Main function to push lemmas in persistent environment *) let cache_transitivity_lemma (_,(left,lem)) = - if left then + if left then transitivity_left_table := lem :: !transitivity_left_table else transitivity_right_table := lem :: !transitivity_right_table - + let subst_transitivity_lemma (_,subst,(b,ref)) = (b,subst_mps subst ref) let (inTransitivity,_) = @@ -408,22 +408,22 @@ let (inTransitivity,_) = cache_function = cache_transitivity_lemma; open_function = (fun i o -> if i=1 then cache_transitivity_lemma o); subst_function = subst_transitivity_lemma; - classify_function = (fun o -> Substitute o); + classify_function = (fun o -> Substitute o); export_function = (fun x -> Some x) } (* Synchronisation with reset *) let freeze () = !transitivity_left_table, !transitivity_right_table -let unfreeze (l,r) = +let unfreeze (l,r) = transitivity_left_table := l; transitivity_right_table := r -let init () = +let init () = transitivity_left_table := []; transitivity_right_table := [] -let _ = +let _ = declare_summary "transitivity-steps" { freeze_function = freeze; unfreeze_function = unfreeze; @@ -468,7 +468,7 @@ END (*spiwack : Vernac commands for retroknowledge *) VERNAC COMMAND EXTEND RetroknowledgeRegister - | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> + | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> [ let tc = Constrintern.interp_constr Evd.empty (Global.env ()) c in let tb = Constrintern.interp_constr Evd.empty (Global.env ()) b in Global.register f tc tb ] @@ -476,7 +476,7 @@ END -(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as +(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) TACTIC EXTEND generalize_eqs | ["generalize_eqs" hyp(id) ] -> [ abstract_generalize id ~generalize_vars:false ] diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml index e6130cfcdc..73aeec501d 100644 --- a/tactics/hiddentac.ml +++ b/tactics/hiddentac.ml @@ -37,7 +37,7 @@ let h_assumption = abstract_tactic TacAssumption assumption let h_exact c = abstract_tactic (TacExact (inj_open c)) (exact_check c) let h_exact_no_check c = abstract_tactic (TacExactNoCheck (inj_open c)) (exact_no_check c) -let h_vm_cast_no_check c = +let h_vm_cast_no_check c = abstract_tactic (TacVmCastNoCheck (inj_open c)) (vm_cast_no_check c) let h_apply simple ev cb = abstract_tactic (TacApply (simple,ev,List.map snd cb,None)) @@ -60,7 +60,7 @@ let h_mutual_fix b id n l = let h_cofix ido = abstract_tactic (TacCofix ido) (cofix ido) let h_mutual_cofix b id l = abstract_tactic - (TacMutualCofix (b,id,List.map (fun (id,c) -> (id,inj_open c)) l)) + (TacMutualCofix (b,id,List.map (fun (id,c) -> (id,inj_open c)) l)) (mutual_cofix id l 0) let h_cut c = abstract_tactic (TacCut (inj_open c)) (cut c) @@ -78,13 +78,13 @@ let h_let_tac b na c cl = (* Derived basic tactics *) let h_simple_induction_destruct isrec h = - abstract_tactic (TacSimpleInductionDestruct (isrec,h)) + abstract_tactic (TacSimpleInductionDestruct (isrec,h)) (if isrec then (simple_induct h) else (simple_destruct h)) let h_simple_induction = h_simple_induction_destruct true let h_simple_destruct = h_simple_induction_destruct false let h_induction_destruct isrec ev l = - abstract_tactic (TacInductionDestruct (isrec,ev,List.map (fun (c,e,idl,cl) -> + abstract_tactic (TacInductionDestruct (isrec,ev,List.map (fun (c,e,idl,cl) -> List.map inj_ia c,Option.map inj_open_wb e,idl,cl) l)) (induction_destruct ev isrec l) let h_new_induction ev c e idl cl = h_induction_destruct ev true [c,e,idl,cl] @@ -118,7 +118,7 @@ let h_simplest_left = h_left false NoBindings let h_simplest_right = h_right false NoBindings (* Conversion *) -let h_reduce r cl = +let h_reduce r cl = abstract_tactic (TacReduce (inj_red_expr r,cl)) (reduce r cl) let h_change oc c cl = abstract_tactic (TacChange (Option.map inj_occ oc,inj_open c,cl)) diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli index e0c267c071..f4da57144b 100644 --- a/tactics/hiddentac.mli +++ b/tactics/hiddentac.mli @@ -37,10 +37,10 @@ val h_exact : constr -> tactic val h_exact_no_check : constr -> tactic val h_vm_cast_no_check : constr -> tactic -val h_apply : advanced_flag -> evars_flag -> +val h_apply : advanced_flag -> evars_flag -> open_constr with_bindings located list -> tactic -val h_apply_in : advanced_flag -> evars_flag -> - open_constr with_bindings located list -> +val h_apply_in : advanced_flag -> evars_flag -> + open_constr with_bindings located list -> identifier * intro_pattern_expr located option -> tactic val h_elim : evars_flag -> constr with_ebindings -> @@ -52,15 +52,15 @@ val h_case_type : constr -> tactic val h_mutual_fix : hidden_flag -> identifier -> int -> (identifier * int * constr) list -> tactic val h_fix : identifier option -> int -> tactic -val h_mutual_cofix : hidden_flag -> identifier -> +val h_mutual_cofix : hidden_flag -> identifier -> (identifier * constr) list -> tactic val h_cofix : identifier option -> tactic -val h_cut : constr -> tactic -val h_generalize : constr list -> tactic -val h_generalize_gen : (constr with_occurrences * name) list -> tactic -val h_generalize_dep : constr -> tactic -val h_let_tac : letin_flag -> name -> constr -> +val h_cut : constr -> tactic +val h_generalize : constr list -> tactic +val h_generalize_gen : (constr with_occurrences * name) list -> tactic +val h_generalize_dep : constr -> tactic +val h_let_tac : letin_flag -> name -> constr -> Tacticals.clause -> tactic (* Derived basic tactics *) @@ -68,16 +68,16 @@ val h_let_tac : letin_flag -> name -> constr -> val h_simple_induction : quantified_hypothesis -> tactic val h_simple_destruct : quantified_hypothesis -> tactic val h_simple_induction_destruct : rec_flag -> quantified_hypothesis -> tactic -val h_new_induction : evars_flag -> +val h_new_induction : evars_flag -> constr with_ebindings induction_arg list -> constr with_ebindings option -> intro_pattern_expr located option * intro_pattern_expr located option -> Tacticals.clause option -> tactic -val h_new_destruct : evars_flag -> - constr with_ebindings induction_arg list -> constr with_ebindings option -> +val h_new_destruct : evars_flag -> + constr with_ebindings induction_arg list -> constr with_ebindings option -> intro_pattern_expr located option * intro_pattern_expr located option -> Tacticals.clause option -> tactic val h_induction_destruct : rec_flag -> evars_flag -> - (constr with_ebindings induction_arg list * constr with_ebindings option * + (constr with_ebindings induction_arg list * constr with_ebindings option * (intro_pattern_expr located option * intro_pattern_expr located option) * Tacticals.clause option) list -> tactic @@ -115,8 +115,8 @@ val h_reflexivity : tactic val h_symmetry : Tacticals.clause -> tactic val h_transitivity : constr option -> tactic -val h_simplest_apply : constr -> tactic -val h_simplest_eapply : constr -> tactic +val h_simplest_apply : constr -> tactic +val h_simplest_eapply : constr -> tactic val h_simplest_elim : constr -> tactic val h_simplest_case : constr -> tactic diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index bf34a5598f..b2824fbfbc 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -32,10 +32,10 @@ open Declarations is an inductive but non-recursive type, a general conjuction, a general disjunction, or a type with no constructors. - They are more general than matching with or_term, and_term, etc, - since they do not depend on the name of the type. Hence, they + They are more general than matching with or_term, and_term, etc, + since they do not depend on the name of the type. Hence, they also work on ad-hoc disjunctions introduced by the user. - + -- Eduardo (6/8/97). *) type 'a matching_function = constr -> 'a option @@ -50,16 +50,16 @@ let meta4 = mkmeta 4 let op2bool = function Some _ -> true | None -> false -let match_with_non_recursive_type t = - match kind_of_term t with - | App _ -> +let match_with_non_recursive_type t = + match kind_of_term t with + | App _ -> let (hdapp,args) = decompose_app t in (match kind_of_term hdapp with - | Ind ind -> - if not (Global.lookup_mind (fst ind)).mind_finite then - Some (hdapp,args) - else - None + | Ind ind -> + if not (Global.lookup_mind (fst ind)).mind_finite then + Some (hdapp,args) + else + None | _ -> None) | _ -> None @@ -69,34 +69,34 @@ let is_non_recursive_type t = op2bool (match_with_non_recursive_type t) let rec has_nodep_prod_after n c = match kind_of_term c with - | Prod (_,_,b) -> - ( n>0 || not (dependent (mkRel 1) b)) + | Prod (_,_,b) -> + ( n>0 || not (dependent (mkRel 1) b)) && (has_nodep_prod_after (n-1) b) | _ -> true - + let has_nodep_prod = has_nodep_prod_after 0 -(* A general conjunctive type is a non-recursive with-no-indices inductive +(* A general conjunctive type is a non-recursive with-no-indices inductive type with only one constructor and no dependencies between argument; - it is strict if it has the form + it is strict if it has the form "Inductive I A1 ... An := C (_:A1) ... (_:An)" *) (* style: None = record; Some false = conjunction; Some true = strict conj *) let match_with_one_constructor style allow_rec t = - let (hdapp,args) = decompose_app t in + let (hdapp,args) = decompose_app t in match kind_of_term hdapp with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in if (Array.length mip.mind_consnames = 1) && (allow_rec or not (mis_is_recursive (ind,mib,mip))) && (mip.mind_nrealargs = 0) then if style = Some true (* strict conjunction *) then - let ctx = - (prod_assum (snd + let ctx = + (prod_assum (snd (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in - if + if List.for_all (fun (_,b,c) -> b=None && c = mkRel mib.mind_nparams) ctx then @@ -126,7 +126,7 @@ let is_conjunction ?(strict=false) t = let is_record t = op2bool (match_with_record t) -let match_with_tuple t = +let match_with_tuple t = let t = match_with_one_constructor None true t in Option.map (fun (hd,l) -> let ind = destInd hd in @@ -137,9 +137,9 @@ let match_with_tuple t = let is_tuple t = op2bool (match_with_tuple t) -(* A general disjunction type is a non-recursive with-no-indices inductive +(* A general disjunction type is a non-recursive with-no-indices inductive type with of which all constructors have a single argument; - it is strict if it has the form + it is strict if it has the form "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *) let test_strict_disjunction n lc = @@ -149,7 +149,7 @@ let test_strict_disjunction n lc = | _ -> false) 0 lc let match_with_disjunction ?(strict=false) t = - let (hdapp,args) = decompose_app t in + let (hdapp,args) = decompose_app t in match kind_of_term hdapp with | Ind ind -> let car = mis_constr_nargs ind in @@ -167,7 +167,7 @@ let match_with_disjunction ?(strict=false) t = Array.map (fun ar -> pi2 (destProd (prod_applist ar args))) mip.mind_nf_lc in Some (hdapp,Array.to_list cargs) - else + else None | _ -> None @@ -180,12 +180,12 @@ let is_disjunction ?(strict=false) t = let match_with_empty_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in - let nconstr = Array.length mip.mind_consnames in + let nconstr = Array.length mip.mind_consnames in if nconstr = 0 then Some hdapp else None | _ -> None - + let is_empty_type t = op2bool (match_with_empty_type t) (* This filters inductive types with one constructor with no arguments; @@ -194,14 +194,14 @@ let is_empty_type t = op2bool (match_with_empty_type t) let match_with_unit_or_eq_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in - let constr_types = mip.mind_nf_lc in + let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in - let zero_args c = nb_prod c = mib.mind_nparams in - if nconstr = 1 && zero_args constr_types.(0) then + let zero_args c = nb_prod c = mib.mind_nparams in + if nconstr = 1 && zero_args constr_types.(0) then Some hdapp - else + else None | _ -> None @@ -249,7 +249,7 @@ let match_with_equation t = HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) else let (mib,mip) = Global.lookup_inductive ind in - let constr_types = mip.mind_nf_lc in + let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in if nconstr = 1 then if is_matching coq_refl_leibniz1_pattern constr_types.(0) then @@ -265,13 +265,13 @@ let match_with_equation t = let match_with_equality_type t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind when args <> [] -> + | Ind ind when args <> [] -> let (mib,mip) = Global.lookup_inductive ind in let nconstr = Array.length mip.mind_consnames in if nconstr = 1 && constructor_nrealargs (Global.env()) (ind,1) = 0 - then + then Some (hdapp,args) - else + else None | _ -> None @@ -282,34 +282,34 @@ let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ] let match_arrow_pattern t = match matches coq_arrow_pattern t with | [(m1,arg);(m2,mind)] -> assert (m1=meta1 & m2=meta2); (arg, mind) - | _ -> anomaly "Incorrect pattern matching" + | _ -> anomaly "Incorrect pattern matching" let match_with_nottype t = try let (arg,mind) = match_arrow_pattern t in if is_empty_type mind then Some (mind,arg) else None - with PatternMatchingFailure -> None + with PatternMatchingFailure -> None let is_nottype t = op2bool (match_with_nottype t) - + let match_with_forall_term c= match kind_of_term c with | Prod (nam,a,b) -> Some (nam,a,b) | _ -> None -let is_forall_term c = op2bool (match_with_forall_term c) +let is_forall_term c = op2bool (match_with_forall_term c) let match_with_imp_term c= match kind_of_term c with | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b) | _ -> None -let is_imp_term c = op2bool (match_with_imp_term c) +let is_imp_term c = op2bool (match_with_imp_term c) let match_with_nodep_ind t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in if Array.length (mib.mind_packets)>1 then None else let nodep_constr = has_nodep_prod_after mib.mind_nparams in @@ -318,24 +318,24 @@ let match_with_nodep_ind t = if mip.mind_nrealargs=0 then args else fst (list_chop mib.mind_nparams args) in Some (hdapp,params,mip.mind_nrealargs) - else + else None | _ -> None - + let is_nodep_ind t=op2bool (match_with_nodep_ind t) let match_with_sigma_type t= let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in if (Array.length (mib.mind_packets)=1) && (mip.mind_nrealargs=0) && (Array.length mip.mind_consnames=1) && has_nodep_prod_after (mib.mind_nparams+1) mip.mind_nf_lc.(0) then - (*allowing only 1 existential*) + (*allowing only 1 existential*) Some (hdapp,args) - else + else None | _ -> None @@ -377,7 +377,7 @@ let find_eq_data eqn = (* fails with PatternMatchingFailure *) first_match (match_eq eqn) equalities let extract_eq_args gl = function - | MonomorphicLeibnizEq (e1,e2) -> + | MonomorphicLeibnizEq (e1,e2) -> let t = Tacmach.pf_type_of gl e1 in (t,e1,e2) | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2) | HeterogenousEq (t1,e1,t2,e2) -> @@ -389,13 +389,13 @@ let find_eq_data_decompose gl eqn = (lbeq,extract_eq_args gl eq_args) let find_this_eq_data_decompose gl eqn = - let (lbeq,eq_args) = + let (lbeq,eq_args) = try find_eq_data eqn with PatternMatchingFailure -> errorlabstrm "" (str "No primitive equality found.") in let eq_args = try extract_eq_args gl eq_args - with PatternMatchingFailure -> + with PatternMatchingFailure -> error "Don't know what to do with JMeq on arguments not of same type." in (lbeq,eq_args) @@ -430,7 +430,7 @@ let match_sigma ex ex_pat = anomaly "match_sigma: a successful sigma pattern should match 4 terms" let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) - first_match (match_sigma ex) + first_match (match_sigma ex) [coq_existT_pattern, build_sigma_type] (* Pattern "(sig ?1 ?2)" *) @@ -468,14 +468,14 @@ let op_sum = coq_sumbool_ref let match_eqdec t = let eqonleft,op,subst = try true,op_sum,matches (Lazy.force coq_eqdec_inf_pattern) t - with PatternMatchingFailure -> + with PatternMatchingFailure -> try false,op_sum,matches (Lazy.force coq_eqdec_inf_rev_pattern) t - with PatternMatchingFailure -> + with PatternMatchingFailure -> try true,op_or,matches (Lazy.force coq_eqdec_pattern) t - with PatternMatchingFailure -> + with PatternMatchingFailure -> false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in match subst with - | [(_,typ);(_,c1);(_,c2)] -> + | [(_,typ);(_,c1);(_,c2)] -> eqonleft, Libnames.constr_of_global (Lazy.force op), c1, c2, typ | _ -> anomaly "Unexpected pattern" diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 3f5411e00f..001755b1ea 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -42,8 +42,8 @@ open Coqlib is an inductive but non-recursive type, a general conjuction, a general disjunction, or a type with no constructors. - They are more general than matching with [or_term], [and_term], etc, - since they do not depend on the name of the type. Hence, they + They are more general than matching with [or_term], [and_term], etc, + since they do not depend on the name of the type. Hence, they also work on ad-hoc disjunctions introduced by the user. (Eduardo, 6/8/97). *) @@ -51,49 +51,49 @@ type 'a matching_function = constr -> 'a option type testing_function = constr -> bool val match_with_non_recursive_type : (constr * constr list) matching_function -val is_non_recursive_type : testing_function +val is_non_recursive_type : testing_function (* Non recursive type with no indices and exactly one argument for each constructor; canonical definition of n-ary disjunction if strict *) val match_with_disjunction : ?strict:bool -> (constr * constr list) matching_function -val is_disjunction : ?strict:bool -> testing_function +val is_disjunction : ?strict:bool -> testing_function (* Non recursive tuple (one constructor and no indices) with no inner dependencies; canonical definition of n-ary conjunction if strict *) val match_with_conjunction : ?strict:bool -> (constr * constr list) matching_function -val is_conjunction : ?strict:bool -> testing_function +val is_conjunction : ?strict:bool -> testing_function (* Non recursive tuple, possibly with inner dependencies *) val match_with_record : (constr * constr list) matching_function -val is_record : testing_function +val is_record : testing_function (* Like record but supports and tells if recursive (e.g. Acc) *) val match_with_tuple : (constr * constr list * bool) matching_function -val is_tuple : testing_function +val is_tuple : testing_function (* No constructor, possibly with indices *) val match_with_empty_type : constr matching_function -val is_empty_type : testing_function +val is_empty_type : testing_function (* type with only one constructor and no arguments, possibly with indices *) val match_with_unit_or_eq_type : constr matching_function -val is_unit_or_eq_type : testing_function +val is_unit_or_eq_type : testing_function (* type with only one constructor and no arguments, no indices *) -val is_unit_type : testing_function +val is_unit_type : testing_function (* type with only one constructor, no arguments and at least one dependency *) val match_with_equality_type : (constr * constr list) matching_function val is_equality_type : testing_function val match_with_nottype : (constr * constr) matching_function -val is_nottype : testing_function +val is_nottype : testing_function val match_with_forall_term : (name * constr * constr) matching_function -val is_forall_term : testing_function +val is_forall_term : testing_function val match_with_imp_term : (constr * constr) matching_function -val is_imp_term : testing_function +val is_imp_term : testing_function (* I added these functions to test whether a type contains dependent products or not, and if an inductive has constructors with dependent types @@ -103,11 +103,11 @@ val is_imp_term : testing_function val has_nodep_prod_after : int -> testing_function val has_nodep_prod : testing_function -val match_with_nodep_ind : (constr * constr list * int) matching_function -val is_nodep_ind : testing_function +val match_with_nodep_ind : (constr * constr list * int) matching_function +val is_nodep_ind : testing_function -val match_with_sigma_type : (constr * constr list) matching_function -val is_sigma_type : testing_function +val match_with_sigma_type : (constr * constr list) matching_function +val is_sigma_type : testing_function (* Recongnize inductive relation defined by reflexivity *) @@ -125,11 +125,11 @@ val match_with_equation: (* Match terms [eq A t u], [identity A t u] or [JMeq A t A u] *) (* Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) -val find_eq_data_decompose : Proof_type.goal sigma -> constr -> +val find_eq_data_decompose : Proof_type.goal sigma -> constr -> coq_eq_data * (types * constr * constr) (* Idem but fails with an error message instead of PatternMatchingFailure *) -val find_this_eq_data_decompose : Proof_type.goal sigma -> constr -> +val find_this_eq_data_decompose : Proof_type.goal sigma -> constr -> coq_eq_data * (types * constr * constr) (* A variant that returns more informative structure on the equality found *) @@ -137,7 +137,7 @@ val find_eq_data : constr -> coq_eq_data * equation_kind (* Match a term of the form [(existT A P t p)] *) (* Returns associated lemmas and [A,P,t,p] *) -val find_sigma_data_decompose : constr -> +val find_sigma_data_decompose : constr -> coq_sigma_data * (constr * constr * constr * constr) (* Match a term of the form [{x:A|P}], returns [A] and [P] *) diff --git a/tactics/inv.ml b/tactics/inv.ml index ae76e6b26e..5a1fb6eeeb 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -37,18 +37,18 @@ open Rawterm open Genarg open Tacexpr -let collect_meta_variables c = +let collect_meta_variables c = let rec collrec acc c = match kind_of_term c with | Meta mv -> mv::acc | _ -> fold_constr collrec acc c - in + in collrec [] c let check_no_metas clenv ccl = if occur_meta ccl then let metas = List.filter (fun na -> na<>Anonymous) (List.map (Evd.meta_name clenv.evd) (collect_meta_variables ccl)) in - errorlabstrm "inversion" + errorlabstrm "inversion" (str ("Cannot find an instantiation for variable"^ (if List.length metas = 1 then " " else "s ")) ++ prlist_with_sep pr_coma pr_name metas @@ -60,7 +60,7 @@ let var_occurs_in_pf gl id = List.exists (occur_var_in_decl env id) (pf_hyps gl) (* [make_inv_predicate (ity,args) C] - + is given the inductive type, its arguments, both the global parameters and its local arguments, and is expected to produce a predicate P such that if largs is the "local" part of the @@ -130,13 +130,13 @@ let make_inv_predicate env sigma indf realargs id status concl = | [] -> (it_mkProd concl eqns,n) | (ai,(xi,ti))::restlist -> let (lhs,eqnty,rhs) = - if closed0 ti then + if closed0 ti then (xi,ti,ai) - else + else make_iterated_tuple env' sigma ai (xi,ti) in let eq_term = Coqlib.build_coq_eq () in - let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in + let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist in let (newconcl,neqns) = build_concl [] 0 pairs in @@ -188,21 +188,21 @@ let make_inv_predicate env sigma indf realargs id status concl = it generalizes them, applies tac to rewrite all occurrencies of t, and introduces generalized hypotheis. Precondition: t=(mkVar id) *) - -let rec dependent_hyps id idlist gl = + +let rec dependent_hyps id idlist gl = let rec dep_rec =function | [] -> [] - | (id1,_,_)::l -> + | (id1,_,_)::l -> (* Update the type of id1: it may have been subject to rewriting *) let d = pf_get_hyp gl id1 in if occur_var_in_decl (Global.env()) id d then d :: dep_rec l else dep_rec l - in - dep_rec idlist + in + dep_rec idlist let split_dep_and_nodep hyps gl = - List.fold_right + List.fold_right (fun (id,_,_ as d) (l1,l2) -> if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2)) hyps ([],[]) @@ -280,17 +280,17 @@ Summary: nine useless hypotheses! Nota: with Inversion_clear, only four useless hypotheses *) -let generalizeRewriteIntros tac depids id gls = +let generalizeRewriteIntros tac depids id gls = let dids = dependent_hyps id depids gls in (tclTHENSEQ - [bring_hyps dids; tac; + [bring_hyps dids; tac; (* may actually fail to replace if dependent in a previous eq *) intros_replacing (ids_of_named_context dids)]) gls let rec tclMAP_i n tacfun = function | [] -> tclDO n (tacfun None) - | a::l -> + | a::l -> if n=0 then error "Too much names." else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l) @@ -317,7 +317,7 @@ let projectAndApply thin id eqname names depids gls = | _ -> tac id gls in let deq_trailer id neqns = - tclTHENSEQ + tclTHENSEQ [(if names <> [] then clear [id] else tclIDTAC); (tclMAP_i neqns (fun idopt -> tclTHEN @@ -349,7 +349,7 @@ let rewrite_equations_gene othin neqns ba gl = (tclTHEN intro (onLastHypId (fun id -> - tclTRY + tclTRY (projectAndApply thin id (ref no_move) [] depids)))); onHyps (compose List.rev (afterHyp last)) bring_hyps; @@ -384,7 +384,7 @@ let rec get_names allow_conj (loc,pat) = match pat with error "Fresh pattern not allowed for inversion equations." | IntroRewrite _-> error "Rewriting pattern not allowed for inversion equations." - | IntroOrAndPattern [l] -> + | IntroOrAndPattern [l] -> if allow_conj then if l = [] then (None,[]) else let l = List.map (fun id -> Option.get (fst (get_names false id))) l in @@ -440,18 +440,18 @@ let rewrite_equations_tac (gene, othin) id neqns names ba = let tac = if gene then rewrite_equations_gene othin neqns ba else rewrite_equations othin neqns names ba in - if othin = Some true (* if Inversion_clear, clear the hypothesis *) then + if othin = Some true (* if Inversion_clear, clear the hypothesis *) then tclTHEN tac (tclTRY (clear [id])) - else + else tac let raw_inversion inv_kind id status names gl = let env = pf_env gl and sigma = project gl in let c = mkVar id in - let (ind,t) = + let (ind,t) = try pf_reduce_to_atomic_ind gl (pf_type_of gl c) - with UserError _ -> + with UserError _ -> errorlabstrm "raw_inversion" (str ("The type of "^(string_of_id id)^" is not inductive.")) in let indclause = mk_clenv_from gl (c,t) in @@ -461,16 +461,16 @@ let raw_inversion inv_kind id status names gl = let (elim_predicate,neqns) = make_inv_predicate env sigma indf realargs id status (pf_concl gl) in let (cut_concl,case_tac) = - if status <> NoDep & (dependent c (pf_concl gl)) then + if status <> NoDep & (dependent c (pf_concl gl)) then Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), - case_then_using - else + case_then_using + else Reduction.beta_appvect elim_predicate (Array.of_list realargs), - case_nodep_then_using + case_nodep_then_using in (tclTHENS (assert_tac Anonymous cut_concl) - [case_tac names + [case_tac names (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns)) (Some elim_predicate) ([],[]) ind indclause; onLastHypId @@ -487,7 +487,7 @@ let wrap_inv_error id = function (Indrec.NotAllowedCaseAnalysis (_,(Type _ | Prop Pos as k),i)) -> errorlabstrm "" (strbrk "Inversion would require case analysis on sort " ++ - pr_sort k ++ + pr_sort k ++ strbrk " which is not allowed for inductive definition " ++ pr_inductive (Global.env()) i ++ str ".") | e -> raise e @@ -526,16 +526,16 @@ let invIn k names ids id gls = let intros_replace_ids gls = let nb_of_new_hyp = nb_prod (pf_concl gls) - (List.length hyps + nb_prod_init) - in - if nb_of_new_hyp < 1 then + in + if nb_of_new_hyp < 1 then intros_replacing ids gls - else + else tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) gls in - try + try (tclTHENSEQ [bring_hyps hyps; - inversion (false,k) NoDep names id; + inversion (false,k) NoDep names id; intros_replace_ids]) gls with e -> wrap_inv_error id e diff --git a/tactics/inv.mli b/tactics/inv.mli index 322e139f06..8ec0e2db24 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -24,7 +24,7 @@ val inv_gen : bool -> inversion_kind -> inversion_status -> intro_pattern_expr located option -> quantified_hypothesis -> tactic val invIn_gen : - inversion_kind -> intro_pattern_expr located option -> identifier list -> + inversion_kind -> intro_pattern_expr located option -> identifier list -> quantified_hypothesis -> tactic val inv_clause : diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 9a39b22723..c2be67d750 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -39,7 +39,7 @@ open Decl_kinds let not_work_message = "tactic fails to build the inversion lemma, may be because the predicate has arguments that depend on other arguments" let no_inductive_inconstr env constr = - (str "Cannot recognize an inductive predicate in " ++ + (str "Cannot recognize an inductive predicate in " ++ pr_lconstr_env env constr ++ str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++ spc () ++ str "or of the type of constructors" ++ spc () ++ @@ -87,7 +87,7 @@ let no_inductive_inconstr env constr = the respective assumption in each subgoal. *) - + let thin_ids env (hyps,vars) = fst (List.fold_left @@ -106,16 +106,16 @@ let thin_ids env (hyps,vars) = let get_local_sign sign = let lid = ids_of_sign sign in let globsign = Global.named_context() in - let add_local id res_sign = - if not (mem_sign globsign id) then + let add_local id res_sign = + if not (mem_sign globsign id) then add_sign (lookup_sign id sign) res_sign - else + else res_sign - in + in List.fold_right add_local lid nil_sign *) (* returs the identifier of lid that was the latest declared in sign. - * (i.e. is the identifier id of lid such that + * (i.e. is the identifier id of lid such that * sign_length (sign_prefix id sign) > sign_length (sign_prefix id' sign) > * for any id'<>id in lid). * it returns both the pair (id,(sign_prefix id sign)) *) @@ -123,14 +123,14 @@ let get_local_sign sign = let max_prefix_sign lid sign = let rec max_rec (resid,prefix) = function | [] -> (resid,prefix) - | (id::l) -> - let pre = sign_prefix id sign in - if sign_length pre > sign_length prefix then + | (id::l) -> + let pre = sign_prefix id sign in + if sign_length pre > sign_length prefix then max_rec (id,pre) l - else + else max_rec (resid,prefix) l in - match lid with + match lid with | [] -> nil_sign | id::l -> snd (max_rec (id, sign_prefix id sign) l) *) @@ -148,14 +148,14 @@ let rec add_prods_sign env sigma t = (* [dep_option] indicates wether the inversion lemma is dependent or not. If it is dependent and I is of the form (x_bar:T_bar)(I t_bar) then - the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) + the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) where P:(x_bar:T_bar)(H:(I x_bar))[sort]. The generalisation of such a goal at the moment of the dependent case should be easy. If it is non dependent, then if [I]=(I t_bar) and (x_bar:T_bar) are the variables occurring in [I], then the stated goal will be: - (x_bar:T_bar)(I t_bar)->(P x_bar) + (x_bar:T_bar)(I t_bar)->(P x_bar) where P: P:(x_bar:T_bar)[sort]. *) @@ -166,7 +166,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let pty,goal = if dep_option then let pty = make_arity env true indf sort in - let goal = + let goal = mkProd (Anonymous, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) in @@ -177,11 +177,11 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let revargs,ownsign = fold_named_context (fun env (id,_,_ as d) (revargs,hyps) -> - if List.mem id ivars then + if List.mem id ivars then ((mkVar id)::revargs,add_named_decl d hyps) - else + else (revargs,hyps)) - env ~init:([],[]) + env ~init:([],[]) in let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in @@ -203,14 +203,14 @@ let inversion_scheme env sigma t sort dep_option inv_op = let ind = try find_rectype env sigma i with Not_found -> - errorlabstrm "inversion_scheme" (no_inductive_inconstr env i) + errorlabstrm "inversion_scheme" (no_inductive_inconstr env i) in let (invEnv,invGoal) = - compute_first_inversion_scheme env sigma ind sort dep_option + compute_first_inversion_scheme env sigma ind sort dep_option in - assert - (list_subset - (global_vars env invGoal) + assert + (list_subset + (global_vars env invGoal) (ids_of_named_context (named_context invEnv))); (* errorlabstrm "lemma_inversion" @@ -226,7 +226,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = (fun env (id,_,_ as d) sign -> if mem_named_context id global_named_context then sign else add_named_decl d sign) - invEnv ~init:empty_named_context + invEnv ~init:empty_named_context in let (_,ownSign,mvb) = List.fold_left @@ -234,23 +234,23 @@ let inversion_scheme env sigma t sort dep_option inv_op = let h = next_ident_away (id_of_string "H") avoid in (h::avoid, add_named_decl (h,None,mvty) sign, (mv,mkVar h)::mvb)) (ids_of_context invEnv, ownSign, []) - meta_types + meta_types in - let invProof = + let invProof = it_mkNamedLambda_or_LetIn - (local_strong (fun _ -> whd_meta mvb) Evd.empty pfterm) ownSign + (local_strong (fun _ -> whd_meta mvb) Evd.empty pfterm) ownSign in invProof let add_inversion_lemma name env sigma t sort dep inv_op = let invProof = inversion_scheme env sigma t sort dep inv_op in - let _ = + let _ = declare_constant name - (DefinitionEntry + (DefinitionEntry { const_entry_body = invProof; const_entry_type = None; const_entry_opaque = false; - const_entry_boxed = true && (Flags.boxed_definitions())}, + const_entry_boxed = true && (Flags.boxed_definitions())}, IsProof Lemma) in () @@ -262,11 +262,11 @@ let add_inversion_lemma name env sigma t sort dep inv_op = let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op = let pts = get_pftreestate() in let gl = nth_goal_of_pftreestate n pts in - let t = + let t = try pf_get_hyp_typ gl id with Not_found -> Pretype_errors.error_var_not_found_loc loc id in let env = pf_env gl and sigma = project gl in -(* Pourquoi ??? +(* Pourquoi ??? let fv = global_vars env t in let thin_ids = thin_ids (hyps,fv) in if not(list_subset thin_ids fv) then @@ -275,14 +275,14 @@ let inversion_lemma_from_goal n na (loc,id) sort dep_option inv_op = str"free variables in the types of an inductive" ++ spc () ++ str"which are not free in its instance."); *) add_inversion_lemma na env sigma t sort dep_option inv_op - + let add_inversion_lemma_exn na com comsort bool tac = let env = Global.env () and sigma = Evd.empty in let c = Constrintern.interp_type sigma env com in let sort = Pretyping.interp_sort comsort in try add_inversion_lemma na env sigma c sort bool tac - with + with | UserError ("Case analysis",s) -> (* référence à Indrec *) errorlabstrm "Inv needs Nodep Prop Set" s @@ -295,23 +295,23 @@ let lemInv id c gls = let clause = mk_clenv_type_of gls c in let clause = clenv_constrain_last_binding (mkVar id) clause in Clenvtac.res_pf clause ~allow_K:true gls - with - | UserError (a,b) -> - errorlabstrm "LemInv" - (str "Cannot refine current goal with the lemma " ++ - pr_lconstr_env (Global.env()) c) + with + | UserError (a,b) -> + errorlabstrm "LemInv" + (str "Cannot refine current goal with the lemma " ++ + pr_lconstr_env (Global.env()) c) let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id let lemInvIn id c ids gls = let hyps = List.map (pf_get_hyp gls) ids in let intros_replace_ids gls = - let nb_of_new_hyp = nb_prod (pf_concl gls) - List.length ids in - if nb_of_new_hyp < 1 then + let nb_of_new_hyp = nb_prod (pf_concl gls) - List.length ids in + if nb_of_new_hyp < 1 then intros_replacing ids gls - else + else (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)) gls - in + in ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c)) (intros_replace_ids)) gls) diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 3e12f770e1..b4b5737b5f 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -8,7 +8,7 @@ open Topconstr val lemInv_gen : quantified_hypothesis -> constr -> tactic val lemInvIn_gen : quantified_hypothesis -> constr -> identifier list -> tactic -val lemInv_clause : +val lemInv_clause : quantified_hypothesis -> constr -> identifier list -> tactic val inversion_lemma_from_goal : diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml index 431748868c..4e72d07080 100644 --- a/tactics/nbtermdn.ml +++ b/tactics/nbtermdn.ml @@ -31,7 +31,7 @@ type ('na,'a) t = { mutable table : ('na,constr_pattern * 'a) Gmap.t; mutable patterns : (global_reference option,'a Btermdn.t) Gmap.t } -type ('na,'a) frozen_t = +type ('na,'a) frozen_t = ('na,constr_pattern * 'a) Gmap.t * (global_reference option,'a Btermdn.t) Gmap.t @@ -43,46 +43,46 @@ let get_dn dnm hkey = try Gmap.find hkey dnm with Not_found -> Btermdn.create () let add dn (na,(pat,valu)) = - let hkey = Option.map fst (Termdn.constr_pat_discr pat) in + let hkey = Option.map fst (Termdn.constr_pat_discr pat) in dn.table <- Gmap.add na (pat,valu) dn.table; let dnm = dn.patterns in dn.patterns <- Gmap.add hkey (Btermdn.add None (get_dn dnm hkey) (pat,valu)) dnm - + let rmv dn na = let (pat,valu) = Gmap.find na dn.table in - let hkey = Option.map fst (Termdn.constr_pat_discr pat) in + let hkey = Option.map fst (Termdn.constr_pat_discr pat) in dn.table <- Gmap.remove na dn.table; let dnm = dn.patterns in dn.patterns <- Gmap.add hkey (Btermdn.rmv None (get_dn dnm hkey) (pat,valu)) dnm let in_dn dn na = Gmap.mem na dn.table - + let remap ndn na (pat,valu) = rmv ndn na; add ndn (na,(pat,valu)) let lookup dn valu = - let hkey = - match (Termdn.constr_val_discr valu) with + let hkey = + match (Termdn.constr_val_discr valu) with | Dn.Label(l,_) -> Some l | _ -> None - in + in try Btermdn.lookup None (Gmap.find hkey dn.patterns) valu with Not_found -> [] let app f dn = Gmap.iter f dn.table - + let dnet_depth = Btermdn.dnet_depth - + let freeze dn = (dn.table, dn.patterns) let unfreeze (fnm,fdnm) dn = dn.table <- fnm; dn.patterns <- fdnm -let empty dn = +let empty dn = dn.table <- Gmap.empty; dn.patterns <- Gmap.empty -let to2lists dn = +let to2lists dn = (Gmap.to_list dn.table, Gmap.to_list dn.patterns) diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli index 8665cc7057..350b53df71 100644 --- a/tactics/nbtermdn.mli +++ b/tactics/nbtermdn.mli @@ -34,5 +34,5 @@ val dnet_depth : int ref val freeze : ('na,'a) t -> ('na,'a) frozen_t val unfreeze : ('na,'a) frozen_t -> ('na,'a) t -> unit val empty : ('na,'a) t -> unit -val to2lists : ('na,'a) t -> ('na * (constr_pattern * 'a)) list * +val to2lists : ('na,'a) t -> ('na * (constr_pattern * 'a)) list * (global_reference option * 'a Btermdn.t) list diff --git a/tactics/refine.ml b/tactics/refine.ml index ff644c1432..5258b319b3 100644 --- a/tactics/refine.ml +++ b/tactics/refine.ml @@ -16,7 +16,7 @@ * où les trous sont typés -- et que les sous-buts correspondants * soient engendrés pour finir la preuve. * - * Exemple : + * Exemple : * J'ai le but * (x:nat) { y:nat | (minus y x) = x } * et je donne la preuve incomplète @@ -70,12 +70,12 @@ let rec pp_th (TH(c,mm,sg)) = (* pp_mm mm ++ fnl () ++ *) pp_sg sg) ++ str "]") and pp_mm l = - hov 0 (prlist_with_sep (fun _ -> (fnl ())) + hov 0 (prlist_with_sep (fun _ -> (fnl ())) (fun (n,c) -> (int n ++ str" --> " ++ pr_lconstr c)) l) and pp_sg sg = hov 0 (prlist_with_sep (fun _ -> (fnl ())) (function None -> (str"None") | Some th -> (pp_th th)) sg) - + (* compute_metamap : constr -> 'a evar_map -> term_with_holes * réalise le 2. ci-dessus * @@ -84,7 +84,7 @@ and pp_sg sg = * par un terme de preuve incomplet (Some c). * * On a donc l'INVARIANT suivant : le terme c rendu est "de niveau 1" - * -- i.e. à plat -- et la meta_map contient autant d'éléments qu'il y + * -- i.e. à plat -- et la meta_map contient autant d'éléments qu'il y * a de meta-variables dans c. On suppose de plus que l'ordre dans la * meta_map correspond à celui des buts qui seront engendrés par le refine. *) @@ -108,7 +108,7 @@ let replace_by_meta env sigma = function (* | Fix ((_,j),(v,_,_)) -> v.(j) (* en pleine confiance ! *) - | _ -> invalid_arg "Tcc.replace_by_meta (TO DO)" + | _ -> invalid_arg "Tcc.replace_by_meta (TO DO)" *) in mkCast (m,DEFAULTcast, ty),[n,ty],[Some th] @@ -120,13 +120,13 @@ let replace_in_array keep_length env sigma a = raise NoMeta; let a' = Array.map (function | (TH (c,mm,[])) when not keep_length -> c,mm,[] - | th -> replace_by_meta env sigma th) a + | th -> replace_by_meta env sigma th) a in let v' = Array.map pi1 a' in let mm = Array.fold_left (@) [] (Array.map pi2 a') in let sgp = Array.fold_left (@) [] (Array.map pi3 a') in v',mm,sgp - + let fresh env n = let id = match n with Name x -> x | _ -> id_of_string "_H" in next_global_ident_away true id (ids_of_named_context (named_context env)) @@ -134,14 +134,14 @@ let fresh env n = let rec compute_metamap env sigma c = match kind_of_term c with (* le terme est directement une preuve *) | (Const _ | Evar _ | Ind _ | Construct _ | - Sort _ | Var _ | Rel _) -> + Sort _ | Var _ | Rel _) -> TH (c,[],[]) (* le terme est une mv => un but *) | Meta n -> TH (c,[],[None]) - | Cast (m,_, ty) when isMeta m -> + | Cast (m,_, ty) when isMeta m -> TH (c,[destMeta m,ty],[None]) @@ -154,7 +154,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with begin match compute_metamap env' sigma (subst1 (mkVar v) c2) with (* terme de preuve complet *) | TH (_,_,[]) -> TH (c,[],[]) - (* terme de preuve incomplet *) + (* terme de preuve incomplet *) | th -> let m,mm,sgp = replace_by_meta env' sigma th in TH (mkLambda (Name v,c1,m), mm, sgp) @@ -168,13 +168,13 @@ let rec compute_metamap env sigma c = match kind_of_term c with begin match th1,th2 with (* terme de preuve complet *) | TH (_,_,[]), TH (_,_,[]) -> TH (c,[],[]) - (* terme de preuve incomplet *) + (* terme de preuve incomplet *) | TH (c1,mm1,sgp1), TH (c2,mm2,sgp2) -> let m1,mm1,sgp1 = - if sgp1=[] then (c1,mm1,[]) + if sgp1=[] then (c1,mm1,[]) else replace_by_meta env sigma th1 in let m2,mm2,sgp2 = - if sgp2=[] then (c2,mm2,[]) + if sgp2=[] then (c2,mm2,[]) else replace_by_meta env' sigma th2 in TH (mkNamedLetIn v m1 t1 m2, mm1@mm2, sgp1@sgp2) end @@ -213,7 +213,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with let env' = push_named_rec_types (fi',ai,v) env in let a = Array.map (compute_metamap env' sigma) - (Array.map (substl (List.map mkVar (Array.to_list vi))) v) + (Array.map (substl (List.map mkVar (Array.to_list vi))) v) in begin try @@ -223,12 +223,12 @@ let rec compute_metamap env sigma c = match kind_of_term c with with NoMeta -> TH (c,[],[]) end - + (* Cast. Est-ce bien exact ? *) | Cast (c,_,t) -> compute_metamap env sigma c (*let TH (c',mm,sgp) = compute_metamap sign c in TH (mkCast (c',t),mm,sgp) *) - + (* Produit. Est-ce bien exact ? *) | Prod (_,_,_) -> if occur_meta c then @@ -243,7 +243,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with let env' = push_named_rec_types (fi',ai,v) env in let a = Array.map (compute_metamap env' sigma) - (Array.map (substl (List.map mkVar (Array.to_list vi))) v) + (Array.map (substl (List.map mkVar (Array.to_list vi))) v) in begin try @@ -256,7 +256,7 @@ let rec compute_metamap env sigma c = match kind_of_term c with (* tcc_aux : term_with_holes -> tactic - * + * * Réalise le 3. ci-dessus *) @@ -269,11 +269,11 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = | Cast (c,_,_), _ when isMeta c -> tclIDTAC gl - + (* terme pur => refine *) | _,[] -> refine c gl - + (* abstraction => intro *) | Lambda (Name id,_,m), _ -> assert (isMeta (strip_outer_cast m)); @@ -292,7 +292,7 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = | [Some th] -> tclTHEN intro - (onLastHypId (fun id -> + (onLastHypId (fun id -> tclTHEN (clear [id]) (tcc_aux (mkVar (*dummy*) id::subst) th))) gl @@ -303,25 +303,25 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = | LetIn (Name id,c1,t1,c2), _ when not (isMeta (strip_outer_cast c1)) -> let c = pf_concl gl in let newc = mkNamedLetIn id c1 t1 c in - tclTHEN - (change_in_concl None newc) - (match sgp with + tclTHEN + (change_in_concl None newc) + (match sgp with | [None] -> introduction id | [Some th] -> tclTHEN (introduction id) (onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)) - | _ -> assert false) + | _ -> assert false) gl (* let in with holes in the body => unable to handle dependency because of evars limitation, use non dependent assert instead *) | LetIn (Name id,c1,t1,c2), _ -> tclTHENS - (assert_tac (Name id) t1) - [(match List.hd sgp with + (assert_tac (Name id) t1) + [(match List.hd sgp with | None -> tclIDTAC | Some th -> onLastHypId (fun id -> tcc_aux (mkVar id::subst) th)); - (match List.tl sgp with + (match List.tl sgp with | [] -> refine (subst1 (mkVar id) c2) (* a complete proof *) | [None] -> tclIDTAC (* a meta *) | [Some th] -> (* a partial proof *) @@ -340,7 +340,7 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = tclTHENS (mutual_fix (out_name fi.(j)) (succ ni.(j)) (firsts@List.tl lasts) j) (List.map (function - | None -> tclIDTAC + | None -> tclIDTAC | Some th -> tcc_aux subst th) sgp) gl @@ -355,7 +355,7 @@ let rec tcc_aux subst (TH (c,mm,sgp) as _th) gl = tclTHENS (mutual_cofix (out_name fi.(j)) (firsts@List.tl lasts) j) (List.map (function - | None -> tclIDTAC + | None -> tclIDTAC | Some th -> tcc_aux subst th) sgp) gl @@ -375,7 +375,7 @@ let refine (evd,c) gl = let evd = Typeclasses.resolve_typeclasses ~onlyargs:true (pf_env gl) evd in let c = Evarutil.nf_evar evd c in let (evd,c) = Evarutil.evars_to_metas sigma (evd,c) in - (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise + (* Relies on Cast's put on Meta's by evars_to_metas, because it is otherwise complicated to update meta types when passing through a binder *) let th = compute_metamap (pf_env gl) evd c in tclTHEN (Refiner.tclEVARS evd) (tcc_aux [] th) gl diff --git a/tactics/rewrite.ml4 b/tactics/rewrite.ml4 index 02bff3b15f..1c48988c77 100644 --- a/tactics/rewrite.ml4 +++ b/tactics/rewrite.ml4 @@ -47,18 +47,18 @@ let check_required_library d = let dir = make_dirpath (List.rev d') in if not (Library.library_is_loaded dir) then error ("Library "^(list_last d)^" has to be required first.") - + let classes_dirpath = make_dirpath (List.map id_of_string ["Classes";"Coq"]) - + let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else check_required_library ["Coq";"Setoids";"Setoid"] -let proper_class = +let proper_class = lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.Proper")))) -let proper_proxy_class = +let proper_proxy_class = lazy (class_info (Nametab.global (Qualid (dummy_loc, qualid_of_string "Coq.Classes.Morphisms.ProperProxy")))) let proper_proj = lazy (mkConst (Option.get (snd (List.hd (Lazy.force proper_class).cl_projs)))) @@ -68,10 +68,10 @@ let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) let try_find_global_reference dir s = let sp = Libnames.make_path (make_dir ("Coq"::dir)) (id_of_string s) in Nametab.global_of_path sp - + let try_find_reference dir s = constr_of_global (try_find_global_reference dir s) - + let gen_constant dir s = Coqlib.gen_constant "rewrite" dir s let coq_proj1 = lazy(gen_constant ["Init"; "Logic"] "proj1") let coq_proj2 = lazy(gen_constant ["Init"; "Logic"] "proj2") @@ -131,16 +131,16 @@ let setoid_refl_proj = lazy (gen_constant ["Classes"; "SetoidClass"] "Equivalenc let rewrite_relation_class = lazy (gen_constant ["Classes"; "RelationClasses"] "RewriteRelation") let rewrite_relation = lazy (gen_constant ["Classes"; "RelationClasses"] "rewrite_relation") - -let arrow_morphism a b = + +let arrow_morphism a b = if isprop a && isprop b then Lazy.force impl else mkApp(Lazy.force arrow, [|a;b|]) -let setoid_refl pars x = +let setoid_refl pars x = applistc (Lazy.force setoid_refl_proj) (pars @ [x]) - + let proper_type = lazy (constr_of_global (Lazy.force proper_class).cl_impl) let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).cl_impl) @@ -148,9 +148,9 @@ let proper_proxy_type = lazy (constr_of_global (Lazy.force proper_proxy_class).c let is_applied_rewrite_relation env sigma rels t = match kind_of_term t with | App (c, args) when Array.length args >= 2 -> - let head = if isApp c then fst (destApp c) else c in + let head = if isApp c then fst (destApp c) else c in if eq_constr (Lazy.force coq_eq) head then None - else + else (try let params, args = array_chop (Array.length args - 2) args in let env' = Environ.push_rel_context rels env in @@ -160,19 +160,19 @@ let is_applied_rewrite_relation env sigma rels t = Some (sigma, it_mkProd_or_LetIn t rels) with _ -> None) | _ -> None - -let _ = + +let _ = Equality.register_is_applied_rewrite_relation is_applied_rewrite_relation let split_head = function hd :: tl -> hd, tl | [] -> assert(false) -let new_goal_evar (goal,cstr) env t = +let new_goal_evar (goal,cstr) env t = let goal', t = Evarutil.new_evar goal env t in (goal', cstr), t -let new_cstr_evar (goal,cstr) env t = +let new_cstr_evar (goal,cstr) env t = let cstr', t = Evarutil.new_evar cstr env t in (goal, cstr'), t @@ -183,7 +183,7 @@ let build_signature evars env m (cstrs : 'a option list) (finalcstr : 'a option) in let mk_relty evars env ty obj = match obj with - | None -> + | None -> let relty = mk_relation ty in new_evar evars env relty | Some x -> evars, f x @@ -191,7 +191,7 @@ let build_signature evars env m (cstrs : 'a option list) (finalcstr : 'a option) let rec aux env evars ty l = let t = Reductionops.whd_betadeltaiota env (fst evars) ty in match kind_of_term t, l with - | Prod (na, ty, b), obj :: cstrs -> + | Prod (na, ty, b), obj :: cstrs -> if dependent (mkRel 1) b then let (evars, b, arg, cstrs) = aux (Environ.push_rel (na, None, ty) env) evars b cstrs in let ty = Reductionops.nf_betaiota (fst evars) ty in @@ -207,22 +207,22 @@ let build_signature evars env m (cstrs : 'a option list) (finalcstr : 'a option) let newarg = mkApp (Lazy.force respectful, [| ty ; b' ; relty ; arg |]) in evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs | _, obj :: _ -> anomaly "build_signature: not enough products" - | _, [] -> + | _, [] -> (match finalcstr with - | None -> + | None -> let t = Reductionops.nf_betaiota (fst evars) ty in - let evars, rel = mk_relty evars env t None in + let evars, rel = mk_relty evars env t None in evars, t, rel, [t, Some rel] | Some codom -> let (t, rel) = codom in evars, t, rel, [t, Some rel]) in aux env evars m cstrs - + let proper_proof env evars carrier relation x = let goal = mkApp (Lazy.force proper_proxy_type, [| carrier ; relation; x |]) in new_cstr_evar evars env goal let find_class_proof proof_type proof_method env evars carrier relation = - try + try let goal = mkApp (Lazy.force proof_type, [| carrier ; relation |]) in let evars, c = Typeclasses.resolve_one_typeclass env evars goal in mkApp (Lazy.force proof_method, [| carrier; relation; c |]) @@ -234,7 +234,7 @@ let get_transitive_proof env = find_class_proof transitive_type transitive_proof exception FoundInt of int -let array_find (arr: 'a array) (pred: int -> 'a -> bool): int = +let array_find (arr: 'a array) (pred: int -> 'a -> bool): int = try for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (FoundInt i) done; raise Not_found @@ -253,12 +253,12 @@ type hypinfo = { } let evd_convertible env evd x y = - try ignore(Evarconv.the_conv_x env x y evd); true + try ignore(Evarconv.the_conv_x env x y evd); true with _ -> false - + let decompose_applied_relation env sigma c left2right = let ctype = Typing.type_of env sigma c in - let find_rel ty = + let find_rel ty = let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in let rec split_last_two = function @@ -267,7 +267,7 @@ let decompose_applied_relation env sigma c left2right = let l,res = split_last_two (y::z) in x::l, res | _ -> error "The term provided is not an applied relation." in let others,(c1,c2) = split_last_two args in - let ty1, ty2 = + let ty1, ty2 = Typing.mtype_of env eqclause.evd c1, Typing.mtype_of env eqclause.evd c2 in if not (evd_convertible env eqclause.evd ty1 ty2) then None @@ -278,12 +278,12 @@ let decompose_applied_relation env sigma c left2right = in match find_rel ctype with | Some c -> c - | None -> + | None -> let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) match find_rel (it_mkProd_or_LetIn t' ctx) with | Some c -> c | None -> error "The term does not end with an applied homogeneous relation." - + let rewrite_unif_flags = { Unification.modulo_conv_on_closed_terms = None; Unification.use_metas_eagerly = true; @@ -312,27 +312,27 @@ let setoid_rewrite_unif_flags = { let convertible env evd x y = Reductionops.is_conv env evd x y - + let allowK = true -let refresh_hypinfo env sigma hypinfo = +let refresh_hypinfo env sigma hypinfo = if hypinfo.abs = None then let {l2r=l2r; c=c;cl=cl} = hypinfo in - match c with + match c with | Some c -> (* Refresh the clausenv to not get the same meta twice in the goal. *) decompose_applied_relation env cl.evd c l2r; | _ -> hypinfo else hypinfo -let unify_eqn env sigma hypinfo t = +let unify_eqn env sigma hypinfo t = if isEvar t then None - else try + else try let {cl=cl; prf=prf; car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=c; abs=abs} = !hypinfo in let left = if l2r then c1 else c2 in let env', prf, c1, c2, car, rel = match abs with - | Some (absprf, absprfty) -> + | Some (absprf, absprfty) -> let env' = clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl in env', prf, c1, c2, car, rel | None -> @@ -342,7 +342,7 @@ let unify_eqn env sigma hypinfo t = (* For Ring essentially, only when doing setoid_rewrite *) clenv_unify allowK ~flags:rewrite2_unif_flags CONV left t cl in - let env' = + let env' = let mvs = clenv_dependent false env' in clenv_pose_metas_as_evars env' mvs in @@ -350,13 +350,13 @@ let unify_eqn env sigma hypinfo t = let env' = { env' with evd = evd' } in let nf c = Evarutil.nf_evar evd' (Clenv.clenv_nf_meta env' c) in let c1 = nf c1 and c2 = nf c2 - and car = nf car and rel = nf rel + and car = nf car and rel = nf rel and prf = nf (Clenv.clenv_value env') in - let ty1 = Typing.mtype_of env'.env env'.evd c1 + let ty1 = Typing.mtype_of env'.env env'.evd c1 and ty2 = Typing.mtype_of env'.env env'.evd c2 in if convertible env env'.evd ty1 ty2 then ( - if occur_meta prf then + if occur_meta prf then hypinfo := refresh_hypinfo env sigma !hypinfo; env', prf, c1, c2, car, rel) else raise Reduction.NotConvertible @@ -364,7 +364,7 @@ let unify_eqn env sigma hypinfo t = let res = if l2r then (prf, (car, rel, c1, c2)) else - try (mkApp (get_symmetric_proof env Evd.empty car rel, + try (mkApp (get_symmetric_proof env Evd.empty car rel, [| c1 ; c2 ; prf |]), (car, rel, c2, c1)) with Not_found -> @@ -374,16 +374,16 @@ let unify_eqn env sigma hypinfo t = let unfold_impl t = match kind_of_term t with - | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> + | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> mkProd (Anonymous, a, lift 1 b) | _ -> assert false -let unfold_id t = +let unfold_id t = match kind_of_term t with | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_id) *) -> b | _ -> assert false -let unfold_all t = +let unfold_all t = match kind_of_term t with | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> (match kind_of_term b with @@ -391,7 +391,7 @@ let unfold_all t = | _ -> assert false) | _ -> assert false -let decomp_prod env evm n c = +let decomp_prod env evm n c = snd (Reductionops.splay_prod_n env evm n c) let rec decomp_pointwise n c = @@ -400,19 +400,19 @@ let rec decomp_pointwise n c = match kind_of_term c with | App (pointwise, [| a; b; relb |]) -> decomp_pointwise (pred n) relb | _ -> raise Not_found - + let lift_cstr env sigma evars args cstr = let cstr = - let start = + let start = match cstr with | Some codom -> codom - | None -> + | None -> let car = Evarutil.e_new_evar evars env (new_Type ()) in let rel = Evarutil.e_new_evar evars env (mk_relation car) in (car, rel) in Array.fold_right - (fun arg (car, rel) -> + (fun arg (car, rel) -> let ty = Typing.type_of env sigma arg in let car' = mkProd (Anonymous, ty, car) in let rel' = mkApp (Lazy.force pointwise_relation, [| ty; car; rel |]) in @@ -440,10 +440,10 @@ type rewrite_result_info = { } type rewrite_result = rewrite_result_info option - + type strategy = Environ.env -> evar_defs -> constr -> types -> constr option -> evars -> rewrite_result option - + let resolve_subrelation env sigma car rel rel' res = if eq_constr rel rel' then res else @@ -452,14 +452,14 @@ let resolve_subrelation env sigma car rel rel' res = (* with NotConvertible -> *) let app = mkApp (Lazy.force subrelation, [|car; rel; rel'|]) in let evars, subrel = new_cstr_evar res.rew_evars env app in - { res with + { res with rew_prf = mkApp (subrel, [| res.rew_from ; res.rew_to ; res.rew_prf |]); rew_rel = rel'; rew_evars = evars } let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars = - let evars, morph_instance, proj, sigargs, m', args, args' = + let evars, morph_instance, proj, sigargs, m', args, args' = let first = try (array_find args' (fun i b -> b <> None)) with Not_found -> raise (Invalid_argument "resolve_morphism") in let morphargs, morphobjs = array_chop first args in let morphargs', morphobjs' = array_chop first args' in @@ -477,22 +477,22 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars in let evars, morph = new_cstr_evar evars env' app in evars, morph, morph, sigargs, appm, morphobjs, morphobjs' - in - let projargs, subst, evars, respars, typeargs = - array_fold_left2 - (fun (acc, subst, evars, sigargs, typeargs') x y -> + in + let projargs, subst, evars, respars, typeargs = + array_fold_left2 + (fun (acc, subst, evars, sigargs, typeargs') x y -> let (carrier, relation), sigargs = split_head sigargs in match relation with | Some relation -> - let carrier = substl subst carrier + let carrier = substl subst carrier and relation = substl subst relation in (match y with | None -> let evars, proof = proper_proof env evars carrier relation x in [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' - | Some r -> + | Some r -> [ r.rew_prf; r.rew_to; x ] @ acc, subst, evars, sigargs, r.rew_to :: typeargs') - | None -> + | None -> if y <> None then error "Cannot rewrite the argument of a dependent function"; x :: acc, x :: subst, evars, sigargs, x :: typeargs') ([], [], evars, sigargs, []) args args' @@ -502,7 +502,7 @@ let resolve_morphism env sigma oldt m ?(fnewt=fun x -> x) args args' cstr evars match respars with [ a, Some r ] -> evars, proof, a, r, oldt, fnewt newt | _ -> assert(false) - + let apply_constraint env sigma car rel cstr res = match cstr with | None -> res @@ -512,7 +512,7 @@ let eq_env x y = x == y let apply_rule hypinfo loccs : strategy = let (nowhere_except_in,occs) = loccs in - let is_occ occ = + let is_occ occ = if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in let occ = ref 0 in fun env sigma t ty cstr evars -> @@ -520,13 +520,13 @@ let apply_rule hypinfo loccs : strategy = let unif = unify_eqn env sigma hypinfo t in if unif <> None then incr occ; match unif with - | Some (env', (prf, (car, rel, c1, c2))) when is_occ !occ -> + | Some (env', (prf, (car, rel, c1, c2))) when is_occ !occ -> begin let goalevars = Evd.evar_merge (fst evars) (Evd.undefined_evars (Evarutil.nf_evar_defs env'.evd)) in - let res = { rew_car = ty; rew_rel = rel; rew_from = c1; - rew_to = c2; rew_prf = prf; rew_evars = goalevars, snd evars } + let res = { rew_car = ty; rew_rel = rel; rew_from = c1; + rew_to = c2; rew_prf = prf; rew_evars = goalevars, snd evars } in Some (Some (apply_constraint env sigma car rel cstr res)) end | _ -> None @@ -538,27 +538,27 @@ let apply_lemma (evm,c) left2right loccs : strategy = apply_rule hypinfo loccs env sigma let make_leibniz_proof c ty r = - let prf = mkApp (Lazy.force coq_f_equal, + let prf = mkApp (Lazy.force coq_f_equal, [| r.rew_car; ty; mkLambda (Anonymous, r.rew_car, c (mkRel 1)); r.rew_from; r.rew_to; r.rew_prf |]) in - { r with rew_car = ty; rew_rel = mkApp (Lazy.force coq_eq, [| ty |]); + { r with rew_car = ty; rew_rel = mkApp (Lazy.force coq_eq, [| ty |]); rew_from = c r.rew_from; rew_to = c r.rew_to; rew_prf = prf } - + let subterm all flags (s : strategy) : strategy = let rec aux env sigma t ty cstr evars = let cstr' = Option.map (fun c -> (ty, c)) cstr in match kind_of_term t with | App (m, args) -> - let rewrite_args success = + let rewrite_args success = let args', evars', progress = - Array.fold_left - (fun (acc, evars, progress) arg -> + Array.fold_left + (fun (acc, evars, progress) arg -> if progress <> None && not all then (None :: acc, evars, progress) - else + else let res = s env sigma arg (Typing.type_of env sigma arg) None evars in - match res with + match res with | Some None -> (None :: acc, evars, if progress = None then Some false else progress) | Some (Some r) -> (Some r :: acc, r.rew_evars, Some true) | None -> (None :: acc, evars, progress)) @@ -573,11 +573,11 @@ let subterm all flags (s : strategy) : strategy = let res = { rew_car = ty; rew_rel = rel; rew_from = c1; rew_to = c2; rew_prf = prf; rew_evars = evars' } in Some (Some res) - in + in if flags.on_morphisms then let evarsref = ref (snd evars) in let cstr' = lift_cstr env sigma evarsref args cstr' in - let m' = s env sigma m (Typing.type_of env sigma m) + let m' = s env sigma m (Typing.type_of env sigma m) (Option.map snd cstr') (fst evars, !evarsref) in match m' with @@ -587,14 +587,14 @@ let subterm all flags (s : strategy) : strategy = (* We rewrote the function and get a proof of pointwise rel for the arguments. We just apply it. *) let nargs = Array.length args in - let res = + let res = { rew_car = decomp_prod env (fst r.rew_evars) nargs r.rew_car; - rew_rel = decomp_pointwise nargs r.rew_rel; + rew_rel = decomp_pointwise nargs r.rew_rel; rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); rew_prf = mkApp (r.rew_prf, args); rew_evars = r.rew_evars } in Some (Some res) else rewrite_args None - + | Prod (n, x, b) when not (dependent (mkRel 1) b) -> let b = subst1 mkProp b in let tx = Typing.type_of env sigma x and tb = Typing.type_of env sigma b in @@ -602,7 +602,7 @@ let subterm all flags (s : strategy) : strategy = (match res with | Some (Some r) -> Some (Some { r with rew_to = unfold_impl r.rew_to }) | _ -> res) - + (* if x' = None && flags.under_lambdas then *) (* let lam = mkLambda (n, x, b) in *) (* let lam', occ = aux env lam occ None in *) @@ -616,14 +616,14 @@ let subterm all flags (s : strategy) : strategy = (* cstr evars) *) (* in res, occ *) (* else *) - + | Prod (n, dom, codom) when eq_constr ty mkProp -> let lam = mkLambda (n, dom, codom) in let res = aux env sigma (mkApp (Lazy.force coq_all, [| dom; lam |])) ty cstr evars in (match res with | Some (Some r) -> Some (Some { r with rew_to = unfold_all r.rew_to }) | _ -> res) - + | Lambda (n, t, b) when flags.under_lambdas -> let env' = Environ.push_rel (n, None, t) env in let b' = s env' sigma b (Typing.type_of env' sigma b) (unlift_cstr env sigma cstr) evars in @@ -636,7 +636,7 @@ let subterm all flags (s : strategy) : strategy = rew_from = mkLambda(n, t, r.rew_from); rew_to = mkLambda (n, t, r.rew_to) }) | _ -> b') - + | Case (ci, p, c, brs) -> let cty = Typing.type_of env sigma c in let cstr = Some (mkApp (Lazy.force coq_eq, [| cty |])) in @@ -644,16 +644,16 @@ let subterm all flags (s : strategy) : strategy = (match c' with | Some (Some r) -> Some (Some (make_leibniz_proof (fun x -> mkCase (ci, p, x, brs)) ty r)) - | x -> + | x -> if array_for_all ((=) 0) ci.ci_cstr_nargs then let cstr = Some (mkApp (Lazy.force coq_eq, [| ty |])) in - let found, brs' = Array.fold_left (fun (found, acc) br -> - if found <> None then (found, fun x -> br :: acc x) + let found, brs' = Array.fold_left (fun (found, acc) br -> + if found <> None then (found, fun x -> br :: acc x) else match s env sigma br ty cstr evars with | Some (Some r) -> (Some r, fun x -> x :: acc x) - | _ -> (None, fun x -> br :: acc x)) - (None, fun x -> []) brs + | _ -> (None, fun x -> br :: acc x)) + (None, fun x -> []) brs in match found with | Some r -> @@ -674,7 +674,7 @@ let transitivity env sigma (res : rewrite_result_info) (next : strategy) : rewri match next env sigma res.rew_to res.rew_car (Some res.rew_rel) res.rew_evars with | None -> None | Some None -> Some (Some res) - | Some (Some res') -> + | Some (Some res') -> let prfty = mkApp (Lazy.force transitive_type, [| res.rew_car ; res.rew_rel |]) in let evars, prf = new_cstr_evar res'.rew_evars env prfty in let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; @@ -682,22 +682,22 @@ let transitivity env sigma (res : rewrite_result_info) (next : strategy) : rewri in Some (Some { res' with rew_from = res.rew_from; rew_evars = evars; rew_prf = prf }) (** Rewriting strategies. - + Inspired by ELAN's rewriting strategies: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049 *) -module Strategies = +module Strategies = struct - let fail : strategy = + let fail : strategy = fun env sigma t ty cstr evars -> None - let id : strategy = + let id : strategy = fun env sigma t ty cstr evars -> Some None let refl : strategy = - fun env sigma t ty cstr evars -> + fun env sigma t ty cstr evars -> let evars, rel = match cstr with | None -> new_cstr_evar evars env (mk_relation ty) | Some r -> evars, r @@ -706,11 +706,11 @@ module Strategies = let mty = mkApp (Lazy.force proper_proxy_type, [| ty ; rel; t |]) in new_cstr_evar evars env mty in - Some (Some { rew_car = ty; rew_rel = rel; rew_from = t; rew_to = t; + Some (Some { rew_car = ty; rew_rel = rel; rew_from = t; rew_to = t; rew_prf = proof; rew_evars = evars }) - + let progress (s : strategy) : strategy = - fun env sigma t ty cstr evars -> + fun env sigma t ty cstr evars -> match s env sigma t ty cstr evars with | None -> None | Some None -> None @@ -722,7 +722,7 @@ module Strategies = | None -> None | Some None -> snd env sigma t ty cstr evars | Some (Some res) -> transitivity env sigma res snd - + let choice fst snd : strategy = fun env sigma t ty cstr evars -> match fst env sigma t ty cstr evars with @@ -731,7 +731,7 @@ module Strategies = let try_ str : strategy = choice str id - let fix (f : strategy -> strategy) : strategy = + let fix (f : strategy -> strategy) : strategy = let rec aux env = f (fun env -> aux env) env in aux let any (s : strategy) : strategy = @@ -740,10 +740,10 @@ module Strategies = let repeat (s : strategy) : strategy = seq s (any s) - let bu (s : strategy) : strategy = + let bu (s : strategy) : strategy = fix (fun s' -> seq (choice (all_subterms s') s) (try_ s')) - let td (s : strategy) : strategy = + let td (s : strategy) : strategy = fix (fun s' -> seq (choice s (all_subterms s')) (try_ s')) let innermost (s : strategy) : strategy = @@ -756,7 +756,7 @@ module Strategies = List.fold_left (fun tac (l,l2r) -> choice tac (apply_lemma l l2r (false,[]))) fail cs - + let old_hints (db : string) : strategy = let rules = Autorewrite.find_rewrites db in lemmas (List.map (fun hint -> (inj_open hint.Autorewrite.rew_lemma, hint.Autorewrite.rew_l2r)) rules) @@ -771,9 +771,9 @@ end (** The strategy for a single rewrite, dealing with occurences. *) -let rewrite_strat flags occs hyp = +let rewrite_strat flags occs hyp = let app = apply_rule hyp occs in - let rec aux () = + let rec aux () = Strategies.choice app (subterm true flags (fun env -> aux () env)) in aux () @@ -791,26 +791,26 @@ let apply_strategy (s : strategy) env sigma concl cstr evars = match res with | None -> None | Some None -> Some None - | Some (Some res) -> + | Some (Some res) -> evars := res.rew_evars; Some (Some (res.rew_prf, (res.rew_car, res.rew_rel, res.rew_from, res.rew_to))) -let split_evars_once sigma evd = +let split_evars_once sigma evd = Evd.fold (fun ev evi deps -> - if Intset.mem ev deps then + if Intset.mem ev deps then Intset.union (Class_tactics.evars_of_evi evi) deps else deps) evd sigma - + let existentials_of_evd evd = - Evd.fold (fun ev evi acc -> Intset.add ev acc) evd Intset.empty + Evd.fold (fun ev evi acc -> Intset.add ev acc) evd Intset.empty let evd_of_existentials evd exs = - Intset.fold (fun i acc -> + Intset.fold (fun i acc -> let evi = Evd.find evd i in Evd.add acc i evi) exs Evd.empty -let split_evars sigma evd = - let rec aux deps = +let split_evars sigma evd = + let rec aux deps = let deps' = split_evars_once deps evd in if Intset.equal deps' deps then evd_of_existentials evd deps @@ -822,12 +822,12 @@ let solve_constraints env evars = Typeclasses.resolve_typeclasses env ~split:false ~fail:true (merge_evars evars) let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = - let concl, is_hyp = + let concl, is_hyp = match clause with Some id -> pf_get_hyp_typ gl id, Some id | None -> pf_concl gl, None in - let cstr = + let cstr = let sort = mkProp in let impl = Lazy.force impl in match is_hyp with @@ -839,34 +839,34 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = let env = pf_env gl in let eq = apply_strategy strat env sigma concl (Some cstr) evars in match eq with - | Some (Some (p, (_, _, oldt, newt))) -> + | Some (Some (p, (_, _, oldt, newt))) -> (try let cstrevars = !evars in let evars = solve_constraints env cstrevars in let p = Evarutil.nf_isevar evars p in let newt = Evarutil.nf_isevar evars newt in - let abs = Option.map (fun (x, y) -> + let abs = Option.map (fun (x, y) -> Evarutil.nf_isevar evars x, Evarutil.nf_isevar evars y) abs in let undef = split_evars (fst cstrevars) evars in - let rewtac = + let rewtac = match is_hyp with - | Some id -> - let term = + | Some id -> + let term = match abs with | None -> p - | Some (t, ty) -> + | Some (t, ty) -> mkApp (mkLambda (Name (id_of_string "lemma"), ty, p), [| t |]) in - cut_replacing id newt + cut_replacing id newt (fun x -> Tacmach.refine_no_check (mkApp (term, [| mkVar id |]))) - | None -> + | None -> (match abs with - | None -> + | None -> let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in tclTHENLAST (Tacmach.internal_cut_no_check false name newt) (tclTHEN (Tactics.revert [name]) (Tacmach.refine_no_check p)) - | Some (t, ty) -> + | Some (t, ty) -> Tacmach.refine_no_check (mkApp (mkLambda (Name (id_of_string "newt"), newt, mkLambda (Name (id_of_string "lemma"), ty, @@ -874,20 +874,20 @@ let cl_rewrite_clause_aux ?(abs=None) strat goal_meta clause gl = [| mkMeta goal_meta; t |]))) in let evartac = - if not (undef = Evd.empty) then + if not (undef = Evd.empty) then Refiner.tclEVARS undef else tclIDTAC in tclTHENLIST [evartac; rewtac] gl - with + with | Stdpp.Exc_located (_, TypeClassError (env, (UnsatisfiableConstraints _ as e))) | TypeClassError (env, (UnsatisfiableConstraints _ as e)) -> - Refiner.tclFAIL_lazy 0 - (lazy (str"setoid rewrite failed: unable to satisfy the rewriting constraints." + Refiner.tclFAIL_lazy 0 + (lazy (str"setoid rewrite failed: unable to satisfy the rewriting constraints." ++ fnl () ++ Himsg.explain_typeclass_error env e)) gl) - | Some None -> + | Some None -> tclFAIL 0 (str"setoid rewrite failed: no progress made") gl | None -> raise Not_found - + let cl_rewrite_clause_strat strat clause gl = init_setoid (); let meta = Evarutil.new_meta() in @@ -910,7 +910,7 @@ open Extraargs let occurrences_of = function | n::_ as nl when n < 0 -> (false,List.map abs nl) - | nl -> + | nl -> if List.exists (fun n -> n < 0) nl then error "Illegal negative occurrence number."; (true,nl) @@ -924,7 +924,7 @@ let interp_strategy ist gl c = c let glob_strategy ist l = l let subst_strategy evm l = l -let apply_constr_expr c l2r occs = fun env sigma -> +let apply_constr_expr c l2r occs = fun env sigma -> let c = Constrintern.interp_open_constr sigma env c in apply_lemma c l2r occs env sigma @@ -985,8 +985,8 @@ END let clsubstitute o c = let is_tac id = match kind_of_term (snd c) with Var id' when id' = id -> true | _ -> false in - Tacticals.onAllHypsAndConcl - (fun cl -> + Tacticals.onAllHypsAndConcl + (fun cl -> match cl with | Some id when is_tac id -> tclIDTAC | _ -> tclTRY (cl_rewrite_clause c o all_occurrences cl)) @@ -997,7 +997,7 @@ END (* Compatibility with old Setoids *) - + TACTIC EXTEND setoid_rewrite [ "setoid_rewrite" orient(o) open_constr(c) ] -> [ cl_rewrite_clause c o all_occurrences None ] @@ -1019,73 +1019,73 @@ let mkappc s l = CAppExpl (dummy_loc,(None,(Libnames.Ident (dummy_loc,id_of_stri let declare_an_instance n s args = ((dummy_loc,Name n), Explicit, - CAppExpl (dummy_loc, (None, Qualid (dummy_loc, qualid_of_string s)), + CAppExpl (dummy_loc, (None, Qualid (dummy_loc, qualid_of_string s)), args)) let declare_instance a aeq n s = declare_an_instance n s [a;aeq] -let anew_instance binders instance fields = +let anew_instance binders instance fields = new_instance binders instance (CRecord (dummy_loc,None,fields)) ~generalize:false None let require_library dirpath = let qualid = (dummy_loc, Libnames.qualid_of_dirpath (Libnames.dirpath_of_string dirpath)) in Library.require_library [qualid] (Some false) -let declare_instance_refl binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" - in anew_instance binders instance +let declare_instance_refl binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" + in anew_instance binders instance [((dummy_loc,id_of_string "reflexivity"),lemma)] -let declare_instance_sym binders a aeq n lemma = +let declare_instance_sym binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" - in anew_instance binders instance + in anew_instance binders instance [((dummy_loc,id_of_string "symmetry"),lemma)] -let declare_instance_trans binders a aeq n lemma = - let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" - in anew_instance binders instance +let declare_instance_trans binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" + in anew_instance binders instance [((dummy_loc,id_of_string "transitivity"),lemma)] let constr_tac = Tacinterp.interp (Tacexpr.TacAtom (dummy_loc, Tacexpr.TacAnyConstructor (false,None))) -let declare_relation ?(binders=[]) a aeq n refl symm trans = +let declare_relation ?(binders=[]) a aeq n refl symm trans = init_setoid (); let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" in ignore(anew_instance binders instance []); - match (refl,symm,trans) with + match (refl,symm,trans) with (None, None, None) -> () - | (Some lemma1, None, None) -> + | (Some lemma1, None, None) -> ignore (declare_instance_refl binders a aeq n lemma1) - | (None, Some lemma2, None) -> + | (None, Some lemma2, None) -> ignore (declare_instance_sym binders a aeq n lemma2) - | (None, None, Some lemma3) -> + | (None, None, Some lemma3) -> ignore (declare_instance_trans binders a aeq n lemma3) - | (Some lemma1, Some lemma2, None) -> - ignore (declare_instance_refl binders a aeq n lemma1); + | (Some lemma1, Some lemma2, None) -> + ignore (declare_instance_refl binders a aeq n lemma1); ignore (declare_instance_sym binders a aeq n lemma2) - | (Some lemma1, None, Some lemma3) -> + | (Some lemma1, None, Some lemma3) -> let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" in ignore( - anew_instance binders instance + anew_instance binders instance [((dummy_loc,id_of_string "PreOrder_Reflexive"), lemma1); ((dummy_loc,id_of_string "PreOrder_Transitive"),lemma3)]) - | (None, Some lemma2, Some lemma3) -> + | (None, Some lemma2, Some lemma3) -> let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" in ignore( - anew_instance binders instance + anew_instance binders instance [((dummy_loc,id_of_string "PER_Symmetric"), lemma2); ((dummy_loc,id_of_string "PER_Transitive"),lemma3)]) - | (Some lemma1, Some lemma2, Some lemma3) -> - let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in + | (Some lemma1, Some lemma2, Some lemma3) -> + let _lemma_refl = declare_instance_refl binders a aeq n lemma1 in let _lemma_sym = declare_instance_sym binders a aeq n lemma2 in let _lemma_trans = declare_instance_trans binders a aeq n lemma3 in - let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" in ignore( - anew_instance binders instance + anew_instance binders instance [((dummy_loc,id_of_string "Equivalence_Reflexive"), lemma1); ((dummy_loc,id_of_string "Equivalence_Symmetric"), lemma2); ((dummy_loc,id_of_string "Equivalence_Transitive"), lemma3)]) @@ -1100,19 +1100,19 @@ let (wit_binders_let : Genarg.tlevel binders_let_argtype), open Pcoq.Constr VERNAC COMMAND EXTEND AddRelation - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) None None ] - | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> [ declare_relation a aeq n None None None ] END VERNAC COMMAND EXTEND AddRelation2 - [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation a aeq n None (Some lemma2) None ] | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> @@ -1120,33 +1120,33 @@ VERNAC COMMAND EXTEND AddRelation2 END VERNAC COMMAND EXTEND AddRelation3 - [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation a aeq n None None (Some lemma3) ] + "as" ident(n) ] -> + [ declare_relation a aeq n None None (Some lemma3) ] END VERNAC COMMAND EXTEND AddParametricRelation | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) - "reflexivity" "proved" "by" constr(lemma1) + "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) - "reflexivity" "proved" "by" constr(lemma1) + "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] - | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None None None ] END VERNAC COMMAND EXTEND AddParametricRelation2 - [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> @@ -1154,16 +1154,16 @@ VERNAC COMMAND EXTEND AddParametricRelation2 END VERNAC COMMAND EXTEND AddParametricRelation3 - [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] - | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) - "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] | [ "Add" "Parametric" "Relation" binders_let(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) - "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] END let mk_qualid s = @@ -1178,10 +1178,10 @@ let proper_projection r ty = let ctx, inst = decompose_prod_assum ty in let mor, args = destApp inst in let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in - let app = mkApp (Lazy.force proper_proj, + let app = mkApp (Lazy.force proper_proj, Array.append args [| instarg |]) in it_mkLambda_or_LetIn app ctx - + let declare_projection n instance_id r = let ty = Global.type_of_global r in let c = constr_of_global r in @@ -1189,41 +1189,41 @@ let declare_projection n instance_id r = let typ = Typing.type_of (Global.env ()) Evd.empty term in let ctx, typ = decompose_prod_assum typ in let typ = - let n = - let rec aux t = + let n = + let rec aux t = match kind_of_term t with - App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) -> + App (f, [| a ; a' ; rel; rel' |]) when eq_constr f (Lazy.force respectful) -> succ (aux rel') | _ -> 0 in - let init = + let init = match kind_of_term typ with - App (f, args) when eq_constr f (Lazy.force respectful) -> + App (f, args) when eq_constr f (Lazy.force respectful) -> mkApp (f, fst (array_chop (Array.length args - 2) args)) | _ -> typ in aux init in let ctx,ccl = Reductionops.splay_prod_n (Global.env()) Evd.empty (3 * n) typ - in it_mkProd_or_LetIn ccl ctx + in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in - let cst = + let cst = { const_entry_body = term; const_entry_type = Some typ; const_entry_opaque = false; const_entry_boxed = false } in ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) - + let build_morphism_signature m = let env = Global.env () in let m = Constrintern.interp_constr Evd.empty env m in let t = Typing.type_of env Evd.empty m in let isevars = ref (Evd.empty, Evd.empty) in - let cstrs = - let rec aux t = + let cstrs = + let rec aux t = match kind_of_term t with - | Prod (na, a, b) -> + | Prod (na, a, b) -> None :: aux b | _ -> [] in aux t @@ -1231,7 +1231,7 @@ let build_morphism_signature m = let evars, t', sig_, cstrs = build_signature !isevars env t cstrs None snd in let _ = isevars := evars in let _ = List.iter - (fun (ty, rel) -> + (fun (ty, rel) -> Option.iter (fun rel -> let default = mkApp (Lazy.force default_relation, [| ty; rel |]) in let evars,c = new_cstr_evar !isevars env default in @@ -1239,13 +1239,13 @@ let build_morphism_signature m = rel) cstrs in - let morph = + let morph = mkApp (Lazy.force proper_type, [| t; sig_; m |]) in let evd = solve_constraints env !isevars in let m = Evarutil.nf_isevar evd morph in Evarutil.check_evars env Evd.empty evd m; m - + let default_morphism sign m = let env = Global.env () in let t = Typing.type_of env Evd.empty m in @@ -1257,10 +1257,10 @@ let default_morphism sign m = in let evars, mor = resolve_one_typeclass env (merge_evars evars) morph in mor, proper_projection mor morph - + let add_setoid binders a aeq t n = init_setoid (); - let _lemma_refl = declare_instance_refl binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_refl = declare_instance_refl binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in let _lemma_sym = declare_instance_sym binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in let _lemma_trans = declare_instance_trans binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" @@ -1274,7 +1274,7 @@ let add_morphism_infer glob m n = init_setoid (); let instance_id = add_suffix n "_Proper" in let instance = build_morphism_signature m in - if Lib.is_modtype () then + if Lib.is_modtype () then let cst = Declare.declare_internal_constant instance_id (Entries.ParameterEntry (instance,false), Decl_kinds.IsAssumption Decl_kinds.Logical) in @@ -1282,30 +1282,30 @@ let add_morphism_infer glob m n = declare_projection n instance_id (ConstRef cst) else let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in - Flags.silently + Flags.silently (fun () -> - Command.start_proof instance_id kind instance + Command.start_proof instance_id kind instance (fun _ -> function - Libnames.ConstRef cst -> - add_instance (Typeclasses.new_instance (Lazy.force proper_class) None + Libnames.ConstRef cst -> + add_instance (Typeclasses.new_instance (Lazy.force proper_class) None glob cst); declare_projection n instance_id (ConstRef cst) | _ -> assert false); Pfedit.by (Tacinterp.interp <:tactic< Coq.Classes.SetoidTactics.add_morphism_tactic>>)) (); - Flags.if_verbose (fun x -> msg (Printer.pr_open_subgoals x)) () - + Flags.if_verbose (fun x -> msg (Printer.pr_open_subgoals x)) () + let add_morphism glob binders m s n = init_setoid (); let instance_id = add_suffix n "_Proper" in - let instance = + let instance = ((dummy_loc,Name instance_id), Explicit, - CAppExpl (dummy_loc, - (None, Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")), + CAppExpl (dummy_loc, + (None, Qualid (dummy_loc, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper")), [cHole; s; m])) - in + in let tac = Tacinterp.interp <:tactic> in ignore(new_instance ~global:glob binders instance (CRecord (dummy_loc,None,[])) - ~generalize:false ~tac + ~generalize:false ~tac ~hook:(fun cst -> declare_projection n instance_id (ConstRef cst)) None) VERNAC COMMAND EXTEND AddSetoid1 @@ -1317,8 +1317,8 @@ VERNAC COMMAND EXTEND AddSetoid1 [ add_morphism_infer (not (Vernacexpr.use_section_locality ())) m n ] | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] -> [ add_morphism (not (Vernacexpr.use_section_locality ())) [] m s n ] - | [ "Add" "Parametric" "Morphism" binders_let(binders) ":" constr(m) - "with" "signature" lconstr(s) "as" ident(n) ] -> + | [ "Add" "Parametric" "Morphism" binders_let(binders) ":" constr(m) + "with" "signature" lconstr(s) "as" ident(n) ] -> [ add_morphism (not (Vernacexpr.use_section_locality ())) binders m s n ] END @@ -1347,7 +1347,7 @@ let check_evar_map_of_evars_defs evd = check_freemetas_is_empty rebus2 freemetas2 ) metas -let unification_rewrite l2r c1 c2 cl car rel but gl = +let unification_rewrite l2r c1 c2 cl car rel but gl = let env = pf_env gl in let (evd',c') = try @@ -1375,11 +1375,11 @@ let unification_rewrite l2r c1 c2 cl car rel but gl = let cl' = { cl' with templval = mk_freelisted prf ; templtyp = mk_freelisted prfty } in {cl=cl'; prf=(mkRel 1); car=car; rel=rel; l2r=l2r; c1=c1; c2=c2; c=None; abs=Some (prf, prfty)} -let get_hyp gl evars (evm,c) clause l2r = +let get_hyp gl evars (evm,c) clause l2r = let hi = decompose_applied_relation (pf_env gl) evars c l2r in let but = match clause with Some id -> pf_get_hyp_typ gl id | None -> pf_concl gl in unification_rewrite hi.l2r hi.c1 hi.c2 hi.cl hi.car hi.rel but gl - + let general_rewrite_flags = { under_lambdas = false; on_morphisms = false } let apply_lemma gl (evm,c) cl l2r occs = @@ -1387,10 +1387,10 @@ let apply_lemma gl (evm,c) cl l2r occs = let evars = Evd.merge sigma evm in let hypinfo = ref (get_hyp gl evars (evm,c) cl l2r) in let app = apply_rule hypinfo occs in - let rec aux () = + let rec aux () = Strategies.choice app (subterm true general_rewrite_flags (fun env -> aux () env)) in !hypinfo, aux () - + let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = let meta = Evarutil.new_meta() in let hypinfo, strat = apply_lemma gl c cl l2r occs in @@ -1406,7 +1406,7 @@ let general_s_rewrite_clause x = match x with | None -> general_s_rewrite None | Some id -> general_s_rewrite (Some id) - + let _ = Equality.register_general_rewrite_clause general_s_rewrite_clause let is_loaded d = @@ -1421,24 +1421,24 @@ let try_loaded f gl = (** [setoid_]{reflexivity,symmetry,transitivity} tactics *) let not_declared env ty rel = - tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++ + tclFAIL 0 (str" The relation " ++ Printer.pr_constr_env env rel ++ str" is not a declared " ++ str ty ++ str" relation. Maybe you need to require the Setoid library") -let relation_of_constr env c = +let relation_of_constr env c = match kind_of_term c with - | App (f, args) when Array.length args >= 2 -> + | App (f, args) when Array.length args >= 2 -> let relargs, args = array_chop (Array.length args - 2) args in mkApp (f, relargs), args - | _ -> errorlabstrm "relation_of_constr" + | _ -> errorlabstrm "relation_of_constr" (str "The term " ++ Printer.pr_constr_env env c ++ str" is not an applied relation.") - + let setoid_proof gl ty fn fallback = let env = pf_env gl in - try + try let rel, args = relation_of_constr env (pf_concl gl) in let evm, car = project gl, pf_type_of gl args.(0) in fn env evm car rel gl - with e -> + with e -> try fallback gl with Hipattern.NoEquationFound -> match e with @@ -1446,19 +1446,19 @@ let setoid_proof gl ty fn fallback = let rel, args = relation_of_constr env (pf_concl gl) in not_declared env ty rel gl | _ -> raise e - + let setoid_reflexivity gl = - setoid_proof gl "reflexive" + setoid_proof gl "reflexive" (fun env evm car rel -> apply (get_reflexive_proof env evm car rel)) (reflexivity_red true) - + let setoid_symmetry gl = - setoid_proof gl "symmetric" + setoid_proof gl "symmetric" (fun env evm car rel -> apply (get_symmetric_proof env evm car rel)) (symmetry_red true) - + let setoid_transitivity c gl = - setoid_proof gl "transitive" + setoid_proof gl "transitive" (fun env evm car rel -> let proof = get_transitive_proof env evm car rel in match c with @@ -1466,7 +1466,7 @@ let setoid_transitivity c gl = | Some c -> apply_with_bindings (proof,Rawterm.ExplicitBindings [ dummy_loc, Rawterm.NamedHyp (id_of_string "y"), c ])) (transitivity_red true c) - + let setoid_symmetry_in id gl = let ctype = pf_type_of gl (mkVar id) in let binders,concl = decompose_prod_assum ctype in @@ -1507,12 +1507,12 @@ END let implify id gl = let (_, b, ctype) = pf_get_hyp gl id in let binders,concl = decompose_prod_assum ctype in - let ctype' = + let ctype' = match binders with - | (_, None, ty as hd) :: tl when not (dependent (mkRel 1) concl) -> + | (_, None, ty as hd) :: tl when not (dependent (mkRel 1) concl) -> let env = Environ.push_rel_context tl (pf_env gl) in let sigma = project gl in - let tyhd = Typing.type_of env sigma ty + let tyhd = Typing.type_of env sigma ty and tyconcl = Typing.type_of (Environ.push_rel hd env) sigma concl in let app = mkApp (arrow_morphism tyhd (subst1 mkProp tyconcl), [| ty; (subst1 mkProp concl) |]) in it_mkProd_or_LetIn app tl diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index 28173b7a34..8e55d4f5cc 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -51,13 +51,13 @@ open Extrawit open Pcoq let safe_msgnl s = - try msgnl s with e -> - msgnl + try msgnl s with e -> + msgnl (str "bug in the debugger: " ++ str "an exception is raised while printing debug information") let error_syntactic_metavariables_not_allowed loc = - user_err_loc + user_err_loc (loc,"out_ident", str "Syntactic metavariables allowed only in quotations.") @@ -76,7 +76,7 @@ type ltac_type = type value = | VRTactic of (goal list sigma * validation) (* For Match results *) (* Not a true value *) - | VFun of ltac_trace * (identifier*value) list * + | VFun of ltac_trace * (identifier*value) list * identifier option list * glob_tactic_expr | VVoid | VInteger of int @@ -135,7 +135,7 @@ let rec pr_value env = function str "a list (first element is " ++ pr_value env a ++ str")" (* Transforms an id into a constr if possible, or fails *) -let constr_of_id env id = +let constr_of_id env id = construct_reference (Environ.named_context env) id (* To embed tactics *) @@ -212,7 +212,7 @@ let _ = "fail", TacFail(ArgArg 0,[]); "fresh", TacArg(TacFreshId []) ] - + let lookup_atomic id = Idmap.find id !atomic_mactab let is_atomic_kn kn = let (_,_,l) = repr_kn kn in @@ -238,7 +238,7 @@ let tac_tab = Hashtbl.create 17 let add_tactic s t = if Hashtbl.mem tac_tab s then - errorlabstrm ("Refiner.add_tactic: ") + errorlabstrm ("Refiner.add_tactic: ") (str ("Cannot redeclare tactic "^s^".")); Hashtbl.add tac_tab s t @@ -250,9 +250,9 @@ let overwriting_add_tactic s t = Hashtbl.add tac_tab s t let lookup_tactic s = - try + try Hashtbl.find tac_tab s - with Not_found -> + with Not_found -> errorlabstrm "Refiner.lookup_tactic" (str"The tactic " ++ str s ++ str" is not installed.") (* @@ -271,7 +271,7 @@ type glob_sign = { type interp_genarg_type = (glob_sign -> raw_generic_argument -> glob_generic_argument) * - (interp_sign -> goal sigma -> glob_generic_argument -> + (interp_sign -> goal sigma -> glob_generic_argument -> typed_generic_argument) * (substitution -> glob_generic_argument -> glob_generic_argument) @@ -279,7 +279,7 @@ let extragenargtab = ref (Gmap.empty : (string,interp_genarg_type) Gmap.t) let add_interp_genarg id f = extragenargtab := Gmap.add id f !extragenargtab -let lookup_genarg id = +let lookup_genarg id = try Gmap.find id !extragenargtab with Not_found -> failwith ("No interpretation function found for entry "^id) @@ -300,7 +300,7 @@ let propagate_trace ist loc id = function (* Dynamically check that an argument is a tactic *) let coerce_to_tactic loc id = function | VFun _ | VRTactic _ as a -> a - | _ -> user_err_loc + | _ -> user_err_loc (loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") (*****************) @@ -309,8 +309,8 @@ let coerce_to_tactic loc id = function (* We have identifier <| global_reference <| constr *) -let find_ident id ist = - List.mem id (fst ist.ltacvars) or +let find_ident id ist = + List.mem id (fst ist.ltacvars) or List.mem id (ids_of_named_context (Environ.named_context ist.genv)) let find_recvar qid ist = List.assoc qid ist.ltacrecvars @@ -344,7 +344,7 @@ let vars_of_ist (lfun,_,_,env) = let get_current_context () = try Pfedit.get_current_goal_context () - with e when Logic.catchable_exception e -> + with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) let strict_check = ref false @@ -374,10 +374,10 @@ let intern_inductive ist = function let intern_global_reference ist = function | Ident (loc,id) when find_var id ist -> ArgVar (loc,id) - | r -> + | r -> let loc,_ as lqid = qualid_of_reference r in try ArgArg (loc,locate_global_with_alias lqid) - with Not_found -> + with Not_found -> error_global_not_found_loc lqid let intern_ltac_variable ist = function @@ -485,16 +485,16 @@ let intern_quantified_hypothesis ist = function | NamedHyp id -> (* Uncomment to disallow "intros until n" in ltac when n is not bound *) NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*)) - + let intern_binding_name ist x = (* We use identifier both for variables and binding names *) - (* Todo: consider the body of the lemma to which the binding refer + (* Todo: consider the body of the lemma to which the binding refer and if a term w/o ltac vars, check the name is indeed quantified *) x let intern_constr_gen isarity {ltacvars=lfun; gsigma=sigma; genv=env} c = let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in - let c' = + let c' = warn (Constrintern.intern_gen isarity ~ltacvars:(fst lfun,[]) sigma env) c in (c',if !strict_check then None else Some c) @@ -541,7 +541,7 @@ let intern_evaluable_global_reference ist r = let lqid = qualid_of_reference r in try evaluable_of_global_reference ist.genv (locate_global_with_alias lqid) with Not_found -> - match r with + match r with | Ident (loc,id) when not !strict_check -> EvalVarRef id | _ -> error_global_not_found_loc lqid @@ -578,7 +578,7 @@ let intern_red_expr ist = function | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l) | Simpl o -> Simpl (Option.map (intern_constr_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ | CbvVm as r ) -> r - + let intern_in_hyp_as ist lf (id,ipat) = (intern_hyp_or_metaid ist id, Option.map (intern_intro_pattern lf ist) ipat) @@ -660,7 +660,7 @@ let rec intern_match_goal_hyps sigma env lfun = function (* Utilities *) let extract_let_names lrc = - List.fold_right + List.fold_right (fun ((loc,name),_) l -> if List.mem name l then user_err_loc @@ -676,7 +676,7 @@ let clause_app f = function (* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *) let rec intern_atomic lf ist x = - match (x:raw_atomic_tactic_expr) with + match (x:raw_atomic_tactic_expr) with (* Basic tactics *) | TacIntroPattern l -> TacIntroPattern (List.map (intern_intro_pattern lf ist) l) @@ -759,12 +759,12 @@ let rec intern_atomic lf ist x = | TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l) | TacMove (dep,id1,id2) -> TacMove (dep,intern_hyp_or_metaid ist id1,intern_move_location ist id2) - | TacRename l -> - TacRename (List.map (fun (id1,id2) -> - intern_hyp_or_metaid ist id1, + | TacRename l -> + TacRename (List.map (fun (id1,id2) -> + intern_hyp_or_metaid ist id1, intern_hyp_or_metaid ist id2) l) | TacRevert l -> TacRevert (List.map (intern_hyp_or_metaid ist) l) - + (* Constructors *) | TacLeft (ev,bl) -> TacLeft (ev,intern_bindings ist bl) | TacRight (ev,bl) -> TacRight (ev,intern_bindings ist bl) @@ -785,14 +785,14 @@ let rec intern_atomic lf ist x = (* Equivalence relations *) | TacReflexivity -> TacReflexivity - | TacSymmetry idopt -> + | TacSymmetry idopt -> TacSymmetry (clause_app (intern_hyp_location ist) idopt) | TacTransitivity c -> TacTransitivity (Option.map (intern_constr ist) c) (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - TacRewrite - (ev, + | TacRewrite (ev,l,cl,by) -> + TacRewrite + (ev, List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings ist c)) l, clause_app (intern_hyp_location ist) cl, Option.map (intern_tactic ist) by) @@ -819,7 +819,7 @@ and intern_tactic_seq ist = function | TacLetIn (isrec,l,u) -> let (l1,l2) = ist.ltacvars in let ist' = { ist with ltacvars = (extract_let_names l @ l1, l2) } in - let l = List.map (fun (n,b) -> + let l = List.map (fun (n,b) -> (n,intern_tacarg !strict_check (if isrec then ist' else ist) b)) l in ist.ltacvars, TacLetIn (isrec,l,intern_tactic ist' u) | TacMatchGoal (lz,lr,lmr) -> @@ -827,7 +827,7 @@ and intern_tactic_seq ist = function | TacMatch (lz,c,lmr) -> ist.ltacvars, TacMatch (lz,intern_tactic ist c,intern_match_rule ist lmr) | TacId l -> ist.ltacvars, TacId (intern_message ist l) - | TacFail (n,l) -> + | TacFail (n,l) -> ist.ltacvars, TacFail (intern_or_var ist n,intern_message ist l) | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac) | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s) @@ -846,7 +846,7 @@ and intern_tactic_seq ist = function let ist' = { ist with ltacvars = lfun' } in (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) lfun', TacThens (t, List.map (intern_tactic ist') tl) - | TacDo (n,tac) -> + | TacDo (n,tac) -> ist.ltacvars, TacDo (intern_or_var ist n,intern_tactic ist tac) | TacTry tac -> ist.ltacvars, TacTry (intern_tactic ist tac) | TacInfo tac -> ist.ltacvars, TacInfo (intern_tactic ist tac) @@ -858,7 +858,7 @@ and intern_tactic_seq ist = function | TacComplete tac -> ist.ltacvars, TacComplete (intern_tactic ist tac) | TacArg a -> ist.ltacvars, TacArg (intern_tacarg true ist a) -and intern_tactic_fun ist (var,body) = +and intern_tactic_fun ist (var,body) = let (l1,l2) = ist.ltacvars in let lfun' = List.rev_append (Option.List.flatten var) l1 in (var,intern_tactic { ist with ltacvars = (lfun',l2) } body) @@ -866,7 +866,7 @@ and intern_tactic_fun ist (var,body) = and intern_tacarg strict ist = function | TacVoid -> TacVoid | Reference r -> intern_non_tactic_reference strict ist r - | IntroPattern ipat -> + | IntroPattern ipat -> let lf = ref([],[]) in (*How to know what names the intropattern binds?*) IntroPattern (intern_intro_pattern lf ist ipat) | Integer n -> Integer n @@ -883,7 +883,7 @@ and intern_tacarg strict ist = function TacCall (loc, intern_applied_tactic_reference ist f, List.map (intern_tacarg !strict_check ist) l) - | TacExternal (loc,com,req,la) -> + | TacExternal (loc,com,req,la) -> TacExternal (loc,com,req,List.map (intern_tacarg !strict_check ist) la) | TacFreshId x -> TacFreshId (List.map (intern_or_var ist) x) | Tacexp t -> Tacexp (intern_tactic ist t) @@ -924,7 +924,7 @@ and intern_genarg ist x = (intern_intro_pattern lf ist (out_gen rawwit_intro_pattern x)) | IdentArgType b -> let lf = ref ([],[]) in - in_gen (globwit_ident_gen b) + in_gen (globwit_ident_gen b) (intern_ident lf ist (out_gen (rawwit_ident_gen b) x)) | VarArgType -> in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x)) @@ -935,7 +935,7 @@ and intern_genarg ist x = | ConstrArgType -> in_gen globwit_constr (intern_constr ist (out_gen rawwit_constr x)) | ConstrMayEvalArgType -> - in_gen globwit_constr_may_eval + in_gen globwit_constr_may_eval (intern_constr_may_eval ist (out_gen rawwit_constr_may_eval x)) | QuantHypArgType -> in_gen globwit_quant_hyp @@ -957,7 +957,7 @@ and intern_genarg ist x = | PairArgType _ -> app_pair (intern_genarg ist) (intern_genarg ist) x | ExtraArgType s -> match tactic_genarg_level s with - | Some n -> + | Some n -> (* Special treatment of tactic arguments *) in_gen (globwit_tactic n) (intern_tactic ist (out_gen (rawwit_tactic n) x)) @@ -989,7 +989,7 @@ let give_context ctxt = function | Some id -> [id,VConstr_context ctxt] (* Reads a pattern by substituting vars of lfun *) -let eval_pattern lfun c = +let eval_pattern lfun c = let lvar = List.map (fun (id,c) -> (id,lazy(pattern_of_constr c))) lfun in instantiate_pattern lvar c @@ -1062,7 +1062,7 @@ let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps = | Subterm (b,ic,t) -> let rec match_next_pattern find_next () = let (lmeta,ctxt,find_next') = find_next () in - try + try let lmeta = verify_metas_coherence gl lmatch lmeta in (give_context ctxt ic,lmeta,match_next_pattern find_next') with @@ -1075,30 +1075,30 @@ let apply_one_mhyp_context ist env gl lmatch (hypname,patv,pat) lhyps = let rec match_next_pattern find_next () = try let (ids, lmeta, find_next') = find_next () in - (get_id_couple id hypname@ids, lmeta, hd, + (get_id_couple id hypname@ids, lmeta, hd, match_next_pattern find_next') with | PatternMatchingFailure -> apply_one_mhyp_context_rec tl in match_next_pattern (fun () -> match_pat lmatch hyp pat) () - | Some patv -> + | Some patv -> match b with - | Some body -> + | Some body -> let rec match_next_pattern_in_body next_in_body () = try let (ids,lmeta,next_in_body') = next_in_body() in let rec match_next_pattern_in_typ next_in_typ () = try let (ids',lmeta',next_in_typ') = next_in_typ() in - (get_id_couple id hypname@ids@ids', lmeta', hd, + (get_id_couple id hypname@ids@ids', lmeta', hd, match_next_pattern_in_typ next_in_typ') with | PatternMatchingFailure -> match_next_pattern_in_body next_in_body' () in - match_next_pattern_in_typ + match_next_pattern_in_typ (fun () -> match_pat lmeta hyp pat) () with PatternMatchingFailure -> apply_one_mhyp_context_rec tl in - match_next_pattern_in_body + match_next_pattern_in_body (fun () -> match_pat lmatch body patv) () | None -> apply_one_mhyp_context_rec tl) | [] -> @@ -1137,12 +1137,12 @@ let debugging_exception_step ist signal_anomaly e pp = let explain_exc = if signal_anomaly then explain_logic_error else explain_logic_error_no_anomaly in - debugging_step ist (fun () -> + debugging_step ist (fun () -> pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ !explain_exc e) let error_ltac_variable loc id env v s = - user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ - strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ + user_err_loc (loc, "", str "Ltac variable " ++ pr_id id ++ + strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ strbrk "which cannot be coerced to " ++ str s ++ str".") exception CannotCoerceTo of string @@ -1169,7 +1169,7 @@ let interp_ident_gen fresh ist gl id = try try_interp_ltac_var (coerce_to_ident fresh env) ist (Some env) (dloc,id) with Not_found -> id -let interp_ident = interp_ident_gen false +let interp_ident = interp_ident_gen false let interp_fresh_ident = interp_ident_gen true (* Interprets an optional identifier which must be fresh *) @@ -1216,7 +1216,7 @@ let int_or_var_list_of_VList = function | _ -> raise Not_found let interp_int_or_var_as_list ist = function - | ArgVar (_,id as locid) -> + | ArgVar (_,id as locid) -> (try int_or_var_list_of_VList (List.assoc id ist.lfun) with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)]) | ArgArg n as x -> [x] @@ -1239,7 +1239,7 @@ let interp_hyp ist gl (loc,id as locid) = let env = pf_env gl in (* Look first in lfun for a value coercible to a variable *) try try_interp_ltac_var (coerce_to_hyp env) ist (Some env) locid - with Not_found -> + with Not_found -> (* Then look if bound in the proof context at calling time *) if is_variable env id then id else user_err_loc (loc,"eval_variable",pr_id id ++ str " not found.") @@ -1279,7 +1279,7 @@ let coerce_to_reference env v = let interp_reference ist env = function | ArgArg (_,r) -> r - | ArgVar locid -> + | ArgVar locid -> interp_ltac_var (coerce_to_reference env) ist (Some env) locid let pf_interp_reference ist gl = interp_reference ist (pf_env gl) @@ -1296,7 +1296,7 @@ let coerce_to_evaluable_ref env v = let ev = match v with | VConstr c when isConst c -> EvalConstRef (destConst c) | VConstr c when isVar c -> EvalVarRef (destVar c) - | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env) + | VIntroPattern (IntroIdentifier id) when List.mem id (ids_of_context env) -> EvalVarRef id | _ -> raise (CannotCoerceTo "an evaluable reference") in @@ -1316,7 +1316,7 @@ let interp_evaluable ist env = function | EvalConstRef _ -> r | _ -> Pretype_errors.error_var_not_found_loc loc id) | ArgArg (r,None) -> r - | ArgVar locid -> + | ArgVar locid -> interp_ltac_var (coerce_to_evaluable_ref env) ist (Some env) locid (* Interprets an hypothesis name *) @@ -1334,10 +1334,10 @@ let interp_clause ist gl { onhyps=ol; concl_occs=occs } = (* Extract the constr list from lfun *) let rec constr_list_aux env = function - | (id,v)::tl -> + | (id,v)::tl -> let (l1,l2) = constr_list_aux env tl in (try ((id,constr_of_value env v)::l1,l2) - with Not_found -> + with Not_found -> let ido = match v with | VIntroPattern (IntroIdentifier id0) -> Some id0 | _ -> None in @@ -1349,9 +1349,9 @@ let constr_list ist env = constr_list_aux env ist.lfun (* Extract the identifier list from lfun: join all branches (what to do else?)*) let rec intropattern_ids (loc,pat) = match pat with | IntroIdentifier id -> [id] - | IntroOrAndPattern ll -> + | IntroOrAndPattern ll -> List.flatten (List.map intropattern_ids (List.flatten ll)) - | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ + | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ | IntroForthcoming _ -> [] let rec extract_ids ids = function @@ -1365,8 +1365,8 @@ let default_fresh_id = id_of_string "H" let interp_fresh_id ist gl l = let ids = map_succeed (function ArgVar(_,id) -> id | _ -> failwith "") l in let avoid = (extract_ids ids ist.lfun) @ ist.avoid_ids in - let id = - if l = [] then default_fresh_id + let id = + if l = [] then default_fresh_id else let s = String.concat "" (List.map (function @@ -1396,11 +1396,11 @@ let declare_implicit_tactic tac = implicit_tactic := Some tac open Evd -let solvable_by_tactic env evi (ev,args) src = +let solvable_by_tactic env evi (ev,args) src = match (!implicit_tactic, src) with | Some tac, (ImplicitArg _ | QuestionMark _) - when - Environ.named_context_of_val evi.evar_hyps = + when + Environ.named_context_of_val evi.evar_hyps = Environ.named_context env -> let id = id_of_string "H" in start_proof id (Local,Proof Lemma) evi.evar_hyps evi.evar_concl @@ -1408,9 +1408,9 @@ let solvable_by_tactic env evi (ev,args) src = begin try by (tclCOMPLETE tac); - let _,(const,_,_,_) = cook_proof ignore in + let _,(const,_,_,_) = cook_proof ignore in delete_current_proof (); const.const_entry_body - with e when Logic.catchable_exception e -> + with e when Logic.catchable_exception e -> delete_current_proof(); raise Exit end @@ -1424,13 +1424,13 @@ let solve_remaining_evars env initial_sigma evd c = let (loc,src) = evar_source ev !evdref in let sigma = !evdref in let evi = Evd.find sigma ev in - (try + (try let c = solvable_by_tactic env evi k src in evdref := Evd.define ev c !evdref; c with Exit -> Pretype_errors.error_unsolvable_implicit loc env sigma evi src None) - | _ -> map_constr proc_rec c + | _ -> map_constr proc_rec c in proc_rec (Evarutil.nf_isevar !evdref c) @@ -1524,7 +1524,7 @@ let pf_interp_open_constr_list = let pf_interp_open_constr_list_as_list ist gl (c,_ as x) = match c with | RVar (_,id) -> - (try List.map inj_open + (try List.map inj_open (constr_list_of_VList (pf_env gl) (List.assoc id ist.lfun)) with Not_found -> [interp_open_constr None ist (project gl) (pf_env gl) x]) @@ -1546,16 +1546,16 @@ let interp_unfold ist env (occs,qid) = let interp_flag ist env red = { red with rConst = List.map (interp_evaluable ist env) red.rConst } -let interp_pattern ist sigma env (occs,c) = +let interp_pattern ist sigma env (occs,c) = (interp_occurrences ist occs, interp_constr ist sigma env c) let pf_interp_constr_with_occurrences ist gl = interp_pattern ist (project gl) (pf_env gl) -let pf_interp_constr_with_occurrences_and_name_as_list = +let pf_interp_constr_with_occurrences_and_name_as_list = pf_interp_constr_in_compound_list (fun c -> ((all_occurrences_expr,c),Anonymous)) - (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c + (function ((occs,c),Anonymous) when occs = all_occurrences_expr -> c | _ -> raise Not_found) (fun ist gl (occ_c,na) -> (interp_pattern ist (project gl) (pf_env gl) occ_c, @@ -1586,17 +1586,17 @@ let interp_may_eval f ist gl = function user_err_loc (loc, "interp_may_eval", str "Unbound context identifier" ++ pr_id s ++ str".")) | ConstrTypeOf c -> pf_type_of gl (f ist gl c) - | ConstrTerm c -> - try + | ConstrTerm c -> + try f ist gl c with e -> debugging_exception_step ist false e (fun () -> str"interpretation of term " ++ pr_rawconstr_env (pf_env gl) (fst c)); - raise e + raise e (* Interprets a constr expression possibly to first evaluate *) let interp_constr_may_eval ist gl c = - let csr = + let csr = try interp_may_eval pf_interp_constr ist gl c with e -> @@ -1636,7 +1636,7 @@ let rec interp_message_nl ist = function | l -> prlist_with_sep spc (interp_message_token ist) l ++ fnl() let interp_message ist l = - (* Force evaluation of interp_message_token so that potential errors + (* Force evaluation of interp_message_token so that potential errors are raised now and not at printing time *) prlist (fun x -> spc () ++ x) (List.map (interp_message_token ist) l) @@ -1693,16 +1693,16 @@ let interp_binding_name ist = function (* (as in Inversion) *) let coerce_to_decl_or_quant_hyp env = function | VInteger n -> AnonHyp n - | v -> + | v -> try NamedHyp (coerce_to_hyp env v) - with CannotCoerceTo _ -> + with CannotCoerceTo _ -> raise (CannotCoerceTo "a declared or quantified hypothesis") let interp_declared_or_quantified_hypothesis ist gl = function | AnonHyp n -> AnonHyp n | NamedHyp id -> let env = pf_env gl in - try try_interp_ltac_var + try try_interp_ltac_var (coerce_to_decl_or_quant_hyp env) ist (Some env) (dloc,id) with Not_found -> NamedHyp id @@ -1762,13 +1762,13 @@ let rec val_interp ist gl (tac:glob_tactic_expr) = | TacFun (it,body) -> VFun (ist.trace,ist.lfun,it,body) | TacLetIn (true,l,u) -> interp_letrec ist gl l u | TacLetIn (false,l,u) -> interp_letin ist gl l u - | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr + | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist gl lz lr lmr | TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr | TacArg a -> interp_tacarg ist gl a (* Delayed evaluation *) | t -> VFun (ist.trace,ist.lfun,[],t) - in check_for_interrupt (); + in check_for_interrupt (); match ist.debug with | DebugOn lev -> debug_prompt lev gl tac (fun v -> value_interp {ist with debug=v}) @@ -1792,15 +1792,15 @@ and eval_tactic ist = function | TacAbstract (tac,ido) -> fun gl -> Tactics.tclABSTRACT (Option.map (interp_ident ist gl) ido) (interp_tactic ist tac) gl - | TacThen (t1,tf,t,tl) -> + | TacThen (t1,tf,t,tl) -> tclTHENS3PARTS (interp_tactic ist t1) (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) | TacThens (t1,tl) -> tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl) | TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac) | TacTry tac -> tclTRY (interp_tactic ist tac) - | TacInfo tac -> + | TacInfo tac -> let t = (interp_tactic ist tac) in - tclINFO + tclINFO begin match tac with TacAtom (_,_) -> t @@ -1827,7 +1827,7 @@ and interp_ltac_reference loc' mustbetac ist gl = function | ArgArg (loc,r) -> let ids = extract_ids [] ist.lfun in let loc_info = ((if loc' = dloc then loc else loc'),LtacNameCall r) in - let ist = + let ist = { lfun=[]; debug=ist.debug; avoid_ids=ids; trace = push_trace loc_info ist.trace } in val_interp ist gl (lookup r) @@ -1847,7 +1847,7 @@ and interp_tacarg ist gl = function interp_app loc ist gl fv largs | TacExternal (loc,com,req,la) -> interp_external loc ist gl com req (List.map (interp_tacarg ist gl) la) - | TacFreshId l -> + | TacFreshId l -> let id = interp_fresh_id ist gl l in VIntroPattern (IntroIdentifier id) | Tacexp t -> val_interp ist gl t @@ -1875,7 +1875,7 @@ and interp_app loc ist gl fv largs = (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> let (newlfun,lvar,lval)=head_with_value (var,largs) in if lvar=[] then - let v = + let v = try catch_error trace (val_interp {ist with lfun=newlfun@olfun; trace=trace} gl) body @@ -1916,7 +1916,7 @@ and eval_with_fail ist is_lazy goal tac = VRTactic (catch_error trace tac goal) | a -> a) with - | FailError (0,s) | Stdpp.Exc_located(_, FailError (0,s)) + | FailError (0,s) | Stdpp.Exc_located(_, FailError (0,s)) | Stdpp.Exc_located(_,LtacLocated (_,FailError (0,s))) -> raise (Eval_fail (Lazy.force s)) | FailError (lvl,s) -> raise (FailError (lvl - 1, s)) @@ -1953,7 +1953,7 @@ and interp_match_goal ist goal lz lr lmr = try apply_hyps_context ist env lz goal mt lctxt lgoal mhyps hyps with e when is_match_catchable e -> match_next_pattern find_next' () in match_next_pattern (fun () -> match_subterm_gen app c csr) () in - let rec apply_match_goal ist env goal nrs lex lpt = + let rec apply_match_goal ist env goal nrs lex lpt = begin if lex<>[] then db_pattern_rule ist.debug nrs (List.hd lex); match lpt with @@ -2009,7 +2009,7 @@ and apply_hyps_context ist env lz goal mt lctxt lgmatch mhyps hyps = let id_match = pi1 hyp_match in let nextlhyps = list_remove_assoc_in_triple id_match lhyps_rest in apply_hyps_context_rec (lfun@lids) lm nextlhyps tl - with e when is_match_catchable e -> + with e when is_match_catchable e -> match_next_pattern find_next' in let init_match_pattern () = apply_one_mhyp_context ist env goal lmatch hyp_pat lhyps_rest in @@ -2050,8 +2050,8 @@ and interp_genarg ist gl x = in_gen wit_ref (pf_interp_reference ist gl (out_gen globwit_ref x)) | SortArgType -> in_gen wit_sort - (destSort - (pf_interp_constr ist gl + (destSort + (pf_interp_constr ist gl (RSort (dloc,out_gen globwit_sort x), None))) | ConstrArgType -> in_gen wit_constr (pf_interp_constr ist gl (out_gen globwit_constr x)) @@ -2064,8 +2064,8 @@ and interp_genarg ist gl x = | RedExprArgType -> in_gen wit_red_expr (pf_interp_red_expr ist gl (out_gen globwit_red_expr x)) | OpenConstrArgType casted -> - in_gen (wit_open_constr_gen casted) - (pf_interp_open_constr casted ist gl + in_gen (wit_open_constr_gen casted) + (pf_interp_open_constr casted ist gl (snd (out_gen (globwit_open_constr_gen casted) x))) | ConstrWithBindingsArgType -> in_gen wit_constr_with_bindings @@ -2081,14 +2081,14 @@ and interp_genarg ist gl x = | List1ArgType _ -> app_list1 (interp_genarg ist gl) x | OptArgType _ -> app_opt (interp_genarg ist gl) x | PairArgType _ -> app_pair (interp_genarg ist gl) (interp_genarg ist gl) x - | ExtraArgType s -> + | ExtraArgType s -> match tactic_genarg_level s with - | Some n -> + | Some n -> (* Special treatment of tactic arguments *) in_gen (wit_tactic n) (TacArg(valueIn(VFun(ist.trace,ist.lfun,[], out_gen (globwit_tactic n) x)))) - | None -> + | None -> lookup_interp_genarg s ist gl x and interp_genarg_constr_list0 ist gl x = @@ -2128,7 +2128,7 @@ and interp_match ist g lz constr lmr = with e when is_match_catchable e -> apply_match ist csr []) | (Pat ([],Term c,mt))::tl -> (try - let lmatch = + let lmatch = try extended_matches c csr with e -> debugging_exception_step ist false e (fun () -> @@ -2153,14 +2153,14 @@ and interp_match ist g lz constr lmr = | _ -> errorlabstrm "Tacinterp.apply_match" (str "No matching clauses for match.") in - let csr = + let csr = try interp_ltac_constr ist g constr with e -> debugging_exception_step ist true e (fun () -> str "evaluation of the matched expression"); raise e in let ilr = read_match_rule (fst (constr_list ist (pf_env g))) lmr in - let res = - try apply_match ist csr ilr with e -> + let res = + try apply_match ist csr ilr with e -> debugging_exception_step ist true e (fun () -> str "match expression"); raise e in debugging_step ist (fun () -> @@ -2169,8 +2169,8 @@ and interp_match ist g lz constr lmr = (* Interprets tactic expressions : returns a "constr" *) and interp_ltac_constr ist gl e = - let result = - try val_interp ist gl e with Not_found -> + let result = + try val_interp ist gl e with Not_found -> debugging_step ist (fun () -> str "evaluation failed for" ++ fnl() ++ Pptactic.pr_glob_tactic (pf_env gl) e); @@ -2183,7 +2183,7 @@ and interp_ltac_constr ist gl e = cresult with Not_found -> errorlabstrm "" - (str "Must evaluate to a term" ++ fnl() ++ + (str "Must evaluate to a term" ++ fnl() ++ str "offending expression: " ++ fnl() ++ Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++ str "this is a " ++ (match result with @@ -2192,7 +2192,7 @@ and interp_ltac_constr ist gl e = (str "VFun with body " ++ fnl() ++ Pptactic.pr_glob_tactic (pf_env gl) b ++ fnl() ++ str "instantiated arguments " ++ fnl() ++ - List.fold_right + List.fold_right (fun p s -> let (i,v) = p in str (string_of_id i) ++ str ", " ++ s) il (str "") ++ @@ -2263,7 +2263,7 @@ and interp_atomic ist gl = function h_let_tac b (interp_fresh_name ist gl na) (pf_interp_constr ist gl c) clp (* Automation tactics *) - | TacTrivial (lems,l) -> + | TacTrivial (lems,l) -> Auto.h_trivial (pf_interp_constr_list ist gl lems) (Option.map (List.map (interp_hint_base ist)) l) | TacAuto (n,lems,l) -> @@ -2308,8 +2308,8 @@ and interp_atomic ist gl = function | TacMove (dep,id1,id2) -> h_move dep (interp_hyp ist gl id1) (interp_move_location ist gl id2) | TacRename l -> - h_rename (List.map (fun (id1,id2) -> - interp_hyp ist gl id1, + h_rename (List.map (fun (id1,id2) -> + interp_hyp ist gl id1, interp_fresh_ident ist gl (snd id2)) l) | TacRevert l -> h_revert (interp_hyp_list ist gl l) @@ -2331,7 +2331,7 @@ and interp_atomic ist gl = function (if occl = None & (cl.onhyps = None or cl.onhyps = Some []) & (cl.concl_occs = all_occurrences_expr or cl.concl_occs = no_occurrences_expr) - then pf_interp_type ist gl c + then pf_interp_type ist gl c else pf_interp_constr ist gl c) (interp_clause ist gl cl) @@ -2341,7 +2341,7 @@ and interp_atomic ist gl = function | TacTransitivity c -> h_transitivity (Option.map (pf_interp_constr ist gl) c) (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> + | TacRewrite (ev,l,cl,by) -> Equality.general_multi_multi_rewrite ev (List.map (fun (b,m,c) -> (b,m,interp_open_constr_with_bindings ist gl c)) l) (interp_clause ist gl cl) @@ -2351,7 +2351,7 @@ and interp_atomic ist gl = function (Option.map (interp_intro_pattern ist gl) ids) (interp_declared_or_quantified_hypothesis ist gl hyp) | TacInversion (NonDepInversion (k,idl,ids),hyp) -> - Inv.inv_clause k + Inv.inv_clause k (Option.map (interp_intro_pattern ist gl) ids) (interp_hyp_list ist gl idl) (interp_declared_or_quantified_hypothesis ist gl hyp) @@ -2367,24 +2367,24 @@ and interp_atomic ist gl = function abstract_extended_tactic opn args (tac args) | TacAlias (loc,s,l,(_,body)) -> fun gl -> let rec f x = match genarg_tag x with - | IntArgType -> + | IntArgType -> VInteger (out_gen globwit_int x) | IntOrVarArgType -> mk_int_or_var_value ist (out_gen globwit_int_or_var x) | PreIdentArgType -> failwith "pre-identifiers cannot be bound" | IntroPatternArgType -> - VIntroPattern + VIntroPattern (snd (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))) | IdentArgType b -> value_of_ident (interp_fresh_ident ist gl (out_gen (globwit_ident_gen b) x)) | VarArgType -> mk_hyp_value ist gl (out_gen globwit_var x) - | RefArgType -> - VConstr (constr_of_global + | RefArgType -> + VConstr (constr_of_global (pf_interp_reference ist gl (out_gen globwit_ref x))) - | SortArgType -> + | SortArgType -> VConstr (mkSort (interp_sort (out_gen globwit_sort x))) | ConstrArgType -> mk_constr_value ist gl (out_gen globwit_constr x) @@ -2393,68 +2393,68 @@ and interp_atomic ist gl = function (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x)) | ExtraArgType s when tactic_genarg_level s <> None -> (* Special treatment of tactic arguments *) - val_interp ist gl + val_interp ist gl (out_gen (globwit_tactic (Option.get (tactic_genarg_level s))) x) - | List0ArgType ConstrArgType -> + | List0ArgType ConstrArgType -> let wit = wit_list0 globwit_constr in VList (List.map (mk_constr_value ist gl) (out_gen wit x)) - | List0ArgType VarArgType -> + | List0ArgType VarArgType -> let wit = wit_list0 globwit_var in VList (List.map (mk_hyp_value ist gl) (out_gen wit x)) - | List0ArgType IntArgType -> + | List0ArgType IntArgType -> let wit = wit_list0 globwit_int in VList (List.map (fun x -> VInteger x) (out_gen wit x)) - | List0ArgType IntOrVarArgType -> + | List0ArgType IntOrVarArgType -> let wit = wit_list0 globwit_int_or_var in VList (List.map (mk_int_or_var_value ist) (out_gen wit x)) - | List0ArgType (IdentArgType b) -> + | List0ArgType (IdentArgType b) -> let wit = wit_list0 (globwit_ident_gen b) in let mk_ident x = value_of_ident (interp_fresh_ident ist gl x) in VList (List.map mk_ident (out_gen wit x)) - | List0ArgType IntroPatternArgType -> + | List0ArgType IntroPatternArgType -> let wit = wit_list0 globwit_intro_pattern in let mk_ipat x = VIntroPattern (snd (interp_intro_pattern ist gl x)) in VList (List.map mk_ipat (out_gen wit x)) - | List1ArgType ConstrArgType -> + | List1ArgType ConstrArgType -> let wit = wit_list1 globwit_constr in VList (List.map (mk_constr_value ist gl) (out_gen wit x)) - | List1ArgType VarArgType -> + | List1ArgType VarArgType -> let wit = wit_list1 globwit_var in VList (List.map (mk_hyp_value ist gl) (out_gen wit x)) - | List1ArgType IntArgType -> + | List1ArgType IntArgType -> let wit = wit_list1 globwit_int in VList (List.map (fun x -> VInteger x) (out_gen wit x)) - | List1ArgType IntOrVarArgType -> + | List1ArgType IntOrVarArgType -> let wit = wit_list1 globwit_int_or_var in VList (List.map (mk_int_or_var_value ist) (out_gen wit x)) - | List1ArgType (IdentArgType b) -> + | List1ArgType (IdentArgType b) -> let wit = wit_list1 (globwit_ident_gen b) in let mk_ident x = value_of_ident (interp_fresh_ident ist gl x) in VList (List.map mk_ident (out_gen wit x)) - | List1ArgType IntroPatternArgType -> + | List1ArgType IntroPatternArgType -> let wit = wit_list1 globwit_intro_pattern in let mk_ipat x = VIntroPattern (snd (interp_intro_pattern ist gl x)) in VList (List.map mk_ipat (out_gen wit x)) | StringArgType | BoolArgType - | QuantHypArgType | RedExprArgType - | OpenConstrArgType _ | ConstrWithBindingsArgType - | ExtraArgType _ | BindingsArgType - | OptArgType _ | PairArgType _ - | List0ArgType _ | List1ArgType _ + | QuantHypArgType | RedExprArgType + | OpenConstrArgType _ | ConstrWithBindingsArgType + | ExtraArgType _ | BindingsArgType + | OptArgType _ | PairArgType _ + | List0ArgType _ | List1ArgType _ -> error "This generic type is not supported in alias." - + in let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in let trace = push_trace (loc,LtacNotationCall s) ist.trace in interp_tactic { ist with lfun=lfun; trace=trace } body gl let make_empty_glob_sign () = - { ltacvars = ([],[]); ltacrecvars = []; + { ltacvars = ([],[]); ltacrecvars = []; gsigma = Evd.empty; genv = Global.env() } (* Initial call for interpretation *) -let interp_tac_gen lfun avoid_ids debug t gl = - interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] } +let interp_tac_gen lfun avoid_ids debug t gl = + interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] } (intern_tactic { ltacvars = (List.map fst lfun, []); ltacrecvars = []; gsigma = project gl; genv = pf_env gl } t) gl @@ -2466,17 +2466,17 @@ let eval_tactic t gls = let interp t = interp_tac_gen [] [] (get_debug()) t let eval_ltac_constr gl t = - interp_ltac_constr + interp_ltac_constr { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } gl (intern_tactic (make_empty_glob_sign ()) t ) (* Hides interpretation for pretty-print *) let hide_interp t ot gl = - let ist = { ltacvars = ([],[]); ltacrecvars = []; + let ist = { ltacvars = ([],[]); ltacrecvars = []; gsigma = project gl; genv = pf_env gl } in let te = intern_tactic ist t in let t = eval_tactic te in - match ot with + match ot with | None -> abstract_tactic_expr (TacArg (Tacexp te)) t gl | Some t' -> abstract_tactic_expr ~dflt:true (TacArg (Tacexp te)) (tclTHEN t t') gl @@ -2520,13 +2520,13 @@ let subst_or_var f = function let subst_located f (_loc,id) = (dloc,f id) -let subst_reference subst = +let subst_reference subst = subst_or_var (subst_located (subst_kn subst)) (*CSC: subst_global_reference is used "only" for RefArgType, that propagates to the syntactic non-terminals "global", used in commands such as - Print. It is also used for non-evaluable references. *) -let subst_global_reference subst = + Print. It is also used for non-evaluable references. *) +let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in if not (eq_constr (constr_of_global ref') t') then @@ -2541,7 +2541,7 @@ let subst_evaluable subst = let subst_eval_ref = subst_evaluable_reference subst in subst_or_var (subst_and_short_name subst_eval_ref) -let subst_unfold subst (l,e) = +let subst_unfold subst (l,e) = (l,subst_evaluable subst e) let subst_flag subst red = @@ -2655,8 +2655,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with | TacTransitivity c -> TacTransitivity (Option.map (subst_rawconstr subst) c) (* Equality and inversion *) - | TacRewrite (ev,l,cl,by) -> - TacRewrite (ev, + | TacRewrite (ev,l,cl,by) -> + TacRewrite (ev, List.map (fun (b,m,c) -> b,m,subst_raw_with_bindings subst c) l, cl,Option.map (subst_tactic subst) by) @@ -2710,14 +2710,14 @@ and subst_tacarg subst = function | MetaIdArg (_loc,_,_) -> assert false | TacCall (_loc,f,l) -> TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) - | TacExternal (_loc,com,req,la) -> + | TacExternal (_loc,com,req,la) -> TacExternal (_loc,com,req,List.map (subst_tacarg subst) la) | (TacVoid | IntroPattern _ | Integer _ | TacFreshId _) as x -> x | Tacexp t -> Tacexp (subst_tactic subst t) | TacDynamic(the_loc,t) as x -> (match tag t with | "tactic" | "value" -> x - | "constr" -> + | "constr" -> TacDynamic(the_loc, constr_in (subst_mps subst (constr_out t))) | s -> anomaly_loc (dloc, "Tacinterp.val_interp", str "Unknown dynamic: <" ++ str s ++ str ">")) @@ -2742,11 +2742,11 @@ and subst_genarg subst (x:glob_generic_argument) = | PreIdentArgType -> in_gen globwit_pre_ident (out_gen globwit_pre_ident x) | IntroPatternArgType -> in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x) - | IdentArgType b -> + | IdentArgType b -> in_gen (globwit_ident_gen b) (out_gen (globwit_ident_gen b) x) | VarArgType -> in_gen globwit_var (out_gen globwit_var x) | RefArgType -> - in_gen globwit_ref (subst_global_reference subst + in_gen globwit_ref (subst_global_reference subst (out_gen globwit_ref x)) | SortArgType -> in_gen globwit_sort (out_gen globwit_sort x) @@ -2756,7 +2756,7 @@ and subst_genarg subst (x:glob_generic_argument) = in_gen globwit_constr_may_eval (subst_raw_may_eval subst (out_gen globwit_constr_may_eval x)) | QuantHypArgType -> in_gen globwit_quant_hyp - (subst_declared_or_quantified_hypothesis subst + (subst_declared_or_quantified_hypothesis subst (out_gen globwit_quant_hyp x)) | RedExprArgType -> in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x)) @@ -2775,11 +2775,11 @@ and subst_genarg subst (x:glob_generic_argument) = | PairArgType _ -> app_pair (subst_genarg subst) (subst_genarg subst) x | ExtraArgType s -> match tactic_genarg_level s with - | Some n -> + | Some n -> (* Special treatment of tactic arguments *) in_gen (globwit_tactic n) (subst_tactic subst (out_gen (globwit_tactic n) x)) - | None -> + | None -> lookup_genarg_subst s subst x (***************************************************************************) @@ -2800,7 +2800,7 @@ type tacdef_kind = | NewTac of identifier let load_md i ((sp,kn),defs) = let dp,_ = repr_path sp in let mp,dir,_ = repr_kn kn in - List.iter (fun (id,t) -> + List.iter (fun (id,t) -> match id with NewTac id -> let sp = Libnames.make_path dp id in @@ -2808,11 +2808,11 @@ let load_md i ((sp,kn),defs) = Nametab.push_tactic (Until i) sp kn; add (kn,t) | UpdateTac kn -> replace (kn,t)) defs - + let open_md i((sp,kn),defs) = let dp,_ = repr_path sp in let mp,dir,_ = repr_kn kn in - List.iter (fun (id,t) -> + List.iter (fun (id,t) -> match id with NewTac id -> let sp = Libnames.make_path dp id in @@ -2822,7 +2822,7 @@ let open_md i((sp,kn),defs) = let cache_md x = load_md 1 x -let subst_kind subst id = +let subst_kind subst id = match id with | NewTac _ -> id | UpdateTac kn -> UpdateTac (Mod_subst.subst_kn subst kn) @@ -2836,7 +2836,7 @@ let (inMD,outMD) = load_function = load_md; open_function = open_md; subst_function = subst_md; - classify_function = (fun o -> Substitute o); + classify_function = (fun o -> Substitute o); export_function = (fun x -> Some x)} let print_ltac id = @@ -2855,18 +2855,18 @@ open Libnames (* Adds a definition for tactics in the table *) let make_absolute_name ident repl = let loc = loc_of_reference ident in - try - let id, kn = + try + let id, kn = if repl then None, Nametab.locate_tactic (snd (qualid_of_reference ident)) else let id = coerce_reference_to_id ident in - Some id, Lib.make_kn id + Some id, Lib.make_kn id in if Gmap.mem kn !mactab then if repl then id, kn else user_err_loc (loc,"Tacinterp.add_tacdef", str "There is already an Ltac named " ++ pr_reference ident ++ str".") - else if is_atomic_kn kn then + else if is_atomic_kn kn then user_err_loc (loc,"Tacinterp.add_tacdef", str "Reserved Ltac name " ++ pr_reference ident ++ str".") else id, kn @@ -2877,9 +2877,9 @@ let make_absolute_name ident repl = let add_tacdef isrec tacl = let rfun = List.map (fun (ident, b, _) -> make_absolute_name ident b) tacl in let ist = - {(make_empty_glob_sign()) with ltacrecvars = + {(make_empty_glob_sign()) with ltacrecvars = if isrec then list_map_filter - (function (Some id, qid) -> Some (id, qid) | (None, _) -> None) rfun + (function (Some id, qid) -> Some (id, qid) | (None, _) -> None) rfun else []} in let gtacl = List.map2 (fun (_,b,def) (id, qid) -> @@ -2891,8 +2891,8 @@ let add_tacdef isrec tacl = let _ = match id0 with Some id0 -> ignore(Lib.add_leaf id0 (inMD gtacl)) | _ -> Lib.add_anonymous_leaf (inMD gtacl) in List.iter - (fun (id,b,_) -> - Flags.if_verbose msgnl (Libnames.pr_reference id ++ + (fun (id,b,_) -> + Flags.if_verbose msgnl (Libnames.pr_reference id ++ (if b then str " is redefined" else str " is defined"))) tacl @@ -2902,13 +2902,13 @@ let add_tacdef isrec tacl = let glob_tactic x = intern_tactic (make_empty_glob_sign ()) x -let glob_tactic_env l env x = +let glob_tactic_env l env x = Flags.with_option strict_check (intern_tactic { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env }) x -let interp_redexp env sigma r = +let interp_redexp env sigma r = let ist = { lfun=[]; avoid_ids=[]; debug=get_debug (); trace=[] } in let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in interp_red_expr ist sigma env (intern_red_expr gist r) @@ -2933,10 +2933,10 @@ let tacticOut = function (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = Auto.set_extern_interp - (fun l -> + (fun l -> let l = List.map (fun (id,c) -> (id,VConstr c)) l in interp_tactic {lfun=l;avoid_ids=[];debug=get_debug(); trace=[]}) -let _ = Auto.set_extern_intern_tac +let _ = Auto.set_extern_intern_tac (fun l -> Flags.with_option strict_check (intern_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])})) diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli index 6b7aabe2e3..18873d1c66 100644 --- a/tactics/tacinterp.mli +++ b/tactics/tacinterp.mli @@ -27,7 +27,7 @@ open Redexpr (* Values for interpretation *) type value = | VRTactic of (goal list sigma * validation) - | VFun of ltac_trace * (identifier*value) list * + | VFun of ltac_trace * (identifier*value) list * identifier option list * glob_tactic_expr | VVoid | VInteger of int @@ -44,7 +44,7 @@ and interp_sign = debug : debug_info; trace : ltac_trace } -val extract_ltac_vars : interp_sign -> Evd.evar_defs -> Environ.env -> +val extract_ltac_vars : interp_sign -> Evd.evar_defs -> Environ.env -> Pretyping.var_map * Pretyping.unbound_ltac_var_map (* Transforms an id into a constr if possible *) @@ -53,7 +53,7 @@ val constr_of_id : Environ.env -> identifier -> constr (* To embed several objects in Coqast.t *) val tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t val tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr) - + val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr val valueIn : value -> raw_tactic_arg @@ -88,7 +88,7 @@ type glob_sign = { val add_interp_genarg : string -> (glob_sign -> raw_generic_argument -> glob_generic_argument) * - (interp_sign -> goal sigma -> glob_generic_argument -> + (interp_sign -> goal sigma -> glob_generic_argument -> typed_generic_argument) * (substitution -> glob_generic_argument -> glob_generic_argument) -> unit @@ -99,14 +99,14 @@ val interp_genarg : val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument -val intern_tactic : +val intern_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr val intern_constr : glob_sign -> constr_expr -> rawconstr_and_expr val intern_constr_with_bindings : - glob_sign -> constr_expr * constr_expr Rawterm.bindings -> + glob_sign -> constr_expr * constr_expr Rawterm.bindings -> rawconstr_and_expr * rawconstr_and_expr Rawterm.bindings val intern_hyp : @@ -122,7 +122,7 @@ val subst_rawconstr_and_expr : val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value (* Interprets an expression that evaluates to a constr *) -val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr -> +val interp_ltac_constr : interp_sign -> goal sigma -> glob_tactic_expr -> constr (* Interprets redexp arguments *) @@ -134,7 +134,7 @@ val interp_tac_gen : (identifier * value) list -> identifier list -> val interp_hyp : interp_sign -> goal sigma -> identifier located -> identifier -val interp_bindings : interp_sign -> goal sigma -> rawconstr_and_expr Rawterm.bindings -> +val interp_bindings : interp_sign -> goal sigma -> rawconstr_and_expr Rawterm.bindings -> Evd.open_constr Rawterm.bindings (* Initial call for interpretation *) @@ -158,7 +158,7 @@ val hide_interp : raw_tactic_expr -> tactic option -> tactic val declare_implicit_tactic : tactic -> unit (* Declare the xml printer *) -val declare_xml_printer : +val declare_xml_printer : (out_channel -> Environ.env -> Evd.evar_map -> constr -> unit) -> unit (* printing *) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 2b69d7233f..a20fe72efe 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -86,7 +86,7 @@ let rec tclFIRST_PROGRESS_ON tac = function (************************************************************************) let nthDecl m gl = - try List.nth (pf_hyps gl) (m-1) + try List.nth (pf_hyps gl) (m-1) with Failure _ -> error "No such assumption." let nthHypId m gl = pi1 (nthDecl m gl) @@ -129,7 +129,7 @@ let afterHyp id gl = or (Some id), where id is an identifier. This type is useful for defining tactics that may be used either to transform the conclusion (None) or to transform a hypothesis id (Some id). -- - --Eduardo (8/8/97) + --Eduardo (8/8/97) *) (* A [simple_clause] is a set of hypotheses, possibly extended with @@ -156,7 +156,7 @@ let simple_clause_of cl gls = let error_body_selection () = error "This tactic does not support body selection" in let hyps = - match cl.onhyps with + match cl.onhyps with | None -> List.map Option.make (pf_ids_of_hyps gls) | Some l -> @@ -186,7 +186,7 @@ let onClauseLR tac cl gls = tclMAP tac (List.rev (simple_clause_of cl gls)) gls let ifOnHyp pred tac1 tac2 id gl = if pred (id,pf_get_hyp_typ gl id) then tac1 id gl - else + else tac2 id gl @@ -225,14 +225,14 @@ type concrete_clause = clause_atom list let concrete_clause_of cl gls = let hyps = - match cl.onhyps with + match cl.onhyps with | None -> let f id = OnHyp (id,all_occurrences_expr,InHyp) in List.map f (pf_ids_of_hyps gls) | Some l -> List.map (fun ((occs,id),w) -> OnHyp (id,occs,w)) l in if cl.concl_occs = no_occurrences_expr then hyps - else + else OnConcl cl.concl_occs :: hyps (************************************************************************) @@ -241,10 +241,10 @@ let concrete_clause_of cl gls = (* The following tacticals allow to apply a tactic to the branches generated by the application of an elimination - tactic. + tactic. Two auxiliary types --branch_args and branch_assumptions-- are - used to keep track of some information about the ``branches'' of + used to keep track of some information about the ``branches'' of the elimination. *) type branch_args = { @@ -262,18 +262,18 @@ type branch_assumptions = { assums : named_context} (* the list of assumptions introduced *) let fix_empty_or_and_pattern nv l = - (* 1- The syntax does not distinguish between "[ ]" for one clause with no + (* 1- The syntax does not distinguish between "[ ]" for one clause with no names and "[ ]" for no clause at all *) - (* 2- More generally, we admit "[ ]" for any disjunctive pattern of + (* 2- More generally, we admit "[ ]" for any disjunctive pattern of arbitrary length *) if l = [[]] then list_make nv [] else l let check_or_and_pattern_size loc names n = if List.length names <> n then - if n = 1 then + if n = 1 then user_err_loc (loc,"",str "Expects a conjunctive pattern.") - else - user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n + else + user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n ++ str " branches.") let compute_induction_names n = function @@ -288,7 +288,7 @@ let compute_induction_names n = function let compute_construtor_signatures isrec (_,k as ity) = let rec analrec c recargs = - match kind_of_term c, recargs with + match kind_of_term c, recargs with | Prod (_,_,c), recarg::rest -> let b = match dest_recarg recarg with | Norec | Imbr _ -> false @@ -297,7 +297,7 @@ let compute_construtor_signatures isrec (_,k as ity) = | LetIn (_,_,_,c), rest -> false :: (analrec c rest) | _, [] -> [] | _ -> anomaly "compute_construtor_signatures" - in + in let (mib,mip) = Global.lookup_inductive ity in let n = mib.mind_nparams in let lc = @@ -305,27 +305,27 @@ let compute_construtor_signatures isrec (_,k as ity) = let lrecargs = dest_subterms mip.mind_recargs in array_map2 analrec lc lrecargs -let elimination_sort_of_goal gl = +let elimination_sort_of_goal gl = pf_apply Retyping.get_sort_family_of gl (pf_concl gl) -let elimination_sort_of_hyp id gl = +let elimination_sort_of_hyp id gl = pf_apply Retyping.get_sort_family_of gl (pf_get_hyp_typ gl id) let elimination_sort_of_clause = function - | None -> elimination_sort_of_goal + | None -> elimination_sort_of_goal | Some id -> elimination_sort_of_hyp id (* Find the right elimination suffix corresponding to the sort of the goal *) (* c should be of type A1->.. An->B with B an inductive definition *) -let general_elim_then_using mk_elim - isrec allnames tac predicate (indbindings,elimbindings) +let general_elim_then_using mk_elim + isrec allnames tac predicate (indbindings,elimbindings) ind indclause gl = let elim = mk_elim ind gl in (* applying elimination_scheme just a little modified *) let indclause' = clenv_match_args indbindings indclause in let elimclause = mk_clenv_from gl (elim,pf_type_of gl elim) in - let indmv = + let indmv = match kind_of_term (last_arg elimclause.templval.Evd.rebus) with | Meta mv -> mv | _ -> anomaly "elimination" @@ -341,7 +341,7 @@ let general_elim_then_using mk_elim | Var id -> string_of_id id | _ -> "\b" in - error ("The elimination combinator " ^ name_elim ^ " is unknown.") + error ("The elimination combinator " ^ name_elim ^ " is unknown.") in let elimclause' = clenv_fchain indmv elimclause indclause' in let elimclause' = clenv_match_args elimbindings elimclause' in @@ -351,15 +351,15 @@ let general_elim_then_using mk_elim let (hd,largs) = decompose_app ce.templtyp.Evd.rebus in let ba = { branchsign = branchsigns.(i); branchnames = brnames.(i); - nassums = - List.fold_left + nassums = + List.fold_left (fun acc b -> if b then acc+2 else acc+1) 0 branchsigns.(i); branchnum = i+1; ity = ind; largs = List.map (clenv_nf_meta ce) largs; pred = clenv_nf_meta ce hd } - in + in tac ba gl in let branchtacs ce = Array.init (Array.length branchsigns) (after_tac ce) in @@ -368,7 +368,7 @@ let general_elim_then_using mk_elim | None -> elimclause' | Some p -> clenv_unify true Reduction.CONV (mkMeta pmv) p elimclause' - in + in elim_res_pf_THEN_i elimclause' branchtacs gl (* computing the case/elim combinators *) @@ -382,7 +382,7 @@ let gl_make_case_dep ind gl = let gl_make_case_nodep ind gl = pf_apply Indrec.make_case_nodep gl ind (elimination_sort_of_goal gl) -let elimination_then_using tac predicate bindings c gl = +let elimination_then_using tac predicate bindings c gl = let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let indclause = mk_clenv_from gl (c,t) in general_elim_then_using gl_make_elim @@ -394,14 +394,14 @@ let case_then_using = let case_nodep_then_using = general_elim_then_using gl_make_case_nodep false -let elimination_then tac = elimination_then_using tac None +let elimination_then tac = elimination_then_using tac None let simple_elimination_then tac = elimination_then tac ([],[]) -let make_elim_branch_assumptions ba gl = +let make_elim_branch_assumptions ba gl = let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc = - match lb,lc with - | ([], _) -> + match lb,lc with + | ([], _) -> { ba = ba; assums = assums} | ((true::tl), ((idrec,_,_ as recarg)::(idind,_,_ as indarg)::idtl)) -> @@ -417,7 +417,7 @@ let make_elim_branch_assumptions ba gl = recargs, indargs) tl idtl | (_, _) -> anomaly "make_elim_branch_assumptions" - in + in makerec ([],[],[],[],[]) ba.branchsign (try list_firstn ba.nassums (pf_hyps gl) with Failure _ -> anomaly "make_elim_branch_assumptions") @@ -426,8 +426,8 @@ let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl let make_case_branch_assumptions ba gl = let rec makerec (assums,cargs,constargs,recargs) p_0 p_1 = - match p_0,p_1 with - | ([], _) -> + match p_0,p_1 with + | ([], _) -> { ba = ba; assums = assums} | ((true::tl), ((idrec,_,_ as recarg)::idtl)) -> @@ -441,7 +441,7 @@ let make_case_branch_assumptions ba gl = recargs, id::constargs) tl idtl | (_, _) -> anomaly "make_case_branch_assumptions" - in + in makerec ([],[],[],[]) ba.branchsign (try list_firstn ba.nassums (pf_hyps gl) with Failure _ -> anomaly "make_case_branch_assumptions") diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 762c7dc767..b9c8ab928b 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -93,7 +93,7 @@ val ifOnHyp : (identifier * types -> bool) -> (identifier -> tactic) -> (identifier -> tactic) -> identifier -> tactic -val onHyps : (goal sigma -> named_context) -> +val onHyps : (goal sigma -> named_context) -> (named_context -> tactic) -> tactic (*s Tacticals applying to goal components *) @@ -158,7 +158,7 @@ val concrete_clause_of : clause -> goal sigma -> concrete_clause (*s Elimination tacticals. *) -type branch_args = { +type branch_args = { ity : inductive; (* the type we were eliminating on *) largs : constr list; (* its arguments *) branchnum : int; (* the branch number *) @@ -175,15 +175,15 @@ type branch_assumptions = { (* [check_disjunctive_pattern_size loc pats n] returns an appropriate *) (* error message if |pats| <> n *) val check_or_and_pattern_size : - Util.loc -> or_and_intro_pattern_expr -> int -> unit + Util.loc -> or_and_intro_pattern_expr -> int -> unit (* Tolerate "[]" to mean a disjunctive pattern of any length *) -val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr -> +val fix_empty_or_and_pattern : int -> or_and_intro_pattern_expr -> or_and_intro_pattern_expr (* Useful for [as intro_pattern] modifier *) -val compute_induction_names : - int -> intro_pattern_expr located option -> +val compute_induction_names : + int -> intro_pattern_expr located option -> intro_pattern_expr located list array val elimination_sort_of_goal : goal sigma -> sorts_family @@ -192,30 +192,30 @@ val elimination_sort_of_clause : identifier option -> goal sigma -> sorts_family val general_elim_then_using : (inductive -> goal sigma -> constr) -> rec_flag -> - intro_pattern_expr located option -> (branch_args -> tactic) -> + intro_pattern_expr located option -> (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic - + val elimination_then_using : - (branch_args -> tactic) -> constr option -> + (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> constr -> tactic val elimination_then : - (branch_args -> tactic) -> + (branch_args -> tactic) -> (arg_bindings * arg_bindings) -> constr -> tactic val case_then_using : - intro_pattern_expr located option -> (branch_args -> tactic) -> + intro_pattern_expr located option -> (branch_args -> tactic) -> constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic val case_nodep_then_using : - intro_pattern_expr located option -> (branch_args -> tactic) -> - constr option -> (arg_bindings * arg_bindings) -> + intro_pattern_expr located option -> (branch_args -> tactic) -> + constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic val simple_elimination_then : (branch_args -> tactic) -> constr -> tactic -val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic -val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic +val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic +val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 1ac95f7285..7796c36fbf 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -72,7 +72,7 @@ let inj_red_expr = function let inj_ebindings = function | NoBindings -> NoBindings | ImplicitBindings l -> ImplicitBindings (List.map inj_open l) - | ExplicitBindings l -> + | ExplicitBindings l -> ExplicitBindings (List.map (fun (l,id,c) -> (l,id,inj_open c)) l) let dloc = dummy_loc @@ -85,10 +85,10 @@ let dloc = dummy_loc (* General functions *) (****************************************) -let string_of_inductive c = +let string_of_inductive c = try match kind_of_term c with - | Ind ind_sp -> - let (mib,mip) = Global.lookup_inductive ind_sp in + | Ind ind_sp -> + let (mib,mip) = Global.lookup_inductive ind_sp in string_of_id mip.mind_typename | _ -> raise Bound with Bound -> error "Bound head variable." @@ -101,14 +101,14 @@ let rec head_constr_bound t = | Const _ | Ind _ | Construct _ | Var _ -> (hd,args) | _ -> raise Bound -let head_constr c = +let head_constr c = try head_constr_bound c with Bound -> error "Bound head variable." (******************************************) (* Primitive tactics *) (******************************************) -let introduction = Tacmach.introduction +let introduction = Tacmach.introduction let refine = Tacmach.refine let convert_concl = Tacmach.convert_concl let convert_hyp = Tacmach.convert_hyp @@ -117,16 +117,16 @@ let thin_body = Tacmach.thin_body let error_clear_dependency env id = function | Evarutil.OccurHypInSimpleClause None -> errorlabstrm "" (pr_id id ++ str " is used in conclusion.") - | Evarutil.OccurHypInSimpleClause (Some id') -> + | Evarutil.OccurHypInSimpleClause (Some id') -> errorlabstrm "" (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str".") | Evarutil.EvarTypingBreak ev -> errorlabstrm "" - (str "Cannot remove " ++ pr_id id ++ - strbrk " without breaking the typing of " ++ + (str "Cannot remove " ++ pr_id id ++ + strbrk " without breaking the typing of " ++ Printer.pr_existential env ev ++ str".") -let thin l gl = +let thin l gl = try thin l gl with Evarutil.ClearDependencyError (id,err) -> error_clear_dependency (pf_env gl) id err @@ -148,7 +148,7 @@ let internal_cut_rev = internal_cut_rev_gen false let internal_cut_rev_replace = internal_cut_rev_gen true (* Moving hypotheses *) -let move_hyp = Tacmach.move_hyp +let move_hyp = Tacmach.move_hyp let order_hyps = Tacmach.order_hyps @@ -173,7 +173,7 @@ let fresh_id avoid id gl = let mutual_fix = Tacmach.mutual_fix let fix ido n gl = match ido with - | None -> + | None -> mutual_fix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) n [] 0 gl | Some id -> mutual_fix id n [] 0 gl @@ -182,7 +182,7 @@ let fix ido n gl = match ido with let mutual_cofix = Tacmach.mutual_cofix let cofix ido gl = match ido with - | None -> + | None -> mutual_cofix (fresh_id [] (Pfedit.get_current_proof_name ()) gl) [] 0 gl | Some id -> mutual_cofix id [] 0 gl @@ -196,7 +196,7 @@ type tactic_reduction = env -> evar_map -> constr -> constr let pf_reduce_decl redfun where (id,c,ty) gl = let redfun' = pf_reduce redfun gl in match c with - | None -> + | None -> if where = InHypValueOnly then errorlabstrm "" (pr_id id ++ str "has no value."); (id,None,redfun' ty) @@ -243,7 +243,7 @@ let bind_red_expr_occurrences occs nbcl redexp = if nbcl > 1 && has_at_clause redexp then error_illegal_non_atomic_clause () else - redexp + redexp else match redexp with | Unfold (_::_::_) -> @@ -272,31 +272,31 @@ let bind_red_expr_occurrences occs nbcl redexp = assert false (* The following two tactics apply an arbitrary - reduction function either to the conclusion or to a + reduction function either to the conclusion or to a certain hypothesis *) -let reduct_in_concl (redfun,sty) gl = +let reduct_in_concl (redfun,sty) gl = convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) sty gl let reduct_in_hyp redfun (id,where) gl = convert_hyp_no_check - (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl + (pf_reduce_decl redfun where (pf_get_hyp gl id) gl) gl let reduct_option redfun = function - | Some id -> reduct_in_hyp (fst redfun) id - | None -> reduct_in_concl redfun + | Some id -> reduct_in_hyp (fst redfun) id + | None -> reduct_in_concl redfun (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb t env sigma c = - if is_fconv cv_pb env sigma t c then + if is_fconv cv_pb env sigma t c then t - else + else errorlabstrm "convert-check-hyp" (str "Not convertible.") (* Use cumulativity only if changing the conclusion not a subterm *) let change_on_subterm cv_pb t = function | None -> change_and_check cv_pb t - | Some occl -> contextually false occl (change_and_check Reduction.CONV t) + | Some occl -> contextually false occl (change_and_check Reduction.CONV t) let change_in_concl occl t = reduct_in_concl ((change_on_subterm Reduction.CUMUL t occl),DEFAULTcast) @@ -334,8 +334,8 @@ let normalise_in_hyp = reduct_in_hyp compute let normalise_option = reduct_option (compute,DEFAULTcast) let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,DEFAULTcast) -let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) -let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) +let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) +let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) let pattern_option l = reduct_option (pattern_occs l,DEFAULTcast) (* A function which reduces accordingly to a reduction expression, @@ -369,7 +369,7 @@ let reduce redexp cl goal = (* Unfolding occurrences of a constant *) -let unfold_constr = function +let unfold_constr = function | ConstRef sp -> unfold_in_concl [all_occurrences,EvalConstRef sp] | VarRef id -> unfold_in_concl [all_occurrences,EvalVarRef id] | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.") @@ -394,7 +394,7 @@ let default_id env sigma = function | (name,Some b,_) -> id_of_name_using_hdchar env b name (* Non primitive introduction tactics are treated by central_intro - There is possibly renaming, with possibly names to avoid and + There is possibly renaming, with possibly names to avoid and possibly a move to do after the introduction *) type intro_name_flag = @@ -403,11 +403,11 @@ type intro_name_flag = | IntroMustBe of identifier let find_name loc decl gl = function - | IntroAvoid idl -> + | IntroAvoid idl -> (* this case must be compatible with [find_intro_names] below. *) let id = fresh_id idl (default_id (pf_env gl) gl.sigma decl) gl in id | IntroBasedOn (id,idl) -> fresh_id idl id gl - | IntroMustBe id -> + | IntroMustBe id -> let id' = fresh_id [] id gl in if id'<>id then user_err_loc (loc,"",pr_id id ++ str" is already used."); id' @@ -417,16 +417,16 @@ let find_name loc decl gl = function iteration of [find_name] above. As [default_id] checks the sort of the type to build hyp names, we maintain an environment to be able to type dependent hyps. *) -let find_intro_names ctxt gl = - let _, res = List.fold_right - (fun decl acc -> +let find_intro_names ctxt gl = + let _, res = List.fold_right + (fun decl acc -> let wantedname,x,typdecl = decl in let env,idl = acc in let name = fresh_id idl (default_id env gl.sigma decl) gl in let newenv = push_rel (wantedname,x,typdecl) env in (newenv,(name::idl))) ctxt (pf_env gl , []) in - List.rev res + List.rev res let build_intro_tac id = function | MoveToEnd true -> introduction id @@ -439,7 +439,7 @@ let rec intro_gen loc name_flag move_flag force_flag dep_flag gl = | LetIn (name,b,t,u) when not dep_flag or (dependent (mkRel 1) u) -> build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag gl - | _ -> + | _ -> if not force_flag then raise (RefinerError IntroNeedsProduct); try tclTHEN try_red_in_concl @@ -481,14 +481,14 @@ let thin_for_replacing l gl = | Evarutil.OccurHypInSimpleClause None -> errorlabstrm "" (str "Cannot change " ++ pr_id id ++ str ", it is used in conclusion.") - | Evarutil.OccurHypInSimpleClause (Some id') -> + | Evarutil.OccurHypInSimpleClause (Some id') -> errorlabstrm "" - (str "Cannot change " ++ pr_id id ++ + (str "Cannot change " ++ pr_id id ++ strbrk ", it is used in hypothesis " ++ pr_id id' ++ str".") | Evarutil.EvarTypingBreak ev -> errorlabstrm "" - (str "Cannot change " ++ pr_id id ++ - strbrk " without breaking the typing of " ++ + (str "Cannot change " ++ pr_id id ++ + strbrk " without breaking the typing of " ++ Printer.pr_existential (pf_env gl) ev ++ str".") let intro_replacing id gl = @@ -496,13 +496,13 @@ let intro_replacing id gl = tclTHENLIST [thin_for_replacing [id]; introduction id; move_hyp true id next_hyp] gl -let intros_replacing ids gl = +let intros_replacing ids gl = let rec introrec = function | [] -> tclIDTAC | id::tl -> tclTHEN (tclORELSE (intro_replacing id) (intro_using id)) (introrec tl) - in + in introrec ids gl (* User-level introduction tactics *) @@ -520,8 +520,8 @@ let pf_lookup_hypothesis_as_renamed_gen red h gl = let rec aux ccl = match pf_lookup_hypothesis_as_renamed env ccl h with | None when red -> - aux - ((fst (Redexpr.reduction_of_red_expr (Red true))) + aux + ((fst (Redexpr.reduction_of_red_expr (Red true))) env (project gl) ccl) | x -> x in @@ -534,7 +534,7 @@ let is_quantified_hypothesis id g = | None -> false let msg_quantified_hypothesis = function - | NamedHyp id -> + | NamedHyp id -> str "quantified hypothesis named " ++ pr_id id | AnonHyp n -> int n ++ str (match n with 1 -> "st" | 2 -> "nd" | _ -> "th") ++ @@ -544,7 +544,7 @@ let depth_of_quantified_hypothesis red h gl = match pf_lookup_hypothesis_as_renamed_gen red h gl with | Some depth -> depth | None -> - errorlabstrm "lookup_quantified_hypothesis" + errorlabstrm "lookup_quantified_hypothesis" (str "No " ++ msg_quantified_hypothesis h ++ strbrk " in current goal" ++ (if red then strbrk " even after head-reduction" else mt ()) ++ @@ -579,8 +579,8 @@ let dependent_in_decl a (_,c,t) = or a term with bindings *) let onInductionArg tac = function - | ElimOnConstr (c,lbindc as cbl) -> - if isVar c & lbindc = NoBindings then + | ElimOnConstr (c,lbindc as cbl) -> + if isVar c & lbindc = NoBindings then tclTHEN (tclTRY (intros_until_id (destVar c))) (tac cbl) else tac cbl @@ -596,11 +596,11 @@ let onInductionArg tac = function let apply_type hdcty argl gl = refine (applist (mkCast (Evarutil.mk_new_meta(),DEFAULTcast, hdcty),argl)) gl - + let apply_term hdc argl gl = refine (applist (hdc,argl)) gl -let bring_hyps hyps = +let bring_hyps hyps = if hyps = [] then Refiner.tclIDTAC else (fun gl -> @@ -634,15 +634,15 @@ let cut_intro t = tclTHENFIRST (cut t) intro (* cut_replacing échoue si l'hypothèse à remplacer apparaît dans le but, ou dans une autre hypothèse *) -let cut_replacing id t tac = +let cut_replacing id t tac = tclTHENLAST (internal_cut_rev_replace id t) (tac (refine_no_check (mkVar id))) -let cut_in_parallel l = +let cut_in_parallel l = let rec prec = function - | [] -> tclIDTAC + | [] -> tclIDTAC | h::t -> tclTHENFIRST (cut h) (prec t) - in + in prec (List.rev l) let error_uninstantiated_metas t clenv = @@ -652,13 +652,13 @@ let error_uninstantiated_metas t clenv = let clenv_refine_in with_evars ?(with_classes=true) id clenv gl = let clenv = clenv_pose_dependent_evars with_evars clenv in - let clenv = - if with_classes then + let clenv = + if with_classes then { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd } else clenv in let new_hyp_typ = clenv_type clenv in - if not with_evars & occur_meta new_hyp_typ then + if not with_evars & occur_meta new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in tclTHEN @@ -672,40 +672,40 @@ let clenv_refine_in with_evars ?(with_classes=true) id clenv gl = (********************************************) let last_arg c = match kind_of_term c with - | App (f,cl) -> + | App (f,cl) -> array_last cl | _ -> anomaly "last_arg" let elim_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; + modulo_conv_on_closed_terms = Some full_transparent_state; use_metas_eagerly = true; modulo_delta = empty_transparent_state; resolve_evars = false; use_evars_pattern_unification = true; } -let elimination_clause_scheme with_evars allow_K elimclause indclause gl = - let indmv = +let elimination_clause_scheme with_evars allow_K elimclause indclause gl = + let indmv = (match kind_of_term (last_arg elimclause.templval.rebus) with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" - (str "The type of elimination clause is not well-formed.")) + (str "The type of elimination clause is not well-formed.")) in - let elimclause' = clenv_fchain ~flags:elim_flags indmv elimclause indclause in + let elimclause' = clenv_fchain ~flags:elim_flags indmv elimclause indclause in res_pf elimclause' ~with_evars:with_evars ~allow_K:allow_K ~flags:elim_flags gl -(* - * Elimination tactic with bindings and using an arbitrary - * elimination constant called elimc. This constant should end +(* + * Elimination tactic with bindings and using an arbitrary + * elimination constant called elimc. This constant should end * with a clause (x:I)(P .. ), where P is a bound variable. - * The term c is of type t, which is a product ending with a type - * matching I, lbindc are the expected terms for c arguments + * The term c is of type t, which is a product ending with a type + * matching I, lbindc are the expected terms for c arguments *) let general_elim_clause_gen elimtac indclause (elimc,lbindelimc) gl = let elimt = pf_type_of gl elimc in - let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in + let elimclause = make_clenv_binding gl (elimc,elimt) lbindelimc in elimtac elimclause indclause gl let general_elim_clause elimtac (c,lbindc) (elimc,lbindelimc) gl = @@ -717,14 +717,14 @@ let general_elim_clause elimtac (c,lbindc) (elimc,lbindelimc) gl = let general_elim with_evars c e ?(allow_K=true) = general_elim_clause (elimination_clause_scheme with_evars allow_K) c e -(* Elimination tactic with bindings but using the default elimination +(* Elimination tactic with bindings but using the default elimination * constant associated with the type. *) let find_eliminator c gl = let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in lookup_eliminator ind (elimination_sort_of_goal gl) -let default_elim with_evars (c,_ as cx) gl = +let default_elim with_evars (c,_ as cx) gl = general_elim with_evars cx (find_eliminator c gl,NoBindings) gl let elim_in_context with_evars c = function @@ -759,20 +759,20 @@ let clenv_fchain_in id elim_flags mv elimclause hypclause = raise (PretypeError (env,NoOccurrenceFound (op,Some id))) let elimination_in_clause_scheme with_evars id elimclause indclause gl = - let (hypmv,indmv) = + let (hypmv,indmv) = match clenv_independent elimclause with [k1;k2] -> (k1,k2) | _ -> errorlabstrm "elimination_clause" (str "The type of elimination clause is not well-formed.") in - let elimclause' = clenv_fchain indmv elimclause indclause in + let elimclause' = clenv_fchain indmv elimclause indclause in let hyp = mkVar id in let hyp_typ = pf_type_of gl hyp in let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in - let elimclause'' = + let elimclause'' = clenv_fchain_in id elim_flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in if eq_constr hyp_typ new_hyp_typ then - errorlabstrm "general_rewrite_in" + errorlabstrm "general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id elimclause'' gl @@ -784,9 +784,9 @@ let general_elim_in with_evars id = let general_case_analysis_in_context with_evars (c,lbindc) gl = let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in let sort = elimination_sort_of_goal gl in - let case = + let case = if occur_term c (pf_concl gl) then make_case_dep else make_case_gen in - let elim = pf_apply case gl mind sort in + let elim = pf_apply case gl mind sort in general_elim with_evars (c,lbindc) (elim,NoBindings) gl let general_case_analysis with_evars (c,lbindc as cx) = @@ -799,7 +799,7 @@ let general_case_analysis with_evars (c,lbindc as cx) = let simplest_case c = general_case_analysis false (c,NoBindings) -(* Apply a tactic below the products of the conclusion of a lemma *) +(* Apply a tactic below the products of the conclusion of a lemma *) let descend_in_conjunctions with_evars tac exit c gl = try @@ -830,18 +830,18 @@ let descend_in_conjunctions with_evars tac exit c gl = let check_evars sigma evm gl = let origsigma = gl.sigma in - let rest = - Evd.fold (fun ev evi acc -> - if not (Evd.mem origsigma ev) && not (Evd.is_defined sigma ev) + let rest = + Evd.fold (fun ev evi acc -> + if not (Evd.mem origsigma ev) && not (Evd.is_defined sigma ev) then Evd.add acc ev evi else acc) evm Evd.empty - in + in if rest <> Evd.empty then - errorlabstrm "apply" (str"Uninstantiated existential variables: " ++ + errorlabstrm "apply" (str"Uninstantiated existential variables: " ++ fnl () ++ pr_evar_defs rest) let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 = - let flags = + let flags = if with_delta then default_unify_flags else default_no_delta_unify_flags in (* The actual type of the theorem. It will be matched against the goal. If this fails, then the head constant will be unfolded step by @@ -861,13 +861,13 @@ let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 = try try_apply thm_ty0 concl_nprod with PretypeError _|RefinerError _|UserError _|Failure _ as exn -> let rec try_red_apply thm_ty = - try + try (* Try to head-reduce the conclusion of the theorem *) let red_thm = try_red_product (pf_env gl) (project gl) thm_ty in try try_apply red_thm concl_nprod with PretypeError _|RefinerError _|UserError _|Failure _ -> try_red_apply red_thm - with Redelimination -> + with Redelimination -> (* Last chance: if the head is a variable, apply may try second order unification *) try if concl_nprod <> 0 then try_apply thm_ty 0 else raise Exit @@ -877,7 +877,7 @@ let general_apply with_delta with_destruct with_evars (loc,(c,lbind)) gl0 = try_main_apply (fun _ -> Stdpp.raise_with_loc loc exn) c gl else Stdpp.raise_with_loc loc exn - in try_red_apply thm_ty0 + in try_red_apply thm_ty0 in if evm = Evd.empty then try_main_apply with_destruct c gl0 else @@ -889,7 +889,7 @@ let rec apply_with_ebindings_gen b e = function | [] -> tclIDTAC | [cb] -> general_apply b b e cb - | cb::cbl -> + | cb::cbl -> tclTHENLAST (general_apply b b e cb) (apply_with_ebindings_gen b e cbl) let apply_with_ebindings cb = apply_with_ebindings_gen false false [dloc,cb] @@ -907,7 +907,7 @@ let apply c = let eapply c = eapply_with_ebindings (inj_open c,NoBindings) -let apply_list = function +let apply_list = function | c::l -> apply_with_bindings (c,ImplicitBindings l) | _ -> assert false @@ -943,12 +943,12 @@ let apply_in_once_main flags innerclause (d,lbind) gl = try progress_with_clause flags innerclause clause with err -> try aux (clenv_push_prod clause) - with NotExtensibleClause -> raise err in + with NotExtensibleClause -> raise err in aux (make_clenv_binding gl (d,thm) lbind) -let apply_in_once with_delta with_destruct with_evars id +let apply_in_once with_delta with_destruct with_evars id (loc,((sigma,d),lbind)) gl0 = - let flags = + let flags = if with_delta then default_unify_flags else default_no_delta_unify_flags in let t' = pf_get_hyp_typ gl0 id in let innerclause = mk_clenv_from_n gl0 (Some 0) (mkVar id,t') in @@ -986,7 +986,7 @@ let apply_in_once with_delta with_destruct with_evars id *) let cut_and_apply c gl = - let goal_constr = pf_concl gl in + let goal_constr = pf_concl gl in match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> tclTHENLAST @@ -1001,14 +1001,14 @@ let cut_and_apply c gl = let exact_check c gl = let concl = (pf_concl gl) in let ct = pf_type_of gl c in - if pf_conv_x_leq gl ct concl then - refine_no_check c gl - else + if pf_conv_x_leq gl ct concl then + refine_no_check c gl + else error "Not an exact proof." let exact_no_check = refine_no_check -let vm_cast_no_check c gl = +let vm_cast_no_check c gl = let concl = pf_concl gl in refine_no_check (Term.mkCast(c,Term.VMcast,concl)) gl @@ -1016,16 +1016,16 @@ let vm_cast_no_check c gl = let exact_proof c gl = (* on experimente la synthese d'ise dans exact *) let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl) - in refine_no_check c gl + in refine_no_check c gl let (assumption : tactic) = fun gl -> - let concl = pf_concl gl in + let concl = pf_concl gl in let hyps = pf_hyps gl in let rec arec only_eq = function - | [] -> + | [] -> if only_eq then arec false hyps else error "No such assumption." - | (id,c,t)::rest -> - if (only_eq & eq_constr t concl) + | (id,c,t)::rest -> + if (only_eq & eq_constr t concl) or (not only_eq & pf_conv_x_leq gl t concl) then refine_no_check (mkVar id) gl else arec only_eq rest @@ -1037,9 +1037,9 @@ let (assumption : tactic) = fun gl -> (*****************************************************************) (* This tactic enables the user to remove hypotheses from the signature. - * Some care is taken to prevent him from removing variables that are - * subsequently used in other hypotheses or in the conclusion of the - * goal. *) + * Some care is taken to prevent him from removing variables that are + * subsequently used in other hypotheses or in the conclusion of the + * goal. *) let clear ids = (* avant seul dyn_clear n'echouait pas en [] *) if ids=[] then tclIDTAC else thin ids @@ -1055,7 +1055,7 @@ let clear_wildcards ids = (error_clear_dependency (pf_env gl) (id_of_string "_") err)) ids -(* Takes a list of booleans, and introduces all the variables +(* Takes a list of booleans, and introduces all the variables * quantified in the goal which are associated with a value * true in the boolean list. *) @@ -1069,38 +1069,38 @@ let rec intros_clearing = function (* Modifying/Adding an hypothesis *) let specialize mopt (c,lbind) g = - let evars, term = - if lbind = NoBindings then None, c - else + let evars, term = + if lbind = NoBindings then None, c + else let clause = make_clenv_binding g (c,pf_type_of g c) lbind in let clause = clenv_unify_meta_types clause in let (thd,tstack) = whd_stack clause.evd (clenv_value clause) in let nargs = List.length tstack in - let tstack = match mopt with - | Some m -> + let tstack = match mopt with + | Some m -> if m < nargs then list_firstn m tstack else tstack - | None -> - let rec chk = function + | None -> + let rec chk = function | [] -> [] | t::l -> if occur_meta t then [] else t :: chk l in chk tstack - in - let term = applist(thd,tstack) in + in + let term = applist(thd,tstack) in if occur_meta term then errorlabstrm "" (str "Cannot infer an instance for " ++ pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ str "."); Some clause.evd, term in - tclTHEN + tclTHEN (match evars with Some e -> tclEVARS e | _ -> tclIDTAC) (match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with | Var id when List.mem id (pf_ids_of_hyps g) -> tclTHENFIRST (fun g -> internal_cut_replace id (pf_type_of g term) g) (exact_no_check term) - | _ -> tclTHENLAST + | _ -> tclTHENLAST (fun g -> cut (pf_type_of g term) g) (exact_no_check term)) g @@ -1126,7 +1126,7 @@ let keep hyps gl = let check_number_of_constructors expctdnumopt i nconstr = if i=0 then error "The constructors are numbered starting from 1."; - begin match expctdnumopt with + begin match expctdnumopt with | Some n when n <> nconstr -> error ("Not an inductive goal with "^ string_of_int n^plural n " constructor"^".") @@ -1135,20 +1135,20 @@ let check_number_of_constructors expctdnumopt i nconstr = if i > nconstr then error "Not enough constructors." let constructor_tac with_evars expctdnumopt i lbind gl = - let cl = pf_concl gl in - let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in + let cl = pf_concl gl in + let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in let nconstr = Array.length (snd (Global.lookup_inductive mind)).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; let cons = mkConstruct (ith_constructor_of_inductive mind i) in let apply_tac = general_apply true false with_evars (dloc,(inj_open cons,lbind)) in - (tclTHENLIST + (tclTHENLIST [convert_concl_no_check redcl DEFAULTcast; intros; apply_tac]) gl let one_constructor i = constructor_tac false None i -(* Try to apply the constructor of the inductive definition followed by +(* Try to apply the constructor of the inductive definition followed by a tactic t given as an argument. Should be generalize in Constructor (Fun c : I -> tactic) *) @@ -1161,7 +1161,7 @@ let any_constructor with_evars tacopt gl = if nconstr = 0 then error "The type has no constructors."; tclFIRST (List.map - (fun i -> tclTHEN (constructor_tac with_evars None i NoBindings) t) + (fun i -> tclTHEN (constructor_tac with_evars None i NoBindings) t) (interval 1 nconstr)) gl let left_with_ebindings with_evars = constructor_tac with_evars (Some 2) 1 @@ -1246,9 +1246,9 @@ let rewrite_hyp l2r id gl = let rec explicit_intro_names = function | (_, IntroIdentifier id) :: l -> id :: explicit_intro_names l -| (_, (IntroWildcard | IntroAnonymous | IntroFresh _ +| (_, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ | IntroForthcoming _)) :: l -> explicit_intro_names l -| (_, IntroOrAndPattern ll) :: l' -> +| (_, IntroOrAndPattern ll) :: l' -> List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll) | [] -> [] @@ -1259,7 +1259,7 @@ let rec explicit_intro_names = function the tactic, for the hyps to clear *) let rec intros_patterns b avoid thin destopt = function | (loc, IntroWildcard) :: l -> - tclTHEN + tclTHEN (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true false) (onLastHypId (fun id -> @@ -1292,7 +1292,7 @@ let rec intros_patterns b avoid thin destopt = function (intro_or_and_pattern loc b ll l' (intros_patterns b avoid thin destopt))) | (loc, IntroRewrite l2r) :: l -> - tclTHEN + tclTHEN (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true false) (onLastHypId (fun id -> @@ -1305,7 +1305,7 @@ let intros_pattern = intros_patterns false [] [] let intro_pattern destopt pat = intros_patterns false [] [] destopt [dloc,pat] -let intro_patterns = function +let intro_patterns = function | [] -> tclREPEAT intro | l -> intros_pattern no_move l @@ -1322,12 +1322,12 @@ let prepare_intros s ipat gl = match ipat with | IntroAnonymous -> make_id s gl, tclIDTAC | IntroFresh id -> fresh_id [] id gl, tclIDTAC | IntroWildcard -> let id = make_id s gl in id, clear_wildcards [dloc,id] - | IntroRewrite l2r -> + | IntroRewrite l2r -> let id = make_id s gl in id, !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allHypsAndConcl | IntroOrAndPattern ll -> make_id s gl, onLastHypId - (intro_or_and_pattern loc true ll [] + (intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move)) | IntroForthcoming _ -> user_err_loc (loc,"",str "Introduction pattern for one hypothesis expected") @@ -1357,13 +1357,13 @@ let assert_tac na = assert_as true (ipat_of_name na) (* apply in as *) let as_tac id ipat = match ipat with - | Some (loc,IntroRewrite l2r) -> + | Some (loc,IntroRewrite l2r) -> !forward_general_multi_rewrite l2r false (inj_open (mkVar id),NoBindings) allHypsAndConcl | Some (loc,IntroOrAndPattern ll) -> intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move) id | Some (loc, - (IntroIdentifier _ | IntroAnonymous | IntroFresh _ | + (IntroIdentifier _ | IntroAnonymous | IntroFresh _ | IntroWildcard | IntroForthcoming _)) -> user_err_loc (loc,"", str "Disjunctive/conjunctive pattern expected") | None -> tclIDTAC @@ -1376,7 +1376,7 @@ let general_apply_in with_delta with_destruct with_evars id lemmas ipat gl = let apply_in simple with_evars = general_apply_in simple simple with_evars -let simple_apply_in id c = +let simple_apply_in id c = apply_in false false id [dloc,((Evd.empty,c),NoBindings)] None (**************************) @@ -1386,16 +1386,16 @@ let simple_apply_in id c = let generalized_name c t ids cl = function | Name id as na -> if List.mem id ids then - errorlabstrm "" (pr_id id ++ str " is already used"); + errorlabstrm "" (pr_id id ++ str " is already used"); na - | Anonymous -> + | Anonymous -> match kind_of_term c with | Var id -> (* Keep the name even if not occurring: may be used by intros later *) Name id | _ -> if noccurn 1 cl then Anonymous else - (* On ne s'etait pas casse la tete : on avait pris pour nom de + (* On ne s'etait pas casse la tete : on avait pris pour nom de variable la premiere lettre du type, meme si "c" avait ete une constante dont on aurait pu prendre directement le nom *) named_hd (Global.env()) t Anonymous @@ -1415,9 +1415,9 @@ let generalize_dep c gl = let init_ids = ids_of_named_context (Global.named_context()) in let rec seek d toquant = if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant - or dependent_in_decl c d then + or dependent_in_decl c d then d::toquant - else + else toquant in let to_quantify = Sign.fold_named_context seek sign ~init:[] in let to_quantify_rev = List.rev to_quantify in @@ -1445,7 +1445,7 @@ let generalize_gen lconstr gl = let generalize l = generalize_gen (List.map (fun c -> ((all_occurrences,c),Anonymous)) l) -let revert hyps gl = +let revert hyps gl = tclTHEN (generalize (List.map mkVar hyps)) (clear hyps) gl (* Faudra-t-il une version avec plusieurs args de generalize_dep ? @@ -1454,7 +1454,7 @@ Cela peut- généralisation dépendante par n. let quantify lconstr = - List.fold_right + List.fold_right (fun com tac -> tclTHEN tac (tactic_com generalize_dep c)) lconstr tclIDTAC @@ -1520,13 +1520,13 @@ let letin_abstract id c occs gl = if not (in_every_hyp occs) then raise (RefinerError (DoesNotOccurIn (c,hyp))) else raise Not_found - else + else (subst1_named_decl (mkVar id) newdecl, true) - with Not_found -> + with Not_found -> (d,List.exists (fun ((id,_,_),dep) -> dep && occur_var_in_decl env id d) ctxt) in d'::ctxt - in + in let ctxt' = fold_named_context compute_dependency env ~init:[] in let compute_marks ((depdecls,marks as accu),lhyp) ((hyp,_,_) as d,b) = if b then ((d::depdecls,(hyp,lhyp)::marks), lhyp) @@ -1544,7 +1544,7 @@ let letin_tac with_eq name c occs gl = if name = Anonymous then fresh_id [] x gl else if not (mem_named_context x (pf_hyps gl)) then x else error ("The variable "^(string_of_id x)^" is already declared") in - let (depdecls,marks,ccl)= letin_abstract id c occs gl in + let (depdecls,marks,ccl)= letin_abstract id c occs gl in let t = pf_type_of gl c in let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in let args = Array.to_list (instance_from_named_context depdecls) in @@ -1569,11 +1569,11 @@ let letin_abstract id c (occs,check_occs) gl = | Some occ -> let newdecl = subst_term_occ_decl occ c d in if occ = (all_occurrences,InHyp) & d = newdecl then - if check_occs & not (in_every_hyp occs) + if check_occs & not (in_every_hyp occs) then raise (RefinerError (DoesNotOccurIn (c,hyp))) else depdecls - else - (subst1_named_decl (mkVar id) newdecl)::depdecls in + else + (subst1_named_decl (mkVar id) newdecl)::depdecls in let depdecls = fold_named_context compute_dependency env ~init:[] in let ccl = match occurrences_of_goal occs with | None -> pf_concl gl @@ -1588,7 +1588,7 @@ let letin_tac_gen with_eq name c ty occs gl = if name = Anonymous then fresh_id [] x gl else if not (mem_named_context x (pf_hyps gl)) then x else error ("The variable "^(string_of_id x)^" is already declared.") in - let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in + let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in let t = match ty with Some t -> t | None -> pf_type_of gl c in let newcl,eq_tac = match with_eq with | Some (lr,(loc,ido)) -> @@ -1619,10 +1619,10 @@ let letin_tac with_eq name c ty occs = (* Tactics "pose proof" (usetac=None) and "assert" (otherwise) *) let forward usetac ipat c gl = match usetac with - | None -> + | None -> let t = pf_type_of gl c in tclTHENFIRST (assert_as true ipat t) (exact_no_check c) gl - | Some tac -> + | Some tac -> tclTHENFIRST (assert_as true ipat c) tac gl let pose_proof na c = forward None (ipat_of_name na) c @@ -1663,7 +1663,7 @@ let unfold_all x gl = (* * A "natural" induction tactic - * + * - [H0:T0, ..., Hi:Ti, hyp0:P->I(args), Hi+1:Ti+1, ..., Hn:Tn |-G] is the goal - [hyp0] is the induction hypothesis - we extract from [args] the variables which are not rigid parameters @@ -1695,13 +1695,13 @@ let unfold_all x gl = let check_unused_names names = if names <> [] & Flags.is_verbose () then - msg_warning + msg_warning (str"Unused introduction " ++ str (plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc pr_intro_pattern names) let rec first_name_buggy avoid gl (loc,pat) = match pat with | IntroOrAndPattern [] -> no_move - | IntroOrAndPattern ([]::l) -> + | IntroOrAndPattern ([]::l) -> first_name_buggy avoid gl (loc,IntroOrAndPattern l) | IntroOrAndPattern ((p::_)::_) -> first_name_buggy avoid gl p | IntroWildcard -> no_move @@ -1766,7 +1766,7 @@ let induct_discharge statuslists destopt avoid' (avoid,ra) names gl = (peel_tac ra' names tophyp) gl | (RecArg,dep,recvarname) :: ra' -> let pat,names = consume_pattern avoid recvarname dep gl names in - tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat]) + tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat]) (peel_tac ra' names tophyp) gl | (OtherArg,_,_) :: ra' -> let pat,names = match names with @@ -1816,7 +1816,7 @@ let atomize_param_of_ind (indref,nparams) hyp0 gl = tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) (atomize_one (i-1) ((mkVar x)::avoid)) gl - else + else tclIDTAC gl in atomize_one (List.length argl) params gl @@ -1834,7 +1834,7 @@ let find_atomic_param_of_ind nparams indtyp = | _ -> () done; Idset.elements !indvars; - + (* [cook_sign] builds the lists [indhyps] of hyps that must be erased, the lists of hyps to be generalize [(hdeps,tdeps)] on the @@ -1853,7 +1853,7 @@ let find_atomic_param_of_ind nparams indtyp = To summarize, the situation looks like this Goal(n,x) -| H6:(Q n); x:A; H5:True; H4:(le O n); H3:(P n); H2:True; n:nat - Left Right + Left Right Induction hypothesis is H4 ([hyp0]) Variable parameters of (le O n) is the singleton list with "n" ([indvars]) @@ -1887,7 +1887,7 @@ let find_atomic_param_of_ind nparams indtyp = would have posed no problem. But for uniformity, we decided to use the right hyp for all hyps on the right of H4. - Others solutions are welcome + Others solutions are welcome PC 9 fev 06: Adapted to accept multi argument principle with no main arg hyp. hyp0 is now optional, meaning that it is possible @@ -1917,15 +1917,15 @@ let cook_sign hyp0_opt indvars env = let before = ref true in let seek_deps env (hyp,_,_ as decl) rhyp = if hyp = hyp0 then begin - before:=false; + before:=false; (* If there was no main induction hypotheses, then hyp is one of indvars too, so add it to indhyps. *) - (if hyp0_opt=None then indhyps := hyp::!indhyps); + (if hyp0_opt=None then indhyps := hyp::!indhyps); MoveToEnd false (* fake value *) end else if List.mem hyp indvars then begin (* warning: hyp can still occur after induction *) (* e.g. if the goal (t hyp hyp0) with other occs of hyp in t *) - indhyps := hyp::!indhyps; + indhyps := hyp::!indhyps; rhyp end else if inhyps <> [] && List.mem hyp inhyps || inhyps = [] && @@ -1933,9 +1933,9 @@ let cook_sign hyp0_opt indvars env = List.exists (fun (id,_,_) -> occur_var_in_decl env id decl) !decldeps) then begin decldeps := decl::!decldeps; - if !before then + if !before then rstatus := (hyp,rhyp)::!rstatus - else + else ldeps := hyp::!ldeps; (* status computed in 2nd phase *) MoveBefore hyp end else @@ -1951,8 +1951,8 @@ let cook_sign hyp0_opt indvars env = end else if List.mem hyp !indhyps then lhyp else MoveAfter hyp in - try - let _ = + try + let _ = fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in raise (Shunt (MoveToEnd true)) (* ?? FIXME *) with Shunt lhyp0 -> @@ -1963,7 +1963,7 @@ let cook_sign hyp0_opt indvars env = (* The general form of an induction principle is the following: - + forall prm1 prm2 ... prmp, (induction parameters) forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates) branch1, branch2, ... , branchr, (branches of the principle) @@ -1972,7 +1972,7 @@ let cook_sign hyp0_opt indvars env = -> (Qi x1...xni HI (f prm1...prmp x1...xni)).(conclusion) ^^ ^^^^^^^^^^^^^^^^^^^^^^^^ optional optional argument added if - even if HI principle generated by functional + even if HI principle generated by functional present above induction, only if HI does not exist [indarg] [farg] @@ -1985,7 +1985,7 @@ let cook_sign hyp0_opt indvars env = (* [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) -type elim_scheme = { +type elim_scheme = { elimc: constr with_ebindings option; elimt: types; indref: global_reference option; @@ -1994,19 +1994,19 @@ type elim_scheme = { predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) npredicates: int; (* Number of predicates *) branches: rel_context; (* branchr,...,branch1 *) - nbranches: int; (* Number of branches *) + nbranches: int; (* Number of branches *) args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (* number of arguments *) - indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) + indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) - concl: types; (* Qi x1...xni HI (f...), HI and (f...) + concl: types; (* Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) } -let empty_scheme = - { +let empty_scheme = + { elimc = None; elimt = mkProp; indref = None; @@ -2028,12 +2028,12 @@ let empty_scheme = (* Unification between ((elimc:elimt) ?i ?j ?k ?l ... ?m) and the hypothesis on which the induction is made *) let induction_tac with_evars (varname,lbind) typ scheme gl = - let elimc,lbindelimc = + let elimc,lbindelimc = match scheme.elimc with | Some x -> x | None -> error "No definition of the principle." in let elimt = scheme.elimt in let indclause = make_clenv_binding gl (mkVar varname,typ) lbind in let elimclause = - make_clenv_binding gl + make_clenv_binding gl (mkCast (elimc,DEFAULTcast, elimt),elimt) lbindelimc in elimination_clause_scheme with_evars true elimclause indclause gl @@ -2047,12 +2047,12 @@ let make_base n id = (* Builds two different names from an optional inductive type and a number, also deals with a list of names to avoid. If the inductive type is None, then hyprecname is IHi where i is a number. *) -let make_up_names n ind_opt cname = +let make_up_names n ind_opt cname = let is_hyp = atompart_of_id cname = "H" in let base = string_of_id (make_base n cname) in let ind_prefix = "IH" in - let base_ind = - if is_hyp then + let base_ind = + if is_hyp then match ind_opt with | None -> id_of_string ind_prefix | Some ind_id -> add_prefix ind_prefix (Nametab.basename_of_global ind_id) @@ -2073,35 +2073,35 @@ let make_up_names n ind_opt cname = let is_indhyp p n t = let l, c = decompose_prod t in - let c,_ = decompose_app c in + let c,_ = decompose_app c in let p = p + List.length l in match kind_of_term c with | Rel k when p < k & k <= p + n -> true | _ -> false -let chop_context n l = +let chop_context n l = let rec chop_aux acc = function | n, (_,Some _,_ as h :: t) -> chop_aux (h::acc) (n, t) | 0, l2 -> (List.rev acc, l2) | n, (h::t) -> chop_aux (h::acc) (n-1, t) | _, [] -> anomaly "chop_context" - in + in chop_aux [] (n,l) let error_ind_scheme s = let s = if s <> "" then s^" " else s in error ("Cannot recognize "^s^"an induction scheme.") -let mkEq t x y = +let mkEq t x y = mkApp (build_coq_eq (), [| t; x; y |]) - -let mkRefl t x = + +let mkRefl t x = mkApp ((build_coq_eq_data ()).refl, [| t; x |]) let mkHEq t x u y = mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq", [| t; x; u; y |]) - + let mkHRefl t x = mkApp (coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl", [| t; x |]) @@ -2112,7 +2112,7 @@ let mkHRefl t x = (* let ty = new_Type () in *) (* mkApp (coq_constant "mkHEq" ["Logic";"EqdepFacts"] "eq_dep", *) (* [| ty; mkApp (Lazy.force id, [|ty|]); t; x; u; y |]) *) - + (* let mkHRefl t x = *) (* let ty = new_Type () in *) (* mkApp (coq_constant "mkHEq" ["Logic";"EqdepFacts"] "eq_dep_intro", *) @@ -2125,21 +2125,21 @@ let lift_togethern n l = (lift n x :: acc, succ n)) l ([], n) in l' - + let lift_together l = lift_togethern 0 l let lift_list l = List.map (lift 1) l -let ids_of_constr vars c = - let rec aux vars c = +let ids_of_constr vars c = + let rec aux vars c = match kind_of_term c with | Var id -> if List.mem id vars then vars else id :: vars - | App (f, args) -> + | App (f, args) -> (match kind_of_term f with - | Construct (ind,_) + | Construct (ind,_) | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in - array_fold_left_from mib.Declarations.mind_nparams + array_fold_left_from mib.Declarations.mind_nparams aux vars args | _ -> fold_constr aux vars c) | _ -> fold_constr aux vars c @@ -2151,13 +2151,13 @@ let mk_term_eq env sigma ty t ty' t' = else mkHEq ty t ty' t', mkHRefl ty' t' -let make_abstract_generalize gl id concl dep ctx c eqs args refls = +let make_abstract_generalize gl id concl dep ctx c eqs args refls = let meta = Evarutil.new_meta() in let term, typ = mkVar id, pf_get_hyp_typ gl id (* de Bruijn closed! *) in let eqslen = List.length eqs in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) - let abshypeq, abshypt = - if dep then + let abshypeq, abshypt = + if dep then let eq, refl = mk_term_eq (push_rel_context ctx (pf_env gl)) (project gl) (lift 1 c) (mkRel 1) typ term in mkProd (Anonymous, eq, lift 1 concl), [| refl |] else concl, [||] @@ -2170,7 +2170,7 @@ let make_abstract_generalize gl id concl dep ctx c eqs args refls = (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn ~init:genarg ctx in (* The goal will become this product. *) - let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in + let genc = mkCast (mkMeta meta, DEFAULTcast, genctyp) in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in (* Then apply to the original instanciated hyp. *) @@ -2179,20 +2179,20 @@ let make_abstract_generalize gl id concl dep ctx c eqs args refls = let appeqs = mkApp (instc, Array.of_list refls) in (* Finaly, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) mkApp (appeqs, abshypt) - -let abstract_args gl id = + +let abstract_args gl id = let c = pf_get_hyp_typ gl id in let sigma = project gl in let env = pf_env gl in let concl = pf_concl gl in let dep = dependent (mkVar id) concl in let avoid = ref [] in - let get_id name = - let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> id_of_string "gen_x") gl in + let get_id name = + let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> id_of_string "gen_x") gl in avoid := id :: !avoid; id in match kind_of_term c with - App (f, args) -> + App (f, args) -> (* Build application generalized w.r.t. the argument plus the necessary eqs. From env |- c : forall G, T and args : G we build (T[G'], G' : ctx, env ; G' |- args' : G, eqs := G'_i = G_i, refls : G' = G, vars to generalize) @@ -2200,7 +2200,7 @@ let abstract_args gl id = eqs are not lifted w.r.t. each other yet. (* will be needed when going to dependent indexes *) *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, vars, env) arg = - let (name, _, ty), arity = + let (name, _, ty), arity = let rel, c = Reductionops.splay_prod_n env sigma 1 prod in List.hd rel, c in @@ -2217,7 +2217,7 @@ let abstract_args gl id = let c' = mkApp (lift 1 c, [|mkRel 1|]) in let args = arg :: args in let liftarg = lift (List.length ctx) arg in - let eq, refl = + let eq, refl = if convertible then mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl argty arg else @@ -2227,10 +2227,10 @@ let abstract_args gl id = let refls = refl :: refls in let vars = ids_of_constr vars arg in (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, vars, env) - in + in let f, args = match kind_of_term f with - | Construct (ind,_) + | Construct (ind,_) | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in let first = mib.Declarations.mind_nparams in @@ -2240,7 +2240,7 @@ let abstract_args gl id = in (match args with [||] -> None | _ -> - let arity, ctx, ctxenv, c', args, eqs, refls, vars, env = + let arity, ctx, ctxenv, c', args, eqs, refls, vars, env = Array.fold_left aux (pf_type_of gl f,[],env,f,[],[],[],[],env) args in let args, refls = List.rev args, List.rev refls in @@ -2254,22 +2254,22 @@ let abstract_generalize id ?(generalize_vars=true) gl = let newc = abstract_args gl id in match newc with | None -> tclIDTAC gl - | Some (newc, dep, n, vars) -> + | Some (newc, dep, n, vars) -> let tac = if dep then - tclTHENLIST [refine newc; rename_hyp [(id, oldid)]; tclDO n intro; - generalize_dep (mkVar oldid)] + tclTHENLIST [refine newc; rename_hyp [(id, oldid)]; tclDO n intro; + generalize_dep (mkVar oldid)] else tclTHENLIST [refine newc; clear [id]; tclDO n intro] - in - if generalize_vars then tclTHEN tac + in + if generalize_vars then tclTHEN tac (tclFIRST [revert (List.rev vars) ; tclMAP (fun id -> tclTRY (generalize_dep (mkVar id))) vars]) gl else tac gl - + let dependent_pattern c gl = let cty = pf_type_of gl c in - let deps = + let deps = match kind_of_term cty with | App (f, args) -> Array.to_list args | _ -> [] @@ -2283,11 +2283,11 @@ let dependent_pattern c gl = mkNamedLambda id cty conclvar in let subst = (c, varname c, cty) :: List.rev_map (fun c -> (c, varname c, pf_type_of gl c)) deps in - let concllda = List.fold_left mklambda (pf_concl gl) subst in + let concllda = List.fold_left mklambda (pf_concl gl) subst in let conclapp = applistc concllda (List.rev_map pi1 subst) in convert_concl_no_check conclapp DEFAULTcast gl - -let occur_rel n c = + +let occur_rel n c = let res = not (noccurn n c) in res @@ -2330,19 +2330,19 @@ let cut_list n l = (* This function splits the products of the induction scheme [elimt] into four - parts: + parts: - branches, easily detectable (they are not referred by rels in the subterm) - what was found before branches (acc1) that is: parameters and predicates - what was found after branches (acc3) that is: args and indarg if any if there is no branch, we try to fill in acc3 with args/indargs. We also return the conclusion. *) -let decompose_paramspred_branch_args elimt = +let decompose_paramspred_branch_args elimt = let rec cut_noccur elimt acc2 : rel_context * rel_context * types = match kind_of_term elimt with - | Prod(nme,tpe,elimt') -> + | Prod(nme,tpe,elimt') -> let hd_tpe,_ = decompose_app ((strip_prod_assum tpe)) in - if not (occur_rel 1 elimt') && isRel hd_tpe + if not (occur_rel 1 elimt') && isRel hd_tpe then cut_noccur elimt' ((nme,None,tpe)::acc2) else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt @@ -2361,7 +2361,7 @@ let decompose_paramspred_branch_args elimt = we must find the predicate of the conclusion to separate params_pred from args. We suppose there is only one predicate here. *) if List.length acc2 <> 0 then acc1, acc2 , acc3, ccl - else + else let hyps,ccl = decompose_prod_assum elimt in let hd_ccl_pred,_ = decompose_app ccl in match kind_of_term hd_ccl_pred with @@ -2379,7 +2379,7 @@ let exchange_hd_app subst_hd t = eliminator by modifying their scheme_info, then rebuild the eliminator type, then prove it (with tactics). *) let rebuild_elimtype_from_scheme (scheme:elim_scheme): types = - let hiconcl = + let hiconcl = match scheme.indarg with | None -> scheme.concl | Some x -> mkProd_or_LetIn x scheme.concl in @@ -2397,8 +2397,8 @@ exception NoLastArgCcl first separate branches. We obtain branches, hyps before (params + preds), hyps after (args <+ indarg if present>) and conclusion. Then we proceed as follows: - - - separate parameters and predicates in params_preds. For that we build: + + - separate parameters and predicates in params_preds. For that we build: forall (x1:Ti_1)(xni:Ti_ni) (HI:I prm1..prmp x1...xni), DUMMY x1...xni HI/farg ^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^ optional opt @@ -2410,28 +2410,28 @@ exception NoLastArgCcl - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *) let compute_elim_sig ?elimc elimt = - let params_preds,branches,args_indargs,conclusion = + let params_preds,branches,args_indargs,conclusion = decompose_paramspred_branch_args elimt in - + let ccl = exchange_hd_app (mkVar (id_of_string "__QI_DUMMY__")) conclusion in - let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in + let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in let nparams = Intset.cardinal (free_rels concl_with_args) in let preds,params = cut_list (List.length params_preds - nparams) params_preds in - + (* A first approximation, further analysis will tweak it *) let res = ref { empty_scheme with (* This fields are ok: *) elimc = elimc; elimt = elimt; concl = conclusion; - predicates = preds; npredicates = List.length preds; - branches = branches; nbranches = List.length branches; + predicates = preds; npredicates = List.length preds; + branches = branches; nbranches = List.length branches; farg_in_concl = isApp ccl && isApp (last_arg ccl); - params = params; nparams = nparams; + params = params; nparams = nparams; (* all other fields are unsure at this point. Including these:*) args = args_indargs; nargs = List.length args_indargs; } in - try + try (* Order of tests below is important. Each of them exits if successful. *) (* 1- First see if (f x...) is in the conclusion. *) - if !res.farg_in_concl + if !res.farg_in_concl then begin res := { !res with indarg = None; @@ -2439,19 +2439,19 @@ let compute_elim_sig ?elimc elimt = raise Exit end; (* 2- If no args_indargs (=!res.nargs at this point) then no indarg *) - if !res.nargs=0 then raise Exit; + if !res.nargs=0 then raise Exit; (* 3- Look at last arg: is it the indarg? *) ignore ( match List.hd args_indargs with | hiname,Some _,hi -> error_ind_scheme "" - | hiname,None,hi -> + | hiname,None,hi -> let hi_ind, hi_args = decompose_app hi in let hi_is_ind = (* hi est d'un type globalisable *) match kind_of_term hi_ind with - | Ind (mind,_) -> true - | Var _ -> true - | Const _ -> true - | Construct _ -> true + | Ind (mind,_) -> true + | Var _ -> true + | Const _ -> true + | Construct _ -> true | _ -> false in let hi_args_enough = (* hi a le bon nbre d'arguments *) List.length hi_args = List.length params + !res.nargs -1 in @@ -2469,12 +2469,12 @@ let compute_elim_sig ?elimc elimt = match !res.indarg with | None -> !res (* No indref *) | Some ( _,Some _,_) -> error_ind_scheme "" - | Some ( _,None,ind) -> + | Some ( _,None,ind) -> let indhd,indargs = decompose_app ind in try {!res with indref = Some (global_of_constr indhd) } with _ -> error "Cannot find the inductive type of the inductive scheme.";; -(* Check that the elimination scheme has a form similar to the +(* Check that the elimination scheme has a form similar to the elimination schemes built by Coq. Schemes may have the standard form computed from an inductive type OR (feb. 2006) a non standard form. That is: with no main induction argument and with an optional @@ -2488,29 +2488,29 @@ let compute_elim_signature elimc elimt names_info ind_type_guess = match scheme.indarg with | Some (_,Some _,_) -> error "Strange letin, cannot recognize an induction scheme." | None -> (* Non standard scheme *) - let is_pred n c = + let is_pred n c = let hd = fst (decompose_app c) in match kind_of_term hd with | Rel q when n < q & q <= n+scheme.npredicates -> IndArg | _ when hd = ind_type_guess & not scheme.farg_in_concl -> RecArg - | _ -> OtherArg in - let rec check_branch p c = + | _ -> OtherArg in + let rec check_branch p c = match kind_of_term c with | Prod (_,t,c) -> (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c | LetIn (_,_,_,c) -> (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c | _ when is_pred p c = IndArg -> [] - | _ -> raise Exit in - let rec find_branches p lbrch = + | _ -> raise Exit in + let rec find_branches p lbrch = match lbrch with | (_,None,t)::brs -> (try let lchck_brch = check_branch p t in - let n = List.fold_left + let n = List.fold_left (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in - let recvarname, hyprecname, avoid = + let recvarname, hyprecname, avoid = make_up_names n scheme.indref names_info in - let namesign = + let namesign = List.map (fun (b,dep) -> (b,dep,if b=IndArg then hyprecname else recvarname)) lchck_brch in @@ -2519,33 +2519,33 @@ let compute_elim_signature elimc elimt names_info ind_type_guess = | (_,Some _,_)::_ -> error_ind_scheme "the branches of" | [] -> [] in let indsign = Array.of_list (find_branches 0 (List.rev scheme.branches)) in - indsign,scheme - + indsign,scheme + | Some ( _,None,ind) -> (* Standard scheme from an inductive type *) let indhd,indargs = decompose_app ind in - let is_pred n c = + let is_pred n c = let hd = fst (decompose_app c) in match kind_of_term hd with | Rel q when n < q & q <= n+scheme.npredicates -> IndArg | _ when hd = indhd -> RecArg | _ -> OtherArg in let rec check_branch p c = match kind_of_term c with - | Prod (_,t,c) -> + | Prod (_,t,c) -> (is_pred p t, dependent (mkRel 1) c) :: check_branch (p+1) c | LetIn (_,_,_,c) -> (OtherArg, dependent (mkRel 1) c) :: check_branch (p+1) c | _ when is_pred p c = IndArg -> [] - | _ -> raise Exit in + | _ -> raise Exit in let rec find_branches p lbrch = match lbrch with | (_,None,t)::brs -> (try let lchck_brch = check_branch p t in - let n = List.fold_left + let n = List.fold_left (fun n (b,_) -> if b=RecArg then n+1 else n) 0 lchck_brch in - let recvarname, hyprecname, avoid = + let recvarname, hyprecname, avoid = make_up_names n scheme.indref names_info in - let namesign = - List.map (fun (b,dep) -> + let namesign = + List.map (fun (b,dep) -> (b,dep,if b=IndArg then hyprecname else recvarname)) lchck_brch in (avoid,namesign) :: find_branches (p+1) brs @@ -2555,12 +2555,12 @@ let compute_elim_signature elimc elimt names_info ind_type_guess = (* Check again conclusion *) let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f = IndArg in - let ind_is_ok = - list_lastn scheme.nargs indargs + let ind_is_ok = + list_lastn scheme.nargs indargs = extended_rel_list 0 scheme.args in if not (ccl_arg_ok & ind_is_ok) then error_ind_scheme "the conclusion of"; - [] + [] in let indsign = Array.of_list (find_branches 0 (List.rev scheme.branches)) in indsign,scheme @@ -2575,7 +2575,7 @@ let find_elim_signature isrec elim hyp0 gl = let elimc = if isrec then lookup_eliminator mind s else - let case = + let case = if dependent_no_evar (mkVar hyp0) (pf_concl gl) then make_case_dep else make_case_gen in pf_apply case gl mind s in @@ -2592,11 +2592,11 @@ let find_elim_signature isrec elim hyp0 gl = (* Instantiate all meta variables of elimclause using lid, some elts of lid are parameters (first ones), the other are arguments. Returns the clause obtained. *) -let recolle_clenv scheme lid elimclause gl = +let recolle_clenv scheme lid elimclause gl = let _,arr = destApp elimclause.templval.rebus in - let lindmv = + let lindmv = Array.map - (fun x -> + (fun x -> match kind_of_term x with | Meta mv -> mv | _ -> errorlabstrm "elimination_clause" @@ -2606,15 +2606,15 @@ let recolle_clenv scheme lid elimclause gl = let lidparams,lidargs = cut_list (scheme.nparams) lid in let nidargs = List.length lidargs in (* parameters correspond to first elts of lid. *) - let clauses_params = + let clauses_params = list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i)) 0 lidparams in (* arguments correspond to last elts of lid. *) - let clauses_args = - list_map_i + let clauses_args = + list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i)) 0 lidargs in - let clause_indarg = + let clause_indarg = match scheme.indarg with | None -> [] | Some (x,_,typx) -> [] @@ -2637,9 +2637,9 @@ let recolle_clenv scheme lid elimclause gl = (elimc ?i ?j ?k...?l). This solves partly meta variables (and may produce new ones). Then refine with the resulting term with holes. *) -let induction_tac_felim with_evars indvars scheme gl = +let induction_tac_felim with_evars indvars scheme gl = let elimt = scheme.elimt in - let elimc,lbindelimc = + let elimc,lbindelimc = match scheme.elimc with | Some x -> x | None -> error "No definition of the principle." in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimclause = @@ -2660,7 +2660,7 @@ let apply_induction_in_context isrec hyp0 indsign indvars names induct_tac gl = List.fold_left (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in tclTHENLIST - [ + [ (* Generalize dependent hyps (but not args) *) if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr; (* clear dependent hyps *) @@ -2668,7 +2668,7 @@ let apply_induction_in_context isrec hyp0 indsign indvars names induct_tac gl = (* side-conditions in elim (resp case) schemes come last (resp first) *) (if isrec then tclTHENFIRSTn else tclTHENLASTn) (tclTHEN induct_tac (tclTRY (thin (List.rev indhyps)))) - (array_map2 + (array_map2 (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names) ] gl @@ -2683,24 +2683,24 @@ let induction_from_context_l isrec with_evars elim_info lid names gl = let indsign,scheme = elim_info in (* number of all args, counting farg and indarg if present. *) let nargs_indarg_farg = scheme.nargs - + (if scheme.farg_in_concl then 1 else 0) + + (if scheme.farg_in_concl then 1 else 0) + (if scheme.indarg <> None then 1 else 0) in (* Number of given induction args must be exact. *) - if List.length lid <> nargs_indarg_farg + scheme.nparams then + if List.length lid <> nargs_indarg_farg + scheme.nparams then error "Not the right number of arguments given to induction scheme."; (* hyp0 is used for re-introducing hyps at the right place afterward. We chose the first element of the list of variables on which to induct. It is probably the first of them appearing in the context. *) - let hyp0,indvars,lid_params = + let hyp0,indvars,lid_params = match lid with | [] -> anomaly "induction_from_context_l" - | e::l -> + | e::l -> let nargs_without_first = nargs_indarg_farg - 1 in let ivs,lp = cut_list nargs_without_first l in e, ivs, lp in (* terms to patternify we must patternify indarg or farg if present in concl *) - let lid_in_pattern = + let lid_in_pattern = if scheme.indarg <> None & not scheme.indarg_in_concl then List.rev indvars else List.rev (hyp0::indvars) in let lidcstr = List.map (fun x -> mkVar x) lid_in_pattern in @@ -2747,7 +2747,7 @@ let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbin let indref = match scheme.indref with | None -> assert false | Some x -> x in tclTHEN (atomize_param_of_ind (indref,scheme.nparams) hyp0) - (induction_from_context isrec with_evars elim_info + (induction_from_context isrec with_evars elim_info (hyp0,lbind) names inhyps) gl (* Induction on a list of induction arguments. Analyse the elim @@ -2756,8 +2756,8 @@ let induction_with_atomization_of_ind_arg isrec with_evars elim names (hyp0,lbin let induction_without_atomization isrec with_evars elim names lid gl = let (indsign,scheme as elim_info) = find_elim_signature isrec elim (List.hd lid) gl in - let awaited_nargs = - scheme.nparams + scheme.nargs + let awaited_nargs = + scheme.nparams + scheme.nargs + (if scheme.farg_in_concl then 1 else 0) + (if scheme.indarg <> None then 1 else 0) in @@ -2787,7 +2787,7 @@ let clear_unselected_context id inhyps cls gl = | None -> tclIDTAC gl | Some cls -> if occur_var (pf_env gl) id (pf_concl gl) && - cls.concl_occs = no_occurrences_expr + cls.concl_occs = no_occurrences_expr then errorlabstrm "" (str "Conclusion must be mentioned: it depends on " ++ pr_id id ++ str "."); @@ -2809,14 +2809,14 @@ let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl = | _ -> [] in match kind_of_term c with | Var id when not (mem_named_context id (Global.named_context())) - & lbind = NoBindings & not with_evars & eqname = None + & lbind = NoBindings & not with_evars & eqname = None & not (has_selected_occurrences cls) -> tclTHEN (clear_unselected_context id inhyps cls) (induction_with_atomization_of_ind_arg isrec with_evars elim names (id,lbind) inhyps) gl | _ -> - let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) + let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in let id = fresh_id [] x gl in (* We need the equality name now *) @@ -2844,22 +2844,22 @@ let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl = | c::l' -> match kind_of_term c with | Var id when not (mem_named_context id (Global.named_context())) - & not with_evars -> + & not with_evars -> let _ = newlc:= id::!newlc in atomize_list l' gl | _ -> - let x = + let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) Anonymous in - + let id = fresh_id [] x gl in let newl' = List.map (replace_term c (mkVar id)) l' in let _ = newlc:=id::!newlc in let _ = letids:=id::!letids in - tclTHEN + tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) (atomize_list newl') gl in - tclTHENLIST + tclTHENLIST [ (atomize_list lc); (fun gl' -> (* recompute each time to have the new value of newlc *) @@ -2872,16 +2872,16 @@ let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl = gl -let induct_destruct_l isrec with_evars lc elim names cls = +let induct_destruct_l isrec with_evars lc elim names cls = (* Several induction hyps: induction scheme is mandatory *) - let _ = + let _ = if elim = None - then - errorlabstrm "" (strbrk "Induction scheme must be given when several induction hypothesis are given.\n" ++ + then + errorlabstrm "" (strbrk "Induction scheme must be given when several induction hypothesis are given.\n" ++ str "Example: induction x1 x2 x3 using my_scheme.") in - let newlc = + let newlc = List.map - (fun x -> + (fun x -> match x with (* FIXME: should we deal with ElimOnIdent? *) | ElimOnConstr (x,NoBindings) -> x | _ -> error "Don't know where to find some argument.") @@ -2893,7 +2893,7 @@ let induct_destruct_l isrec with_evars lc elim names cls = (* Induction either over a term, over a quantified premisse, or over several quantified premisses (like with functional induction - principles). + principles). TODO: really unify induction with one and induction with several args *) let induct_destruct isrec with_evars (lc,elim,names,cls) = @@ -2923,7 +2923,7 @@ let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls) (* The registered tactic, which calls the default elimination * if no elimination constant is provided. *) - + (* Induction tactics *) (* This was Induction before 6.3 (induction only in quantified premisses) *) @@ -2951,7 +2951,7 @@ let simple_destruct = function (* * Eliminations giving the type instead of the proof. * These tactics use the default elimination constant and - * no substitutions at all. + * no substitutions at all. * May be they should be integrated into Elim ... *) @@ -2974,7 +2974,7 @@ let elim_type t gl = let case_type t gl = let (ind,t) = pf_reduce_to_atomic_ind gl t in let env = pf_env gl in - let elimc = make_case_gen env (project gl) ind (elimination_sort_of_goal gl) in + let elimc = make_case_gen env (project gl) ind (elimination_sort_of_goal gl) in elim_scheme_type elimc t gl @@ -2983,10 +2983,10 @@ let case_type t gl = (* These elimination tactics are particularly adapted for sequent calculus. They take a clause as argument, and yield the elimination rule if the clause is of the form (Some id) and a - suitable introduction rule otherwise. They do not depend on - the name of the eliminated constant, so they can be also + suitable introduction rule otherwise. They do not depend on + the name of the eliminated constant, so they can be also used on ad-hoc disjunctions and conjunctions introduced by - the user. + the user. -- Eduardo Gimenez (11/8/97) HH (29/5/99) replaces failures by specific error messages @@ -2994,10 +2994,10 @@ let case_type t gl = let andE id gl = let t = pf_get_hyp_typ gl id in - if is_conjunction (pf_hnf_constr gl t) then + if is_conjunction (pf_hnf_constr gl t) then (tclTHEN (simplest_elim (mkVar id)) (tclDO 2 intro)) gl - else - errorlabstrm "andE" + else + errorlabstrm "andE" (str("Tactic andE expects "^(string_of_id id)^" is a conjunction.")) let dAnd cls = @@ -3009,10 +3009,10 @@ let dAnd cls = let orE id gl = let t = pf_get_hyp_typ gl id in - if is_disjunction (pf_hnf_constr gl t) then + if is_disjunction (pf_hnf_constr gl t) then (tclTHEN (simplest_elim (mkVar id)) intro) gl - else - errorlabstrm "orE" + else + errorlabstrm "orE" (str("Tactic orE expects "^(string_of_id id)^" is a disjunction.")) let dorE b cls = @@ -3024,16 +3024,16 @@ let dorE b cls = let impE id gl = let t = pf_get_hyp_typ gl id in - if is_imp_term (pf_hnf_constr gl t) then - let (dom, _, rng) = destProd (pf_hnf_constr gl t) in + if is_imp_term (pf_hnf_constr gl t) then + let (dom, _, rng) = destProd (pf_hnf_constr gl t) in tclTHENLAST - (cut_intro rng) + (cut_intro rng) (apply_term (mkVar id) [mkMeta (new_meta())]) gl - else + else errorlabstrm "impE" (str("Tactic impE expects "^(string_of_id id)^ " is a an implication.")) - + let dImp cls = onClause (function @@ -3051,19 +3051,19 @@ let setoid_reflexivity = ref (fun _ -> assert false) let register_setoid_reflexivity f = setoid_reflexivity := f let reflexivity_red allowred gl = - (* PL: usual reflexivity don't perform any reduction when searching - for an equality, but we may need to do some when called back from + (* PL: usual reflexivity don't perform any reduction when searching + for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = if not allowred then pf_concl gl - else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) - in + else whd_betadeltaiota (pf_env gl) (project gl) (pf_concl gl) + in match match_with_equality_type concl with | None -> raise NoEquationFound | Some _ -> one_constructor 1 NoBindings gl let reflexivity gl = try reflexivity_red false gl with NoEquationFound -> !setoid_reflexivity gl - + let intros_reflexivity = (tclTHEN intros reflexivity) (* Symmetry tactics *) @@ -3084,18 +3084,18 @@ let prove_symmetry hdcncl eq_kind = | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in tclTHENFIRST (cut symc) - (tclTHENLIST - [ intro; - onLastHyp simplest_case; + (tclTHENLIST + [ intro; + onLastHyp simplest_case; one_constructor 1 NoBindings ]) let symmetry_red allowred gl = - (* PL: usual symmetry don't perform any reduction when searching - for an equality, but we may need to do some when called back from + (* PL: usual symmetry don't perform any reduction when searching + for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl) - in + in match match_with_equation concl with | Some eq_data,_,_ -> tclTHEN @@ -3109,10 +3109,10 @@ let symmetry gl = let setoid_symmetry_in = ref (fun _ _ -> assert false) let register_setoid_symmetry_in f = setoid_symmetry_in := f -let symmetry_in id gl = - let ctype = pf_type_of gl (mkVar id) in +let symmetry_in id gl = + let ctype = pf_type_of gl (mkVar id) in let sign,t = decompose_prod_assum ctype in - try + try let _,hdcncl,eq = match_with_equation t in let symccl = match eq with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |]) @@ -3134,9 +3134,9 @@ let intros_symmetry = (* This tactic first tries to apply a constant named trans_eq, where eq is the name of the equality predicate. If this constant is not - defined and the conclusion is a=b, it solves the goal doing - Cut x1=x2; - [Cut x2=x3; [Intros e1 e2; Case e2;Assumption + defined and the conclusion is a=b, it solves the goal doing + Cut x1=x2; + [Cut x2=x3; [Intros e1 e2; Case e2;Assumption | Idtac] | Idtac] --Eduardo (19/8/97) @@ -3165,8 +3165,8 @@ let prove_transitivity hdcncl eq_kind t gl = assumption ])) gl let transitivity_red allowred t gl = - (* PL: usual transitivity don't perform any reduction when searching - for an equality, but we may need to do some when called back from + (* PL: usual transitivity don't perform any reduction when searching + for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let concl = if not allowred then pf_concl gl else pf_whd_betadeltaiota gl (pf_concl gl) @@ -3192,8 +3192,8 @@ let transitivity t = transitivity_gen (Some t) let intros_transitivity n = tclTHEN intros (transitivity_gen n) -(* tactical to save as name a subproof such that the generalisation of - the current goal, abstracted with respect to the local signature, +(* tactical to save as name a subproof such that the generalisation of + the current goal, abstracted with respect to the local signature, is solved by tac *) let interpretable_as_section_decl d1 d2 = match d1,d2 with @@ -3201,16 +3201,16 @@ let interpretable_as_section_decl d1 d2 = match d1,d2 with | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2 | (_,None,t1), (_,_,t2) -> eq_constr t1 t2 -let abstract_subproof name tac gl = +let abstract_subproof name tac gl = let current_sign = Global.named_context() and global_sign = pf_hyps gl in - let sign,secsign = + let sign,secsign = List.fold_right - (fun (id,_,_ as d) (s1,s2) -> + (fun (id,_,_ as d) (s1,s2) -> if mem_named_context id current_sign & interpretable_as_section_decl (Sign.lookup_named id current_sign) d then (s1,push_named_context_val d s2) - else (add_named_decl d s1,s2)) + else (add_named_decl d s1,s2)) global_sign (empty_named_context,empty_named_context_val) in let na = next_global_ident_away false name (pf_ids_of_hyps gl) in let concl = it_mkNamedProd_or_LetIn (pf_concl gl) sign in @@ -3220,10 +3220,10 @@ let abstract_subproof name tac gl = start_proof na (Global, Proof Lemma) secsign concl (fun _ _ -> ()); let _,(const,_,kind,_) = try - by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); - let r = cook_proof ignore in + by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); + let r = cook_proof ignore in delete_current_proof (); r - with + with e -> (delete_current_proof(); raise e) in (* Faudrait un peu fonctionnaliser cela *) @@ -3231,29 +3231,29 @@ let abstract_subproof name tac gl = let con = Declare.declare_internal_constant na (cd,IsProof Lemma) in constr_of_global (ConstRef con) in - exact_no_check - (applist (lemme, + exact_no_check + (applist (lemme, List.rev (Array.to_list (instance_from_named_context sign)))) gl -let tclABSTRACT name_op tac gl = - let s = match name_op with - | Some s -> s - | None -> add_suffix (get_current_proof_name ()) "_subproof" - in +let tclABSTRACT name_op tac gl = + let s = match name_op with + | Some s -> s + | None -> add_suffix (get_current_proof_name ()) "_subproof" + in abstract_subproof s tac gl let admit_as_an_axiom gl = let current_sign = Global.named_context() and global_sign = pf_hyps gl in - let sign,secsign = + let sign,secsign = List.fold_right - (fun (id,_,_ as d) (s1,s2) -> + (fun (id,_,_ as d) (s1,s2) -> if mem_named_context id current_sign & interpretable_as_section_decl (Sign.lookup_named id current_sign) d then (s1,add_named_decl d s2) - else (add_named_decl d s1,s2)) + else (add_named_decl d s1,s2)) global_sign (empty_named_context,empty_named_context) in let name = add_suffix (get_current_proof_name ()) "_admitted" in let na = next_global_ident_away false name (pf_ids_of_hyps gl) in @@ -3264,19 +3264,19 @@ let admit_as_an_axiom gl = let con = Declare.declare_internal_constant na (cd,IsAssumption Logical) in constr_of_global (ConstRef con) in - exact_no_check - (applist (axiom, + exact_no_check + (applist (axiom, List.rev (Array.to_list (instance_from_named_context sign)))) gl let unify ?(state=full_transparent_state) x y gl = - try - let flags = - {default_unify_flags with + try + let flags = + {default_unify_flags with modulo_delta = state; modulo_conv_on_closed_terms = Some state} in - let evd = w_unify false (pf_env gl) Reduction.CONV + let evd = w_unify false (pf_env gl) Reduction.CONV ~flags x y (Evd.create_evar_defs (project gl)) in tclEVARS evd gl with _ -> tclFAIL 0 (str"Not unifiable") gl diff --git a/tactics/tactics.mli b/tactics/tactics.mli index ee2250b346..40ff0b688e 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -102,7 +102,7 @@ val try_intros_until : (* Apply a tactic on a quantified hypothesis, an hypothesis in context or a term with bindings *) -val onInductionArg : +val onInductionArg : (constr with_ebindings -> tactic) -> constr with_ebindings induction_arg -> tactic @@ -129,7 +129,7 @@ val reduct_in_hyp : tactic_reduction -> hyp_location -> tactic val reduct_option : tactic_reduction * cast_kind -> goal_location -> tactic val reduct_in_concl : tactic_reduction * cast_kind -> tactic val change_in_concl : (occurrences * constr) option -> constr -> tactic -val change_in_hyp : (occurrences * constr) option -> constr -> +val change_in_hyp : (occurrences * constr) option -> constr -> hyp_location -> tactic val red_in_concl : tactic val red_in_hyp : hyp_location -> tactic @@ -146,13 +146,13 @@ val normalise_option : goal_location -> tactic val normalise_vm_in_concl : tactic val unfold_in_concl : (occurrences * evaluable_global_reference) list -> tactic -val unfold_in_hyp : +val unfold_in_hyp : (occurrences * evaluable_global_reference) list -> hyp_location -> tactic -val unfold_option : +val unfold_option : (occurrences * evaluable_global_reference) list -> goal_location -> tactic val change : (occurrences * constr) option -> constr -> clause -> tactic -val pattern_option : +val pattern_option : (occurrences * constr) list -> goal_location -> tactic val reduce : red_expr -> clause -> tactic val unfold_constr : global_reference -> tactic @@ -179,7 +179,7 @@ val bring_hyps : named_context -> tactic val apply : constr -> tactic val eapply : constr -> tactic -val apply_with_ebindings_gen : +val apply_with_ebindings_gen : advanced_flag -> evars_flag -> open_constr with_ebindings located list -> tactic @@ -191,8 +191,8 @@ val eapply_with_ebindings : open_constr with_ebindings -> tactic val cut_and_apply : constr -> tactic -val apply_in : - advanced_flag -> evars_flag -> identifier -> +val apply_in : + advanced_flag -> evars_flag -> identifier -> open_constr with_ebindings located list -> intro_pattern_expr located option -> tactic @@ -203,7 +203,7 @@ val simple_apply_in : identifier -> constr -> tactic (* The general form of an induction principle is the following: - + forall prm1 prm2 ... prmp, (induction parameters) forall Q1...,(Qi:Ti_1 -> Ti_2 ->...-> Ti_ni),...Qq, (predicates) branch1, branch2, ... , branchr, (branches of the principle) @@ -226,7 +226,7 @@ val simple_apply_in : identifier -> constr -> tactic (* [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) -type elim_scheme = { +type elim_scheme = { elimc: constr with_ebindings option; elimt: types; indref: global_reference option; @@ -235,12 +235,12 @@ type elim_scheme = { predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) npredicates: int; (* Number of predicates *) branches: rel_context; (* branchr,...,branch1 *) - nbranches: int; (* Number of branches *) + nbranches: int; (* Number of branches *) args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (* number of arguments *) - indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) + indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) - concl: types; (* Qi x1...xni HI (f...), HI and (f...) + concl: types; (* Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) @@ -250,7 +250,7 @@ type elim_scheme = { val compute_elim_sig : ?elimc: constr with_ebindings -> types -> elim_scheme val rebuild_elimtype_from_scheme: elim_scheme -> types -val elimination_clause_scheme : evars_flag -> +val elimination_clause_scheme : evars_flag -> bool -> clausenv -> clausenv -> tactic val elimination_in_clause_scheme : evars_flag -> identifier -> @@ -261,18 +261,18 @@ val general_elim_clause_gen : (Clenv.clausenv -> 'a -> tactic) -> val general_elim : evars_flag -> constr with_ebindings -> constr with_ebindings -> ?allow_K:bool -> tactic -val general_elim_in : evars_flag -> +val general_elim_in : evars_flag -> identifier -> constr with_ebindings -> constr with_ebindings -> tactic val default_elim : evars_flag -> constr with_ebindings -> tactic val simplest_elim : constr -> tactic -val elim : +val elim : evars_flag -> constr with_ebindings -> constr with_ebindings option -> tactic val simple_induct : quantified_hypothesis -> tactic -val new_induct : evars_flag -> constr with_ebindings induction_arg list -> - constr with_ebindings option -> +val new_induct : evars_flag -> constr with_ebindings induction_arg list -> + constr with_ebindings option -> intro_pattern_expr located option * intro_pattern_expr located option -> clause option -> tactic @@ -282,14 +282,14 @@ val general_case_analysis : evars_flag -> constr with_ebindings -> tactic val simplest_case : constr -> tactic val simple_destruct : quantified_hypothesis -> tactic -val new_destruct : evars_flag -> constr with_ebindings induction_arg list -> - constr with_ebindings option -> +val new_destruct : evars_flag -> constr with_ebindings induction_arg list -> + constr with_ebindings option -> intro_pattern_expr located option * intro_pattern_expr located option -> clause option -> tactic (*s Generic case analysis / induction tactics. *) -val induction_destruct : evars_flag -> rec_flag -> +val induction_destruct : evars_flag -> rec_flag -> (constr with_ebindings induction_arg list * constr with_ebindings option * (intro_pattern_expr located option * intro_pattern_expr located option) * @@ -313,7 +313,7 @@ val dorE : bool -> clause ->tactic (*s Introduction tactics. *) -val constructor_tac : evars_flag -> int option -> int -> +val constructor_tac : evars_flag -> int option -> int -> open_constr bindings -> tactic val any_constructor : evars_flag -> tactic option -> tactic val one_constructor : int -> open_constr bindings -> tactic @@ -352,13 +352,13 @@ val intros_transitivity : constr option -> tactic val cut : constr -> tactic val cut_intro : constr -> tactic -val cut_replacing : +val cut_replacing : identifier -> constr -> (tactic -> tactic) -> tactic val cut_in_parallel : constr list -> tactic val assert_as : bool -> intro_pattern_expr located option -> constr -> tactic val forward : tactic option -> intro_pattern_expr located option -> constr -> tactic -val letin_tac : (bool * intro_pattern_expr located) option -> name -> +val letin_tac : (bool * intro_pattern_expr located) option -> name -> constr -> types option -> clause -> tactic val assert_tac : name -> types -> tactic val assert_by : name -> types -> tactic -> tactic @@ -379,5 +379,5 @@ val abstract_generalize : identifier -> ?generalize_vars:bool -> tactic val dependent_pattern : constr -> tactic -val register_general_multi_rewrite : +val register_general_multi_rewrite : (bool -> evars_flag -> open_constr with_bindings -> clause -> tactic) -> unit diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index ad2fd90093..ebfb9446f3 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -50,7 +50,7 @@ let iff_unfolding = ref false open Goptions let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "unfolding of iff and not in intuition"; optkey = ["Intuition";"Iff";"Unfolding"]; @@ -77,7 +77,7 @@ let is_unit_or_eq ist = let is_record t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in mib.Declarations.mind_record | _ -> false @@ -86,13 +86,13 @@ let is_binary t = isApp t && let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with - | Ind ind -> + | Ind ind -> let (mib,mip) = Global.lookup_inductive ind in mib.Declarations.mind_nparams = 2 | _ -> false let iter_tac tacl = - List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl + List.fold_right (fun tac tacs -> <:tactic< $tac; $tacs >>) tacl (** Dealing with conjunction *) @@ -111,10 +111,10 @@ let flatten_contravariant_conj ist = match match_with_conjunction ~strict:strict_in_contravariant_hyp typ with | Some (_,args) -> let i = List.length args in - if not binary_mode || i = 2 then + if not binary_mode || i = 2 then let newtyp = valueIn (VConstr (List.fold_right mkArrow args c)) in let intros = - iter_tac (List.map (fun _ -> <:tactic< intro >>) args) + iter_tac (List.map (fun _ -> <:tactic< intro >>) args) <:tactic< idtac >> in <:tactic< let newtyp := $newtyp in @@ -143,10 +143,10 @@ let flatten_contravariant_disj ist = match match_with_disjunction ~strict:strict_in_contravariant_hyp typ with | Some (_,args) -> let i = List.length args in - if not binary_mode || i = 2 then + if not binary_mode || i = 2 then iter_tac (list_map_i (fun i arg -> let typ = valueIn (VConstr (mkArrow arg c)) in - <:tactic< + <:tactic< let typ := $typ in assert typ by (intro; apply id; constructor $i; assumption) >>) 1 args) <:tactic< clear id >> @@ -166,7 +166,7 @@ let not_dep_intros ist = | H:(Coq.Init.Logic.not _)|-_ => unfold Coq.Init.Logic.not at 1 in H | H:(Coq.Init.Logic.not _)->_|-_ => unfold Coq.Init.Logic.not at 1 in H end >> - + let axioms ist = let t_is_unit_or_eq = tacticIn is_unit_or_eq and t_is_empty = tacticIn is_empty in @@ -231,7 +231,7 @@ let rec tauto_intuit t_reduce solver ist = || match reverse goal with | id:(?X1 -> ?X2)-> ?X3|- _ => cut X3; - [ intro; clear id; $t_tauto_intuit + [ intro; clear id; $t_tauto_intuit | cut (X1 -> X2); [ exact id | generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id; @@ -276,7 +276,7 @@ let tauto_classical nnpp g = with UserError _ -> errorlabstrm "tauto" (str "Classical tauto failed.") let tauto g = - try + try let nnpp = constr_of_global (Nametab.global_of_path coq_nnpp_path) in (* try intuitionistic version first to avoid an axiom if possible *) tclORELSE tauto_intuitionistic (tauto_classical nnpp) g diff --git a/tactics/termdn.ml b/tactics/termdn.ml index 591b2947c9..32e65239dd 100644 --- a/tactics/termdn.ml +++ b/tactics/termdn.ml @@ -25,20 +25,20 @@ type 'a t = (global_reference,constr_pattern,'a) Dn.t (*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*) -let decomp = +let decomp = let rec decrec acc c = match kind_of_term c with | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f | Cast (c1,_,_) -> decrec acc c1 | _ -> (c,acc) - in + in decrec [] -let decomp_pat = +let decomp_pat = let rec decrec acc = function | PApp (f,args) -> decrec (Array.to_list args @ acc) f | c -> (c,acc) - in - decrec [] + in + decrec [] let constr_pat_discr t = if not (occur_meta_pattern t) then @@ -54,7 +54,7 @@ let constr_pat_discr_st (idpred,cpred) t = match decomp_pat t with | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (ref,args) - | PRef ((VarRef v) as ref), args when not (Idpred.mem v idpred) -> + | PRef ((VarRef v) as ref), args when not (Idpred.mem v idpred) -> Some(ref,args) | PVar v, args when not (Idpred.mem v idpred) -> Some(VarRef v,args) @@ -64,7 +64,7 @@ let constr_pat_discr_st (idpred,cpred) t = open Dn -let constr_val_discr t = +let constr_val_discr t = let c, l = decomp t in match kind_of_term c with | Ind ind_sp -> Label(IndRef ind_sp,l) @@ -72,8 +72,8 @@ let constr_val_discr t = | Var id -> Label(VarRef id,l) | Const _ -> Everything | _ -> Nothing - -let constr_val_discr_st (idpred,cpred) t = + +let constr_val_discr_st (idpred,cpred) t = let c, l = decomp t in match kind_of_term c with | Const c -> if Cpred.mem c cpred then Everything else Label(ConstRef c,l) @@ -83,12 +83,12 @@ let constr_val_discr_st (idpred,cpred) t = | Evar _ -> Everything | _ -> Nothing -let create = Dn.create +let create = Dn.create let add dn st = Dn.add dn (constr_pat_discr_st st) let rmv dn st = Dn.rmv dn (constr_pat_discr_st st) let lookup dn st t = Dn.lookup dn (constr_val_discr_st st) t - + let app f dn = Dn.app f dn diff --git a/tactics/termdn.mli b/tactics/termdn.mli index a9f11b3afa..92a1b8c3ea 100644 --- a/tactics/termdn.mli +++ b/tactics/termdn.mli @@ -14,7 +14,7 @@ open Pattern open Libnames open Names (*i*) - + (* Discrimination nets of terms. *) (* This module registers actions (typically tactics) mapped to patterns *) @@ -23,7 +23,7 @@ open Names order in such a way patterns having the same prefix have this common prefix shared and the seek for the action associated to the patterns that a term matches are found in time proportional to the maximal -number of nodes of the patterns matching the term. The [transparent_state] +number of nodes of the patterns matching the term. The [transparent_state] indicates which constants and variables can be considered as rigid. These dnets are able to cope with existential variables as well, which match [Everything]. *) diff --git a/test-suite/bugs/closed/1519.v b/test-suite/bugs/closed/1519.v index 98e3e2144c..de60de59e9 100644 --- a/test-suite/bugs/closed/1519.v +++ b/test-suite/bugs/closed/1519.v @@ -2,7 +2,7 @@ Section S. Variable A:Prop. Variable W:A. - + Remark T: A -> A. intro Z. rename W into Z_. diff --git a/test-suite/bugs/closed/1780.v b/test-suite/bugs/closed/1780.v index 3929fbae23..ade4462a79 100644 --- a/test-suite/bugs/closed/1780.v +++ b/test-suite/bugs/closed/1780.v @@ -1,12 +1,12 @@ Definition bug := Eval vm_compute in eq_rect. (* bug: -Error: Illegal application (Type Error): +Error: Illegal application (Type Error): The term "eq" of type "forall A : Type, A -> A -> Prop" cannot be applied to the terms "x" : "A" "P" : "A -> Type" "x0" : "A" -The 1st term has type "A" which should be coercible to +The 1st term has type "A" which should be coercible to "Type". *) diff --git a/test-suite/bugs/closed/shouldfail/2006.v b/test-suite/bugs/closed/shouldfail/2006.v index f67e997e8c..91a16f955a 100644 --- a/test-suite/bugs/closed/shouldfail/2006.v +++ b/test-suite/bugs/closed/shouldfail/2006.v @@ -3,7 +3,7 @@ Definition Type1 := Type. Record R : Type1 := { p:Type1 }. (* was accepted before trunk revision 11619 *) -(* +(* Remarks: - The behaviour was inconsistent with the one of Inductive, e.g. @@ -18,6 +18,6 @@ Remarks: Record R : CProp := { ... }. CoRN may have to change the CProp definition into a notation if the - preservation of the former semantics of Record type constraints + preservation of the former semantics of Record type constraints turns to be required. *) diff --git a/test-suite/bugs/closed/shouldsucceed/1100.v b/test-suite/bugs/closed/shouldsucceed/1100.v index 6d619c7486..32c78b4b9e 100644 --- a/test-suite/bugs/closed/shouldsucceed/1100.v +++ b/test-suite/bugs/closed/shouldsucceed/1100.v @@ -6,7 +6,7 @@ Parameter PQ : forall n, P n <-> Q n. Lemma PQ2 : forall n, P n -> Q n. intros. - rewrite PQ in H. + rewrite PQ in H. trivial. Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1322.v b/test-suite/bugs/closed/shouldsucceed/1322.v index 7e21aa7ce3..1ec7d452a6 100644 --- a/test-suite/bugs/closed/shouldsucceed/1322.v +++ b/test-suite/bugs/closed/shouldsucceed/1322.v @@ -7,7 +7,7 @@ Variable I_eq :I -> I -> Prop. Variable I_eq_equiv : Setoid_Theory I I_eq. (* Add Relation I I_eq - reflexivity proved by I_eq_equiv.(Seq_refl I I_eq) + reflexivity proved by I_eq_equiv.(Seq_refl I I_eq) symmetry proved by I_eq_equiv.(Seq_sym I I_eq) transitivity proved by I_eq_equiv.(Seq_trans I I_eq) as I_eq_relation. *) diff --git a/test-suite/bugs/closed/shouldsucceed/1411.v b/test-suite/bugs/closed/shouldsucceed/1411.v index e330d46fd1..a1a7b288a5 100644 --- a/test-suite/bugs/closed/shouldsucceed/1411.v +++ b/test-suite/bugs/closed/shouldsucceed/1411.v @@ -23,7 +23,7 @@ Program Fixpoint fetch t p (x:Exact t p) {struct t} := match t, p with | No p' , nil => p' | No p' , _::_ => unreachable nat _ - | Br l r, nil => unreachable nat _ + | Br l r, nil => unreachable nat _ | Br l r, true::t => fetch l t _ | Br l r, false::t => fetch r t _ end. diff --git a/test-suite/bugs/closed/shouldsucceed/1414.v b/test-suite/bugs/closed/shouldsucceed/1414.v index 06922e50ad..495a16bca2 100644 --- a/test-suite/bugs/closed/shouldsucceed/1414.v +++ b/test-suite/bugs/closed/shouldsucceed/1414.v @@ -7,8 +7,8 @@ Inductive t : Set := | Node : t -> data -> t -> Z -> t. Parameter avl : t -> Prop. -Parameter bst : t -> Prop. -Parameter In : data -> t -> Prop. +Parameter bst : t -> Prop. +Parameter In : data -> t -> Prop. Parameter cardinal : t -> nat. Definition card2 (s:t*t) := let (s1,s2) := s in cardinal s1 + cardinal s2. @@ -16,25 +16,25 @@ Parameter split : data -> t -> t*(bool*t). Parameter join : t -> data -> t -> t. Parameter add : data -> t -> t. -Program Fixpoint union +Program Fixpoint union (s u:t) - (hb1: bst s)(ha1: avl s)(hb2: bst u)(hb2: avl u) - { measure (cardinal s + cardinal u) } : - {s' : t | bst s' /\ avl s' /\ forall x, In x s' <-> In x s \/ In x u} := - match s, u with + (hb1: bst s)(ha1: avl s)(hb2: bst u)(hb2: avl u) + { measure (cardinal s + cardinal u) } : + {s' : t | bst s' /\ avl s' /\ forall x, In x s' <-> In x s \/ In x u} := + match s, u with | Leaf,t2 => t2 | t1,Leaf => t1 - | Node l1 v1 r1 h1, Node l2 v2 r2 h2 => + | Node l1 v1 r1 h1, Node l2 v2 r2 h2 => if (Z_ge_lt_dec h1 h2) then - if (Z_eq_dec h2 1) + if (Z_eq_dec h2 1) then add v2 s else let (l2', r2') := split v1 u in join (union l1 l2' _ _ _ _) v1 (union r1 (snd r2') _ _ _ _) else - if (Z_eq_dec h1 1) + if (Z_eq_dec h1 1) then add v1 s else let (l1', r1') := split v2 u in join (union l1' l2 _ _ _ _) v2 (union (snd r1') r2 _ _ _ _) - end. + end. diff --git a/test-suite/bugs/closed/shouldsucceed/1425.v b/test-suite/bugs/closed/shouldsucceed/1425.v index 8e26209a12..6be30174ae 100644 --- a/test-suite/bugs/closed/shouldsucceed/1425.v +++ b/test-suite/bugs/closed/shouldsucceed/1425.v @@ -1,4 +1,4 @@ -Require Import Setoid. +Require Import Setoid. Parameter recursion : forall A : Set, A -> (nat -> A -> A) -> nat -> A. diff --git a/test-suite/bugs/closed/shouldsucceed/1446.v b/test-suite/bugs/closed/shouldsucceed/1446.v index d4e7cea81d..8cb2d653b6 100644 --- a/test-suite/bugs/closed/shouldsucceed/1446.v +++ b/test-suite/bugs/closed/shouldsucceed/1446.v @@ -1,8 +1,8 @@ Lemma not_true_eq_false : forall (b:bool), b <> true -> b = false. Proof. - destruct b;intros;trivial. - elim H. - exact (refl_equal true). + destruct b;intros;trivial. + elim H. + exact (refl_equal true). Qed. Section BUG. @@ -13,7 +13,7 @@ Section BUG. Hypothesis H1 : b <> true. Goal False. - rewrite (not_true_eq_false _ H) in * |-. + rewrite (not_true_eq_false _ H) in * |-. contradiction. Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1507.v b/test-suite/bugs/closed/shouldsucceed/1507.v index 32e6489c56..f1872a2bb7 100644 --- a/test-suite/bugs/closed/shouldsucceed/1507.v +++ b/test-suite/bugs/closed/shouldsucceed/1507.v @@ -8,10 +8,10 @@ rational intervals. *) -Definition associative (A:Type)(op:A->A->A) := +Definition associative (A:Type)(op:A->A->A) := forall x y z:A, op (op x y) z = op x (op y z). -Definition commutative (A:Type)(op:A->A->A) := +Definition commutative (A:Type)(op:A->A->A) := forall x y:A, op x y = op y x. Definition trichotomous (A:Type)(R:A->A->Prop) := @@ -19,7 +19,7 @@ Definition trichotomous (A:Type)(R:A->A->Prop) := Definition relation (A:Type) := A -> A -> Prop. Definition reflexive (A:Type)(R:relation A) := forall x:A, R x x. -Definition transitive (A:Type)(R:relation A) := +Definition transitive (A:Type)(R:relation A) := forall x y z:A, R x y -> R y z -> R x z. Definition symmetric (A:Type)(R:relation A) := forall x y:A, R x y -> R y x. @@ -52,7 +52,7 @@ Record I (grnd:Set)(le:grnd->grnd->Prop) : Type := Imake { Iplus_opp_r : forall x:Icar, Ic (Iplus x (Iopp x)) (Izero); Imult_inv_r : forall x:Icar, ~(Ic x Izero) -> Ic (Imult x (Iinv x)) Ione; (* distributive laws *) - Imult_plus_distr_l : forall x x' y y' z z' z'', + Imult_plus_distr_l : forall x x' y y' z z' z'', Ic x x' -> Ic y y' -> Ic z z' -> Ic z z'' -> Ic (Imult (Iplus x y) z) (Iplus (Imult x' z') (Imult y' z'')); (* order and lattice structure *) @@ -70,7 +70,7 @@ Record I (grnd:Set)(le:grnd->grnd->Prop) : Type := Imake { Ic_sym : symmetric _ Ic }. -Definition interval_set (X:Set)(le:X->X->Prop) := +Definition interval_set (X:Set)(le:X->X->Prop) := (interval X le) -> Prop. (* can be Set as well *) Check interval_set. Check Ic. @@ -101,7 +101,7 @@ Record N (grnd:Set)(le:grnd->grnd->Prop)(grndI:I grnd le) : Type := Nmake { Nplus_opp_r : forall x:Ncar, Nc (Nplus x (Nopp x)) (Nzero); Nmult_inv_r : forall x:Ncar, ~(Nc x Nzero) -> Nc (Nmult x (Ninv x)) None; (* distributive laws *) - Nmult_plus_distr_l : forall x x' y y' z z' z'', + Nmult_plus_distr_l : forall x x' y y' z z' z'', Nc x x' -> Nc y y' -> Nc z z' -> Nc z z'' -> Nc (Nmult (Nplus x y) z) (Nplus (Nmult x' z') (Nmult y' z'')); (* order and lattice structure *) diff --git a/test-suite/bugs/closed/shouldsucceed/1568.v b/test-suite/bugs/closed/shouldsucceed/1568.v index 9f10f7490e..3609e9c83b 100644 --- a/test-suite/bugs/closed/shouldsucceed/1568.v +++ b/test-suite/bugs/closed/shouldsucceed/1568.v @@ -3,7 +3,7 @@ CoInductive A: Set := with B: Set := mk_B: A -> B. -CoFixpoint a:A := mk_A b +CoFixpoint a:A := mk_A b with b:B := mk_B a. Goal b = match a with mk_A a1 => a1 end. diff --git a/test-suite/bugs/closed/shouldsucceed/1576.v b/test-suite/bugs/closed/shouldsucceed/1576.v index c9ebbd1426..3621f7a1ff 100644 --- a/test-suite/bugs/closed/shouldsucceed/1576.v +++ b/test-suite/bugs/closed/shouldsucceed/1576.v @@ -13,8 +13,8 @@ End TC. Module Type TD. Declare Module B: TB . -Declare Module C: TC - with Module B := B . +Declare Module C: TC + with Module B := B . End TD. Module Type TE. @@ -25,7 +25,7 @@ Module Type TF. Declare Module E: TE. End TF. -Module G (D: TD). +Module G (D: TD). Module B' := D.C.B. End G. diff --git a/test-suite/bugs/closed/shouldsucceed/1582.v b/test-suite/bugs/closed/shouldsucceed/1582.v index 47953a66f9..be5d3dd211 100644 --- a/test-suite/bugs/closed/shouldsucceed/1582.v +++ b/test-suite/bugs/closed/shouldsucceed/1582.v @@ -1,12 +1,12 @@ Require Import Peano_dec. -Definition fact_F : +Definition fact_F : forall (n:nat), (forall m, m nat) -> nat. -refine +refine (fun n fact_rec => - if eq_nat_dec n 0 then + if eq_nat_dec n 0 then 1 else let fn := fact_rec (n-1) _ in diff --git a/test-suite/bugs/closed/shouldsucceed/1618.v b/test-suite/bugs/closed/shouldsucceed/1618.v index a90290bfb2..a9b067ceb2 100644 --- a/test-suite/bugs/closed/shouldsucceed/1618.v +++ b/test-suite/bugs/closed/shouldsucceed/1618.v @@ -6,7 +6,7 @@ Definition A_size (a: A) : nat := | A1 n => 0 end. -Require Import Recdef. +Require Import Recdef. Function n3 (P: A -> Prop) (f: forall n, P (A1 n)) (a: A) {struct a} : P a := match a return (P a) with diff --git a/test-suite/bugs/closed/shouldsucceed/1634.v b/test-suite/bugs/closed/shouldsucceed/1634.v index e0c540f36e..0150c25038 100644 --- a/test-suite/bugs/closed/shouldsucceed/1634.v +++ b/test-suite/bugs/closed/shouldsucceed/1634.v @@ -18,7 +18,7 @@ Add Parametric Relation a : (S a) Seq Goal forall (a : A) (x y : S a), Seq x y -> Seq x y. intros a x y H. - setoid_replace x with y. + setoid_replace x with y. reflexivity. trivial. Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1683.v b/test-suite/bugs/closed/shouldsucceed/1683.v index 1571ee20e5..3e99694b3c 100644 --- a/test-suite/bugs/closed/shouldsucceed/1683.v +++ b/test-suite/bugs/closed/shouldsucceed/1683.v @@ -30,7 +30,7 @@ Add Parametric Relation A : (ms_type A) (ms_eq A) Hypothesis foobar : forall n, ms_eq CR (IRasCR (foo IR n)) (foo CRasCRing n). Goal forall (b:ms_type CR), - ms_eq CR (IRasCR (foo IR O)) b -> + ms_eq CR (IRasCR (foo IR O)) b -> ms_eq CR (IRasCR (foo IR O)) b. intros b H. rewrite foobar. diff --git a/test-suite/bugs/closed/shouldsucceed/1738.v b/test-suite/bugs/closed/shouldsucceed/1738.v index 0deed3663b..c2926a2b25 100644 --- a/test-suite/bugs/closed/shouldsucceed/1738.v +++ b/test-suite/bugs/closed/shouldsucceed/1738.v @@ -5,10 +5,10 @@ Module SomeSetoids (Import M:FSetInterface.S). Lemma Equal_refl : forall s, s[=]s. Proof. red; split; auto. Qed. -Add Relation t Equal - reflexivity proved by Equal_refl +Add Relation t Equal + reflexivity proved by Equal_refl symmetry proved by eq_sym - transitivity proved by eq_trans + transitivity proved by eq_trans as EqualSetoid. Add Morphism Empty with signature Equal ==> iff as Empty_m. diff --git a/test-suite/bugs/closed/shouldsucceed/1740.v b/test-suite/bugs/closed/shouldsucceed/1740.v index d9ce546a2b..ec4a7a6bcb 100644 --- a/test-suite/bugs/closed/shouldsucceed/1740.v +++ b/test-suite/bugs/closed/shouldsucceed/1740.v @@ -17,7 +17,7 @@ Goal f = | n, O => n | _, _ => O end. - unfold f. + unfold f. reflexivity. Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/1775.v b/test-suite/bugs/closed/shouldsucceed/1775.v index dab4120b96..932949a371 100644 --- a/test-suite/bugs/closed/shouldsucceed/1775.v +++ b/test-suite/bugs/closed/shouldsucceed/1775.v @@ -13,7 +13,7 @@ Goal forall s k k' m, (pl k' (nexists (fun w => (nexists (fun b => pl (pair w w) (pl (pair s b) (nexists (fun w0 => (nexists (fun a => pl (pair b w0) - (nexists (fun w1 => (nexists (fun c => pl + (nexists (fun w1 => (nexists (fun c => pl (pair a w1) (pl (pair a c) k))))))))))))))) m. intros. eapply plImp; [ | eauto | intros ]. diff --git a/test-suite/bugs/closed/shouldsucceed/1776.v b/test-suite/bugs/closed/shouldsucceed/1776.v index abf854553b..58491f9de1 100644 --- a/test-suite/bugs/closed/shouldsucceed/1776.v +++ b/test-suite/bugs/closed/shouldsucceed/1776.v @@ -10,7 +10,7 @@ Definition nexists (P:nat -> nat -> Prop) : nat -> Prop := Goal forall a A m, True -> - (pl A (nexists (fun x => (nexists + (pl A (nexists (fun x => (nexists (fun y => pl (pair a (S x)) (pair a (S y))))))) m. Proof. intros. diff --git a/test-suite/bugs/closed/shouldsucceed/1784.v b/test-suite/bugs/closed/shouldsucceed/1784.v index 5855b16836..8c2e50e07d 100644 --- a/test-suite/bugs/closed/shouldsucceed/1784.v +++ b/test-suite/bugs/closed/shouldsucceed/1784.v @@ -56,16 +56,16 @@ Require Import Program. Program Fixpoint lt_dec (x y:sv) { struct x } : {slt x y}+{~slt x y} := match x with - | I x => + | I x => match y with | I y => if (Z_eq_dec x y) then in_left else in_right | S ys => in_right end - | S xs => + | S xs => match y with | I y => in_right | S ys => - let fix list_in (xs ys:list sv) {struct xs} : + let fix list_in (xs ys:list sv) {struct xs} : {slist_in xs ys} + {~slist_in xs ys} := match xs with | nil => in_left @@ -76,8 +76,8 @@ Program Fixpoint lt_dec (x y:sv) { struct x } : {slt x y}+{~slt x y} := | y::ys => if lt_dec x y then in_left else if elem_in ys then in_left else in_right end - in - if elem_in ys then + in + if elem_in ys then if list_in xs ys then in_left else in_right else in_right end @@ -90,7 +90,7 @@ Next Obligation. intro H; inversion H. Defined. Next Obligation. intro H; inversion H. Defined. Next Obligation. intro H; inversion H; subst. Defined. Next Obligation. - intro H1; contradict H. inversion H1; subst. assumption. + intro H1; contradict H. inversion H1; subst. assumption. contradict H0; assumption. Defined. Next Obligation. intro H1; contradict H0. inversion H1; subst. assumption. Defined. diff --git a/test-suite/bugs/closed/shouldsucceed/1791.v b/test-suite/bugs/closed/shouldsucceed/1791.v index 694f056e83..be0e8ae8ba 100644 --- a/test-suite/bugs/closed/shouldsucceed/1791.v +++ b/test-suite/bugs/closed/shouldsucceed/1791.v @@ -9,7 +9,7 @@ Definition k1 := k0 -> k0. (** iterating X n times *) Fixpoint Pow (X:k1)(k:nat){struct k}:k1:= match k with 0 => fun X => X - | S k' => fun A => X (Pow X k' A) + | S k' => fun A => X (Pow X k' A) end. Parameter Bush: k1. diff --git a/test-suite/bugs/closed/shouldsucceed/1844.v b/test-suite/bugs/closed/shouldsucceed/1844.v index 545f261546..5627612f6d 100644 --- a/test-suite/bugs/closed/shouldsucceed/1844.v +++ b/test-suite/bugs/closed/shouldsucceed/1844.v @@ -188,7 +188,7 @@ with exec_finish: function -> outcome -> store -> value -> store -> Prop := with exec_function: function -> store -> value -> store -> Prop := | exec_function_intro: forall f st out st1 v st', - exec f.(fn_body) st out st1 -> + exec f.(fn_body) st out st1 -> exec_finish f out st1 v st' -> exec_function f st v st'. diff --git a/test-suite/bugs/closed/shouldsucceed/1901.v b/test-suite/bugs/closed/shouldsucceed/1901.v index 598db36601..7d86adbfb2 100644 --- a/test-suite/bugs/closed/shouldsucceed/1901.v +++ b/test-suite/bugs/closed/shouldsucceed/1901.v @@ -2,9 +2,9 @@ Require Import Relations. Record Poset{A:Type}(Le : relation A) : Type := Build_Poset - { - Le_refl : forall x : A, Le x x; - Le_trans : forall x y z : A, Le x y -> Le y z -> Le x z; + { + Le_refl : forall x : A, Le x x; + Le_trans : forall x y z : A, Le x y -> Le y z -> Le x z; Le_antisym : forall x y : A, Le x y -> Le y x -> x = y }. Definition nat_Poset : Poset Peano.le. diff --git a/test-suite/bugs/closed/shouldsucceed/1905.v b/test-suite/bugs/closed/shouldsucceed/1905.v index fb2725c976..8c81d7510b 100644 --- a/test-suite/bugs/closed/shouldsucceed/1905.v +++ b/test-suite/bugs/closed/shouldsucceed/1905.v @@ -5,7 +5,7 @@ Axiom t : Set. Axiom In : nat -> t -> Prop. Axiom InE : forall (x : nat) (s:t), impl (In x s) True. -Goal forall a s, +Goal forall a s, In a s -> False. Proof. intros a s Ia. diff --git a/test-suite/bugs/closed/shouldsucceed/1918.v b/test-suite/bugs/closed/shouldsucceed/1918.v index 9d4a3e047c..474ec935b2 100644 --- a/test-suite/bugs/closed/shouldsucceed/1918.v +++ b/test-suite/bugs/closed/shouldsucceed/1918.v @@ -35,7 +35,7 @@ Definition mon (X:k1) : Type := forall (A B:Set), (A -> B) -> X A -> X B. (** extensionality *) Definition ext (X:k1)(h: mon X): Prop := - forall (A B:Set)(f g:A -> B), + forall (A B:Set)(f g:A -> B), (forall a, f a = g a) -> forall r, h _ _ f r = h _ _ g r. (** first functor law *) @@ -44,7 +44,7 @@ Definition fct1 (X:k1)(m: mon X) : Prop := (** second functor law *) Definition fct2 (X:k1)(m: mon X) : Prop := - forall (A B C:Set)(f:A -> B)(g:B -> C)(x:X A), + forall (A B C:Set)(f:A -> B)(g:B -> C)(x:X A), m _ _ (g o f) x = m _ _ g (m _ _ f x). (** pack up the good properties of the approximation into @@ -60,7 +60,7 @@ Definition pEFct (F:k2) : Type := forall (X:k1), EFct X -> EFct (F X). -(** we show some closure properties of pEFct, depending on such properties +(** we show some closure properties of pEFct, depending on such properties for EFct *) Definition moncomp (X Y:k1)(mX:mon X)(mY:mon Y): mon (fun A => X(Y A)). @@ -92,7 +92,7 @@ Proof. apply (f2 ef2). Defined. -Corollary comppEFct (F G:k2): pEFct F -> pEFct G -> +Corollary comppEFct (F G:k2): pEFct F -> pEFct G -> pEFct (fun X A => F X (G X A)). Proof. red. @@ -104,7 +104,7 @@ Defined. Lemma sumEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A + Y A)%type. Proof. intros X Y ef1 ef2. - set (m12:=fun (A B:Set)(f:A->B) x => match x with + set (m12:=fun (A B:Set)(f:A->B) x => match x with | inl y => inl _ (m ef1 f y) | inr y => inr _ (m ef2 f y) end). @@ -133,7 +133,7 @@ Proof. rewrite (f2 ef2); reflexivity. Defined. -Corollary sumpEFct (F G:k2): pEFct F -> pEFct G -> +Corollary sumpEFct (F G:k2): pEFct F -> pEFct G -> pEFct (fun X A => F X A + G X A)%type. Proof. red. @@ -145,7 +145,7 @@ Defined. Lemma prodEFct (X Y:k1): EFct X -> EFct Y -> EFct (fun A => X A * Y A)%type. Proof. intros X Y ef1 ef2. - set (m12:=fun (A B:Set)(f:A->B) x => match x with + set (m12:=fun (A B:Set)(f:A->B) x => match x with (x1,x2) => (m ef1 f x1, m ef2 f x2) end). apply (mkEFct(m:=m12)); red; intros. (* prove ext *) @@ -168,7 +168,7 @@ Proof. apply (f2 ef2). Defined. -Corollary prodpEFct (F G:k2): pEFct F -> pEFct G -> +Corollary prodpEFct (F G:k2): pEFct F -> pEFct G -> pEFct (fun X A => F X A * G X A)%type. Proof. red. @@ -248,19 +248,19 @@ Module Type LNMIt_Type. Parameter F:k2. Parameter FpEFct: pEFct F. -Parameter mu20: k1. +Parameter mu20: k1. Definition mu2: k1:= fun A => mu20 A. Parameter mapmu2: mon mu2. Definition MItType: Type := forall G : k1, (forall X : k1, X c_k1 G -> F X c_k1 G) -> mu2 c_k1 G. Parameter MIt0 : MItType. -Definition MIt : MItType:= fun G s A t => MIt0 s t. -Definition InType : Type := - forall (X:k1)(ef:EFct X)(j: X c_k1 mu2), +Definition MIt : MItType:= fun G s A t => MIt0 s t. +Definition InType : Type := + forall (X:k1)(ef:EFct X)(j: X c_k1 mu2), NAT j (m ef) mapmu2 -> F X c_k1 mu2. Parameter In : InType. Axiom mapmu2Red : forall (A:Set)(X:k1)(ef:EFct X)(j: X c_k1 mu2) - (n: NAT j (m ef) mapmu2)(t: F X A)(B:Set)(f:A->B), + (n: NAT j (m ef) mapmu2)(t: F X A)(B:Set)(f:A->B), mapmu2 f (In ef n t) = In ef n (m (FpEFct ef) f t). Axiom MItRed : forall (G : k1) (s : forall X : k1, X c_k1 G -> F X c_k1 G)(X : k1)(ef:EFct X)(j: X c_k1 mu2) @@ -327,8 +327,8 @@ Fixpoint Pow (X:k1)(k:nat){struct k}:k1:= Fixpoint POW (k:nat)(X:k1)(m:mon X){struct k} : mon (Pow X k) := match k return mon (Pow X k) - with 0 => fun _ _ f => f - | S k' => fun _ _ f => m _ _ (POW k' m f) + with 0 => fun _ _ f => f + | S k' => fun _ _ f => m _ _ (POW k' m f) end. Module Type BushkToList_Type. diff --git a/test-suite/bugs/closed/shouldsucceed/1925.v b/test-suite/bugs/closed/shouldsucceed/1925.v index 17eb721add..4caee1c36d 100644 --- a/test-suite/bugs/closed/shouldsucceed/1925.v +++ b/test-suite/bugs/closed/shouldsucceed/1925.v @@ -3,14 +3,14 @@ Require Import List. -Definition compose (A B C : Type) (g : B -> C) (f : A -> B) : A -> C := +Definition compose (A B C : Type) (g : B -> C) (f : A -> B) : A -> C := fun x : A => g(f x). -Definition map_fuse' : - forall (A B C : Type) (g : B -> C) (f : A -> B) (xs : list A), - (map g (map f xs)) = map (compose _ _ _ g f) xs +Definition map_fuse' : + forall (A B C : Type) (g : B -> C) (f : A -> B) (xs : list A), + (map g (map f xs)) = map (compose _ _ _ g f) xs := - fun A B C g f => + fun A B C g f => (fix loop (ys : list A) {struct ys} := match ys as ys return (map g (map f ys)) = map (compose _ _ _ g f) ys with diff --git a/test-suite/bugs/closed/shouldsucceed/1931.v b/test-suite/bugs/closed/shouldsucceed/1931.v index bc8be78fe4..930ace1d55 100644 --- a/test-suite/bugs/closed/shouldsucceed/1931.v +++ b/test-suite/bugs/closed/shouldsucceed/1931.v @@ -8,7 +8,7 @@ Inductive T (A:Set) : Set := Fixpoint map (A B:Set)(f:A->B)(t:T A) : T B := match t with app t1 t2 => app (map f t1)(map f t2) - end. + end. Fixpoint subst (A B:Set)(f:A -> T B)(t:T A) :T B := match t with @@ -19,7 +19,7 @@ Fixpoint subst (A B:Set)(f:A -> T B)(t:T A) :T B := Definition k0:=Set. (** interaction of subst with map *) -Lemma substLaw1 (A:k0)(B C:Set)(f: A -> B)(g:B -> T C)(t: T A): +Lemma substLaw1 (A:k0)(B C:Set)(f: A -> B)(g:B -> T C)(t: T A): subst g (map f t) = subst (fun x => g (f x)) t. Proof. intros. diff --git a/test-suite/bugs/closed/shouldsucceed/1935.v b/test-suite/bugs/closed/shouldsucceed/1935.v index 641dcb7af5..72396d4903 100644 --- a/test-suite/bugs/closed/shouldsucceed/1935.v +++ b/test-suite/bugs/closed/shouldsucceed/1935.v @@ -1,14 +1,14 @@ Definition f (n:nat) := n = n. Lemma f_refl : forall n , f n. -intros. reflexivity. +intros. reflexivity. Qed. Definition f' (x:nat) (n:nat) := n = n. Lemma f_refl' : forall n , f' n n. Proof. - intros. reflexivity. + intros. reflexivity. Qed. Require Import ZArith. diff --git a/test-suite/bugs/closed/shouldsucceed/1939.v b/test-suite/bugs/closed/shouldsucceed/1939.v index 3aa55e834c..5e61529b4b 100644 --- a/test-suite/bugs/closed/shouldsucceed/1939.v +++ b/test-suite/bugs/closed/shouldsucceed/1939.v @@ -14,6 +14,6 @@ Require Import Setoid Program.Basics. Goal forall x y, R x y -> P y -> P x. Proof. intros x y H1 H2. - rewrite H1. + rewrite H1. auto. Qed. \ No newline at end of file diff --git a/test-suite/bugs/closed/shouldsucceed/1944.v b/test-suite/bugs/closed/shouldsucceed/1944.v index 7d9f9eb267..ee2918c6e9 100644 --- a/test-suite/bugs/closed/shouldsucceed/1944.v +++ b/test-suite/bugs/closed/shouldsucceed/1944.v @@ -1,6 +1,6 @@ (* Test some uses of ? in introduction patterns *) -Inductive J : nat -> Prop := +Inductive J : nat -> Prop := | K : forall p, J p -> (True /\ True) -> J (S p). Lemma bug : forall n, J n -> J (S n). diff --git a/test-suite/bugs/closed/shouldsucceed/1951.v b/test-suite/bugs/closed/shouldsucceed/1951.v index 4fbd6b22db..12c0ef9bf5 100644 --- a/test-suite/bugs/closed/shouldsucceed/1951.v +++ b/test-suite/bugs/closed/shouldsucceed/1951.v @@ -28,7 +28,7 @@ Inductive sg : Type := Sg. (* single *) Definition ipl2 (P : a -> Type) := (* in Prop, that means P is true forall *) fold_right (fun x => prod (P x)) sg. (* the elements of a given list *) -Definition ind +Definition ind : forall S : a -> Type, (forall ls : list a, ipl2 S ls -> S (b ls)) -> forall s : a, S s := fun (S : a -> Type) diff --git a/test-suite/bugs/closed/shouldsucceed/1981.v b/test-suite/bugs/closed/shouldsucceed/1981.v index 0c3b96dad9..99952682d5 100644 --- a/test-suite/bugs/closed/shouldsucceed/1981.v +++ b/test-suite/bugs/closed/shouldsucceed/1981.v @@ -1,5 +1,5 @@ Implicit Arguments ex_intro [A]. Goal exists n : nat, True. - eapply ex_intro. exact 0. exact I. + eapply ex_intro. exact 0. exact I. Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2001.v b/test-suite/bugs/closed/shouldsucceed/2001.v index 323021dea1..c50ad036d7 100644 --- a/test-suite/bugs/closed/shouldsucceed/2001.v +++ b/test-suite/bugs/closed/shouldsucceed/2001.v @@ -2,7 +2,7 @@ computed when the user explicitly indicated it *) Inductive T : Set := -| v : T. +| v : T. Definition f (s:nat) (t:T) : nat. fix 2. @@ -12,9 +12,9 @@ refine | v => s end. Defined. - + Lemma test : forall s, f s v = s. -Proof. +Proof. reflexivity. -Qed. +Qed. diff --git a/test-suite/bugs/closed/shouldsucceed/2017.v b/test-suite/bugs/closed/shouldsucceed/2017.v index 948cea3eee..df6661483a 100644 --- a/test-suite/bugs/closed/shouldsucceed/2017.v +++ b/test-suite/bugs/closed/shouldsucceed/2017.v @@ -8,8 +8,8 @@ Set Implicit Arguments. Variable choose : forall(P : bool -> Prop)(H : exists x, P x), bool. Variable H : exists x : bool, True. - + Definition coef := match Some true with - Some _ => @choose _ H |_ => true -end . + Some _ => @choose _ H |_ => true +end . diff --git a/test-suite/bugs/closed/shouldsucceed/2083.v b/test-suite/bugs/closed/shouldsucceed/2083.v index 63f91e5658..6fc046495c 100644 --- a/test-suite/bugs/closed/shouldsucceed/2083.v +++ b/test-suite/bugs/closed/shouldsucceed/2083.v @@ -2,11 +2,11 @@ Require Import Program Arith. Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) (H : forall (i : { i | i < n }), i < p -> P i = true) - {measure (n - p)} : + {measure (n - p)} : Exc (forall (p : { i | i < n}), P p = true) := match le_lt_dec n p with | left _ => value _ - | right cmp => + | right cmp => if dec (P p) then check_n n P (S p) _ else diff --git a/test-suite/bugs/closed/shouldsucceed/2117.v b/test-suite/bugs/closed/shouldsucceed/2117.v index 763d85e2ca..6377a8b74a 100644 --- a/test-suite/bugs/closed/shouldsucceed/2117.v +++ b/test-suite/bugs/closed/shouldsucceed/2117.v @@ -44,7 +44,7 @@ Ltac Subst := apply substcopy;intros;EtaLong. Ltac Rigid_aux := fun A => apply A|| Rigid_aux (copyr_fun _ _ _ _ A). Ltac Rigid := fun A => apply copyr_atom; Rigid_aux A. -Theorem church0: forall i:Type, exists X:(i->i)->i->i, +Theorem church0: forall i:Type, exists X:(i->i)->i->i, copy ((i->i)->i->i) (fun f:i->i => fun x:i=>f (X f x)) (fun f:i->i=>fun x:i=>app i i (X f) (f x)). intros. esplit. diff --git a/test-suite/bugs/closed/shouldsucceed/2139.v b/test-suite/bugs/closed/shouldsucceed/2139.v index 4f71d097ff..415a1b27dd 100644 --- a/test-suite/bugs/closed/shouldsucceed/2139.v +++ b/test-suite/bugs/closed/shouldsucceed/2139.v @@ -2,19 +2,19 @@ Class Patch (patch : Type) := { commute : patch -> patch -> Prop -}. - +}. + Parameter flip : forall `{patchInstance : Patch patch} - {a b : patch}, + {a b : patch}, commute a b <-> commute b a. - + Lemma Foo : forall `{patchInstance : Patch patch} - {a b : patch}, + {a b : patch}, (commute a b) -> True. -Proof. -intros. -apply flip in H. +Proof. +intros. +apply flip in H. (* failed in well-formed arity check because elimination predicate of iff in (@flip _ _ _ _) had normalized evars while the ones in the diff --git a/test-suite/bugs/closed/shouldsucceed/38.v b/test-suite/bugs/closed/shouldsucceed/38.v index 7bc04b1fe4..4fc8d7c97d 100644 --- a/test-suite/bugs/closed/shouldsucceed/38.v +++ b/test-suite/bugs/closed/shouldsucceed/38.v @@ -6,7 +6,7 @@ Inductive liste : Set := | vide : liste | c : A -> liste -> liste. -Inductive e : A -> liste -> Prop := +Inductive e : A -> liste -> Prop := | ec : forall (x : A) (l : liste), e x (c x l) | ee : forall (x y : A) (l : liste), e x l -> e x (c y l). diff --git a/test-suite/bugs/closed/shouldsucceed/846.v b/test-suite/bugs/closed/shouldsucceed/846.v index a963b225fe..ee5ec1fa6a 100644 --- a/test-suite/bugs/closed/shouldsucceed/846.v +++ b/test-suite/bugs/closed/shouldsucceed/846.v @@ -27,7 +27,7 @@ Definition index := list bool. Inductive L (A:Set) : index -> Set := initL: A -> L A nil - | pluslL: forall l:index, One -> L A (false::l) + | pluslL: forall l:index, One -> L A (false::l) | plusrL: forall l:index, L A l -> L A (false::l) | varL: forall l:index, L A l -> L A (true::l) | appL: forall l:index, L A (true::l) -> L A (true::l) -> L A (true::l) @@ -109,7 +109,7 @@ Proof. exact (monL (fun x:One + A => (match (maybe (fun a:A => initL a) x) with | inl u => pluslL _ _ u - | inr t' => plusrL t' end)) r). + | inr t' => plusrL t' end)) r). Defined. Section minimal. @@ -119,11 +119,11 @@ Hypothesis G: Set -> Set. Hypothesis step: sub1 (LamF' G) G. Fixpoint L'(A:Set)(i:index){struct i} : Set := - match i with + match i with nil => A | false::l => One + L' A l | true::l => G (L' A l) - end. + end. Definition LinL': forall (A:Set)(i:index), L A i -> L' A i. Proof. @@ -177,7 +177,7 @@ Proof. assumption. induction a. simpl L' in t. - apply (aczelapp (l1:=true::nil) (l2:=i)). + apply (aczelapp (l1:=true::nil) (l2:=i)). exact (lam' IHi t). simpl L' in t. induction t. diff --git a/test-suite/bugs/opened/shouldnotfail/1416.v b/test-suite/bugs/opened/shouldnotfail/1416.v index c6f4302d86..da67d9b04f 100644 --- a/test-suite/bugs/opened/shouldnotfail/1416.v +++ b/test-suite/bugs/opened/shouldnotfail/1416.v @@ -4,12 +4,12 @@ Record Place (Env A: Type) : Type := { read: Env -> A ; write: Env -> A -> Env ; write_read: forall (e:Env), (write e (read e))=e -}. +}. Hint Rewrite -> write_read: placeeq. Record sumPl (Env A B: Type) (vL:(Place Env A)) (vR:(Place Env B)) : Type := - { + { mkEnv: A -> B -> Env ; mkEnv2writeL: forall (e:Env) (x:A), (mkEnv x (read vR e))=(write vL e x) }. diff --git a/test-suite/bugs/opened/shouldnotfail/1501.v b/test-suite/bugs/opened/shouldnotfail/1501.v index 85c09dbd14..1845dd1f60 100644 --- a/test-suite/bugs/opened/shouldnotfail/1501.v +++ b/test-suite/bugs/opened/shouldnotfail/1501.v @@ -8,7 +8,7 @@ Require Export Setoid. Section Essais. (* Parametrized Setoid *) -Parameter K : Type -> Type. +Parameter K : Type -> Type. Parameter equiv : forall A : Type, K A -> K A -> Prop. Parameter equiv_refl : forall (A : Type) (x : K A), equiv x x. Parameter equiv_sym : forall (A : Type) (x y : K A), equiv x y -> equiv y x. @@ -40,7 +40,7 @@ Parameter Hint Resolve equiv_refl equiv_sym equiv_trans: monad. -Add Relation K equiv +Add Relation K equiv reflexivity proved by (@equiv_refl) symmetry proved by (@equiv_sym) transitivity proved by (@equiv_trans) @@ -67,7 +67,7 @@ Proof. unfold fequiv; intros; eapply equiv_trans; auto with monad. Qed. -Add Relation (fun (A B:Type) => A -> K B) fequiv +Add Relation (fun (A B:Type) => A -> K B) fequiv reflexivity proved by (@fequiv_refl) symmetry proved by (@fequiv_sym) transitivity proved by (@fequiv_trans) @@ -82,12 +82,12 @@ Qed. Lemma test: forall (A B: Type) (m1 m2 m3: K A) (f: A -> A -> K B), - (equiv m1 m2) -> (equiv m2 m3) -> + (equiv m1 m2) -> (equiv m2 m3) -> equiv (bind m1 (fun a => bind m2 (fun a' => f a a'))) (bind m2 (fun a => bind m3 (fun a' => f a a'))). Proof. - intros A B m1 m2 m3 f H1 H2. + intros A B m1 m2 m3 f H1 H2. setoid_rewrite H1. (* this works *) setoid_rewrite H2. trivial by equiv_refl. -Qed. +Qed. diff --git a/test-suite/bugs/opened/shouldnotfail/1596.v b/test-suite/bugs/opened/shouldnotfail/1596.v index 766bf524cf..de77e35d32 100644 --- a/test-suite/bugs/opened/shouldnotfail/1596.v +++ b/test-suite/bugs/opened/shouldnotfail/1596.v @@ -11,12 +11,12 @@ Module OrderedPair (X:OrderedType) (Y:OrderedType) <: OrderedType with Definition t := (X.t * Y.t)%type. Definition t := (X.t * Y.t)%type. - Definition eq (xy1:t) (xy2:t) := + Definition eq (xy1:t) (xy2:t) := let (x1,y1) := xy1 in let (x2,y2) := xy2 in (X.eq x1 x2) /\ (Y.eq y1 y2). - Definition lt (xy1:t) (xy2:t) := + Definition lt (xy1:t) (xy2:t) := let (x1,y1) := xy1 in let (x2,y2) := xy2 in (X.lt x1 x2) \/ ((X.eq x1 x2) /\ (Y.lt y1 y2)). @@ -101,7 +101,7 @@ Definition t := (X.t * Y.t)%type. Defined. Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. + Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. End OrderedPair. Module MessageSpi. @@ -189,8 +189,8 @@ n)->(hedge_synthesis_relation h m n). Fixpoint hedge_in_synthesis (h:hedge) (m:MessageSpi.message) (n:MessageSpi.message) {struct m} : bool := - if H.mem (m,n) h - then true + if H.mem (m,n) h + then true else false. Definition hedge_synthesis_spec (h:hedge) := hedge_synthesis_relation @@ -221,8 +221,8 @@ n). Fixpoint hedge_in_synthesis (h:hedge) (m:MessageSpi.t) (n:MessageSpi.t) {struct m} : bool := - if H.mem (m,n) h - then true + if H.mem (m,n) h + then true else false. Definition hedge_synthesis_spec (h:hedge) := hedge_synthesis_relation @@ -235,7 +235,7 @@ n). induction m;simpl;intro. elim (Bool_elim_bool (H.mem (MessageSpi.MNam n,n0) h));intros. apply SynInc;apply H.mem_2;trivial. - + rewrite H in H0. (* !! impossible here !! *) discriminate H0. Qed. diff --git a/test-suite/bugs/opened/shouldnotfail/1671.v b/test-suite/bugs/opened/shouldnotfail/1671.v index 800c431ec5..d95c210842 100644 --- a/test-suite/bugs/opened/shouldnotfail/1671.v +++ b/test-suite/bugs/opened/shouldnotfail/1671.v @@ -6,7 +6,7 @@ CoInductive hdlist : unit -> Type := Variable P : forall bo, hdlist bo -> Prop. Variable all : forall bo l, P bo l. -Definition F (l:hdlist tt) : P tt l := +Definition F (l:hdlist tt) : P tt l := match l in hdlist u return P u l with | cons (cons l') => all tt _ end. diff --git a/test-suite/complexity/injection.v b/test-suite/complexity/injection.v index db2d9c53f9..335996c27b 100644 --- a/test-suite/complexity/injection.v +++ b/test-suite/complexity/injection.v @@ -43,11 +43,11 @@ Record joinmap (key: Type) (t: Type) (j : joinable t) : Type exists s2, jm_j.(join) s1 s2 s3 }. -Parameter mkJoinmap : forall (key: Type) (t: Type) (j: joinable t), +Parameter mkJoinmap : forall (key: Type) (t: Type) (j: joinable t), joinmap key j. Parameter ADMIT: forall p: Prop, p. -Implicit Arguments ADMIT [p]. +Implicit Arguments ADMIT [p]. Module Share. Parameter jb : joinable bool. @@ -90,7 +90,7 @@ Definition jown : joinable own := Joinable own_is_empty own_join ADMIT ADMIT ADMIT ADMIT ADMIT ADMIT ADMIT ADMIT . End Own. - + Fixpoint sinv (n: nat) : Type := match n with | O => unit diff --git a/test-suite/failure/Case5.v b/test-suite/failure/Case5.v index 29996fd451..494443f1c9 100644 --- a/test-suite/failure/Case5.v +++ b/test-suite/failure/Case5.v @@ -1,7 +1,7 @@ Inductive MS : Set := | X : MS -> MS | Y : MS -> MS. - + Type (fun p : MS => match p return nat with | X x => 0 end). diff --git a/test-suite/failure/Case9.v b/test-suite/failure/Case9.v index a3b99f6314..d63c49403b 100644 --- a/test-suite/failure/Case9.v +++ b/test-suite/failure/Case9.v @@ -1,7 +1,7 @@ Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}. Type match compare 0 0 return nat with - + (* k 0 (* k=i *) | left _ _ _ => 0 (* k>i *) | right _ _ _ => 0 diff --git a/test-suite/failure/guard.v b/test-suite/failure/guard.v index 7e07a90585..75e5113860 100644 --- a/test-suite/failure/guard.v +++ b/test-suite/failure/guard.v @@ -18,4 +18,4 @@ Definition f := let h := f in (* h = Rel 4 *) fix F (n:nat) : nat := h F S n. (* here Rel 4 = g *) - + diff --git a/test-suite/failure/inductive3.v b/test-suite/failure/inductive3.v index e5a4e1b66c..cf035edf79 100644 --- a/test-suite/failure/inductive3.v +++ b/test-suite/failure/inductive3.v @@ -1,4 +1,4 @@ -(* Check that the nested inductive types positivity check avoids recursively +(* Check that the nested inductive types positivity check avoids recursively non uniform parameters (at least if these parameters break positivity) *) Inductive t (A:Type) : Type := c : t (A -> A) -> t A. diff --git a/test-suite/failure/proofirrelevance.v b/test-suite/failure/proofirrelevance.v index eedf2612b3..93e159e8bd 100644 --- a/test-suite/failure/proofirrelevance.v +++ b/test-suite/failure/proofirrelevance.v @@ -1,5 +1,5 @@ (* This was working in version 8.1beta (bug in the Sort-polymorphism - of inductive types), but this is inconsistent with classical logic + of inductive types), but this is inconsistent with classical logic in Prop *) Inductive bool_in_prop : Type := hide : bool -> bool_in_prop diff --git a/test-suite/failure/rewrite_in_hyp2.v b/test-suite/failure/rewrite_in_hyp2.v index a32037a21a..1533966efe 100644 --- a/test-suite/failure/rewrite_in_hyp2.v +++ b/test-suite/failure/rewrite_in_hyp2.v @@ -1,4 +1,4 @@ -(* Until revision 10221, rewriting in hypotheses of the form +(* Until revision 10221, rewriting in hypotheses of the form "(fun x => phi(x)) t" with "t" not rewritable used to behave as a beta-normalization tactic instead of raising the expected message "nothing to rewrite" *) diff --git a/test-suite/failure/subtyping.v b/test-suite/failure/subtyping.v index 35fd20369f..127da85133 100644 --- a/test-suite/failure/subtyping.v +++ b/test-suite/failure/subtyping.v @@ -4,17 +4,17 @@ Module Type T. Parameter A : Type. - Inductive L : Prop := + Inductive L : Prop := | L0 | L1 : (A -> Prop) -> L. End T. -Module TT : T. +Module TT : T. Parameter A : Type. - Inductive L : Type := + Inductive L : Type := | L0 | L1 : (A -> Prop) -> L. diff --git a/test-suite/failure/subtyping2.v b/test-suite/failure/subtyping2.v index 0a75ae4565..addd3b459f 100644 --- a/test-suite/failure/subtyping2.v +++ b/test-suite/failure/subtyping2.v @@ -61,7 +61,7 @@ End Inverse_Image. Section Burali_Forti_Paradox. - Definition morphism (A : Type) (R : A -> A -> Prop) + Definition morphism (A : Type) (R : A -> A -> Prop) (B : Type) (S : B -> B -> Prop) (f : A -> B) := forall x y : A, R x y -> S (f x) (f y). @@ -69,7 +69,7 @@ Section Burali_Forti_Paradox. assumes there exists an universal system of notations, i.e: - A type A0 - An injection i0 from relations on any type into A0 - - The proof that i0 is injective modulo morphism + - The proof that i0 is injective modulo morphism *) Variable A0 : Type. (* Type_i *) Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *) @@ -82,7 +82,7 @@ Section Burali_Forti_Paradox. (* Embedding of x in y: x and y are images of 2 well founded relations R1 and R2, the ordinal of R2 being strictly greater than that of R1. *) - Record emb (x y : A0) : Prop := + Record emb (x y : A0) : Prop := {X1 : Type; R1 : X1 -> X1 -> Prop; eqx : x = i0 X1 R1; @@ -166,7 +166,7 @@ Defined. End Subsets. - Definition fsub (a b : A0) (H : emb a b) (x : sub a) : + Definition fsub (a b : A0) (H : emb a b) (x : sub a) : sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H). (* F is a morphism: a < b => F(a) < F(b) diff --git a/test-suite/failure/univ_include.v b/test-suite/failure/univ_include.v index 4be70d888c..56f04f9d60 100644 --- a/test-suite/failure/univ_include.v +++ b/test-suite/failure/univ_include.v @@ -1,9 +1,9 @@ Definition T := Type. Definition U := Type. -Module Type MT. +Module Type MT. Parameter t : T. -End MT. +End MT. Module Type MU. Parameter t : U. diff --git a/test-suite/failure/universes-buraliforti-redef.v b/test-suite/failure/universes-buraliforti-redef.v index 049f97f221..034b7f0947 100644 --- a/test-suite/failure/universes-buraliforti-redef.v +++ b/test-suite/failure/universes-buraliforti-redef.v @@ -64,7 +64,7 @@ End Inverse_Image. Section Burali_Forti_Paradox. - Definition morphism (A : Type) (R : A -> A -> Prop) + Definition morphism (A : Type) (R : A -> A -> Prop) (B : Type) (S : B -> B -> Prop) (f : A -> B) := forall x y : A, R x y -> S (f x) (f y). @@ -72,7 +72,7 @@ Section Burali_Forti_Paradox. assumes there exists an universal system of notations, i.e: - A type A0 - An injection i0 from relations on any type into A0 - - The proof that i0 is injective modulo morphism + - The proof that i0 is injective modulo morphism *) Variable A0 : Type. (* Type_i *) Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *) @@ -85,7 +85,7 @@ Section Burali_Forti_Paradox. (* Embedding of x in y: x and y are images of 2 well founded relations R1 and R2, the ordinal of R2 being strictly greater than that of R1. *) - Record emb (x y : A0) : Prop := + Record emb (x y : A0) : Prop := {X1 : Type; R1 : X1 -> X1 -> Prop; eqx : x = i0 X1 R1; @@ -168,7 +168,7 @@ Defined. End Subsets. - Definition fsub (a b : A0) (H : emb a b) (x : sub a) : + Definition fsub (a b : A0) (H : emb a b) (x : sub a) : sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H). (* F is a morphism: a < b => F(a) < F(b) diff --git a/test-suite/failure/universes-buraliforti.v b/test-suite/failure/universes-buraliforti.v index d18d211951..1f96ab34a2 100644 --- a/test-suite/failure/universes-buraliforti.v +++ b/test-suite/failure/universes-buraliforti.v @@ -47,7 +47,7 @@ End Inverse_Image. Section Burali_Forti_Paradox. - Definition morphism (A : Type) (R : A -> A -> Prop) + Definition morphism (A : Type) (R : A -> A -> Prop) (B : Type) (S : B -> B -> Prop) (f : A -> B) := forall x y : A, R x y -> S (f x) (f y). @@ -55,7 +55,7 @@ Section Burali_Forti_Paradox. assumes there exists an universal system of notations, i.e: - A type A0 - An injection i0 from relations on any type into A0 - - The proof that i0 is injective modulo morphism + - The proof that i0 is injective modulo morphism *) Variable A0 : Type. (* Type_i *) Variable i0 : forall X : Type, (X -> X -> Prop) -> A0. (* X: Type_j *) @@ -68,7 +68,7 @@ Section Burali_Forti_Paradox. (* Embedding of x in y: x and y are images of 2 well founded relations R1 and R2, the ordinal of R2 being strictly greater than that of R1. *) - Record emb (x y : A0) : Prop := + Record emb (x y : A0) : Prop := {X1 : Type; R1 : X1 -> X1 -> Prop; eqx : x = i0 X1 R1; @@ -152,7 +152,7 @@ Defined. End Subsets. - Definition fsub (a b : A0) (H : emb a b) (x : sub a) : + Definition fsub (a b : A0) (H : emb a b) (x : sub a) : sub b := Build_sub _ (witness _ x) (emb_trans _ _ _ (emb_wit _ x) H). (* F is a morphism: a < b => F(a) < F(b) diff --git a/test-suite/failure/universes3.v b/test-suite/failure/universes3.v index 427cec1907..8fb414d5ae 100644 --- a/test-suite/failure/universes3.v +++ b/test-suite/failure/universes3.v @@ -15,7 +15,7 @@ Inductive I (B:Type (*6*)) := C : B -> impl Prop (I B). where Type(7) is the auxiliary level used to infer the type of I *) -(* We cannot enforce Type1 < Type(6) while we already have +(* We cannot enforce Type1 < Type(6) while we already have Type(6) <= Type(7) < Type3 < Type1 *) Definition J := I Type1. diff --git a/test-suite/ideal-features/Case9.v b/test-suite/ideal-features/Case9.v index 800c431ec5..d95c210842 100644 --- a/test-suite/ideal-features/Case9.v +++ b/test-suite/ideal-features/Case9.v @@ -6,7 +6,7 @@ CoInductive hdlist : unit -> Type := Variable P : forall bo, hdlist bo -> Prop. Variable all : forall bo l, P bo l. -Definition F (l:hdlist tt) : P tt l := +Definition F (l:hdlist tt) : P tt l := match l in hdlist u return P u l with | cons (cons l') => all tt _ end. diff --git a/test-suite/ideal-features/complexity/evars_subst.v b/test-suite/ideal-features/complexity/evars_subst.v index 6f9f86a95c..b3dfb33cdc 100644 --- a/test-suite/ideal-features/complexity/evars_subst.v +++ b/test-suite/ideal-features/complexity/evars_subst.v @@ -3,12 +3,12 @@ (* Let n be the number of let-in. The complexity comes from the fact that each implicit arguments of f was in a larger and larger - context. To compute the type of "let _ := f ?Tn 0 in f ?T 0", + context. To compute the type of "let _ := f ?Tn 0 in f ?T 0", "f ?Tn 0" is substituted in the type of "f ?T 0" which is ?T. This type is an evar instantiated on the n variables denoting the "f ?Ti 0". One obtain "?T[1;...;n-1;f ?Tn[1;...;n-1] 0]". To compute the type of "let _ := f ?Tn-1 0 in let _ := f ?Tn 0 in f ?T 0", another - substitution is done leading to + substitution is done leading to "?T[1;...;n-2;f ?Tn[1;...;n-2] 0;f ?Tn[1;...;n-2;f ?Tn[1;...;n-2] 0] 0]" and so on. At the end, we get a term of exponential size *) @@ -25,7 +25,7 @@ Time Check let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in - + let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in diff --git a/test-suite/ideal-features/eapply_evar.v b/test-suite/ideal-features/eapply_evar.v index b10d5dbf9c..8c9a448e76 100644 --- a/test-suite/ideal-features/eapply_evar.v +++ b/test-suite/ideal-features/eapply_evar.v @@ -1,9 +1,9 @@ (* Test propagation of evars from subgoal to brother subgoals *) -(* This does not work (oct 2008) because "match goal" sees "?evar = O" +(* This does not work (oct 2008) because "match goal" sees "?evar = O" and not "O = O" Lemma eapply_evar : O=O -> 0=O. -intro H; eapply trans_equal; +intro H; eapply trans_equal; [apply H | match goal with |- ?x = ?x => reflexivity end]. Qed. diff --git a/test-suite/ideal-features/evars_subst.v b/test-suite/ideal-features/evars_subst.v index 6f9f86a95c..b3dfb33cdc 100644 --- a/test-suite/ideal-features/evars_subst.v +++ b/test-suite/ideal-features/evars_subst.v @@ -3,12 +3,12 @@ (* Let n be the number of let-in. The complexity comes from the fact that each implicit arguments of f was in a larger and larger - context. To compute the type of "let _ := f ?Tn 0 in f ?T 0", + context. To compute the type of "let _ := f ?Tn 0 in f ?T 0", "f ?Tn 0" is substituted in the type of "f ?T 0" which is ?T. This type is an evar instantiated on the n variables denoting the "f ?Ti 0". One obtain "?T[1;...;n-1;f ?Tn[1;...;n-1] 0]". To compute the type of "let _ := f ?Tn-1 0 in let _ := f ?Tn 0 in f ?T 0", another - substitution is done leading to + substitution is done leading to "?T[1;...;n-2;f ?Tn[1;...;n-2] 0;f ?Tn[1;...;n-2;f ?Tn[1;...;n-2] 0] 0]" and so on. At the end, we get a term of exponential size *) @@ -25,7 +25,7 @@ Time Check let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in - + let _ := f _ 0 in let _ := f _ 0 in let _ := f _ 0 in diff --git a/test-suite/ideal-features/implicit_binders.v b/test-suite/ideal-features/implicit_binders.v index 5b66944b5c..2ec7278080 100644 --- a/test-suite/ideal-features/implicit_binders.v +++ b/test-suite/ideal-features/implicit_binders.v @@ -1,8 +1,8 @@ (** * Questions de syntaxe autour de la généralisation implicite ** Lieurs de classes - Aujourd'hui, les lieurs de classe [ ] et les - lieurs {{ }} sont équivalents et on a toutes les combinaisons de { et ( pour + Aujourd'hui, les lieurs de classe [ ] et les + lieurs {{ }} sont équivalents et on a toutes les combinaisons de { et ( pour les lieurs de classes (où la variable liée peut être anonyme): *) @@ -22,7 +22,7 @@ Definition barâ‚„ {( F : Foo A )} (x y : A) := foo x + foo y. (** Les lieurs sont généralisés à tous les termes, pas seulement aux classes: *) -Definition relation A := A -> A -> Prop. +Definition relation A := A -> A -> Prop. Definition inverse {( R : relation A )} := fun x y => R y x. @@ -43,7 +43,7 @@ Definition inverse {( R : relation A )} := fun x y => R y x. [Definition inverse _{R : relation A} := fun x y => R y x] [Definition inverse `(R : relation A) := fun x y => R y x] et - + [Definition inverse `[R : relation A] := fun x y => R y x] ou [Definition inverse `{R : relation A} := fun x y => R y x] @@ -53,7 +53,7 @@ Definition inverse {( R : relation A )} := fun x y => R y x. Definition div (x : nat) ({ y <> 0 }) := 0. -(** Un choix à faire pour les inductifs: accepter ou non de ne pas donner de nom à +(** Un choix à faire pour les inductifs: accepter ou non de ne pas donner de nom à l'argument. Manque de variables anonymes pour l'utilisateur mais pas pour le système... *) Inductive bla [ Foo A ] : Type :=. @@ -73,10 +73,10 @@ Definition instimpl ({ SomeStruct a }) : nat := a + a. (** Donne l'instance explicitement (façon foncteur). *) -Definition foo_prod {( Foo A, Foo B )} : Foo (A * B) := +Definition foo_prod {( Foo A, Foo B )} : Foo (A * B) := fun x => let (l, r) := x in foo l + foo r. -(** *** Questions: +(** *** Questions: - Gardez les crochets [ ] pour {{ }} ? - Quelle syntaxe pour la généralisation ? - Veut-on toutes les combinaisons de statut pour les variables généralisées et la variable liée ? @@ -98,12 +98,12 @@ Definition baz := `{x + y + z = x + (y + z)}. Print baz. (** Proposition d'Arthur C.: déclarer les noms de variables généralisables à la [Implicit Types] - pour plus de robustesse (cela vaudrait aussi pour les lieurs). Les typos du genre de l'exemple suivant + pour plus de robustesse (cela vaudrait aussi pour les lieurs). Les typos du genre de l'exemple suivant ne sont plus silencieuses: *) Check `(foob 0 + x). -(** Utilisé pour généraliser l'implémentation de la généralisation implicite dans +(** Utilisé pour généraliser l'implémentation de la généralisation implicite dans les déclarations d'instances (i.e. les deux defs suivantes sont équivalentes). *) Instance fooa : Foo A. @@ -111,8 +111,8 @@ Admitted. Definition fooa' : `(Foo A). Admitted. -(** Un peu différent de la généralisation des lieurs qui "explosent" les variables - libres en les liant au même niveau que l'objet. Dans la deuxième defs [a] n'est pas lié dans +(** Un peu différent de la généralisation des lieurs qui "explosent" les variables + libres en les liant au même niveau que l'objet. Dans la deuxième defs [a] n'est pas lié dans la définition mais [F : Π a, SomeStruct a]. *) Definition qux {( F : SomeStruct a )} : nat := a. diff --git a/test-suite/ideal-features/universes.v b/test-suite/ideal-features/universes.v index 6db4cfe18f..49530ebcea 100644 --- a/test-suite/ideal-features/universes.v +++ b/test-suite/ideal-features/universes.v @@ -7,7 +7,7 @@ Definition Ty := Type (* Top.1 *). Inductive Q (A:Type (* Top.2 *)) : Prop := q : A -> Q A. Inductive T (B:Type (* Top.3 *)) := t : B -> Q (T B) -> T B. -(* ajoute Top.4 <= Top.2 inutilement: +(* ajoute Top.4 <= Top.2 inutilement: 4 est l'univers utilisé dans le calcul du type polymorphe de T *) Definition C := T Ty. (* ajoute Top.1 < Top.3 : @@ -23,7 +23,7 @@ Definition C := T Ty. Definition f (A:Type (* Top.1 *)) := True. Inductive R := r : f R -> R. -(* ajoute Top.3 <= Top.1 inutilement: +(* ajoute Top.3 <= Top.1 inutilement: Top.3 est l'univers utilisé dans le calcul du type polymorphe de R *) (* mais il manque la contrainte que l'univers de R est plus petit que Top.1 diff --git a/test-suite/interactive/Evar.v b/test-suite/interactive/Evar.v index 1bc1f71d5d..50c5bba0f0 100644 --- a/test-suite/interactive/Evar.v +++ b/test-suite/interactive/Evar.v @@ -1,6 +1,6 @@ (* Check that no toplevel "unresolved evar" flees through Declare Implicit Tactic support (bug #1229) *) -Goal True. +Goal True. (* should raise an error, not an anomaly *) set (x := _). diff --git a/test-suite/micromega/example.v b/test-suite/micromega/example.v index 5cb1039533..f424f0fcca 100644 --- a/test-suite/micromega/example.v +++ b/test-suite/micromega/example.v @@ -19,7 +19,7 @@ Lemma not_so_easy : forall x n : Z, 2*x + 1 <= 2 *n -> x <= n-1. Proof. intros. - lia. + lia. Qed. @@ -27,19 +27,19 @@ Qed. Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0. Proof. - intros. + intros. psatz Z 2. Qed. -Lemma Zdiscr: forall a b c x, +Lemma Zdiscr: forall a b c x, a * x ^ 2 + b * x + c = 0 -> b ^ 2 - 4 * a * c >= 0. Proof. intros ; psatz Z 4. Qed. -Lemma plus_minus : forall x y, +Lemma plus_minus : forall x y, 0 = x + y -> 0 = x -y -> 0 = x /\ 0 = y. Proof. intros. @@ -48,20 +48,20 @@ Qed. -Lemma mplus_minus : forall x y, +Lemma mplus_minus : forall x y, x + y >= 0 -> x -y >= 0 -> x^2 - y^2 >= 0. Proof. intros; psatz Z 2. Qed. -Lemma pol3: forall x y, 0 <= x + y -> +Lemma pol3: forall x y, 0 <= x + y -> x^3 + 3*x^2*y + 3*x* y^2 + y^3 >= 0. Proof. intros; psatz Z 4. Qed. -(* Motivating example from: Expressiveness + Automation + Soundness: +(* Motivating example from: Expressiveness + Automation + Soundness: Towards COmbining SMT Solvers and Interactive Proof Assistants *) Parameter rho : Z. Parameter rho_ge : rho >= 0. @@ -76,7 +76,7 @@ Definition rbound2 (C:Z -> Z -> Z) : Prop := Lemma bounded_drift : forall s t p q C D, s <= t /\ correct p t /\ correct q t /\ - rbound1 C /\ rbound2 C /\ rbound1 D /\ rbound2 D -> + rbound1 C /\ rbound2 C /\ rbound1 D /\ rbound2 D -> Zabs (C p t - D q t) <= Zabs (C p s - D q s) + 2 * rho * (t- s). Proof. intros. @@ -194,8 +194,8 @@ Qed. (* from hol_light/Examples/sos.ml *) Lemma hol_light1 : forall a1 a2 b1 b2, - a1 >= 0 -> a2 >= 0 -> - (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) -> + a1 >= 0 -> a2 >= 0 -> + (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) -> (a1 * b1 + a2 * b2 = 0) -> a1 * a2 - b1 * b2 >= 0. Proof. intros ; psatz Z 4. @@ -323,7 +323,7 @@ Proof. Qed. -Lemma hol_light24 : forall x1 y1 x2 y2, x1 >= 0 -> x2 >= 0 -> y1 >= 0 -> y2 >= 0 -> +Lemma hol_light24 : forall x1 y1 x2 y2, x1 >= 0 -> x2 >= 0 -> y1 >= 0 -> y2 >= 0 -> ((x1 + y1) ^2 + x1 + 1 = (x2 + y2) ^ 2 + x2 + 1) -> (x1 + y1 = x2 + y2). Proof. diff --git a/test-suite/micromega/heap3_vcgen_25.v b/test-suite/micromega/heap3_vcgen_25.v index 0298303f58..efb5c7fd5c 100644 --- a/test-suite/micromega/heap3_vcgen_25.v +++ b/test-suite/micromega/heap3_vcgen_25.v @@ -11,7 +11,7 @@ Require Import Psatz. Open Scope Z_scope. -Lemma vcgen_25 : forall +Lemma vcgen_25 : forall (n : Z) (m : Z) (jt : Z) diff --git a/test-suite/micromega/qexample.v b/test-suite/micromega/qexample.v index 1fa250e092..c9c779f90e 100644 --- a/test-suite/micromega/qexample.v +++ b/test-suite/micromega/qexample.v @@ -10,7 +10,7 @@ Require Import Psatz. Require Import QArith. Require Import Ring_normalize. -Lemma plus_minus : forall x y, +Lemma plus_minus : forall x y, 0 == x + y -> 0 == x -y -> 0 == x /\ 0 == y. Proof. intros. @@ -37,7 +37,7 @@ Qed. Open Scope Z_scope. Open Scope Q_scope. -Lemma vcgen_25 : forall +Lemma vcgen_25 : forall (n : Q) (m : Q) (jt : Q) diff --git a/test-suite/micromega/rexample.v b/test-suite/micromega/rexample.v index d7386a4ec3..c957add69c 100644 --- a/test-suite/micromega/rexample.v +++ b/test-suite/micromega/rexample.v @@ -12,7 +12,7 @@ Require Import Ring_normalize. Open Scope R_scope. -Lemma yplus_minus : forall x y, +Lemma yplus_minus : forall x y, 0 = x + y -> 0 = x -y -> 0 = x /\ 0 = y. Proof. intros. @@ -34,7 +34,7 @@ Proof. Qed. -Lemma vcgen_25 : forall +Lemma vcgen_25 : forall (n : R) (m : R) (jt : R) diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v index b78bba25cd..4c00ffe4a5 100644 --- a/test-suite/micromega/square.v +++ b/test-suite/micromega/square.v @@ -20,7 +20,7 @@ Proof. intros [n [p [Heq Hnz]]]; pose (n' := Zabs n); pose (p':=Zabs p). assert (facts : 0 <= Zabs n /\ 0 <= Zabs p /\ Zabs n^2=n^2 /\ Zabs p^2 = p^2) by auto. -assert (H : (0 < n' /\ 0 <= p' /\ n' ^2 = 2* p' ^2)) by +assert (H : (0 < n' /\ 0 <= p' /\ n' ^2 = 2* p' ^2)) by (destruct facts as [Hf1 [Hf2 [Hf3 Hf4]]]; unfold n', p' ; psatz Z 2). generalize p' H; elim n' using (well_founded_ind (Zwf_well_founded 0)); clear. intros n IHn p [Hn [Hp Heq]]. @@ -55,7 +55,7 @@ Theorem sqrt2_not_rational : ~exists x:Q, x^2==2#1. Proof. unfold Qeq; intros [x]; simpl (Qden (2#1)); rewrite Zmult_1_r. intros HQeq. - assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by + assert (Heq : (Qnum x ^ 2 = 2 * ' Qden x ^ 2%Q)%Z) by (rewrite QnumZpower in HQeq ; rewrite QdenZpower in HQeq ; auto). assert (Hnx : (Qnum x <> 0)%Z) by (intros Hx; simpl in HQeq; rewrite Hx in HQeq; discriminate HQeq). diff --git a/test-suite/micromega/zomicron.v b/test-suite/micromega/zomicron.v index 60c16a9985..3b24602336 100644 --- a/test-suite/micromega/zomicron.v +++ b/test-suite/micromega/zomicron.v @@ -24,7 +24,7 @@ Lemma omega_nightmare : forall x y, 27 <= 11 * x + 13 * y <= 45 -> -10 <= 7 * x Proof. intros ; intuition auto. lia. -Qed. +Qed. Lemma compact_proof : forall z, (z < 0) -> @@ -32,5 +32,5 @@ Lemma compact_proof : forall z, (0 >= z \/ 0 < z) -> False. Proof. intros. - lia. + lia. Qed. \ No newline at end of file diff --git a/test-suite/modules/PO.v b/test-suite/modules/PO.v index 354c3957fa..71d331772a 100644 --- a/test-suite/modules/PO.v +++ b/test-suite/modules/PO.v @@ -7,11 +7,11 @@ Implicit Arguments snd. Module Type PO. Parameter T : Set. Parameter le : T -> T -> Prop. - + Axiom le_refl : forall x : T, le x x. Axiom le_trans : forall x y z : T, le x y -> le y z -> le x z. Axiom le_antis : forall x y : T, le x y -> le y x -> x = y. - + Hint Resolve le_refl le_trans le_antis. End PO. @@ -28,10 +28,10 @@ Module Pair (X: PO) (Y: PO) <: PO. Lemma le_trans : forall p1 p2 p3 : T, le p1 p2 -> le p2 p3 -> le p1 p3. unfold le in |- *; intuition; info eauto. - Qed. + Qed. Lemma le_antis : forall p1 p2 : T, le p1 p2 -> le p2 p1 -> p1 = p2. - destruct p1. + destruct p1. destruct p2. unfold le in |- *. intuition. diff --git a/test-suite/modules/Przyklad.v b/test-suite/modules/Przyklad.v index 014f6c604c..e3694b818d 100644 --- a/test-suite/modules/Przyklad.v +++ b/test-suite/modules/Przyklad.v @@ -1,4 +1,4 @@ -Definition ifte (T : Set) (A B : Prop) (s : {A} + {B}) +Definition ifte (T : Set) (A B : Prop) (s : {A} + {B}) (th el : T) := if s then th else el. Implicit Arguments ifte. @@ -33,7 +33,7 @@ Module Type ELEM. Parameter T : Set. Parameter eq_dec : forall a a' : T, {a = a'} + {a <> a'}. End ELEM. - + Module Type SET (Elt: ELEM). Parameter T : Set. Parameter empty : T. @@ -104,11 +104,11 @@ Module Nat. End Nat. -Module SetNat := F Nat. +Module SetNat := F Nat. -Lemma no_zero_in_empty : SetNat.find 0 SetNat.empty = false. -apply SetNat.find_empty_false. +Lemma no_zero_in_empty : SetNat.find 0 SetNat.empty = false. +apply SetNat.find_empty_false. Qed. (***************************************************************************) @@ -120,8 +120,8 @@ Module Lemmas (G: SET) (E: ELEM). forall (S : ESet.T) (a1 a2 : E.T), let S1 := ESet.add a1 (ESet.add a2 S) in let S2 := ESet.add a2 (ESet.add a1 S) in - forall a : E.T, ESet.find a S1 = ESet.find a S2. - + forall a : E.T, ESet.find a S1 = ESet.find a S2. + intros. unfold S1, S2 in |- *. elim (E.eq_dec a a1); elim (E.eq_dec a a2); intros H1 H2; @@ -137,10 +137,10 @@ Inductive list (A : Set) : Set := | nil : list A | cons : A -> list A -> list A. -Module ListDict (E: ELEM). +Module ListDict (E: ELEM). Definition T := list E.T. Definition elt := E.T. - + Definition empty := nil elt. Definition add (e : elt) (s : T) := cons elt e s. Fixpoint find (e : elt) (s : T) {struct s} : bool := @@ -160,7 +160,7 @@ Module ListDict (E: ELEM). auto. Qed. - + Lemma find_add_false : forall (s : T) (e e' : E.T), e <> e' -> find e (add e' s) = find e s. @@ -171,8 +171,8 @@ Module ListDict (E: ELEM). rewrite H0. simpl in |- *. reflexivity. - Qed. - + Qed. + End ListDict. diff --git a/test-suite/modules/Tescik.v b/test-suite/modules/Tescik.v index 8dadace77d..1d1b1e0ab2 100644 --- a/test-suite/modules/Tescik.v +++ b/test-suite/modules/Tescik.v @@ -7,20 +7,20 @@ End ELEM. Module Nat. Definition A := nat. Definition x := 0. -End Nat. +End Nat. Module List (X: ELEM). Inductive list : Set := | nil : list | cons : X.A -> list -> list. - + Definition head (l : list) := match l with | nil => X.x | cons x _ => x end. Definition singl (x : X.A) := cons x nil. - + Lemma head_singl : forall x : X.A, head (singl x) = x. auto. Qed. diff --git a/test-suite/modules/fun_objects.v b/test-suite/modules/fun_objects.v index f4dc19b3ed..dce2ffd50b 100644 --- a/test-suite/modules/fun_objects.v +++ b/test-suite/modules/fun_objects.v @@ -4,7 +4,7 @@ Unset Strict Implicit. Module Type SIG. Parameter id : forall A : Set, A -> A. End SIG. - + Module M (X: SIG). Definition idid := X.id X.id. Definition id := idid X.id. diff --git a/test-suite/modules/injection_discriminate_inversion.v b/test-suite/modules/injection_discriminate_inversion.v index 88c19cb1a6..d4ac7b3a24 100644 --- a/test-suite/modules/injection_discriminate_inversion.v +++ b/test-suite/modules/injection_discriminate_inversion.v @@ -7,18 +7,18 @@ Module M1 := M. Goal forall x, M.C x = M1.C 0 -> x = 0 . intros x H. - (* - injection sur deux constructeurs egaux mais appeles - par des modules differents + (* + injection sur deux constructeurs egaux mais appeles + par des modules differents *) - injection H. + injection H. tauto. Qed. Goal M.C 0 <> M1.C 1. - (* - Discriminate sur deux constructeurs egaux mais appeles - par des modules differents + (* + Discriminate sur deux constructeurs egaux mais appeles + par des modules differents *) intro H;discriminate H. Qed. @@ -26,9 +26,9 @@ Qed. Goal forall x, M.C x = M1.C 0 -> x = 0. intros x H. - (* - inversion sur deux constructeurs egaux mais appeles - par des modules differents + (* + inversion sur deux constructeurs egaux mais appeles + par des modules differents *) inversion H. reflexivity. Qed. \ No newline at end of file diff --git a/test-suite/modules/mod_decl.v b/test-suite/modules/mod_decl.v index b886eb59de..8b40213a48 100644 --- a/test-suite/modules/mod_decl.v +++ b/test-suite/modules/mod_decl.v @@ -31,17 +31,17 @@ Module Type T. Module M0. Axiom A : Set. End M0. - + Declare Module M1: SIG. - + Module M2 <: SIG. Definition A := nat. End M2. - + Module M3 := M0. - + Module M4 : SIG := M0. - + Module M5 <: SIG := M0. Module M6 := F M0. diff --git a/test-suite/modules/modeq.v b/test-suite/modules/modeq.v index 45cf9f1242..1238ee9deb 100644 --- a/test-suite/modules/modeq.v +++ b/test-suite/modules/modeq.v @@ -19,4 +19,4 @@ Module Z. Module N := M. End Z. -Module A : SIG := Z. \ No newline at end of file +Module A : SIG := Z. \ No newline at end of file diff --git a/test-suite/modules/modul.v b/test-suite/modules/modul.v index 9d24d6ce45..36a542ef0a 100644 --- a/test-suite/modules/modul.v +++ b/test-suite/modules/modul.v @@ -6,7 +6,7 @@ Module M. Hint Resolve w. (* : Grammar is replaced by Notation *) - + Print Hint *. Lemma w1 : rel 0 1. diff --git a/test-suite/modules/obj.v b/test-suite/modules/obj.v index 97337a125b..fda1a074ae 100644 --- a/test-suite/modules/obj.v +++ b/test-suite/modules/obj.v @@ -1,7 +1,7 @@ Set Implicit Arguments. Unset Strict Implicit. -Module M. +Module M. Definition a (s : Set) := s. Print a. End M. diff --git a/test-suite/modules/objects.v b/test-suite/modules/objects.v index 070f859eaa..d3a4c0b055 100644 --- a/test-suite/modules/objects.v +++ b/test-suite/modules/objects.v @@ -2,7 +2,7 @@ Module Type SET. Axiom T : Set. Axiom x : T. End SET. - + Set Implicit Arguments. Unset Strict Implicit. diff --git a/test-suite/modules/objects2.v b/test-suite/modules/objects2.v index e286609e52..220e2b3694 100644 --- a/test-suite/modules/objects2.v +++ b/test-suite/modules/objects2.v @@ -4,7 +4,7 @@ (* Bug #1118 (simplified version), submitted by Evelyne Contejean (used to failed in pre-V8.1 trunk because of a call to lookup_mind - for structure objects) + for structure objects) *) Module Type S. Record t : Set := { a : nat; b : nat }. End S. diff --git a/test-suite/modules/sig.v b/test-suite/modules/sig.v index 4cb6291df9..da5d25fa2e 100644 --- a/test-suite/modules/sig.v +++ b/test-suite/modules/sig.v @@ -18,8 +18,8 @@ Module Type SPRYT. End N. End SPRYT. -Module K : SPRYT := N. -Module K' : SPRYT := M. +Module K : SPRYT := N. +Module K' : SPRYT := M. Module Type SIG. Definition T : Set := M.N.T. diff --git a/test-suite/modules/sub_objects.v b/test-suite/modules/sub_objects.v index 5eec077582..fdfd09f802 100644 --- a/test-suite/modules/sub_objects.v +++ b/test-suite/modules/sub_objects.v @@ -12,7 +12,7 @@ Module M. Module N. Definition idid (A : Set) (x : A) := id x. (* : Grammar is replaced by Notation *) - Notation inc := (plus 1). + Notation inc := (plus 1). End N. Definition zero := N.idid 0. diff --git a/test-suite/modules/subtyping.v b/test-suite/modules/subtyping.v index 2df8e84e5c..dd7daf429d 100644 --- a/test-suite/modules/subtyping.v +++ b/test-suite/modules/subtyping.v @@ -15,7 +15,7 @@ Module Type T. Parameter A : Type (* Top.1 *) . - Inductive L : Type (* max(Top.1,1) *) := + Inductive L : Type (* max(Top.1,1) *) := | L0 | L1 : (A -> Prop) -> L. @@ -23,17 +23,17 @@ End T. Axiom Tp : Type (* Top.5 *) . -Module TT : T. +Module TT : T. Definition A : Type (* Top.6 *) := Tp. (* generates Top.5 <= Top.6 *) - Inductive L : Type (* max(Top.6,1) *) := + Inductive L : Type (* max(Top.6,1) *) := | L0 | L1 : (A -> Prop) -> L. End TT. (* Generates Top.6 <= Top.1 (+ auxiliary constraints for L_rect) *) -(* Note: Top.6 <= Top.1 is generated by subtyping on A; +(* Note: Top.6 <= Top.1 is generated by subtyping on A; subtyping of L follows and has not to be checked *) diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 37ee71e957..b63375867d 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -12,7 +12,7 @@ Require Import Arith. Definition proj (x y:nat) (P:nat -> Type) (def:P x) (prf:P y) : P y := match eq_nat_dec x y return P y with - | left eqprf => + | left eqprf => match eqprf in (_ = z) return (P z) with | refl_equal => def end diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v index 2b13c20419..af5f05f653 100644 --- a/test-suite/output/Fixpoint.v +++ b/test-suite/output/Fixpoint.v @@ -1,7 +1,7 @@ Require Import List. Check - (fix F (A B : Set) (f : A -> B) (l : list A) {struct l} : + (fix F (A B : Set) (f : A -> B) (l : list A) {struct l} : list B := match l with | nil => nil | a :: l => f a :: F _ _ f l diff --git a/test-suite/output/Notations.v b/test-suite/output/Notations.v index b37c3638af..8d16dff5be 100644 --- a/test-suite/output/Notations.v +++ b/test-suite/output/Notations.v @@ -64,26 +64,26 @@ Open Scope nat_scope. Inductive znat : Set := Zpos (n : nat) | Zneg (m : nat). Coercion Zpos: nat >-> znat. - + Delimit Scope znat_scope with znat. Open Scope znat_scope. - + Variable addz : znat -> znat -> znat. Notation "z1 + z2" := (addz z1 z2) : znat_scope. (* Check that "3+3", where 3 is in nat and the coercion to znat is implicit, - is printed the same way, and not "S 2 + S 2" as if numeral printing was + is printed the same way, and not "S 2 + S 2" as if numeral printing was only tested with coercion still present *) Check (3+3). (**********************************************************************) (* Check recursive notations *) - + Require Import List. Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..). Check [1;2;4]. - + Reserved Notation "( x ; y , .. , z )" (at level 0). Notation "( x ; y , .. , z )" := (pair .. (pair x y) .. z). Check (1;2,4). @@ -102,7 +102,7 @@ Check (pred 3). Check (fun n => match n with 0 => 0 | S n => n end). Check (fun n => match n with S p as x => p | y => 0 end). -Notation "'ifn' x 'is' 'succ' n 'then' t 'else' u" := +Notation "'ifn' x 'is' 'succ' n 'then' t 'else' u" := (match x with O => u | S n => t end) (at level 0, u at level 0). Check fun x => ifn x is succ n then n else 0. diff --git a/test-suite/output/reduction.v b/test-suite/output/reduction.v index 4a460a83fa..c4592369f7 100644 --- a/test-suite/output/reduction.v +++ b/test-suite/output/reduction.v @@ -9,5 +9,5 @@ Eval simpl in (fix plus (n m : nat) {struct n} : nat := | S p => S (p + m) end) a a. -Eval hnf in match (plus (S n) O) with S n => n | _ => O end. +Eval hnf in match (plus (S n) O) with S n => n | _ => O end. diff --git a/test-suite/success/Abstract.v b/test-suite/success/Abstract.v index fc8800a564..ffd50f6efd 100644 --- a/test-suite/success/Abstract.v +++ b/test-suite/success/Abstract.v @@ -18,7 +18,7 @@ Proof. induction n. simpl ; apply Dummy0. replace (2 * S n0) with (2*n0 + 2) ; auto with arith. - apply DummyApp. + apply DummyApp. 2:exact Dummy2. apply IHn0 ; abstract omega. Defined. diff --git a/test-suite/success/AdvancedCanonicalStructure.v b/test-suite/success/AdvancedCanonicalStructure.v index 8e613dcaa4..c1405cf91f 100644 --- a/test-suite/success/AdvancedCanonicalStructure.v +++ b/test-suite/success/AdvancedCanonicalStructure.v @@ -54,7 +54,7 @@ Open Scope type_scope. Section type_reification. -Inductive term :Type := +Inductive term :Type := Fun : term -> term -> term | Prod : term -> term -> term | Bool : term @@ -63,18 +63,18 @@ Inductive term :Type := | TYPE :term | Var : Type -> term. -Fixpoint interp (t:term) := - match t with +Fixpoint interp (t:term) := + match t with Bool => bool | SET => Set | PROP => Prop - | TYPE => Type + | TYPE => Type | Fun a b => interp a -> interp b | Prod a b => interp a * interp b | Var x => x end. -Record interp_pair :Type := +Record interp_pair :Type := { repr:>term; abs:>Type; link: abs = interp repr }. @@ -95,25 +95,25 @@ thus thesis using rewrite (link a);rewrite (link b);reflexivity. end proof. Qed. -Canonical Structure ProdCan (a b:interp_pair) := +Canonical Structure ProdCan (a b:interp_pair) := Build_interp_pair (Prod a b) (a * b) (prod_interp a b). -Canonical Structure FunCan (a b:interp_pair) := +Canonical Structure FunCan (a b:interp_pair) := Build_interp_pair (Fun a b) (a -> b) (fun_interp a b). -Canonical Structure BoolCan := +Canonical Structure BoolCan := Build_interp_pair Bool bool (refl_equal _). -Canonical Structure VarCan (x:Type) := +Canonical Structure VarCan (x:Type) := Build_interp_pair (Var x) x (refl_equal _). -Canonical Structure SetCan := +Canonical Structure SetCan := Build_interp_pair SET Set (refl_equal _). -Canonical Structure PropCan := +Canonical Structure PropCan := Build_interp_pair PROP Prop (refl_equal _). -Canonical Structure TypeCan := +Canonical Structure TypeCan := Build_interp_pair TYPE Type (refl_equal _). (* Print Canonical Projections. *) @@ -140,5 +140,5 @@ End type_reification. - + diff --git a/test-suite/success/AdvancedTypeClasses.v b/test-suite/success/AdvancedTypeClasses.v index e6950a2a13..219a8a7551 100644 --- a/test-suite/success/AdvancedTypeClasses.v +++ b/test-suite/success/AdvancedTypeClasses.v @@ -2,7 +2,7 @@ Open Scope type_scope. Section type_reification. -Inductive term :Type := +Inductive term :Type := Fun : term -> term -> term | Prod : term -> term -> term | Bool : term @@ -11,19 +11,19 @@ Inductive term :Type := | TYPE :term | Var : Type -> term. -Fixpoint interp (t:term) := - match t with +Fixpoint interp (t:term) := + match t with Bool => bool | SET => Set | PROP => Prop - | TYPE => Type + | TYPE => Type | Fun a b => interp a -> interp b | Prod a b => interp a * interp b | Var x => x end. Class interp_pair (abs : Type) := - { repr : term; + { repr : term; link: abs = interp repr }. Implicit Arguments repr [[interp_pair]]. @@ -52,7 +52,7 @@ Instance ProdCan `(interp_pair a, interp_pair b) : interp_pair (a * b) := Instance FunCan `(interp_pair a, interp_pair b) : interp_pair (a -> b) := { link := fun_interp }. -Instance BoolCan : interp_pair bool := +Instance BoolCan : interp_pair bool := { repr := Bool ; link := refl_equal _ }. Instance VarCan : interp_pair x | 10 := { repr := Var x ; link := refl_equal _ }. diff --git a/test-suite/success/Case12.v b/test-suite/success/Case12.v index f6a0d57801..729ab824f8 100644 --- a/test-suite/success/Case12.v +++ b/test-suite/success/Case12.v @@ -62,10 +62,10 @@ Check Inductive list''' (A:Set) (B:=(A*A)%type) (a:A) : B -> Set := | nil''' : list''' A a (a,a) - | cons''' : + | cons''' : forall a' : A, let m := (a',a) in list''' A a m -> list''' A a (a,a). -Fixpoint length''' (A:Set) (B:=(A*A)%type) (a:A) (m:B) (l:list''' A a m) +Fixpoint length''' (A:Set) (B:=(A*A)%type) (a:A) (m:B) (l:list''' A a m) {struct l} : nat := match l with | nil''' => 0 diff --git a/test-suite/success/Case15.v b/test-suite/success/Case15.v index 8431880d14..69fca48e24 100644 --- a/test-suite/success/Case15.v +++ b/test-suite/success/Case15.v @@ -12,7 +12,7 @@ Check (* Suggested by Pierre Letouzey (PR#207) *) Inductive Boite : Set := - boite : forall b : bool, (if b then nat else (nat * nat)%type) -> Boite. + boite : forall b : bool, (if b then nat else (nat * nat)%type) -> Boite. Definition test (B : Boite) := match B return nat with @@ -30,7 +30,7 @@ Check [x] end. Check [x] - Cases x of + Cases x of (c true true) => true | (c false O) => true | _ => false @@ -40,7 +40,7 @@ Check [x] Check [x:I] Cases x of - (c b y) => + (c b y) => (<[b:bool](if b then bool else nat)->bool>if b then [y](if y then true else false) else [y]Cases y of diff --git a/test-suite/success/Case17.v b/test-suite/success/Case17.v index 061e136e0f..66af9e0d36 100644 --- a/test-suite/success/Case17.v +++ b/test-suite/success/Case17.v @@ -11,7 +11,7 @@ Variables (l0 : list bool) (rec : forall l' : list bool, length l' <= S (length l0) -> - {l'' : list bool & + {l'' : list bool & {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} + {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}). @@ -25,17 +25,17 @@ Check | inleft (existS _ _) => inright _ (HHH _) | inright Hnp => inright _ (HHH _) end - :{l'' : list bool & + :{l'' : list bool & {t : nat | parse_rel (true :: l0) l'' t /\ length l'' <= S (length l0)}} + {(forall (l'' : list bool) (t : nat), ~ parse_rel (true :: l0) l'' t)}). - + (* The same but with relative links to l0 and rec *) - + Check (fun (l0 : list bool) (rec : forall l' : list bool, length l' <= S (length l0) -> - {l'' : list bool & + {l'' : list bool & {t : nat | parse_rel l' l'' t /\ length l'' <= length l'}} + {(forall (l'' : list bool) (t : nat), ~ parse_rel l' l'' t)}) => match rec l0 (HHH _) with @@ -45,6 +45,6 @@ Check | inleft (existS _ _) => inright _ (HHH _) | inright Hnp => inright _ (HHH _) end - :{l'' : list bool & + :{l'' : list bool & {t : nat | parse_rel (true :: l0) l'' t /\ length l'' <= S (length l0)}} + {(forall (l'' : list bool) (t : nat), ~ parse_rel (true :: l0) l'' t)}). diff --git a/test-suite/success/Cases.v b/test-suite/success/Cases.v index ccd92f6960..e63972ce17 100644 --- a/test-suite/success/Cases.v +++ b/test-suite/success/Cases.v @@ -256,7 +256,7 @@ Type match 0, 1 return nat with Type match 0, 1 with | x, y => x + y end. - + Type match 0, 1 return nat with | O, y => y | S x, y => x + y @@ -523,7 +523,7 @@ Type | O, _ => 0 | S _, _ => c end). - + (* Rows of pattern variables: some tricky cases *) Axioms (P : nat -> Prop) (f : forall n : nat, P n). @@ -613,14 +613,14 @@ Type (* Type [A:Set][n:nat][l:(Listn A n)] - <[_:nat](Listn A O)>Cases l of + <[_:nat](Listn A O)>Cases l of (Niln as b) => b | (Consn n a (Niln as b))=> (Niln A) | (Consn n a (Consn m b l)) => (Niln A) end. Type [A:Set][n:nat][l:(Listn A n)] - Cases l of + Cases l of (Niln as b) => b | (Consn n a (Niln as b))=> (Niln A) | (Consn n a (Consn m b l)) => (Niln A) @@ -628,9 +628,9 @@ Type [A:Set][n:nat][l:(Listn A n)] *) (******** This example rises an error unconstrained_variables! Type [A:Set][n:nat][l:(Listn A n)] - Cases l of + Cases l of (Niln as b) => (Consn A O O b) - | ((Consn n a Niln) as L) => L + | ((Consn n a Niln) as L) => L | (Consn n a _) => (Consn A O O (Niln A)) end. **********) @@ -957,7 +957,7 @@ Definition length3 (n : nat) (l : listn n) := | _ => 0 end. - + Type match LeO 0 return nat with | LeS n m h => n + m | x => 0 @@ -1072,10 +1072,10 @@ Type | Consn _ _ _ as b => b end). -(** Horrible error message! +(** Horrible error message! Type [A:Set][n:nat][l:(Listn A n)] - Cases l of + Cases l of (Niln as b) => b | ((Consn _ _ _ ) as b)=> b end. @@ -1180,7 +1180,7 @@ Type (fun n : nat => match test n with Parameter compare : forall n m : nat, {n < m} + {n = m} + {n > m}. Type match compare 0 0 return nat with - + (* k 0 (* k=i *) | inleft _ => 0 (* k>i *) | inright _ => 0 @@ -1188,7 +1188,7 @@ Type Type match compare 0 0 with - + (* k 0 (* k=i *) | inleft _ => 0 (* k>i *) | inright _ => 0 @@ -1375,7 +1375,7 @@ Type | var, var => True | oper op1 l1, oper op2 l2 => False | _, _ => False - end. + end. Reset LTERM. @@ -1661,7 +1661,7 @@ Type | Cons a x, Cons b y => V4 a x b y end). - + (* ===================================== *) Inductive Eqlong : @@ -1725,7 +1725,7 @@ Parameter -Fixpoint Eqlongdec (n : nat) (x : listn n) (m : nat) +Fixpoint Eqlongdec (n : nat) (x : listn n) (m : nat) (y : listn m) {struct x} : Eqlong n x m y \/ ~ Eqlong n x m y := match x in (listn n), y in (listn m) diff --git a/test-suite/success/CasesDep.v b/test-suite/success/CasesDep.v index 63957885c9..2972184338 100644 --- a/test-suite/success/CasesDep.v +++ b/test-suite/success/CasesDep.v @@ -38,29 +38,29 @@ Require Import Logic_Type. Section Orderings. Variable U : Type. - + Definition Relation := U -> U -> Prop. Variable R : Relation. - + Definition Reflexive : Prop := forall x : U, R x x. - + Definition Transitive : Prop := forall x y z : U, R x y -> R y z -> R x z. - + Definition Symmetric : Prop := forall x y : U, R x y -> R y x. - + Definition Antisymmetric : Prop := forall x y : U, R x y -> R y x -> x = y. - + Definition contains (R R' : Relation) : Prop := forall x y : U, R' x y -> R x y. Definition same_relation (R R' : Relation) : Prop := contains R R' /\ contains R' R. Inductive Equivalence : Prop := Build_Equivalence : Reflexive -> Transitive -> Symmetric -> Equivalence. - + Inductive PER : Prop := Build_PER : Symmetric -> Transitive -> PER. - + End Orderings. (***** Setoid *******) @@ -105,7 +105,7 @@ Definition Map_setoid := Build_Setoid Map ext Equiv_map_eq. End Maps. -Notation ap := (explicit_ap _ _). +Notation ap := (explicit_ap _ _). (* : Grammar is replaced by Notation *) @@ -128,8 +128,8 @@ Axiom eq_Suc : forall n m : posint, n = m -> Suc n = Suc m. Definition pred (n : posint) : posint := match n return posint with - | Z => (* Z *) Z - (* Suc u *) + | Z => (* Z *) Z + (* Suc u *) | Suc u => u end. @@ -141,7 +141,7 @@ Axiom not_eq_Suc : forall n m : posint, n <> m -> Suc n <> Suc m. Definition IsSuc (n : posint) : Prop := match n return Prop with | Z => (* Z *) False - (* Suc p *) + (* Suc p *) | Suc p => True end. Definition IsZero (n : posint) : Prop := @@ -163,7 +163,7 @@ Definition Decidable (A : Type) (R : Relation A) := forall x y : A, R x y \/ ~ R x y. -Record DSetoid : Type := +Record DSetoid : Type := {Set_of : Setoid; prf_decid : Decidable (elem Set_of) (equal Set_of)}. (* example de Dsetoide d'entiers *) @@ -190,7 +190,7 @@ Definition Dposint := Build_DSetoid Set_of_posint Eq_posint_deci. Section Sig. -Record Signature : Type := +Record Signature : Type := {Sigma : DSetoid; Arity : Map (Set_of Sigma) (Set_of Dposint)}. Variable S : Signature. @@ -268,8 +268,8 @@ Reset equalT. Fixpoint equalT (t1 : TERM) : TERM -> Prop := match t1 return (TERM -> Prop) with - | var v1 => - (*var*) + | var v1 => + (*var*) fun t2 : TERM => match t2 return Prop with | var v2 => @@ -289,12 +289,12 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop := EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 end end - + with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} : forall n2 : posint, LTERM n2 -> Prop := match l1 in (LTERM _) return (forall n2 : posint, LTERM n2 -> Prop) with | nil => - (*nil*) + (*nil*) fun (n2 : posint) (l2 : LTERM n2) => match l2 in (LTERM _) return Prop with | nil => @@ -336,7 +336,7 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop := EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 end end - + with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} : forall n2 : posint, LTERM n2 -> Prop := match l1 return (forall n2 : posint, LTERM n2 -> Prop) with @@ -374,8 +374,8 @@ Fixpoint equalT (t1 : TERM) : TERM -> Prop := EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 end end - - with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) + + with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) (l2 : LTERM n2) {struct l1} : Prop := match l1 with | nil => match l2 with @@ -401,8 +401,8 @@ Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop := equal _ op1 op2 /\ EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2 | _, _ => False end - - with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) + + with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint) (l2 : LTERM n2) {struct l1} : Prop := match l1, l2 with | nil, nil => True @@ -433,16 +433,16 @@ Inductive I : unit -> Type := | C : forall a, I a -> I tt. (* -Definition F (l:I tt) : l = l := +Definition F (l:I tt) : l = l := match l return l = l with | C tt (C _ l') => refl_equal (C tt (C _ l')) end. one would expect that the compilation of F (this involves -some kind of pattern-unification) would produce: +some kind of pattern-unification) would produce: *) -Definition F (l:I tt) : l = l := +Definition F (l:I tt) : l = l := match l return l = l with | C tt l' => match l' return C _ l' = C _ l' with C _ l'' => refl_equal (C tt (C _ l'')) end end. @@ -451,7 +451,7 @@ Inductive J : nat -> Type := | D : forall a, J (S a) -> J a. (* -Definition G (l:J O) : l = l := +Definition G (l:J O) : l = l := match l return l = l with | D O (D 1 l') => refl_equal (D O (D 1 l')) | D _ _ => refl_equal _ @@ -461,7 +461,7 @@ one would expect that the compilation of G (this involves inversion) would produce: *) -Definition G (l:J O) : l = l := +Definition G (l:J O) : l = l := match l return l = l with | D 0 l'' => match l'' as _l'' in J n return @@ -488,7 +488,7 @@ Require Import List. Inductive nt := E. Definition root := E. -Inductive ctor : list nt -> nt -> Type := +Inductive ctor : list nt -> nt -> Type := Plus : ctor (cons E (cons E nil)) E. Inductive term : nt -> Type := diff --git a/test-suite/success/Discriminate.v b/test-suite/success/Discriminate.v index b57c547819..dffad3230a 100644 --- a/test-suite/success/Discriminate.v +++ b/test-suite/success/Discriminate.v @@ -2,11 +2,11 @@ (* Check that Discriminate tries Intro until *) -Lemma l1 : 0 = 1 -> False. +Lemma l1 : 0 = 1 -> False. discriminate 1. Qed. -Lemma l2 : forall H : 0 = 1, H = H. +Lemma l2 : forall H : 0 = 1, H = H. discriminate H. Qed. diff --git a/test-suite/success/Equations.v b/test-suite/success/Equations.v index e31135c2f3..d6e17f30db 100644 --- a/test-suite/success/Equations.v +++ b/test-suite/success/Equations.v @@ -3,7 +3,7 @@ Require Import Program. Equations neg (b : bool) : bool := neg true := false ; neg false := true. - + Eval compute in neg. Require Import Coq.Lists.List. @@ -30,7 +30,7 @@ app' A (cons a v) l := cons a (app' v l). Equations app (l l' : list nat) : list nat := [] ++ l := l ; - (a :: v) ++ l := a :: (v ++ l) + (a :: v) ++ l := a :: (v ++ l) where " x ++ y " := (app x y). @@ -73,7 +73,7 @@ Require Import Bvector. Implicit Arguments Vnil [[A]]. Implicit Arguments Vcons [[A] [n]]. -Equations vhead {A n} (v : vector A (S n)) : A := +Equations vhead {A n} (v : vector A (S n)) : A := vhead A n (Vcons a v) := a. Equations vmap {A B} (f : A -> B) {n} (v : vector A n) : (vector B n) := @@ -109,7 +109,7 @@ Fixpoint Below_vector (P : Π A n, vector A n -> Type) A n (v : vector A n) : Ty Equations below_vector (P : Π A n, vector A n -> Type) A n (v : vector A n) (step : Π A n (v : vector A n), Below_vector P A n v -> P A n v) : Below_vector P A n v := below_vector P A ?(0) Vnil step := tt ; -below_vector P A ?(S n) (Vcons a v) step := +below_vector P A ?(S n) (Vcons a v) step := let rest := below_vector P A n v step in (step A n v rest, rest). @@ -125,7 +125,7 @@ Definition rec_vector (P : Π A n, vector A n -> Type) A n v (step : Π A n (v : vector A n), Below_vector P A n v -> P A n v) : P A n v := step A n v (below_vector P A n v step). -Class Recursor (A : Type) (BP : BelowPack A) := +Class Recursor (A : Type) (BP : BelowPack A) := { rec_type : Π x : A, Type ; rec : Π x : A, rec_type x }. Instance nat_Recursor : Recursor nat nat_BelowPack := @@ -159,7 +159,7 @@ Notation " x ~= y " := (@JMeq _ x _ y) (at level 70, no associativity). Section Image. Context {S T : Type}. Variable f : S -> T. - + Inductive Imf : T -> Type := imf (s : S) : Imf (f s). Equations inv (t : T) (im : Imf t) : S := @@ -173,7 +173,7 @@ Section Univ. | ubool | unat | uarrow (from:univ) (to:univ). Equations interp (u : univ) : Type := - interp ubool := bool ; interp unat := nat ; + interp ubool := bool ; interp unat := nat ; interp (uarrow from to) := interp from -> interp to. Equations foo (u : univ) (el : interp u) : interp u := @@ -238,7 +238,7 @@ Lemma vlast_equation2 A n a v : @vlast' A (S n) (Vcons a v) = vlast' v. Proof. intros. simplify_equations ; reflexivity. Qed. Print Assumptions vlast'. -Print Assumptions nth. +Print Assumptions nth. Print Assumptions tabulate. Extraction vlast. diff --git a/test-suite/success/Field.v b/test-suite/success/Field.v index 6fb922b0f3..ab90dc88ae 100644 --- a/test-suite/success/Field.v +++ b/test-suite/success/Field.v @@ -31,7 +31,7 @@ Proof. intros. field. Abort. - + (* Example 3 *) Goal forall a b : R, 1 / (a * b) * (1 / (1 / b)) = 1 / a. Proof. @@ -44,7 +44,7 @@ Proof. intros. field_simplify_eq. Abort. - + Goal forall a b : R, 1 / (a * b) * (1 / 1 / b) = 1 / a. Proof. intros. @@ -58,21 +58,21 @@ Proof. intros. field; auto. Qed. - + (* Example 5 *) Goal forall a : R, 1 = 1 * (1 / a) * a. Proof. intros. field. Abort. - + (* Example 6 *) Goal forall a b : R, b = b * / a * a. Proof. intros. field. Abort. - + (* Example 7 *) Goal forall a b : R, b = b * (1 / a) * a. Proof. diff --git a/test-suite/success/Fixpoint.v b/test-suite/success/Fixpoint.v index cf82107331..4130a16ca6 100644 --- a/test-suite/success/Fixpoint.v +++ b/test-suite/success/Fixpoint.v @@ -5,7 +5,7 @@ Inductive listn : nat -> Set := | consn : forall n:nat, nat -> listn n -> listn (S n). Fixpoint f (n:nat) (m:=pred n) (l:listn m) (p:=S n) {struct l} : nat := - match n with O => p | _ => + match n with O => p | _ => match l with niln => p | consn q _ l => f (S q) l end end. diff --git a/test-suite/success/Fourier.v b/test-suite/success/Fourier.v index 2d184fef1a..b63bead477 100644 --- a/test-suite/success/Fourier.v +++ b/test-suite/success/Fourier.v @@ -1,10 +1,10 @@ Require Import Rfunctions. Require Import Fourier. - + Lemma l1 : forall x y z : R, Rabs (x - z) <= Rabs (x - y) + Rabs (y - z). intros; split_Rabs; fourier. Qed. - + Lemma l2 : forall x y : R, x < Rabs y -> y < 1 -> x >= 0 -> - y <= 1 -> Rabs x <= 1. intros. diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v index 1c3e56f207..b17adef678 100644 --- a/test-suite/success/Funind.v +++ b/test-suite/success/Funind.v @@ -6,7 +6,7 @@ Definition iszero (n : nat) : bool := end. Functional Scheme iszero_ind := Induction for iszero Sort Prop. - + Lemma toto : forall n : nat, n = 0 -> iszero n = true. intros x eg. functional induction iszero x; simpl in |- *. @@ -14,7 +14,7 @@ trivial. inversion eg. Qed. - + Function ftest (n m : nat) : nat := match n with | O => match m with @@ -30,7 +30,7 @@ intros n m. Qed. Lemma test2 : forall m n, ~ 2 = ftest n m. -Proof. +Proof. intros n m;intro H. functional inversion H ftest. Qed. @@ -45,9 +45,9 @@ Require Import Arith. Lemma test11 : forall m : nat, ftest 0 m <= 2. intros m. functional induction ftest 0 m. -auto. auto. -auto with *. +auto. +auto with *. Qed. Function lamfix (m n : nat) {struct n } : nat := @@ -92,7 +92,7 @@ Function trivfun (n : nat) : nat := end. -(* essaie de parametre variables non locaux:*) +(* essaie de parametre variables non locaux:*) Parameter varessai : nat. @@ -101,7 +101,7 @@ Lemma first_try : trivfun varessai = 0. trivial. assumption. Defined. - + Functional Scheme triv_ind := Induction for trivfun Sort Prop. @@ -134,7 +134,7 @@ Function funex (n : nat) : nat := | S r => funex r end end. - + Function nat_equal_bool (n m : nat) {struct n} : bool := match n with @@ -150,7 +150,7 @@ Function nat_equal_bool (n m : nat) {struct n} : bool := Require Export Div2. - + Functional Scheme div2_ind := Induction for div2 Sort Prop. Lemma div2_inf : forall n : nat, div2 n <= n. intros n. @@ -177,7 +177,7 @@ intros n m. functional induction nested_lam n m; simpl;auto. Qed. - + Function essai (x : nat) (p : nat * nat) {struct x} : nat := let (n, m) := (p: nat*nat) in match n with @@ -187,7 +187,7 @@ Function essai (x : nat) (p : nat * nat) {struct x} : nat := | S r => S (essai r (q, m)) end end. - + Lemma essai_essai : forall (x : nat) (p : nat * nat), let (n, m) := p in 0 < n -> 0 < essai x p. intros x p. @@ -209,30 +209,30 @@ Function plus_x_not_five'' (n m : nat) {struct n} : nat := | false => S recapp end end. - + Lemma notplusfive'' : forall x y : nat, y = 5 -> plus_x_not_five'' x y = x. intros a b. functional induction plus_x_not_five'' a b; intros hyp; simpl in |- *; auto. Qed. - + Lemma iseq_eq : forall n m : nat, n = m -> nat_equal_bool n m = true. intros n m. functional induction nat_equal_bool n m; simpl in |- *; intros hyp; auto. -rewrite <- hyp in y; simpl in y;tauto. +rewrite <- hyp in y; simpl in y;tauto. inversion hyp. Qed. - + Lemma iseq_eq' : forall n m : nat, nat_equal_bool n m = true -> n = m. intros n m. functional induction nat_equal_bool n m; simpl in |- *; intros eg; auto. inversion eg. inversion eg. Qed. - - + + Inductive istrue : bool -> Prop := istrue0 : istrue true. - + Functional Scheme plus_ind := Induction for plus Sort Prop. Lemma inf_x_plusxy' : forall x y : nat, x <= x + y. @@ -242,7 +242,7 @@ auto with arith. auto with arith. Qed. - + Lemma inf_x_plusxy'' : forall x : nat, x <= x + 0. intros n. unfold plus in |- *. @@ -251,7 +251,7 @@ auto with arith. apply le_n_S. assumption. Qed. - + Lemma inf_x_plusxy''' : forall x : nat, x <= 0 + x. intros n. functional induction plus 0 n; intros; auto with arith. @@ -263,25 +263,25 @@ Function mod2 (n : nat) : nat := | S (S m) => S (mod2 m) | _ => 0 end. - + Lemma princ_mod2 : forall n : nat, mod2 n <= n. intros n. functional induction mod2 n; simpl in |- *; auto with arith. Qed. - + Function isfour (n : nat) : bool := match n with | S (S (S (S O))) => true | _ => false end. - + Function isononeorfour (n : nat) : bool := match n with | S O => true | S (S (S (S O))) => true | _ => false end. - + Lemma toto'' : forall n : nat, istrue (isfour n) -> istrue (isononeorfour n). intros n. functional induction isononeorfour n; intros istr; simpl in |- *; @@ -294,14 +294,14 @@ destruct n. inversion istr. destruct n. tauto. simpl in *. inversion H0. Qed. - + Lemma toto' : forall n m : nat, n = 4 -> istrue (isononeorfour n). intros n. functional induction isononeorfour n; intros m istr; inversion istr. apply istrue0. rewrite H in y; simpl in y;tauto. Qed. - + Function ftest4 (n m : nat) : nat := match n with | O => match m with @@ -313,12 +313,12 @@ Function ftest4 (n m : nat) : nat := | S r => 1 end end. - + Lemma test4 : forall n m : nat, ftest n m <= 2. intros n m. functional induction ftest n m; auto with arith. Qed. - + Lemma test4' : forall n m : nat, ftest4 (S n) m <= 2. intros n m. assert ({n0 | n0 = S n}). @@ -332,7 +332,7 @@ inversion 1. auto with arith. auto with arith. Qed. - + Function ftest44 (x : nat * nat) (n m : nat) : nat := let (p, q) := (x: nat*nat) in match n with @@ -345,7 +345,7 @@ Function ftest44 (x : nat * nat) (n m : nat) : nat := | S r => 1 end end. - + Lemma test44 : forall (pq : nat * nat) (n m o r s : nat), ftest44 pq n (S m) <= 2. intros pq n m o r s. @@ -355,7 +355,7 @@ auto with arith. auto with arith. auto with arith. Qed. - + Function ftest2 (n m : nat) {struct n} : nat := match n with | O => match m with @@ -364,12 +364,12 @@ Function ftest2 (n m : nat) {struct n} : nat := end | S p => ftest2 p m end. - + Lemma test2' : forall n m : nat, ftest2 n m <= 2. intros n m. functional induction ftest2 n m; simpl in |- *; intros; auto. Qed. - + Function ftest3 (n m : nat) {struct n} : nat := match n with | O => 0 @@ -378,7 +378,7 @@ Function ftest3 (n m : nat) {struct n} : nat := | S r => 0 end end. - + Lemma test3' : forall n m : nat, ftest3 n m <= 2. intros n m. functional induction ftest3 n m. @@ -390,7 +390,7 @@ intros. simpl in |- *. auto. Qed. - + Function ftest5 (n m : nat) {struct n} : nat := match n with | O => 0 @@ -399,7 +399,7 @@ Function ftest5 (n m : nat) {struct n} : nat := | S r => ftest5 p r end end. - + Lemma test5 : forall n m : nat, ftest5 n m <= 2. intros n m. functional induction ftest5 n m. @@ -411,21 +411,21 @@ intros. simpl in |- *. auto. Qed. - + Function ftest7 (n : nat) : nat := match ftest5 n 0 with | O => 0 | S r => 0 end. - + Lemma essai7 : forall (Hrec : forall n : nat, ftest5 n 0 = 0 -> ftest7 n <= 2) - (Hrec0 : forall n r : nat, ftest5 n 0 = S r -> ftest7 n <= 2) + (Hrec0 : forall n r : nat, ftest5 n 0 = S r -> ftest7 n <= 2) (n : nat), ftest7 n <= 2. intros hyp1 hyp2 n. functional induction ftest7 n; auto. Qed. - + Function ftest6 (n m : nat) {struct n} : nat := match n with | O => 0 @@ -435,7 +435,7 @@ Function ftest6 (n m : nat) {struct n} : nat := end end. - + Lemma princ6 : (forall n m : nat, n = 0 -> ftest6 0 m <= 2) -> (forall n m p : nat, @@ -448,16 +448,16 @@ generalize hyp1 hyp2 hyp3. clear hyp1 hyp2 hyp3. functional induction ftest6 n m; auto. Qed. - + Lemma essai6 : forall n m : nat, ftest6 n m <= 2. intros n m. functional induction ftest6 n m; simpl in |- *; auto. Qed. -(* Some tests with modules *) +(* Some tests with modules *) Module M. -Function test_m (n:nat) : nat := - match n with +Function test_m (n:nat) : nat := + match n with | 0 => 0 | S n => S (S (test_m n)) end. @@ -470,14 +470,14 @@ reflexivity. simpl;rewrite IHn0;reflexivity. Qed. End M. -(* We redefine a new Function with the same name *) -Function test_m (n:nat) : nat := +(* We redefine a new Function with the same name *) +Function test_m (n:nat) : nat := pred n. Lemma test_m_is_pred : forall n, test_m n = pred n. -Proof. +Proof. intro n. -functional induction (test_m n). (* the test_m_ind to use is the last defined saying that test_m = pred*) +functional induction (test_m n). (* the test_m_ind to use is the last defined saying that test_m = pred*) reflexivity. Qed. diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v index 98b5992ade..a8cc7f745a 100644 --- a/test-suite/success/Hints.v +++ b/test-suite/success/Hints.v @@ -23,11 +23,11 @@ Hint Destruct h8 := 4 Hypothesis (_ <= _) => fun H => apply H. (* Checks that local names are accepted *) Section A. - Remark Refl : forall (A : Set) (x : A), x = x. + Remark Refl : forall (A : Set) (x : A), x = x. Proof. exact refl_equal. Defined. Definition Sym := sym_equal. Let Trans := trans_equal. - + Hint Resolve Refl: foo. Hint Resolve Sym: bar. Hint Resolve Trans: foo2. diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index 724ba502c7..203fbbb776 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -13,7 +13,7 @@ Inductive Y : Set := Inductive eq1 : forall A:Type, let B:=A in A -> Prop := refl1 : eq1 True I. -Check +Check fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) => let B := A in fun (a : A) (e : eq1 A a) => @@ -35,7 +35,7 @@ Check let E := C in let F := D in fun (x y : E -> F) (P : forall c : C, A C D x y c -> Type) - (f : forall z : C, P z (I C D x y z)) (y0 : C) + (f : forall z : C, P z (I C D x y z)) (y0 : C) (a : A C D x y y0) => match a as a0 in (A _ _ _ _ _ _ y1) return (P y1 a0) with | I x0 => f x0 @@ -48,7 +48,7 @@ Check let E := C in let F := D in fun (x y : E -> F) (P : B C D x y -> Type) - (f : forall p0 q0 : C, P (Build_B C D x y p0 q0)) + (f : forall p0 q0 : C, P (Build_B C D x y p0 q0)) (b : B C D x y) => match b as b0 return (P b0) with | Build_B x0 x1 => f x0 x1 diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v index 867d73746c..c5cd7380a2 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -17,7 +17,7 @@ Qed. Lemma l3 : forall x y : nat, existS (fun n : nat => {n = n} + {n = n}) x (left _ (refl_equal x)) = - existS (fun n : nat => {n = n} + {n = n}) y (left _ (refl_equal y)) -> + existS (fun n : nat => {n = n} + {n = n}) y (left _ (refl_equal y)) -> x = y. intros x y H. injection H. diff --git a/test-suite/success/Inversion.v b/test-suite/success/Inversion.v index b08ffcc32b..71e53191b4 100644 --- a/test-suite/success/Inversion.v +++ b/test-suite/success/Inversion.v @@ -5,13 +5,13 @@ Fixpoint T (n : nat) : Type := match n with | O => nat -> Prop | S n' => T n' - end. + end. Inductive R : forall n : nat, T n -> nat -> Prop := | RO : forall (Psi : T 0) (l : nat), Psi l -> R 0 Psi l | RS : - forall (n : nat) (Psi : T (S n)) (l : nat), R n Psi l -> R (S n) Psi l. -Definition Psi00 (n : nat) : Prop := False. -Definition Psi0 : T 0 := Psi00. + forall (n : nat) (Psi : T (S n)) (l : nat), R n Psi l -> R (S n) Psi l. +Definition Psi00 (n : nat) : Prop := False. +Definition Psi0 : T 0 := Psi00. Lemma Inversion_RO : forall l : nat, R 0 Psi0 l -> Psi00 l. inversion 1. Abort. @@ -39,14 +39,14 @@ extension I -> Type := | super_add : forall r (e' : extension I), in_extension r e -> - super_extension e e' -> super_extension e (add_rule r e'). + super_extension e e' -> super_extension e (add_rule r e'). Lemma super_def : forall (I : Set) (e1 e2 : extension I), super_extension e2 e1 -> forall ru, in_extension ru e1 -> in_extension ru e2. -Proof. +Proof. simple induction 1. inversion 1; auto. elim magic. @@ -105,5 +105,5 @@ Abort. Inductive foo2 : option nat -> Prop := Foo : forall t, foo2 (Some t). Goal forall o, foo2 o -> 0 = 1. intros. -eapply trans_eq. +eapply trans_eq. inversion H. diff --git a/test-suite/success/LegacyField.v b/test-suite/success/LegacyField.v index d53e40108f..fada3bd545 100644 --- a/test-suite/success/LegacyField.v +++ b/test-suite/success/LegacyField.v @@ -30,14 +30,14 @@ Proof. intros. legacy field. Abort. - + (* Example 3 *) Goal forall a b : R, (1 / (a * b) * (1 / 1 / b))%R = (1 / a)%R. Proof. intros. legacy field. Abort. - + (* Example 4 *) Goal forall a b : R, a <> 0%R -> b <> 0%R -> (1 / (a * b) / 1 / b)%R = (1 / a)%R. @@ -45,21 +45,21 @@ Proof. intros. legacy field. Abort. - + (* Example 5 *) Goal forall a : R, 1%R = (1 * (1 / a) * a)%R. Proof. intros. legacy field. Abort. - + (* Example 6 *) Goal forall a b : R, b = (b * / a * a)%R. Proof. intros. legacy field. Abort. - + (* Example 7 *) Goal forall a b : R, b = (b * (1 / a) * a)%R. Proof. diff --git a/test-suite/success/LetPat.v b/test-suite/success/LetPat.v index 545b8aeb86..4c790680d6 100644 --- a/test-suite/success/LetPat.v +++ b/test-suite/success/LetPat.v @@ -13,16 +13,16 @@ Definition l4 A (t : someT A) : nat := let 'mkT x y := t in x. Print l4. Print sigT. -Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) := +Definition l5 A (B : A -> Type) (t : sigT B) : B (projT1 t) := let 'existT x y := t return B (projT1 t) in y. -Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) := +Definition l6 A (B : A -> Type) (t : sigT B) : B (projT1 t) := let 'existT x y as t' := t return B (projT1 t') in y. -Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) := +Definition l7 A (B : A -> Type) (t : sigT B) : B (projT1 t) := let 'existT x y as t' in sigT _ := t return B (projT1 t') in y. -Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) := +Definition l8 A (B : A -> Type) (t : sigT B) : B (projT1 t) := match t with existT x y => y end. @@ -47,9 +47,9 @@ Definition identity_functor (c : category) : functor c c := let 'A :& homA :& CA := c in fun x => x. -Definition functor_composition (a b c : category) : functor a b -> functor b c -> functor a c := +Definition functor_composition (a b c : category) : functor a b -> functor b c -> functor a c := let 'A :& homA :& CA := a in let 'B :& homB :& CB := b in let 'C :& homB :& CB := c in - fun f g => + fun f g => fun x => g (f x). diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 84ff2608a2..1bff749335 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -14,7 +14,7 @@ Parameter P : Type -> Type -> Type -> Type. Notation "e |= t --> v" := (P e t v) (at level 100, t at level 54). Check (nat |= nat --> nat). -(* Check that first non empty definition at an empty level can be of any +(* Check that first non empty definition at an empty level can be of any associativity *) Definition marker := O. diff --git a/test-suite/success/Omega0.v b/test-suite/success/Omega0.v index accaec41ed..b8f8660e9c 100644 --- a/test-suite/success/Omega0.v +++ b/test-suite/success/Omega0.v @@ -3,24 +3,24 @@ Open Scope Z_scope. (* Pierre L: examples gathered while debugging romega. *) -Lemma test_romega_0 : - forall m m', +Lemma test_romega_0 : + forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros. omega. Qed. -Lemma test_romega_0b : - forall m m', +Lemma test_romega_0b : + forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros m m'. omega. Qed. -Lemma test_romega_1 : - forall (z z1 z2 : Z), +Lemma test_romega_1 : + forall (z z1 z2 : Z), z2 <= z1 -> z1 <= z2 -> z1 >= 0 -> @@ -32,8 +32,8 @@ intros. omega. Qed. -Lemma test_romega_1b : - forall (z z1 z2 : Z), +Lemma test_romega_1b : + forall (z z1 z2 : Z), z2 <= z1 -> z1 <= z2 -> z1 >= 0 -> @@ -45,42 +45,42 @@ intros z z1 z2. omega. Qed. -Lemma test_romega_2 : forall a b c:Z, +Lemma test_romega_2 : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros. omega. Qed. -Lemma test_romega_2b : forall a b c:Z, +Lemma test_romega_2b : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros a b c. omega. Qed. -Lemma test_romega_3 : forall a b h hl hr ha hb, - 0 <= ha - hl <= 1 -> +Lemma test_romega_3 : forall a b h hl hr ha hb, + 0 <= ha - hl <= 1 -> -2 <= hl - hr <= 2 -> h =b+1 -> (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> - (-2 <= ha-hr <=2 -> hb = a + 1) -> + (-2 <= ha-hr <=2 -> hb = a + 1) -> 0 <= hb - h <= 1. Proof. intros. omega. Qed. -Lemma test_romega_3b : forall a b h hl hr ha hb, - 0 <= ha - hl <= 1 -> +Lemma test_romega_3b : forall a b h hl hr ha hb, + 0 <= ha - hl <= 1 -> -2 <= hl - hr <= 2 -> h =b+1 -> (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> - (-2 <= ha-hr <=2 -> hb = a + 1) -> + (-2 <= ha-hr <=2 -> hb = a + 1) -> 0 <= hb - h <= 1. Proof. intros a b h hl hr ha hb. @@ -88,18 +88,18 @@ omega. Qed. -Lemma test_romega_4 : forall hr ha, +Lemma test_romega_4 : forall hr ha, ha = 0 -> - (ha = 0 -> hr =0) -> + (ha = 0 -> hr =0) -> hr = 0. Proof. intros hr ha. omega. Qed. -Lemma test_romega_5 : forall hr ha, +Lemma test_romega_5 : forall hr ha, ha = 0 -> - (~ha = 0 \/ hr =0) -> + (~ha = 0 \/ hr =0) -> hr = 0. Proof. intros hr ha. @@ -118,14 +118,14 @@ intros z. omega. Qed. -Lemma test_romega_7 : forall z, +Lemma test_romega_7 : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. omega. Qed. -Lemma test_romega_7b : forall z, +Lemma test_romega_7b : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. diff --git a/test-suite/success/Omega2.v b/test-suite/success/Omega2.v index 54b13702ab..c4d086a348 100644 --- a/test-suite/success/Omega2.v +++ b/test-suite/success/Omega2.v @@ -4,7 +4,7 @@ Require Import ZArith Omega. Open Scope Z_scope. -Lemma Test46 : +Lemma Test46 : forall v1 v2 v3 v4 v5 : Z, ((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) -> 9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) -> diff --git a/test-suite/success/OmegaPre.v b/test-suite/success/OmegaPre.v index bb800b7a01..f4996734bf 100644 --- a/test-suite/success/OmegaPre.v +++ b/test-suite/success/OmegaPre.v @@ -4,7 +4,7 @@ Open Scope Z_scope. (** Test of the zify preprocessor for (R)Omega *) (* More details in file PreOmega.v - + (r)omega with Z : starts with zify_op (r)omega with nat : starts with zify_nat (r)omega with positive : starts with zify_positive diff --git a/test-suite/success/ProgramWf.v b/test-suite/success/ProgramWf.v index 1898853f61..a6a0da878c 100644 --- a/test-suite/success/ProgramWf.v +++ b/test-suite/success/ProgramWf.v @@ -16,7 +16,7 @@ Print merge. Require Import ZArith. -Print Zlt. +Print Zlt. Require Import Zwf. Print Zwf. @@ -28,7 +28,7 @@ Program Fixpoint Zwfrec (n m : Z) {measure (n + m) (Zwf 0)} : Z := | _ => 0 end. -Next Obligation. +Next Obligation. red. Admitted. Close Scope Z_scope. @@ -52,7 +52,7 @@ Print merge_one. Eval cbv delta [merge_one] beta zeta in merge_one. Import WfExtensionality. -Lemma merge_unfold n m : merge n m = +Lemma merge_unfold n m : merge n m = match n with | 0 => 0 | S n' => merge n' m @@ -66,7 +66,7 @@ Unset Implicit Arguments. Time Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) (H : forall (i : { i | i < n }), i < p -> P i = true) - {measure (n - p)} : + {measure (n - p)} : Exc (forall (p : { i | i < n}), P p = true) := match le_lt_dec n p with | left _ => value _ @@ -79,14 +79,14 @@ Time Program Fixpoint check_n (n : nat) (P : { i | i < n } -> bool) (p : nat) Require Import Omega Setoid. -Next Obligation. - intros ; simpl in *. apply H. +Next Obligation. + intros ; simpl in *. apply H. simpl in * ; omega. Qed. -Next Obligation. simpl in *; intros. - revert H0 ; clear_subset_proofs. intros. - case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by omega. subst. +Next Obligation. simpl in *; intros. + revert H0 ; clear_subset_proofs. intros. + case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by omega. subst. revert H0 ; clear_subset_proofs ; tauto. apply H. simpl. omega. diff --git a/test-suite/success/Projection.v b/test-suite/success/Projection.v index 88da601331..d8faa88a78 100644 --- a/test-suite/success/Projection.v +++ b/test-suite/success/Projection.v @@ -12,7 +12,7 @@ Check fun (s:S) (a b:s.(Dom)) => s.(Op) a b. Set Implicit Arguments. Unset Strict Implicit. -Unset Strict Implicit. +Unset Strict Implicit. Structure S' (A : Set) : Type := {Dom' : Type; Op' : A -> Dom' -> Dom'}. @@ -29,9 +29,9 @@ Check fun (s:S') (a b:s.(Dom')) => _.(Op') a b. Check fun (s:S') (a b:s.(Dom')) => s.(Op') a b. Set Implicit Arguments. -Unset Strict Implicits. +Unset Strict Implicits. -Structure S' (A:Set) : Type := +Structure S' (A:Set) : Type := {Dom' : Type; Op' : A -> Dom' -> Dom'}. diff --git a/test-suite/success/ROmega.v b/test-suite/success/ROmega.v index 0c37c59aca..801ece9e3d 100644 --- a/test-suite/success/ROmega.v +++ b/test-suite/success/ROmega.v @@ -22,7 +22,7 @@ Qed. Lemma lem3 : forall x y : Z, x = y -> (x + x)%Z = (y + y)%Z. Proof. intros. -romega. +romega. Qed. (* Proposed by Jean-Christophe Filliâtre: confusion between an Omega *) diff --git a/test-suite/success/ROmega0.v b/test-suite/success/ROmega0.v index 86cf49cb5e..1348bb6238 100644 --- a/test-suite/success/ROmega0.v +++ b/test-suite/success/ROmega0.v @@ -3,24 +3,24 @@ Open Scope Z_scope. (* Pierre L: examples gathered while debugging romega. *) -Lemma test_romega_0 : - forall m m', +Lemma test_romega_0 : + forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros. romega. Qed. -Lemma test_romega_0b : - forall m m', +Lemma test_romega_0b : + forall m m', 0<= m <= 1 -> 0<= m' <= 1 -> (0 < m <-> 0 < m') -> m = m'. Proof. intros m m'. romega. Qed. -Lemma test_romega_1 : - forall (z z1 z2 : Z), +Lemma test_romega_1 : + forall (z z1 z2 : Z), z2 <= z1 -> z1 <= z2 -> z1 >= 0 -> @@ -32,8 +32,8 @@ intros. romega. Qed. -Lemma test_romega_1b : - forall (z z1 z2 : Z), +Lemma test_romega_1b : + forall (z z1 z2 : Z), z2 <= z1 -> z1 <= z2 -> z1 >= 0 -> @@ -45,42 +45,42 @@ intros z z1 z2. romega. Qed. -Lemma test_romega_2 : forall a b c:Z, +Lemma test_romega_2 : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros. romega. Qed. -Lemma test_romega_2b : forall a b c:Z, +Lemma test_romega_2b : forall a b c:Z, 0<=a-b<=1 -> b-c<=2 -> a-c<=3. Proof. intros a b c. romega. Qed. -Lemma test_romega_3 : forall a b h hl hr ha hb, - 0 <= ha - hl <= 1 -> +Lemma test_romega_3 : forall a b h hl hr ha hb, + 0 <= ha - hl <= 1 -> -2 <= hl - hr <= 2 -> h =b+1 -> (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> - (-2 <= ha-hr <=2 -> hb = a + 1) -> + (-2 <= ha-hr <=2 -> hb = a + 1) -> 0 <= hb - h <= 1. Proof. intros. romega. Qed. -Lemma test_romega_3b : forall a b h hl hr ha hb, - 0 <= ha - hl <= 1 -> +Lemma test_romega_3b : forall a b h hl hr ha hb, + 0 <= ha - hl <= 1 -> -2 <= hl - hr <= 2 -> h =b+1 -> (ha >= hr /\ a = ha \/ ha <= hr /\ a = hr) -> (hl >= hr /\ b = hl \/ hl <= hr /\ b = hr) -> (-3 <= ha -hr <=3 -> 0 <= hb - a <= 1) -> - (-2 <= ha-hr <=2 -> hb = a + 1) -> + (-2 <= ha-hr <=2 -> hb = a + 1) -> 0 <= hb - h <= 1. Proof. intros a b h hl hr ha hb. @@ -88,18 +88,18 @@ romega. Qed. -Lemma test_romega_4 : forall hr ha, +Lemma test_romega_4 : forall hr ha, ha = 0 -> - (ha = 0 -> hr =0) -> + (ha = 0 -> hr =0) -> hr = 0. Proof. intros hr ha. romega. Qed. -Lemma test_romega_5 : forall hr ha, +Lemma test_romega_5 : forall hr ha, ha = 0 -> - (~ha = 0 \/ hr =0) -> + (~ha = 0 \/ hr =0) -> hr = 0. Proof. intros hr ha. @@ -118,14 +118,14 @@ intros z. romega. Qed. -Lemma test_romega_7 : forall z, +Lemma test_romega_7 : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. romega. Qed. -Lemma test_romega_7b : forall z, +Lemma test_romega_7b : forall z, 0>=0 /\ z=0 \/ 0<=0 /\ z =0 -> 1 = z+1. Proof. intros. diff --git a/test-suite/success/ROmega2.v b/test-suite/success/ROmega2.v index a3be2898c1..87e8c8e33e 100644 --- a/test-suite/success/ROmega2.v +++ b/test-suite/success/ROmega2.v @@ -6,7 +6,7 @@ Open Scope Z_scope. (* First a simplified version used during debug of romega on Test46 *) -Lemma Test46_simplified : +Lemma Test46_simplified : forall v1 v2 v5 : Z, 0 = v2 + v5 -> 0 < v5 -> @@ -18,7 +18,7 @@ Qed. (* The complete problem *) -Lemma Test46 : +Lemma Test46 : forall v1 v2 v3 v4 v5 : Z, ((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) -> 9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) -> diff --git a/test-suite/success/ROmegaPre.v b/test-suite/success/ROmegaPre.v index 550edca507..bd473fa607 100644 --- a/test-suite/success/ROmegaPre.v +++ b/test-suite/success/ROmegaPre.v @@ -4,7 +4,7 @@ Open Scope Z_scope. (** Test of the zify preprocessor for (R)Omega *) (* More details in file PreOmega.v - + (r)omega with Z : starts with zify_op (r)omega with nat : starts with zify_nat (r)omega with positive : starts with zify_positive diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v index 60e170e4f1..14d27924ef 100644 --- a/test-suite/success/RecTutorial.v +++ b/test-suite/success/RecTutorial.v @@ -1,5 +1,5 @@ -Inductive nat : Set := - | O : nat +Inductive nat : Set := + | O : nat | S : nat->nat. Check nat. Check O. @@ -14,8 +14,8 @@ Print le. Theorem zero_leq_three: 0 <= 3. Proof. - constructor 2. - constructor 2. + constructor 2. + constructor 2. constructor 2. constructor 1. @@ -32,7 +32,7 @@ Qed. Lemma zero_lt_three : 0 < 3. Proof. unfold lt. - repeat constructor. + repeat constructor. Qed. @@ -132,7 +132,7 @@ Require Import Compare_dec. Check le_lt_dec. -Definition max (n p :nat) := match le_lt_dec n p with +Definition max (n p :nat) := match le_lt_dec n p with | left _ => p | right _ => n end. @@ -152,9 +152,9 @@ Extraction max. Inductive tree(A:Set) : Set := - node : A -> forest A -> tree A + node : A -> forest A -> tree A with - forest (A: Set) : Set := + forest (A: Set) : Set := nochild : forest A | addchild : tree A -> forest A -> forest A. @@ -162,7 +162,7 @@ with -Inductive +Inductive even : nat->Prop := evenO : even O | evenS : forall n, odd n -> even (S n) @@ -176,11 +176,11 @@ Qed. -Definition nat_case := +Definition nat_case := fun (Q : Type)(g0 : Q)(g1 : nat -> Q)(n:nat) => match n return Q with - | 0 => g0 - | S p => g1 p + | 0 => g0 + | S p => g1 p end. Eval simpl in (nat_case nat 0 (fun p => p) 34). @@ -200,7 +200,7 @@ Eval simpl in fun p => pred (S p). Definition xorb (b1 b2:bool) := -match b1, b2 with +match b1, b2 with | false, true => true | true, false => true | _ , _ => false @@ -208,7 +208,7 @@ end. Definition pred_spec (n:nat) := {m:nat | n=0 /\ m=0 \/ n = S m}. - + Definition predecessor : forall n:nat, pred_spec n. intro n;case n. @@ -220,7 +220,7 @@ Print predecessor. Extraction predecessor. -Theorem nat_expand : +Theorem nat_expand : forall n:nat, n = match n with 0 => 0 | S p => S p end. intro n;case n;simpl;auto. Qed. @@ -228,7 +228,7 @@ Qed. Check (fun p:False => match p return 2=3 with end). Theorem fromFalse : False -> 0=1. - intro absurd. + intro absurd. contradiction. Qed. @@ -244,12 +244,12 @@ Section equality_elimination. End equality_elimination. - + Theorem trans : forall n m p:nat, n=m -> m=p -> n=p. Proof. - intros n m p eqnm. + intros n m p eqnm. case eqnm. - trivial. + trivial. Qed. Lemma Rw : forall x y: nat, y = y * x -> y * x * x = y. @@ -282,7 +282,7 @@ Lemma four_n : forall n:nat, n+n+n+n = 4*n. Undo. intro n; pattern n at 1. - + rewrite <- mult_1_l. repeat rewrite mult_distr_S. @@ -314,7 +314,7 @@ Proof. intros m Hm; exists m;trivial. Qed. -Definition Vtail_total +Definition Vtail_total (A : Set) (n : nat) (v : vector A n) : vector A (pred n):= match v in (vector _ n0) return (vector A (pred n0)) with | Vnil => Vnil A @@ -322,7 +322,7 @@ match v in (vector _ n0) return (vector A (pred n0)) with end. Definition Vtail' (A:Set)(n:nat)(v:vector A n) : vector A (pred n). - intros A n v; case v. + intros A n v; case v. simpl. exact (Vnil A). simpl. @@ -331,7 +331,7 @@ Defined. (* Inductive Lambda : Set := - lambda : (Lambda -> False) -> Lambda. + lambda : (Lambda -> False) -> Lambda. Error: Non strictly positive occurrence of "Lambda" in @@ -347,7 +347,7 @@ Section Paradox. (* understand matchL Q l (fun h : Lambda -> False => t) - as match l return Q with lambda h => t end + as match l return Q with lambda h => t end *) Definition application (f x: Lambda) :False := @@ -377,26 +377,26 @@ Definition isingle l := inode l (fun i => ileaf). Definition t1 := inode 0 (fun n => isingle (Z_of_nat (2*n))). -Definition t2 := inode 0 - (fun n : nat => +Definition t2 := inode 0 + (fun n : nat => inode (Z_of_nat n) (fun p => isingle (Z_of_nat (n*p)))). Inductive itree_le : itree-> itree -> Prop := | le_leaf : forall t, itree_le ileaf t - | le_node : forall l l' s s', - Zle l l' -> - (forall i, exists j:nat, itree_le (s i) (s' j)) -> + | le_node : forall l l' s s', + Zle l l' -> + (forall i, exists j:nat, itree_le (s i) (s' j)) -> itree_le (inode l s) (inode l' s'). -Theorem itree_le_trans : +Theorem itree_le_trans : forall t t', itree_le t t' -> forall t'', itree_le t' t'' -> itree_le t t''. induction t. constructor 1. - + intros t'; case t'. inversion 1. intros z0 i0 H0. @@ -409,20 +409,20 @@ Theorem itree_le_trans : inversion_clear H0. intro i2; case (H4 i2). intros. - generalize (H i2 _ H0). + generalize (H i2 _ H0). intros. case (H3 x);intros. generalize (H5 _ H6). exists x0;auto. Qed. - + Inductive itree_le' : itree-> itree -> Prop := | le_leaf' : forall t, itree_le' ileaf t - | le_node' : forall l l' s s' g, - Zle l l' -> - (forall i, itree_le' (s i) (s' (g i))) -> + | le_node' : forall l l' s s' g, + Zle l l' -> + (forall i, itree_le' (s i) (s' (g i))) -> itree_le' (inode l s) (inode l' s'). @@ -434,7 +434,7 @@ Lemma t1_le_t2 : itree_le t1 t2. constructor. auto with zarith. intro i; exists (2 * i). - unfold isingle. + unfold isingle. constructor. auto with zarith. exists i;constructor. @@ -455,7 +455,7 @@ Qed. Require Import List. -Inductive ltree (A:Set) : Set := +Inductive ltree (A:Set) : Set := lnode : A -> list (ltree A) -> ltree A. Inductive prop : Prop := @@ -482,8 +482,8 @@ Qed. Check (fun (P:Prop->Prop)(p: ex_Prop P) => match p with exP_intro X HX => X end). Error: -Incorrect elimination of "p" in the inductive type -"ex_Prop", the return type has sort "Type" while it should be +Incorrect elimination of "p" in the inductive type +"ex_Prop", the return type has sort "Type" while it should be "Prop" Elimination of an inductive object of sort "Prop" @@ -496,8 +496,8 @@ because proofs can be eliminated only to build proofs Check (match prop_inject with (prop_intro P p) => P end). Error: -Incorrect elimination of "prop_inject" in the inductive type -"prop", the return type has sort "Type" while it should be +Incorrect elimination of "prop_inject" in the inductive type +"prop", the return type has sort "Type" while it should be "Prop" Elimination of an inductive object of sort "Prop" @@ -508,17 +508,17 @@ because proofs can be eliminated only to build proofs Print prop_inject. (* -prop_inject = +prop_inject = prop_inject = prop_intro prop (fun H : prop => H) : prop *) -Inductive typ : Type := - typ_intro : Type -> typ. +Inductive typ : Type := + typ_intro : Type -> typ. Definition typ_inject: typ. -split. +split. exact typ. (* Defined. @@ -564,13 +564,13 @@ Reset comes_from_the_left. Definition comes_from_the_left (P Q:Prop)(H:P \/ Q): Prop := match H with - | or_introl p => True + | or_introl p => True | or_intror q => False end. Error: -Incorrect elimination of "H" in the inductive type -"or", the return type has sort "Type" while it should be +Incorrect elimination of "H" in the inductive type +"or", the return type has sort "Type" while it should be "Prop" Elimination of an inductive object of sort "Prop" @@ -582,41 +582,41 @@ because proofs can be eliminated only to build proofs Definition comes_from_the_left_sumbool (P Q:Prop)(x:{P}+{Q}): Prop := match x with - | left p => True + | left p => True | right q => False end. - + Close Scope Z_scope. -Theorem S_is_not_O : forall n, S n <> 0. +Theorem S_is_not_O : forall n, S n <> 0. -Definition Is_zero (x:nat):= match x with - | 0 => True +Definition Is_zero (x:nat):= match x with + | 0 => True | _ => False end. Lemma O_is_zero : forall m, m = 0 -> Is_zero m. Proof. intros m H; subst m. - (* + (* ============================ Is_zero 0 *) simpl;trivial. Qed. - + red; intros n Hn. apply O_is_zero with (m := S n). assumption. Qed. -Theorem disc2 : forall n, S (S n) <> 1. +Theorem disc2 : forall n, S (S n) <> 1. Proof. intros n Hn; discriminate. Qed. @@ -632,7 +632,7 @@ Qed. Theorem inj_succ : forall n m, S n = S m -> n = m. Proof. - + Lemma inj_pred : forall n m, n = m -> pred n = pred m. Proof. @@ -666,9 +666,9 @@ Proof. intros n p H; case H ; intros; discriminate. Qed. - + eapply not_le_Sn_0_with_constraints; eauto. -Qed. +Qed. Theorem not_le_Sn_0' : forall n:nat, ~ (S n <= 0). @@ -681,7 +681,7 @@ Check le_Sn_0_inv. Theorem le_Sn_0'' : forall n p : nat, ~ S n <= 0 . Proof. - intros n p H; + intros n p H; inversion H using le_Sn_0_inv. Qed. @@ -689,9 +689,9 @@ Derive Inversion_clear le_Sn_0_inv' with (forall n :nat, S n <= 0). Check le_Sn_0_inv'. -Theorem le_reverse_rules : - forall n m:nat, n <= m -> - n = m \/ +Theorem le_reverse_rules : + forall n m:nat, n <= m -> + n = m \/ exists p, n <= p /\ m = S p. Proof. intros n m H; inversion H. @@ -704,21 +704,21 @@ Restart. Qed. Inductive ArithExp : Set := - Zero : ArithExp + Zero : ArithExp | Succ : ArithExp -> ArithExp | Plus : ArithExp -> ArithExp -> ArithExp. Inductive RewriteRel : ArithExp -> ArithExp -> Prop := RewSucc : forall e1 e2 :ArithExp, - RewriteRel e1 e2 -> RewriteRel (Succ e1) (Succ e2) + RewriteRel e1 e2 -> RewriteRel (Succ e1) (Succ e2) | RewPlus0 : forall e:ArithExp, - RewriteRel (Plus Zero e) e + RewriteRel (Plus Zero e) e | RewPlusS : forall e1 e2:ArithExp, RewriteRel e1 e2 -> RewriteRel (Plus (Succ e1) e2) (Succ (Plus e1 e2)). - + Fixpoint plus (n p:nat) {struct n} : nat := match n with | 0 => p @@ -739,7 +739,7 @@ Fixpoint plus'' (n p:nat) {struct n} : nat := Fixpoint even_test (n:nat) : bool := - match n + match n with 0 => true | 1 => false | S (S p) => even_test p @@ -749,20 +749,20 @@ Fixpoint even_test (n:nat) : bool := Reset even_test. Fixpoint even_test (n:nat) : bool := - match n - with + match n + with | 0 => true | S p => odd_test p end with odd_test (n:nat) : bool := match n - with + with | 0 => false | S p => even_test p end. - + Eval simpl in even_test. @@ -779,11 +779,11 @@ Section Principle_of_Induction. Variable P : nat -> Prop. Hypothesis base_case : P 0. Hypothesis inductive_step : forall n:nat, P n -> P (S n). -Fixpoint nat_ind (n:nat) : (P n) := +Fixpoint nat_ind (n:nat) : (P n) := match n return P n with | 0 => base_case | S m => inductive_step m (nat_ind m) - end. + end. End Principle_of_Induction. @@ -803,9 +803,9 @@ Variable P : nat -> nat ->Prop. Hypothesis base_case1 : forall x:nat, P 0 x. Hypothesis base_case2 : forall x:nat, P (S x) 0. Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). -Fixpoint nat_double_ind (n m:nat){struct n} : P n m := - match n, m return P n m with - | 0 , x => base_case1 x +Fixpoint nat_double_ind (n m:nat){struct n} : P n m := + match n, m return P n m with + | 0 , x => base_case1 x | (S x), 0 => base_case2 x | (S x), (S y) => inductive_step x y (nat_double_ind x y) end. @@ -816,15 +816,15 @@ Variable P : nat -> nat -> Set. Hypothesis base_case1 : forall x:nat, P 0 x. Hypothesis base_case2 : forall x:nat, P (S x) 0. Hypothesis inductive_step : forall n m:nat, P n m -> P (S n) (S m). -Fixpoint nat_double_rec (n m:nat){struct n} : P n m := - match n, m return P n m with - | 0 , x => base_case1 x +Fixpoint nat_double_rec (n m:nat){struct n} : P n m := + match n, m return P n m with + | 0 , x => base_case1 x | (S x), 0 => base_case2 x | (S x), (S y) => inductive_step x y (nat_double_rec x y) end. End Principle_of_Double_Recursion. -Definition min : nat -> nat -> nat := +Definition min : nat -> nat -> nat := nat_double_rec (fun (x y:nat) => nat) (fun (x:nat) => 0) (fun (y:nat) => 0) @@ -868,7 +868,7 @@ Require Import Minus. (* Fixpoint div (x y:nat){struct x}: nat := - if eq_nat_dec x 0 + if eq_nat_dec x 0 then 0 else if eq_nat_dec y 0 then x @@ -901,18 +901,18 @@ Qed. Lemma minus_smaller_positive : forall x y:nat, x <>0 -> y <> 0 -> x - y < x. Proof. - destruct x; destruct y; - ( simpl;intros; apply minus_smaller_S || + destruct x; destruct y; + ( simpl;intros; apply minus_smaller_S || intros; absurd (0=0); auto). Qed. -Definition minus_decrease : forall x y:nat, Acc lt x -> - x <> 0 -> +Definition minus_decrease : forall x y:nat, Acc lt x -> + x <> 0 -> y <> 0 -> Acc lt (x-y). Proof. intros x y H; case H. - intros Hz posz posy. + intros Hz posz posy. apply Hz; apply minus_smaller_positive; assumption. Defined. @@ -923,18 +923,18 @@ Print minus_decrease. Definition div_aux (x y:nat)(H: Acc lt x):nat. fix 3. intros. - refine (if eq_nat_dec x 0 - then 0 - else if eq_nat_dec y 0 + refine (if eq_nat_dec x 0 + then 0 + else if eq_nat_dec y 0 then y else div_aux (x-y) y _). - apply (minus_decrease x y H);assumption. + apply (minus_decrease x y H);assumption. Defined. Print div_aux. (* -div_aux = +div_aux = (fix div_aux (x y : nat) (H : Acc lt x) {struct H} : nat := match eq_nat_dec x 0 with | left _ => 0 @@ -948,7 +948,7 @@ div_aux = *) Require Import Wf_nat. -Definition div x y := div_aux x y (lt_wf x). +Definition div x y := div_aux x y (lt_wf x). Extraction div. (* @@ -974,7 +974,7 @@ Proof. Abort. (* - Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n), + Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n), n= 0 -> v = Vnil A. Toplevel input, characters 40281-40287 @@ -990,7 +990,7 @@ The term "Vnil A" has type "vector A 0" while it is expected to have type *) Require Import JMeq. -Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n), +Lemma vector0_is_vnil_aux : forall (A:Set)(n:nat)(v:vector A n), n= 0 -> JMeq v (Vnil A). Proof. destruct v. @@ -1026,7 +1026,7 @@ Eval simpl in (fun (A:Set)(v:vector A 0) => v). Lemma Vid_eq : forall (n:nat) (A:Type)(v:vector A n), v=(Vid _ n v). Proof. - destruct v. + destruct v. reflexivity. reflexivity. Defined. @@ -1034,7 +1034,7 @@ Defined. Theorem zero_nil : forall A (v:vector A 0), v = Vnil. Proof. intros. - change (Vnil (A:=A)) with (Vid _ 0 v). + change (Vnil (A:=A)) with (Vid _ 0 v). apply Vid_eq. Defined. @@ -1050,7 +1050,7 @@ Defined. -Definition vector_double_rect : +Definition vector_double_rect : forall (A:Set) (P: forall (n:nat),(vector A n)->(vector A n) -> Type), P 0 Vnil Vnil -> (forall n (v1 v2 : vector A n) a b, P n v1 v2 -> @@ -1105,7 +1105,7 @@ Qed. | LCons : A -> LList A -> LList A. - + Definition head (A:Set)(s : Stream A) := match s with Cons a s' => a end. @@ -1144,7 +1144,7 @@ Hypothesis bisim2 : forall s1 s2:Stream A, R s1 s2 -> CoFixpoint park_ppl : forall s1 s2:Stream A, R s1 s2 -> EqSt s1 s2 := fun s1 s2 (p : R s1 s2) => - eqst s1 s2 (bisim1 p) + eqst s1 s2 (bisim1 p) (park_ppl (bisim2 p)). End Parks_Principle. @@ -1154,7 +1154,7 @@ Theorem map_iterate : forall (A:Set)(f:A->A)(x:A), Proof. intros A f x. apply park_ppl with - (R:= fun s1 s2 => exists x: A, + (R:= fun s1 s2 => exists x: A, s1 = iterate f (f x) /\ s2 = map f (iterate f x)). intros s1 s2 (x0,(eqs1,eqs2));rewrite eqs1;rewrite eqs2;reflexivity. diff --git a/test-suite/success/Record.v b/test-suite/success/Record.v index c0065809db..8334322c99 100644 --- a/test-suite/success/Record.v +++ b/test-suite/success/Record.v @@ -17,34 +17,34 @@ Obligation Tactic := crush. Program Definition vnil {A} : vector A 0 := {| vec_list := [] |}. -Program Definition vcons {A n} (a : A) (v : vector A n) : vector A (S n) := +Program Definition vcons {A n} (a : A) (v : vector A n) : vector A (S n) := {| vec_list := cons a (vec_list v) |}. Hint Rewrite map_length rev_length : datatypes. -Program Definition vmap {A B n} (f : A -> B) (v : vector A n) : vector B n := +Program Definition vmap {A B n} (f : A -> B) (v : vector A n) : vector B n := {| vec_list := map f v |}. -Program Definition vreverse {A n} (v : vector A n) : vector A n := +Program Definition vreverse {A n} (v : vector A n) : vector A n := {| vec_list := rev v |}. -Fixpoint va_list {A B} (v : list (A -> B)) (w : list A) : list B := +Fixpoint va_list {A B} (v : list (A -> B)) (w : list A) : list B := match v, w with | nil, nil => nil | cons f fs, cons x xs => cons (f x) (va_list fs xs) | _, _ => nil end. -Program Definition va {A B n} (v : vector (A -> B) n) (w : vector A n) : vector B n := +Program Definition va {A B n} (v : vector (A -> B) n) (w : vector A n) : vector B n := {| vec_list := va_list v w |}. -Next Obligation. +Next Obligation. destruct v as [v Hv]; destruct w as [w Hw] ; simpl. - subst n. revert w Hw. induction v ; destruct w ; crush. + subst n. revert w Hw. induction v ; destruct w ; crush. rewrite IHv ; auto. Qed. -(* Correct type inference of record notation. Initial example by Spiwack. *) +(* Correct type inference of record notation. Initial example by Spiwack. *) Inductive Machin := { Bazar : option Machin diff --git a/test-suite/success/Simplify_eq.v b/test-suite/success/Simplify_eq.v index 5b856e3da0..d9abdbf5a6 100644 --- a/test-suite/success/Simplify_eq.v +++ b/test-suite/success/Simplify_eq.v @@ -2,11 +2,11 @@ (* Check that Simplify_eq tries Intro until *) -Lemma l1 : 0 = 1 -> False. +Lemma l1 : 0 = 1 -> False. simplify_eq 1. Qed. -Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False. +Lemma l2 : forall (x : nat) (H : S x = S (S x)), H = H -> False. simplify_eq H. intros. apply (n_Sn x H0). diff --git a/test-suite/success/TestRefine.v b/test-suite/success/TestRefine.v index dd84402dfa..5f44c7525b 100644 --- a/test-suite/success/TestRefine.v +++ b/test-suite/success/TestRefine.v @@ -42,7 +42,7 @@ Abort. (************************************************************************) -Lemma T : nat. +Lemma T : nat. refine (S _). @@ -95,7 +95,7 @@ Abort. (************************************************************************) -Parameter f : nat * nat -> nat -> nat. +Parameter f : nat * nat -> nat -> nat. Lemma essai : nat. @@ -175,10 +175,10 @@ Restart. | S p => _ end). -exists 1. trivial. +exists 1. trivial. elim (f0 p). refine - (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _). + (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _). rewrite h. auto. Qed. diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index f95352b650..8014f73fcc 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -135,7 +135,7 @@ Qed. Definition apply (f:nat->Prop) := forall x, f x. Goal apply (fun n => n=0) -> 1=0. intro H. -auto. +auto. Qed. (* The following fails if the coercion Zpos is not introduced around p @@ -157,10 +157,10 @@ Qed. Definition succ x := S x. Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop), - (forall x y, P x -> Q x y) -> + (forall x y, P x -> Q x y) -> (forall x, P (S x)) -> forall y: I (S 0), Q (succ 0) y. intros. -apply H with (y:=y). +apply H with (y:=y). (* [x] had two possible instances: [S 0], coming from unifying the type of [y] with [I ?n] and [succ 0] coming from the unification with the goal; only the first one allows to make the next apply (which @@ -171,14 +171,14 @@ Qed. (* A similar example with a arbitrary long conversion between the two possible instances *) -Fixpoint compute_succ x := +Fixpoint compute_succ x := match x with O => S 0 | S n => S (compute_succ n) end. Goal forall (I : nat -> Set) (P : nat -> Prop) (Q : forall n:nat, I n -> Prop), - (forall x y, P x -> Q x y) -> + (forall x y, P x -> Q x y) -> (forall x, P (S x)) -> forall y: I (S 100), Q (compute_succ 100) y. intros. -apply H with (y:=y). +apply H with (y:=y). apply H0. Qed. @@ -187,10 +187,10 @@ Qed. subgoal which precisely fails) *) Definition ID (A:Type) := A. -Goal forall f:Type -> Type, - forall (P : forall A:Type, A -> Prop), - (forall (B:Type) x, P (f B) x -> P (f B) x) -> - (forall (A:Type) x, P (f (f A)) x) -> +Goal forall f:Type -> Type, + forall (P : forall A:Type, A -> Prop), + (forall (B:Type) x, P (f B) x -> P (f B) x) -> + (forall (A:Type) x, P (f (f A)) x) -> forall (A:Type) (x:f (f A)), P (f (ID (f A))) x. intros. apply H. @@ -250,7 +250,7 @@ Lemma eta : forall f : (forall P, P 1), (forall P, f P = f P) -> forall Q, f (fun x => Q x) = f (fun x => Q x). intros. -apply H. +apply H. Qed. (* Test propagation of evars from subgoal to brother subgoals *) @@ -258,7 +258,7 @@ Qed. (* This works because unfold calls clos_norm_flags which calls nf_evar *) Lemma eapply_evar_unfold : let x:=O in O=x -> 0=O. -intros x H; eapply trans_equal; +intros x H; eapply trans_equal; [apply H | unfold x;match goal with |- ?x = ?x => reflexivity end]. Qed. diff --git a/test-suite/success/cc.v b/test-suite/success/cc.v index 94d827fd5c..b565183b9c 100644 --- a/test-suite/success/cc.v +++ b/test-suite/success/cc.v @@ -22,12 +22,12 @@ intros. congruence. Qed. -(* Examples that fail due to dependencies *) +(* Examples that fail due to dependencies *) (* yields transitivity problem *) Theorem dep : - forall (A : Set) (P : A -> Set) (f g : forall x : A, P x) + forall (A : Set) (P : A -> Set) (f g : forall x : A, P x) (x y : A) (e : x = y) (e0 : f y = g y), f x = g x. intros; dependent rewrite e; exact e0. Qed. @@ -42,12 +42,12 @@ intros; rewrite e; reflexivity. Qed. -(* example that Congruence. can solve - (dependent function applied to the same argument)*) +(* example that Congruence. can solve + (dependent function applied to the same argument)*) Theorem dep3 : forall (A : Set) (P : A -> Set) (f g : forall x : A, P x), - f = g -> forall x : A, f x = g x. intros. + f = g -> forall x : A, f x = g x. intros. congruence. Qed. @@ -61,7 +61,7 @@ Qed. Theorem inj2 : forall (A : Set) (a c d : A) (f : A -> A * A), - f = pair (B:=A) a -> Some (f c) = Some (f d) -> c = d. + f = pair (B:=A) a -> Some (f c) = Some (f d) -> c = d. intros. congruence. Qed. @@ -80,7 +80,7 @@ Qed. (* example with implications *) -Theorem arrow : forall (A B: Prop) (C D:Set) , A=B -> C=D -> +Theorem arrow : forall (A B: Prop) (C D:Set) , A=B -> C=D -> (A -> C) = (B -> D). congruence. Qed. @@ -101,7 +101,6 @@ Proof. congruence. auto. Qed. - - - \ No newline at end of file + + diff --git a/test-suite/success/clear.v b/test-suite/success/clear.v index 8169361c4b..976bec7371 100644 --- a/test-suite/success/clear.v +++ b/test-suite/success/clear.v @@ -1,7 +1,7 @@ Goal forall x:nat, (forall x, x=0 -> True)->True. intros; eapply H. instantiate (1:=(fun y => _) (S x)). - simpl. + simpl. clear x. trivial. Qed. diff --git a/test-suite/success/coercions.v b/test-suite/success/coercions.v index 525348dec9..3d1c91bbe6 100644 --- a/test-suite/success/coercions.v +++ b/test-suite/success/coercions.v @@ -24,7 +24,7 @@ Coercion C : nat >-> Funclass. (* Remark: in the following example, it cannot be decided whether C is from nat to Funclass or from A to nat. An explicit Coercion command is - expected + expected Parameter A : nat -> Prop. Parameter C:> forall n:nat, A n -> nat. diff --git a/test-suite/success/conv_pbs.v b/test-suite/success/conv_pbs.v index 062c3ee5c3..f6ebacaea5 100644 --- a/test-suite/success/conv_pbs.v +++ b/test-suite/success/conv_pbs.v @@ -30,7 +30,7 @@ Fixpoint remove_assoc (A:Set)(x:variable)(rho: substitution A){struct rho} : substitution A := match rho with | nil => rho - | (y,t) :: rho => if var_eq_dec x y then remove_assoc A x rho + | (y,t) :: rho => if var_eq_dec x y then remove_assoc A x rho else (y,t) :: remove_assoc A x rho end. @@ -38,7 +38,7 @@ Fixpoint assoc (A:Set)(x:variable)(rho:substitution A){struct rho} : option A := match rho with | nil => None - | (y,t) :: rho => if var_eq_dec x y then Some t + | (y,t) :: rho => if var_eq_dec x y then Some t else assoc A x rho end. @@ -126,34 +126,34 @@ Inductive in_context (A:formula) : list formula -> Prop := | OmWeak : forall Gamma B, in_context A Gamma -> in_context A (cons B Gamma). Inductive prove : list formula -> formula -> Type := - | ProofImplyR : forall A B Gamma, prove (cons A Gamma) B + | ProofImplyR : forall A B Gamma, prove (cons A Gamma) B -> prove Gamma (A --> B) - | ProofForallR : forall x A Gamma, (forall y, fresh y (A::Gamma) + | ProofForallR : forall x A Gamma, (forall y, fresh y (A::Gamma) -> prove Gamma (subst A x (Var y))) -> prove Gamma (Forall x A) - | ProofCont : forall A Gamma Gamma' C, context_prefix (A::Gamma) Gamma' + | ProofCont : forall A Gamma Gamma' C, context_prefix (A::Gamma) Gamma' -> (prove_stoup Gamma' A C) -> (Gamma' |- C) where "Gamma |- A" := (prove Gamma A) with prove_stoup : list formula -> formula -> formula -> Type := | ProofAxiom Gamma C: Gamma ; C |- C - | ProofImplyL Gamma C : forall A B, (Gamma |- A) + | ProofImplyL Gamma C : forall A B, (Gamma |- A) -> (prove_stoup Gamma B C) -> (prove_stoup Gamma (A --> B) C) - | ProofForallL Gamma C : forall x t A, (prove_stoup Gamma (subst A x t) C) + | ProofForallL Gamma C : forall x t A, (prove_stoup Gamma (subst A x t) C) -> (prove_stoup Gamma (Forall x A) C) where " Gamma ; B |- A " := (prove_stoup Gamma B A). -Axiom context_prefix_trans : +Axiom context_prefix_trans : forall Gamma Gamma' Gamma'', - context_prefix Gamma Gamma' + context_prefix Gamma Gamma' -> context_prefix Gamma' Gamma'' -> context_prefix Gamma Gamma''. -Axiom Weakening : +Axiom Weakening : forall Gamma Gamma' A, context_prefix Gamma Gamma' -> Gamma |- A -> Gamma' |- A. - + Axiom universal_weakening : forall Gamma Gamma', context_prefix Gamma Gamma' -> forall P, Gamma |- Atom P -> Gamma' |- Atom P. @@ -170,20 +170,20 @@ Canonical Structure Universal := Build_Kripke universal_weakening. Axiom subst_commute : - forall A rho x t, + forall A rho x t, subst_formula ((x,t)::rho) A = subst (subst_formula rho A) x t. Axiom subst_formula_atom : - forall rho p t, + forall rho p t, Atom (p, sem _ rho t) = subst_formula rho (Atom (p,t)). Fixpoint universal_completeness (Gamma:context)(A:formula){struct A} - : forall rho:substitution term, + : forall rho:substitution term, force _ rho Gamma A -> Gamma |- subst_formula rho A := - match A - return forall rho, force _ rho Gamma A - -> Gamma |- subst_formula rho A + match A + return forall rho, force _ rho Gamma A + -> Gamma |- subst_formula rho A with | Atom (p,t) => fun rho H => eq_rect _ (fun A => Gamma |- A) H _ (subst_formula_atom rho p t) | A --> B => fun rho HImplyAB => @@ -192,21 +192,21 @@ Fixpoint universal_completeness (Gamma:context)(A:formula){struct A} (HImplyAB (A'::Gamma)(CtxPrefixTrans A' (CtxPrefixRefl Gamma)) (universal_completeness_stoup A rho (fun C Gamma' Hle p => ProofCont Hle p)))) - | Forall x A => fun rho HForallA - => ProofForallR x (fun y Hfresh - => eq_rect _ _ (universal_completeness Gamma A _ + | Forall x A => fun rho HForallA + => ProofForallR x (fun y Hfresh + => eq_rect _ _ (universal_completeness Gamma A _ (HForallA Gamma (CtxPrefixRefl Gamma)(Var y))) _ (subst_commute _ _ _ _ )) end with universal_completeness_stoup (Gamma:context)(A:formula){struct A} : forall rho, (forall C Gamma', context_prefix Gamma Gamma' -> Gamma' ; subst_formula rho A |- C -> Gamma' |- C) -> force _ rho Gamma A - := - match A return forall rho, - (forall C Gamma', context_prefix Gamma Gamma' + := + match A return forall rho, + (forall C Gamma', context_prefix Gamma Gamma' -> Gamma' ; subst_formula rho A |- C -> Gamma' |- C) - -> force _ rho Gamma A + -> force _ rho Gamma A with | Atom (p,t) as C => fun rho H => H _ Gamma (CtxPrefixRefl Gamma)(ProofAxiom _ _) diff --git a/test-suite/success/decl_mode.v b/test-suite/success/decl_mode.v index fede31a8ad..bc1757fd53 100644 --- a/test-suite/success/decl_mode.v +++ b/test-suite/success/decl_mode.v @@ -8,10 +8,10 @@ proof. assume n:nat. per induction on n. suppose it is 0. - suffices (0=0) to show thesis. + suffices (0=0) to show thesis. thus thesis. suppose it is (S m) and Hrec:thesis for m. - have (div2 (double (S m))= div2 (S (S (double m)))). + have (div2 (double (S m))= div2 (S (S (double m)))). ~= (S (div2 (double m))). thus ~= (S m) by Hrec. end induction. @@ -56,12 +56,12 @@ proof. end proof. Qed. -Lemma main_thm_aux: forall n,even n -> +Lemma main_thm_aux: forall n,even n -> double (double (div2 n *div2 n))=n*n. proof. given n such that H:(even n). - *** have (double (double (div2 n * div2 n)) - = double (div2 n) * double (div2 n)) + *** have (double (double (div2 n * div2 n)) + = double (div2 n) * double (div2 n)) by double_mult_l,double_mult_r. thus ~= (n*n) by H,even_double. end proof. @@ -75,14 +75,14 @@ proof. per induction on m. suppose it is 0. thus thesis. - suppose it is (S mm) and thesis for mm. + suppose it is (S mm) and thesis for mm. then H:(even (S (S (mm+mm)))). have (S (S (mm + mm)) = S mm + S mm) using omega. hence (even (S mm +S mm)) by H. end induction. end proof. Qed. - + Theorem main_theorem: forall n p, n*n=double (p*p) -> p=0. proof. assume n0:nat. @@ -95,7 +95,7 @@ proof. suppose it is (S p'). assume (n * n = double (S p' * S p')). =~ 0 by H1,mult_n_O. - ~= (S ( p' + p' * S p' + S p'* S p')) + ~= (S ( p' + p' * S p' + S p'* S p')) by plus_n_Sm. hence thesis . suppose it is 0. @@ -106,19 +106,19 @@ proof. have (even (double (p*p))) by even_double_n . then (even (n*n)) by H0. then H2:(even n) by even_is_even_times_even. - then (double (double (div2 n *div2 n))=n*n) + then (double (double (div2 n *div2 n))=n*n) by main_thm_aux. ~= (double (p*p)) by H0. - then H':(double (div2 n *div2 n)= p*p) by double_inv. + then H':(double (div2 n *div2 n)= p*p) by double_inv. have (even (double (div2 n *div2 n))) by even_double_n. then (even (p*p)) by even_double_n,H'. then H3:(even p) by even_is_even_times_even. - have (double(double (div2 n * div2 n)) = n*n) + have (double(double (div2 n * div2 n)) = n*n) by H2,main_thm_aux. ~= (double (p*p)) by H0. - ~= (double(double (double (div2 p * div2 p)))) + ~= (double(double (double (div2 p * div2 p)))) by H3,main_thm_aux. - then H'':(div2 n * div2 n = double (div2 p * div2 p)) + then H'':(div2 n * div2 n = double (div2 p * div2 p)) by double_inv. then (div2 n < n) by lt_div2,neq_O_lt,H1. then H4:(div2 p=0) by (H (div2 n)),H''. @@ -137,8 +137,8 @@ Coercion IZR: Z >->R.*) Open Scope R_scope. -Lemma square_abs_square: - forall p,(INR (Zabs_nat p) * INR (Zabs_nat p)) = (IZR p * IZR p). +Lemma square_abs_square: + forall p,(INR (Zabs_nat p) * INR (Zabs_nat p)) = (IZR p * IZR p). proof. assume p:Z. per cases on p. @@ -147,7 +147,7 @@ proof. suppose it is (Zpos z). thus thesis. suppose it is (Zneg z). - have ((INR (Zabs_nat (Zneg z)) * INR (Zabs_nat (Zneg z))) = + have ((INR (Zabs_nat (Zneg z)) * INR (Zabs_nat (Zneg z))) = (IZR (Zpos z) * IZR (Zpos z))). ~= ((- IZR (Zpos z)) * (- IZR (Zpos z))). thus ~= (IZR (Zneg z) * IZR (Zneg z)). @@ -160,19 +160,19 @@ Definition irrational (x:R):Prop := Theorem irrationnal_sqrt_2: irrational (sqrt (INR 2%nat)). proof. - let p:Z,q:nat be such that H:(q<>0%nat) + let p:Z,q:nat be such that H:(q<>0%nat) and H0:(sqrt (INR 2%nat)=(IZR p/INR q)). have H_in_R:(INR q<>0:>R) by H. have triv:((IZR p/INR q* INR q) =IZR p :>R) by * using field. have sqrt2:((sqrt (INR 2%nat) * sqrt (INR 2%nat))= INR 2%nat:>R) by sqrt_def. - have (INR (Zabs_nat p * Zabs_nat p) - = (INR (Zabs_nat p) * INR (Zabs_nat p))) + have (INR (Zabs_nat p * Zabs_nat p) + = (INR (Zabs_nat p) * INR (Zabs_nat p))) by mult_INR. ~= (IZR p* IZR p) by square_abs_square. ~= ((IZR p/INR q*INR q)*(IZR p/INR q*INR q)) by triv. (* we have to factor because field is too weak *) ~= ((IZR p/INR q)*(IZR p/INR q)*(INR q*INR q)) using ring. ~= (sqrt (INR 2%nat) * sqrt (INR 2%nat)*(INR q*INR q)) by H0. - ~= (INR (2%nat * (q*q))) by sqrt2,mult_INR. + ~= (INR (2%nat * (q*q))) by sqrt2,mult_INR. then (Zabs_nat p * Zabs_nat p = 2* (q * q))%nat. ~= ((q*q)+(q*q))%nat. ~= (Div2.double (q*q)). diff --git a/test-suite/success/dependentind.v b/test-suite/success/dependentind.v index 6de7c21977..54bfaa35cc 100644 --- a/test-suite/success/dependentind.v +++ b/test-suite/success/dependentind.v @@ -48,7 +48,7 @@ Fixpoint conc (Δ Γ : ctx) : ctx := Notation " Γ ; Δ " := (conc Δ Γ) (at level 25, left associativity) : context_scope. -Reserved Notation " Γ ⊢ Ï„ " (at level 30, no associativity). +Reserved Notation " Γ ⊢ Ï„ " (at level 30, no associativity). Inductive term : ctx -> type -> Type := | ax : `(Γ, Ï„ ⊢ Ï„) @@ -64,7 +64,7 @@ Open Local Scope context_scope. Ltac eqns := subst ; reverse ; simplify_dep_elim ; simplify_IH_hyps. -Lemma weakening : forall Γ Δ Ï„, Γ ; Δ ⊢ Ï„ -> +Lemma weakening : forall Γ Δ Ï„, Γ ; Δ ⊢ Ï„ -> forall Ï„', Γ , Ï„' ; Δ ⊢ Ï„. Proof with simpl in * ; eqns ; eauto with lambda. intros Γ Δ Ï„ H. @@ -97,7 +97,7 @@ Proof with simpl in * ; eqns ; eauto. apply weak... - apply abs... + apply abs... specialize (IHterm (Δ, Ï„0))... eapply app... diff --git a/test-suite/success/destruct.v b/test-suite/success/destruct.v index 59d583feec..e5f1c61873 100644 --- a/test-suite/success/destruct.v +++ b/test-suite/success/destruct.v @@ -5,7 +5,7 @@ Axiom X : A -> B -> C /\ D. Lemma foo : A -> B -> C. Proof. -intros. +intros. destruct X. (* Should find axiom X and should handle arguments of X *) assumption. assumption. diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v index 26339d5139..c7a2a6c9da 100644 --- a/test-suite/success/eauto.v +++ b/test-suite/success/eauto.v @@ -56,5 +56,5 @@ Lemma simpl_plus_l_rr1 : (forall m p : Nat, plus' n m = plus' n p -> m = p) -> forall m p : Nat, S' (plus' n m) = S' (plus' n p) -> m = p. intros. - eauto. (* does EApply H *) + eauto. (* does EApply H *) Qed. diff --git a/test-suite/success/evars.v b/test-suite/success/evars.v index 6764cfa357..3d3b3b9ef3 100644 --- a/test-suite/success/evars.v +++ b/test-suite/success/evars.v @@ -10,7 +10,7 @@ Definition c A (Q : (nat * A -> Prop) -> Prop) P := (* What does this test ? *) Require Import List. -Definition list_forall_bool (A : Set) (p : A -> bool) +Definition list_forall_bool (A : Set) (p : A -> bool) (l : list A) : bool := fold_right (fun a r => if p a then r else false) true l. @@ -109,21 +109,21 @@ Parameter map_avl: forall (elt elt' : Set) (f : elt -> elt') (m : t elt), avl m -> avl (map f m). Parameter map_bst: forall (elt elt' : Set) (f : elt -> elt') (m : t elt), bst m -> bst (map f m). -Record bbst (elt:Set) : Set := +Record bbst (elt:Set) : Set := Bbst {this :> t elt; is_bst : bst this; is_avl: avl this}. Definition t' := bbst. Section B. Variables elt elt': Set. -Definition map' f (m:t' elt) : t' elt' := +Definition map' f (m:t' elt) : t' elt' := Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). End B. Unset Implicit Arguments. -(* An example from Lexicographic_Exponentiation that tests the +(* An example from Lexicographic_Exponentiation that tests the contraction of reducible fixpoints in type inference *) Require Import List. -Check (fun (A:Set) (a b x:A) (l:list A) +Check (fun (A:Set) (a b x:A) (l:list A) (H : l ++ cons x nil = cons b (cons a nil)) => app_inj_tail l (cons b nil) _ _ H). @@ -133,14 +133,14 @@ Parameter h:(nat->nat)->(nat->nat). Fixpoint G p cont {struct p} := h (fun n => match p with O => cont | S p => G p cont end n). -(* An example from Bordeaux/Cantor that applies evar restriction +(* An example from Bordeaux/Cantor that applies evar restriction below a binder *) Require Import Relations. Parameter lex : forall (A B : Set), (forall (a1 a2:A), {a1=a2}+{a1<>a2}) -> relation A -> relation B -> A * B -> A * B -> Prop. -Check - forall (A B : Set) eq_A_dec o1 o2, +Check + forall (A B : Set) eq_A_dec o1 o2, antisymmetric A o1 -> transitive A o1 -> transitive B o2 -> transitive _ (lex _ _ eq_A_dec o1 o2). @@ -200,7 +200,7 @@ Abort. (* An example from y-not that was failing in 8.2rc1 *) -Fixpoint filter (A:nat->Set) (l:list (sigT A)) : list (sigT A) := +Fixpoint filter (A:nat->Set) (l:list (sigT A)) : list (sigT A) := match l with | nil => nil | (existT k v)::l' => (existT _ k v):: (filter A l') diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v index 74d87ffa7e..d3bdb1b6db 100644 --- a/test-suite/success/extraction.v +++ b/test-suite/success/extraction.v @@ -9,10 +9,10 @@ Require Import Arith. Require Import List. -(**** A few tests for the extraction mechanism ****) +(**** A few tests for the extraction mechanism ****) -(* Ideally, we should monitor the extracted output - for changes, but this is painful. For the moment, +(* Ideally, we should monitor the extracted output + for changes, but this is painful. For the moment, we just check for failures of this script. *) (*** STANDARD EXAMPLES *) @@ -23,7 +23,7 @@ Definition idnat (x:nat) := x. Extraction idnat. (* let idnat x = x *) -Definition id (X:Type) (x:X) := x. +Definition id (X:Type) (x:X) := x. Extraction id. (* let id x = x *) Definition id' := id Set nat. Extraction id'. (* type id' = nat *) @@ -47,7 +47,7 @@ Extraction test5. Definition cf (x:nat) (_:x <= 0) := S x. Extraction NoInline cf. Definition test6 := cf 0 (le_n 0). -Extraction test6. +Extraction test6. (* let test6 = cf O *) Definition test7 := (fun (X:Set) (x:X) => x) nat. @@ -60,9 +60,9 @@ Definition d2 := d Set. Extraction d2. (* type d2 = __ d *) Definition d3 (x:d Set) := 0. Extraction d3. (* let d3 _ = O *) -Definition d4 := d nat. +Definition d4 := d nat. Extraction d4. (* type d4 = nat d *) -Definition d5 := (fun x:d Type => 0) Type. +Definition d5 := (fun x:d Type => 0) Type. Extraction d5. (* let d5 = O *) Definition d6 (x:d Type) := x. Extraction d6. (* type 'x d6 = 'x *) @@ -80,7 +80,7 @@ Definition test11 := let n := 0 in let p := S n in S p. Extraction test11. (* let test11 = S (S O) *) Definition test12 := forall x:forall X:Type, X -> X, x Type Type. -Extraction test12. +Extraction test12. (* type test12 = (__ -> __ -> __) -> __ *) @@ -115,14 +115,14 @@ Extraction test20. (** Simple inductive type and recursor. *) Extraction nat. -(* -type nat = - | O - | S of nat +(* +type nat = + | O + | S of nat *) Extraction sumbool_rect. -(* +(* let sumbool_rect f f0 = function | Left -> f __ | Right -> f0 __ @@ -134,7 +134,7 @@ Inductive c (x:nat) : nat -> Set := | refl : c x x | trans : forall y z:nat, c x y -> y <= z -> c x z. Extraction c. -(* +(* type c = | Refl | Trans of nat * nat * c @@ -150,7 +150,7 @@ Inductive Finite (U:Type) : Ensemble U -> Type := forall A:Ensemble U, Finite U A -> forall x:U, ~ A x -> Finite U (Add U A x). Extraction Finite. -(* +(* type 'u finite = | Empty_is_finite | Union_is_finite of 'u finite * 'u @@ -166,7 +166,7 @@ with forest : Set := | Cons : tree -> forest -> forest. Extraction tree. -(* +(* type tree = | Node of nat * forest and forest = @@ -178,7 +178,7 @@ Fixpoint tree_size (t:tree) : nat := match t with | Node a f => S (forest_size f) end - + with forest_size (f:forest) : nat := match f with | Leaf b => 1 @@ -186,7 +186,7 @@ Fixpoint tree_size (t:tree) : nat := end. Extraction tree_size. -(* +(* let rec tree_size = function | Node (a, f) -> S (forest_size f) and forest_size = function @@ -203,13 +203,13 @@ Definition test14 := tata 0. Extraction test14. (* let test14 x x0 x1 = Tata (O, x, x0, x1) *) Definition test15 := tata 0 1. -Extraction test15. +Extraction test15. (* let test15 x x0 = Tata (O, (S O), x, x0) *) Inductive eta : Type := eta_c : nat -> Prop -> nat -> Prop -> eta. Extraction eta_c. -(* +(* type eta = | Eta_c of nat * nat *) @@ -220,15 +220,15 @@ Definition test17 := eta_c 0 True. Extraction test17. (* let test17 x = Eta_c (O, x) *) Definition test18 := eta_c 0 True 0. -Extraction test18. +Extraction test18. (* let test18 _ = Eta_c (O, O) *) (** Example of singleton inductive type *) Inductive bidon (A:Prop) (B:Type) : Type := - tb : forall (x:A) (y:B), bidon A B. -Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) + tb : forall (x:A) (y:B), bidon A B. +Definition fbidon (A B:Type) (f:A -> B -> bidon True nat) (x:A) (y:B) := f x y. Extraction bidon. (* type 'b bidon = 'b *) @@ -252,11 +252,11 @@ Extraction fbidon2. Inductive test_0 : Prop := ctest0 : test_0 with test_1 : Set := - ctest1 : test_0 -> test_1. + ctest1 : test_0 -> test_1. Extraction test_0. (* test0 : logical inductive *) -Extraction test_1. -(* +Extraction test_1. +(* type test1 = | Ctest1 *) @@ -277,19 +277,19 @@ Inductive tp1 : Type := with tp2 : Type := T' : tp1 -> tp2. Extraction tp1. -(* +(* type tp1 = | T of __ * tp2 and tp2 = | T' of tp1 -*) +*) Inductive tp1bis : Type := Tbis : tp2bis -> tp1bis with tp2bis : Type := T'bis : forall (C:Set) (c:C), tp1bis -> tp2bis. Extraction tp1bis. -(* +(* type tp1bis = | Tbis of tp2bis and tp2bis = @@ -344,8 +344,8 @@ intros. exact n. Qed. Extraction oups. -(* -let oups h0 = +(* +let oups h0 = match Obj.magic h0 with | Nil -> h0 | Cons0 (n, l) -> n @@ -357,7 +357,7 @@ let oups h0 = Definition horibilis (b:bool) := if b as b return (if b then Type else nat) then Set else 0. Extraction horibilis. -(* +(* let horibilis = function | True -> Obj.magic __ | False -> Obj.magic O @@ -370,8 +370,8 @@ Definition natbool (b:bool) := if b then nat else bool. Extraction natbool. (* type natbool = __ *) Definition zerotrue (b:bool) := if b as x return natbool x then 0 else true. -Extraction zerotrue. -(* +Extraction zerotrue. +(* let zerotrue = function | True -> Obj.magic O | False -> Obj.magic True @@ -383,7 +383,7 @@ Definition natTrue (b:bool) := if b return Type then nat else True. Definition zeroTrue (b:bool) := if b as x return natProp x then 0 else True. Extraction zeroTrue. -(* +(* let zeroTrue = function | True -> Obj.magic O | False -> Obj.magic __ @@ -393,7 +393,7 @@ Definition natTrue2 (b:bool) := if b return Type then nat else True. Definition zeroprop (b:bool) := if b as x return natTrue x then 0 else I. Extraction zeroprop. -(* +(* let zeroprop = function | True -> Obj.magic O | False -> Obj.magic __ @@ -410,8 +410,8 @@ Extraction test21. Definition test22 := (fun f:forall X:Type, X -> X => (f nat 0, f bool true)) (fun (X:Type) (x:X) => x). -Extraction test22. -(* let test22 = +Extraction test22. +(* let test22 = let f = fun x -> x in Pair ((f O), (f True)) *) (* still ok via optim beta -> let *) @@ -461,8 +461,8 @@ Extraction f_normal. (* inductive with magic needed *) Inductive Boite : Set := - boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. -Extraction Boite. + boite : forall b:bool, (if b then nat else (nat * nat)%type) -> Boite. +Extraction Boite. (* type boite = | Boite of bool * __ @@ -482,8 +482,8 @@ Definition test_boite (B:Boite) := | boite true n => n | boite false n => fst n + snd n end. -Extraction test_boite. -(* +Extraction test_boite. +(* let test_boite = function | Boite (b0, n) -> (match b0 with @@ -494,23 +494,23 @@ let test_boite = function (* singleton inductive with magic needed *) Inductive Box : Type := - box : forall A:Set, A -> Box. + box : forall A:Set, A -> Box. Extraction Box. (* type box = __ *) -Definition box1 := box nat 0. +Definition box1 := box nat 0. Extraction box1. (* let box1 = Obj.magic O *) (* applied constant, magic needed *) Definition idzarb (b:bool) (x:if b then nat else bool) := x. Definition zarb := idzarb true 0. -Extraction NoInline idzarb. -Extraction zarb. +Extraction NoInline idzarb. +Extraction zarb. (* let zarb = Obj.magic idzarb True (Obj.magic O) *) (** function of variable arity. *) -(** Fun n = nat -> nat -> ... -> nat *) +(** Fun n = nat -> nat -> ... -> nat *) Fixpoint Fun (n:nat) : Set := match n with @@ -532,20 +532,20 @@ Fixpoint proj (k n:nat) {struct n} : Fun n := | O => fun x => Const x n | S k => fun x => proj k n end - end. + end. Definition test_proj := proj 2 4 0 1 2 3. -Eval compute in test_proj. +Eval compute in test_proj. -Recursive Extraction test_proj. +Recursive Extraction test_proj. -(*** TO SUM UP: ***) +(*** TO SUM UP: ***) (* Was previously producing a "test_extraction.ml" *) -Recursive Extraction +Recursive Extraction idnat id id' test2 test3 test4 test5 test6 test7 d d2 d3 d4 d5 d6 test8 id id' test9 test10 test11 test12 test13 test19 test20 nat sumbool_rect c Finite tree @@ -581,7 +581,7 @@ Recursive Extraction zerotrue zeroTrue zeroprop test21 test22 test23 f f_prop f_arity f_normal Boite boite1 boite2 test_boite Box box1 zarb test_proj. - + (*** Finally, a test more focused on everyday's life situations ***) diff --git a/test-suite/success/fix.v b/test-suite/success/fix.v index 78b01f3e18..be4e06845b 100644 --- a/test-suite/success/fix.v +++ b/test-suite/success/fix.v @@ -47,10 +47,10 @@ Fixpoint maxVar (e : rExpr) : rNat := Require Import Streams. -Definition decomp (s:Stream nat) : Stream nat := +Definition decomp (s:Stream nat) : Stream nat := match s with Cons _ s => s end. -CoFixpoint bx0 : Stream nat := Cons 0 bx1 +CoFixpoint bx0 : Stream nat := Cons 0 bx1 with bx1 : Stream nat := Cons 1 bx0. Lemma bx0bx : decomp bx0 = bx1. diff --git a/test-suite/success/hyps_inclusion.v b/test-suite/success/hyps_inclusion.v index 21bfc0758a..af81e53d60 100644 --- a/test-suite/success/hyps_inclusion.v +++ b/test-suite/success/hyps_inclusion.v @@ -8,7 +8,7 @@ tactics were using Typing.type_of and not Typeops.typing; the former was not checking hyps inclusion so that the discrepancy in the types of section variables seen as goal variables was not a problem (at the - end, when the proof is completed, the section variable recovers its + end, when the proof is completed, the section variable recovers its original type and all is correct for Typeops) *) Section A. @@ -16,9 +16,9 @@ Variable H:not True. Lemma f:nat->nat. destruct H. exact I. Defined. Goal f 0=f 1. red in H. -(* next tactic was failing wrt bug #1325 because type-checking the goal +(* next tactic was failing wrt bug #1325 because type-checking the goal detected a syntactically different type for the section variable H *) -case 0. +case 0. Reset A. (* Variant with polymorphic inductive types for bug #1325 *) diff --git a/test-suite/success/implicit.v b/test-suite/success/implicit.v index 9034d6a6f0..aabb057a40 100644 --- a/test-suite/success/implicit.v +++ b/test-suite/success/implicit.v @@ -12,7 +12,7 @@ Infix "#" := op (at level 70). Check (forall x : A, x # x). (* Example submitted by Christine *) -Record stack : Type := +Record stack : Type := {type : Set; elt : type; empty : type -> bool; proof : empty elt = true}. Check @@ -42,7 +42,7 @@ Inductive P n : nat -> Prop := c : P n n. Require Import List. Fixpoint plus n m {struct n} := - match n with + match n with | 0 => m | S p => S (plus p m) end. diff --git a/test-suite/success/import_lib.v b/test-suite/success/import_lib.v index c3dc2fc620..fcedb2b1ad 100644 --- a/test-suite/success/import_lib.v +++ b/test-suite/success/import_lib.v @@ -1,8 +1,8 @@ Definition le_trans := 0. -Module Test_Read. - Module M. +Module Test_Read. + Module M. Require Le. (* Reading without importing *) Check Le.le_trans. @@ -12,7 +12,7 @@ Module Test_Read. Qed. End M. - Check Le.le_trans. + Check Le.le_trans. Lemma th0 : le_trans = 0. reflexivity. @@ -32,84 +32,84 @@ Definition le_decide := 1. (* from Arith/Compare *) Definition min := 0. (* from Arith/Min *) Module Test_Require. - + Module M. Require Import Compare. (* Imports Min as well *) - + Lemma th1 : le_decide = le_decide. reflexivity. Qed. - + Lemma th2 : min = min. reflexivity. Qed. - + End M. - + (* Checks that Compare and List are loaded *) Check Compare.le_decide. Check Min.min. - - + + (* Checks that Compare and List are _not_ imported *) Lemma th1 : le_decide = 1. reflexivity. Qed. - + Lemma th2 : min = 0. reflexivity. Qed. - + (* It should still be the case after Import M *) Import M. - + Lemma th3 : le_decide = 1. reflexivity. Qed. - + Lemma th4 : min = 0. reflexivity. Qed. -End Test_Require. +End Test_Require. (****************************************************************) Module Test_Import. Module M. Import Compare. (* Imports Min as well *) - + Lemma th1 : le_decide = le_decide. reflexivity. Qed. - + Lemma th2 : min = min. reflexivity. Qed. - + End M. - + (* Checks that Compare and List are loaded *) Check Compare.le_decide. Check Min.min. - - + + (* Checks that Compare and List are _not_ imported *) Lemma th1 : le_decide = 1. reflexivity. Qed. - + Lemma th2 : min = 0. reflexivity. Qed. - + (* It should still be the case after Import M *) Import M. - + Lemma th3 : le_decide = 1. reflexivity. Qed. - + Lemma th4 : min = 0. reflexivity. Qed. diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v index 1cf707583b..b78651c916 100644 --- a/test-suite/success/induct.v +++ b/test-suite/success/induct.v @@ -21,7 +21,7 @@ Inductive Y : Set := Inductive eq1 : forall A:Type, let B:=A in A -> Prop := refl1 : eq1 True I. -Check +Check fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) => let B := A in fun (a : A) (e : eq1 A a) => diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index 211ca28b07..09d21628b9 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -3,7 +3,7 @@ (* Submitted by Pierre Crégut *) (* Checks substitution of x *) Ltac f x := unfold x in |- *; idtac. - + Lemma lem1 : 0 + 0 = 0. f plus. reflexivity. @@ -25,7 +25,7 @@ U. Qed. (* Check that Match giving non-tactic arguments are evaluated at Let-time *) - + Ltac B := let y := (match goal with | z:_ |- _ => z end) in @@ -180,8 +180,8 @@ Abort. (* Check second-order pattern unification *) Ltac to_exist := - match goal with - |- forall x y, @?P x y => + match goal with + |- forall x y, @?P x y => let Q := eval lazy beta in (exists x, forall y, P x y) in assert (Q->Q) end. @@ -202,7 +202,7 @@ Abort. (* Utilisation de let rec sans arguments *) -Ltac is := +Ltac is := let rec i := match goal with |- ?A -> ?B => intro; i | _ => idtac end in i. diff --git a/test-suite/success/mutual_ind.v b/test-suite/success/mutual_ind.v index 463efed3f3..f63dfc385a 100644 --- a/test-suite/success/mutual_ind.v +++ b/test-suite/success/mutual_ind.v @@ -9,7 +9,7 @@ Require Export List. - Record signature : Type := + Record signature : Type := {sort : Set; sort_beq : sort -> sort -> bool; sort_beq_refl : forall f : sort, true = sort_beq f f; @@ -20,14 +20,14 @@ Require Export List. fsym_beq_refl : forall f : fsym, true = fsym_beq f f; fsym_beq_eq : forall f1 f2 : fsym, true = fsym_beq f1 f2 -> f1 = f2}. - + Variable F : signature. Definition vsym := (sort F * nat)%type. Definition vsym_sort := fst (A:=sort F) (B:=nat). Definition vsym_nat := snd (A:=sort F) (B:=nat). - + Inductive term : sort F -> Set := | term_var : forall v : vsym, term (vsym_sort v) diff --git a/test-suite/success/parsing.v b/test-suite/success/parsing.v index d1b679d551..3d06d1d0f9 100644 --- a/test-suite/success/parsing.v +++ b/test-suite/success/parsing.v @@ -2,7 +2,7 @@ Section A. Notation "*" := O (at level 8). Notation "**" := O (at level 99). Notation "***" := O (at level 9). -End A. +End A. Notation "*" := O (at level 8). Notation "**" := O (at level 99). Notation "***" := O (at level 9). diff --git a/test-suite/success/refine.v b/test-suite/success/refine.v index b654277c8c..4d743a6d79 100644 --- a/test-suite/success/refine.v +++ b/test-suite/success/refine.v @@ -7,7 +7,7 @@ exists y; auto. Save test1. Goal exists x : nat, x = 0. - refine (let y := 0 + 0 in ex_intro _ (y + y) _). + refine (let y := 0 + 0 in ex_intro _ (y + y) _). auto. Save test2. @@ -79,7 +79,7 @@ Abort. (* Used to failed with error not clean *) Definition div : - forall x:nat, (forall y:nat, forall n:nat, {q:nat | y = q*n}) -> + forall x:nat, (forall y:nat, forall n:nat, {q:nat | y = q*n}) -> forall n:nat, {q:nat | x = q*n}. refine (fun m div_rec n => @@ -94,7 +94,7 @@ Abort. Goal forall f : forall a (H:a=a), Prop, - (forall a (H:a = a :> nat), f a H -> True /\ True) -> + (forall a (H:a = a :> nat), f a H -> True /\ True) -> True. intros. refine (@proj1 _ _ (H 0 _ _)). @@ -105,13 +105,13 @@ Abort. Require Import Peano_dec. -Definition fact_F : +Definition fact_F : forall (n:nat), (forall m, m nat) -> nat. -refine +refine (fun n fact_rec => - if eq_nat_dec n 0 then + if eq_nat_dec n 0 then 1 else let fn := fact_rec (n-1) _ in diff --git a/test-suite/success/replace.v b/test-suite/success/replace.v index 94b75c7f0f..6acdd51616 100644 --- a/test-suite/success/replace.v +++ b/test-suite/success/replace.v @@ -5,7 +5,7 @@ Undo. intros x H H0. replace x with 0. Undo. -replace x with 0 in |- *. +replace x with 0 in |- *. Undo. replace x with 1 in *. Undo. diff --git a/test-suite/success/setoid_ring_module.v b/test-suite/success/setoid_ring_module.v index e947c6d9c4..2d9e85b54e 100644 --- a/test-suite/success/setoid_ring_module.v +++ b/test-suite/success/setoid_ring_module.v @@ -11,11 +11,11 @@ Parameters (Coef:Set)(c0 c1 : Coef) (ceq_refl : forall x, ceq x x). -Add Relation Coef ceq +Add Relation Coef ceq reflexivity proved by ceq_refl symmetry proved by ceq_sym transitivity proved by ceq_trans as ceq_relation. - + Add Morphism cadd with signature ceq ==> ceq ==> ceq as cadd_Morphism. Admitted. diff --git a/test-suite/success/setoid_test.v b/test-suite/success/setoid_test.v index be5999df58..033b3f485f 100644 --- a/test-suite/success/setoid_test.v +++ b/test-suite/success/setoid_test.v @@ -124,7 +124,7 @@ Goal forall (f : Prop -> Prop) (Q : (nat -> Prop) -> Prop) (H : forall (h : nat -> Prop), Q (fun x : nat => f (h x)) <-> True) - (h:nat -> Prop), + (h:nat -> Prop), Q (fun x : nat => f (Q (fun b : nat => f (h x)))) <-> True. intros f0 Q H. setoid_rewrite H. diff --git a/test-suite/success/setoid_test2.v b/test-suite/success/setoid_test2.v index b89787bb0a..6baf79701a 100644 --- a/test-suite/success/setoid_test2.v +++ b/test-suite/success/setoid_test2.v @@ -205,7 +205,7 @@ Theorem test6: rewrite H. assumption. Qed. - + Theorem test7: forall E1 E2 y y', (eqS1 E1 E2) -> (eqS2 y y') -> (f_test6 (g_test6 (h_test6 E2))) -> @@ -228,7 +228,7 @@ Add Morphism f_test8 : f_compat_test8. Admitted. Axiom eqS1_test8': S1_test8 -> S1_test8 -> Prop. Axiom SetoidS1_test8' : Setoid_Theory S1_test8 eqS1_test8'. Add Setoid S1_test8 eqS1_test8' SetoidS1_test8' as S1_test8setoid'. - + (*CSC: for test8 to be significant I want to choose the setoid (S1_test8, eqS1_test8'). However this does not happen and there is still no syntax for it ;-( *) diff --git a/test-suite/success/setoid_test_function_space.v b/test-suite/success/setoid_test_function_space.v index ead93d913a..381cda2cd6 100644 --- a/test-suite/success/setoid_test_function_space.v +++ b/test-suite/success/setoid_test_function_space.v @@ -9,11 +9,11 @@ Hint Unfold feq. Lemma feq_refl: forall f, f =f f. intuition. Qed. - + Lemma feq_sym: forall f g, f =f g-> g =f f. intuition. Qed. - + Lemma feq_trans: forall f g h, f =f g-> g =f h -> f =f h. unfold feq. intuition. rewrite H. @@ -22,7 +22,7 @@ Qed. End feq. Infix "=f":= feq (at level 80, right associativity). Hint Unfold feq. Hint Resolve feq_refl feq_sym feq_trans. - + Variable K:(nat -> nat)->Prop. Variable K_ext:forall a b, (K a)->(a =f b)->(K b). @@ -30,7 +30,7 @@ Add Parametric Relation (A B : Type) : (A -> B) (@feq A B) reflexivity proved by (@feq_refl A B) symmetry proved by (@feq_sym A B) transitivity proved by (@feq_trans A B) as funsetoid. - + Add Morphism K with signature (@feq nat nat) ==> iff as K_ext1. intuition. apply (K_ext H0 H). intuition. assert (y =f x);auto. apply (K_ext H0 H1). diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v index b4de4932ec..271e6ef769 100644 --- a/test-suite/success/simpl.v +++ b/test-suite/success/simpl.v @@ -2,12 +2,12 @@ (* (cf bug #1031) *) Inductive tree : Set := -| node : nat -> forest -> tree +| node : nat -> forest -> tree with forest : Set := -| leaf : forest -| cons : tree -> forest -> forest +| leaf : forest +| cons : tree -> forest -> forest . -Definition copy_of_compute_size_forest := +Definition copy_of_compute_size_forest := fix copy_of_compute_size_forest (f:forest) : nat := match f with | leaf => 1 diff --git a/test-suite/success/specialize.v b/test-suite/success/specialize.v index 4929ae4c0c..5783732174 100644 --- a/test-suite/success/specialize.v +++ b/test-suite/success/specialize.v @@ -2,7 +2,7 @@ Goal forall a b c : nat, a = b -> b = c -> forall d, a+d=c+d. intros. -(* "compatibility" mode: specializing a global name +(* "compatibility" mode: specializing a global name means a kind of generalize *) specialize trans_equal. intros _. diff --git a/test-suite/success/unification.v b/test-suite/success/unification.v index a7e129a380..52c27587a2 100644 --- a/test-suite/success/unification.v +++ b/test-suite/success/unification.v @@ -1,15 +1,15 @@ (* Test patterns unification *) -Lemma l1 : (forall P, (exists x:nat, P x) -> False) +Lemma l1 : (forall P, (exists x:nat, P x) -> False) -> forall P, (exists x:nat, P x /\ P x) -> False. Proof. intros; apply (H _ H0). Qed. Lemma l2 : forall A:Set, forall Q:A->Set, - (forall (P: forall x:A, Q x -> Prop), - (exists x:A, exists y:Q x, P x y) -> False) - -> forall (P: forall x:A, Q x -> Prop), + (forall (P: forall x:A, Q x -> Prop), + (exists x:A, exists y:Q x, P x y) -> False) + -> forall (P: forall x:A, Q x -> Prop), (exists x:A, exists y:Q x, P x y /\ P x y) -> False. Proof. intros; apply (H _ H0). @@ -43,7 +43,7 @@ Check (fun _h1 => (zenon_notall nat _ (fun _T_0 => Note that the example originally came from a non re-typable pretty-printed term (the checked term is actually re-printed the - same form it is checked). + same form it is checked). *) Set Implicit Arguments. @@ -73,10 +73,10 @@ Qed. (* Test unification modulo eta-expansion (if possible) *) -(* In this example, two instances for ?P (argument of hypothesis H) can be +(* In this example, two instances for ?P (argument of hypothesis H) can be inferred (one is by unifying the type [Q true] and [?P true] of the goal and type of [H]; the other is by unifying the argument of [f]); - we need to unify both instances up to allowed eta-expansions of the + we need to unify both instances up to allowed eta-expansions of the instances (eta is allowed if the meta was applied to arguments) This used to fail before revision 9389 in trunk @@ -92,7 +92,7 @@ Qed. (* Test instanciation of evars by unification *) -Goal (forall x, 0 * x = 0 -> True) -> True. +Goal (forall x, 0 * x = 0 -> True) -> True. intros; eapply H. rewrite <- plus_n_Sm. (* should refine ?x with S ?x' *) Abort. @@ -131,7 +131,7 @@ Qed. coq-club, June 1 2009; it did not work in 8.2, probably started to work after Sozeau improved support for the use of types in unification) *) -Goal (forall (A B : Set) (f : A -> B), (fun x => f x) = f) -> +Goal (forall (A B : Set) (f : A -> B), (fun x => f x) = f) -> forall (A B C : Set) (g : (A -> B) -> C) (f : A -> B), g (fun x => f x) = g f. Proof. intros. diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v index 3c2c088310..469cbeb74d 100644 --- a/test-suite/success/univers.v +++ b/test-suite/success/univers.v @@ -29,9 +29,9 @@ Inductive dep_eq : forall X : Type, X -> X -> Prop := forall (A : Type) (B : A -> Type), let T := forall x : A, B x in forall (f g : T) (x : A), dep_eq (B x) (f x) (g x) -> dep_eq T f g. - + Require Import Relations. - + Theorem dep_eq_trans : forall X : Type, transitive X (dep_eq X). Proof. unfold transitive in |- *. @@ -51,7 +51,7 @@ Abort. Especially, universe refreshing was not done for "set/pose" *) -Lemma ind_unsec : forall Q : nat -> Type, True. +Lemma ind_unsec : forall Q : nat -> Type, True. intro. set (C := forall m, Q m -> Q m). exact I. diff --git a/test-suite/typeclasses/clrewrite.v b/test-suite/typeclasses/clrewrite.v index 2978fda266..f21acd4cbf 100644 --- a/test-suite/typeclasses/clrewrite.v +++ b/test-suite/typeclasses/clrewrite.v @@ -15,7 +15,7 @@ Section Equiv. Qed. Tactic Notation "simpl" "*" := auto || relation_tac. - + Goal eqA x y -> eqA y x /\ True. intros H ; clrewrite H. split ; simpl*. @@ -27,13 +27,13 @@ Section Equiv. Qed. Goal eqA x y -> eqA y z -> eqA x y. - intros H. + intros H. clrewrite H. intro. refl. Qed. - + Goal eqA x y -> eqA z y -> eqA x y. - intros H. + intros H. clrewrite <- H at 2. clrewrite <- H at 1. intro. refl. @@ -54,7 +54,7 @@ Section Equiv. clrewrite <- H. refl. Qed. - + Goal eqA x y -> True /\ True /\ False /\ eqA x x -> True /\ True /\ False /\ eqA x y. Proof. intros. @@ -70,12 +70,12 @@ Section Trans. Variables x y z w : A. Tactic Notation "simpl" "*" := auto || relation_tac. - + (* Typeclasses eauto := debug. *) Goal R x y -> R y x -> R y y -> R x x. Proof with auto. - intros H H' H''. + intros H H' H''. clrewrite <- H' at 2. clrewrite H at 1... @@ -86,11 +86,11 @@ Section Trans. clrewrite H. refl. Qed. - + Goal R x y -> R z y -> R x y. - intros H. + intros H. clrewrite <- H at 2. - intro. + intro. clrewrite H at 1. Abort. diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 3f96d43410..208c257891 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -17,11 +17,11 @@ Implicit Types k l p q r : nat. Section Between. Variables P Q : nat -> Prop. - + Inductive between k : nat -> Prop := | bet_emp : between k k | bet_S : forall l, between k l -> P l -> between k (S l). - + Hint Constructors between: arith v62. Lemma bet_eq : forall k l, l = k -> between k l. @@ -185,5 +185,5 @@ Section Between. End Between. Hint Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le - in_int_S in_int_intro: arith v62. + in_int_S in_int_intro: arith v62. Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith v62. diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index 573f54e9f7..a684d5a10d 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -107,7 +107,7 @@ Qed. Theorem not_lt : forall n m, ~ n < m -> n >= m. Proof. - intros x y H; exact (not_gt y x H). + intros x y H; exact (not_gt y x H). Qed. diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 4c3b2ff849..999a645448 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -36,7 +36,7 @@ Proof. intros P H0 H1 Hn. cut (forall n, P n /\ P (S n)). intros H'n n. elim (H'n n). auto with arith. - + induction n. auto with arith. intros. elim IHn; auto with arith. Qed. @@ -150,7 +150,7 @@ Proof fun n => proj2 (proj2 (even_odd_double n)). Hint Resolve even_double double_even odd_double double_odd: arith. -(** Application: +(** Application: - if [n] is even then there is a [p] such that [n = 2p] - if [n] is odd then there is a [p] such that [n = 2p+1] diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index d2a4006a0a..eaa1bb2d61 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -17,7 +17,7 @@ Open Local Scope nat_scope. Implicit Types m n : nat. -(** * Definition of [even] and [odd], and basic facts *) +(** * Definition of [even] and [odd], and basic facts *) Inductive even : nat -> Prop := | even_O : even 0 @@ -52,9 +52,9 @@ Qed. (** * Facts about [even] & [odd] wrt. [plus] *) -Lemma even_plus_split : forall n m, +Lemma even_plus_split : forall n m, (even (n + m) -> even n /\ even m \/ odd n /\ odd m) -with odd_plus_split : forall n m, +with odd_plus_split : forall n m, odd (n + m) -> odd n /\ even m \/ even n /\ odd m. Proof. intros. clear even_plus_split. destruct n; simpl in *. @@ -95,7 +95,7 @@ Proof. intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. intro; destruct (not_even_and_odd n); auto. Qed. - + Lemma even_plus_even_inv_l : forall n m, even (n + m) -> even m -> even n. Proof. intros n m H; destruct (even_plus_split n m) as [[]|[]]; auto. @@ -120,13 +120,13 @@ Proof. intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. intro; destruct (not_even_and_odd m); auto. Qed. - + Lemma odd_plus_even_inv_r : forall n m, odd (n + m) -> odd n -> even m. Proof. intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. intro; destruct (not_even_and_odd n); auto. Qed. - + Lemma odd_plus_odd_inv_l : forall n m, odd (n + m) -> even m -> odd n. Proof. intros n m H; destruct (odd_plus_split n m) as [[]|[]]; auto. @@ -203,7 +203,7 @@ Proof. intros n m; case (even_mult_aux n m); auto. intros H H0; case H0; auto. Qed. - + Lemma even_mult_r : forall n m, even m -> even (n * m). Proof. intros n m; case (even_mult_aux n m); auto. @@ -219,7 +219,7 @@ Proof. intros H'3; elim H'3; auto. intros H; case (not_even_and_odd n); auto. Qed. - + Lemma even_mult_inv_l : forall n m, even (n * m) -> odd m -> even n. Proof. intros n m H' H'0. @@ -228,13 +228,13 @@ Proof. intros H'3; elim H'3; auto. intros H; case (not_even_and_odd m); auto. Qed. - + Lemma odd_mult : forall n m, odd n -> odd m -> odd (n * m). Proof. intros n m; case (even_mult_aux n m); intros H; case H; auto. Qed. Hint Resolve even_mult_l even_mult_r odd_mult: arith. - + Lemma odd_mult_inv_l : forall n m, odd (n * m) -> odd n. Proof. intros n m H'. diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index 5d6e231c52..1fb5b3e558 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -26,7 +26,7 @@ Theorem lt_irrefl : forall n, ~ n < n. Proof le_Sn_n. Hint Resolve lt_irrefl: arith v62. -(** * Relationship between [le] and [lt] *) +(** * Relationship between [le] and [lt] *) Theorem lt_le_S : forall n m, n < m -> S n <= m. Proof. diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index e43b804e56..dcc973a960 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -25,7 +25,7 @@ Fixpoint max n m {struct n} : nat := (** * Inductive characterization of [max] *) -Lemma max_case_strong : forall n m (P:nat -> Type), +Lemma max_case_strong : forall n m (P:nat -> Type), (m<=n -> P n) -> (n<=m -> P m) -> P (max n m). Proof. induction n; destruct m; simpl in *; auto with arith. @@ -63,7 +63,7 @@ Qed. Lemma plus_max_distr_l : forall n m p, max (p + n) (p + m) = p + max n m. Proof. - induction p; simpl; auto. + induction p; simpl; auto. Qed. Lemma plus_max_distr_r : forall n m p, max (n + p) (m + p) = max n m + p. diff --git a/theories/Arith/Min.v b/theories/Arith/Min.v index 7654c856ce..503029015a 100644 --- a/theories/Arith/Min.v +++ b/theories/Arith/Min.v @@ -27,7 +27,7 @@ Fixpoint min n m {struct n} : nat := Lemma min_0_l : forall n : nat, min 0 n = 0. Proof. - trivial. + trivial. Qed. Lemma min_0_r : forall n : nat, min n 0 = 0. diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index 1bf6102e94..b6ea04c010 100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -120,10 +120,10 @@ Proof. intros n m Hnm; apply le_elim_rel with (n:=n) (m:=m); trivial. intros q; destruct q; auto with arith. - simpl. + simpl. apply le_trans with (m := p - 0); [apply HI | rewrite <- minus_n_O]; auto with arith. - + intros q r Hqr _. simpl. auto using HI. Qed. diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index 1183dc2eec..7b48ffe05f 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -43,7 +43,7 @@ Hint Resolve mult_1_l: arith v62. Lemma mult_1_r : forall n, n * 1 = n. Proof. - induction n; [ trivial | + induction n; [ trivial | simpl; rewrite IHn; reflexivity]. Qed. Hint Resolve mult_1_r: arith v62. @@ -118,7 +118,7 @@ Proof. edestruct O_S; eauto. destruct plus_is_one with (1:=H) as [[-> Hnm] | [-> Hnm]]. simpl in H; rewrite mult_0_r in H; elim (O_S _ H). - rewrite mult_1_r in Hnm; auto. + rewrite mult_1_r in Hnm; auto. Qed. (** ** Multiplication and successor *) @@ -176,7 +176,7 @@ Qed. Lemma mult_S_lt_compat_l : forall n m p, m < p -> S n * m < S n * p. Proof. - induction n; intros; simpl in *. + induction n; intros; simpl in *. rewrite <- 2! plus_n_O; assumption. auto using plus_lt_compat. Qed. @@ -219,8 +219,8 @@ Qed. (** * Tail-recursive mult *) -(** [tail_mult] is an alternative definition for [mult] which is - tail-recursive, whereas [mult] is not. This can be useful +(** [tail_mult] is an alternative definition for [mult] which is + tail-recursive, whereas [mult] is not. This can be useful when extracting programs. *) Fixpoint mult_acc (s:nat) m n {struct n} : nat := @@ -244,7 +244,7 @@ Proof. intros; unfold tail_mult in |- *; rewrite <- mult_acc_aux; auto. Qed. -(** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus] +(** [TailSimpl] transforms any [tail_plus] and [tail_mult] into [plus] and [mult] and simplify *) Ltac tail_simpl := diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index 5f7517c751..cba87f9e54 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -65,7 +65,7 @@ Qed. Hint Resolve plus_assoc: arith v62. Lemma plus_permute : forall n m p, n + (m + p) = m + (n + p). -Proof. +Proof. intros; rewrite (plus_assoc m n p); rewrite (plus_comm m n); auto with arith. Qed. @@ -179,7 +179,7 @@ Definition plus_is_one : Proof. intro m; destruct m as [| n]; auto. destruct n; auto. - intros. + intros. simpl in H. discriminate H. Defined. @@ -187,14 +187,14 @@ Defined. Lemma plus_permute_2_in_4 : forall n m p q, n + m + (p + q) = n + p + (m + q). Proof. - intros m n p q. + intros m n p q. rewrite <- (plus_assoc m n (p + q)). rewrite (plus_assoc n p q). rewrite (plus_comm n p). rewrite <- (plus_assoc p n q). apply plus_assoc. Qed. (** * Tail-recursive plus *) -(** [tail_plus] is an alternative definition for [plus] which is +(** [tail_plus] is an alternative definition for [plus] which is tail-recursive, whereas [plus] is not. This can be useful when extracting programs. *) @@ -215,7 +215,7 @@ Lemma succ_plus_discr : forall n m, n <> S (plus m n). Proof. intros n m; induction n as [|n IHn]. discriminate. - intro H; apply IHn; apply eq_add_S; rewrite H; rewrite <- plus_n_Sm; + intro H; apply IHn; apply eq_add_S; rewrite H; rewrite <- plus_n_Sm; reflexivity. Qed. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index e87901080c..d142cb77fb 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -46,9 +46,9 @@ Defined. (** It is possible to directly prove the induction principle going back to primitive recursion on natural numbers ([induction_ltof1]) or to use the previous lemmas to extract a program with a fixpoint - ([induction_ltof2]) + ([induction_ltof2]) -the ML-like program for [induction_ltof1] is : +the ML-like program for [induction_ltof1] is : [[ let induction_ltof1 f F a = let rec indrec n k = @@ -58,7 +58,7 @@ let induction_ltof1 f F a = in indrec (f a + 1) a ]] -the ML-like program for [induction_ltof2] is : +the ML-like program for [induction_ltof2] is : [[ let induction_ltof2 F a = indrec a where rec indrec a = F a indrec;; @@ -78,7 +78,7 @@ Proof. unfold ltof in |- *; intros b ltfafb. apply IHn. apply lt_le_trans with (f a); auto with arith. -Defined. +Defined. Theorem induction_gtof1 : forall P:A -> Set, @@ -271,8 +271,8 @@ Fixpoint iter_nat (n:nat) (A:Type) (f:A -> A) (x:A) {struct n} : A := Theorem iter_nat_plus : forall (n m:nat) (A:Type) (f:A -> A) (x:A), iter_nat (n + m) A f x = iter_nat n A f (iter_nat m A f x). -Proof. +Proof. simple induction n; [ simpl in |- *; auto with arith - | intros; simpl in |- *; apply f_equal with (f := f); apply H ]. + | intros; simpl in |- *; apply f_equal with (f := f); apply H ]. Qed. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index dcb10f3cf3..bc42c6564d 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -39,7 +39,7 @@ Qed. Hint Resolve diff_true_false : bool v62. Lemma diff_false_true : false <> true. -Proof. +Proof. red in |- *; intros H; apply diff_true_false. symmetry in |- *. assumption. @@ -129,7 +129,7 @@ Qed. (************************) (** * A synonym of [if] on [bool] *) (************************) - + Definition ifb (b1 b2 b3:bool) : bool := match b1 with | true => b2 @@ -186,7 +186,7 @@ Proof. trivial with bool. trivial with bool. Qed. - + Lemma eqb_negb2 : forall b:bool, eqb b (negb b) = false. Proof. destruct b. @@ -318,7 +318,7 @@ Hint Resolve orb_comm orb_assoc: bool v62. (** * Properties of [andb] *) (*******************************) -Lemma andb_true_iff : +Lemma andb_true_iff : forall b1 b2:bool, b1 && b2 = true <-> b1 = true /\ b2 = true. Proof. destruct b1; destruct b2; intuition. @@ -382,7 +382,7 @@ Hint Resolve andb_false_elim: bool v62. Lemma andb_negb_r : forall b:bool, b && negb b = false. Proof. destruct b; reflexivity. -Qed. +Qed. Hint Resolve andb_negb_r: bool v62. Notation andb_neg_b := andb_negb_r (only parsing). @@ -542,8 +542,8 @@ Qed. (** Lemmas about the [b = true] embedding of [bool] to [Prop] *) -Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2. -Proof. +Lemma eq_true_iff_eq : forall b1 b2, (b1 = true <-> b2 = true) -> b1 = b2. +Proof. intros b1 b2; case b1; case b2; intuition. Qed. @@ -556,7 +556,7 @@ Qed. Notation bool_3 := eq_true_negb_classical (only parsing). (* Compatibility *) -Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true. +Lemma eq_true_not_negb : forall b:bool, b <> true -> negb b = true. Proof. destruct b; intuition. Qed. @@ -628,7 +628,7 @@ Qed. (** [Is_true] and connectives *) -Lemma orb_prop_elim : +Lemma orb_prop_elim : forall a b:bool, Is_true (a || b) -> Is_true a \/ Is_true b. Proof. destruct a; destruct b; simpl; tauto. @@ -636,7 +636,7 @@ Qed. Notation orb_prop2 := orb_prop_elim (only parsing). -Lemma orb_prop_intro : +Lemma orb_prop_intro : forall a b:bool, Is_true a \/ Is_true b -> Is_true (a || b). Proof. destruct a; destruct b; simpl; tauto. @@ -663,16 +663,16 @@ Hint Resolve andb_prop_elim: bool v62. Notation andb_prop2 := andb_prop_elim (only parsing). -Lemma eq_bool_prop_intro : - forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2. -Proof. +Lemma eq_bool_prop_intro : + forall b1 b2, (Is_true b1 <-> Is_true b2) -> b1 = b2. +Proof. destruct b1; destruct b2; simpl in *; intuition. Qed. Lemma eq_bool_prop_elim : forall b1 b2, b1 = b2 -> (Is_true b1 <-> Is_true b2). -Proof. +Proof. intros b1 b2; case b1; case b2; intuition. -Qed. +Qed. Lemma negb_prop_elim : forall b, Is_true (negb b) -> ~ Is_true b. Proof. @@ -696,26 +696,26 @@ Qed. (** Rewrite rules about andb, orb and if (used in romega) *) -Lemma andb_if : forall (A:Type)(a a':A)(b b' : bool), - (if b && b' then a else a') = +Lemma andb_if : forall (A:Type)(a a':A)(b b' : bool), + (if b && b' then a else a') = (if b then if b' then a else a' else a'). Proof. destruct b; destruct b'; auto. Qed. -Lemma negb_if : forall (A:Type)(a a':A)(b:bool), - (if negb b then a else a') = +Lemma negb_if : forall (A:Type)(a a':A)(b:bool), + (if negb b then a else a') = (if b then a' else a). Proof. destruct b; auto. Qed. (*****************************************) -(** * Alternative versions of [andb] and [orb] +(** * Alternative versions of [andb] and [orb] with lazy behavior (for vm_compute) *) (*****************************************) -Notation "a &&& b" := (if a then b else false) +Notation "a &&& b" := (if a then b else false) (at level 40, left associativity) : lazy_bool_scope. Notation "a ||| b" := (if a then true else b) (at level 50, left associativity) : lazy_bool_scope. diff --git a/theories/Bool/Bvector.v b/theories/Bool/Bvector.v index 9dbd90f058..2682a8848b 100644 --- a/theories/Bool/Bvector.v +++ b/theories/Bool/Bvector.v @@ -16,7 +16,7 @@ Require Import Arith. Open Local Scope nat_scope. -(** +(** On s'inspire de List.v pour fabriquer les vecteurs de bits. La dimension du vecteur est un paramètre trop important pour se contenter de la fonction "length". @@ -27,22 +27,22 @@ La seconde id longueur est un paramètre de construction. Cela complique un peu les inductions structurelles et dans certains cas on utilisera un terme de preuve comme définition, car le -mécanisme d'inférence du type du filtrage n'est pas toujours +mécanisme d'inférence du type du filtrage n'est pas toujours aussi puissant que celui implanté par les tactiques d'élimination. *) Section VECTORS. -(** +(** Un vecteur est une liste de taille n d'éléments d'un ensemble A. -Si la taille est non nulle, on peut extraire la première composante et -le reste du vecteur, la dernière composante ou rajouter ou enlever +Si la taille est non nulle, on peut extraire la première composante et +le reste du vecteur, la dernière composante ou rajouter ou enlever une composante (carry) ou repeter la dernière composante en fin de vecteur. On peut aussi tronquer le vecteur de ses p dernières composantes ou au contraire l'étendre (concaténer) d'un vecteur de longueur p. Une fonction unaire sur A génère une fonction des vecteurs de taille n dans les vecteurs de taille n en appliquant f terme à terme. -Une fonction binaire sur A génère une fonction des couples de vecteurs +Une fonction binaire sur A génère une fonction des couples de vecteurs de taille n dans les vecteurs de taille n en appliquant f terme à terme. *) @@ -93,7 +93,7 @@ Lemma Vshiftin : forall n:nat, A -> vector n -> vector (S n). Proof. induction n as [| n f]; intros a v. exact (Vcons a 0 v). - + inversion v as [| a0 n0 H0 H1 ]. exact (Vcons a (S n) (f a H0)). Defined. @@ -103,7 +103,7 @@ Proof. induction n as [| n f]; intro v. inversion v. exact (Vcons a 1 v). - + inversion v as [| a n0 H0 H1 ]. exact (Vcons a (S (S n)) (f H0)). Defined. @@ -113,9 +113,9 @@ Proof. induction p as [| p f]; intros H v. rewrite <- minus_n_O. exact v. - + apply (Vshiftout (n - S p)). - + rewrite minus_Sn_m. apply f. auto with *. @@ -147,7 +147,7 @@ Lemma Vbinary : forall n:nat, vector n -> vector n -> vector n. Proof. induction n as [| n h]; intros v v0. exact Vnil. - + inversion v as [| a n0 H0 H1]; inversion v0 as [| a0 n1 H2 H3]. exact (Vcons (g a a0) n (h H0 H2)). Defined. @@ -180,7 +180,7 @@ Qed. End VECTORS. -(* suppressed: incompatible with Coq-Art book +(* suppressed: incompatible with Coq-Art book Implicit Arguments Vnil [A]. Implicit Arguments Vcons [A n]. *) @@ -188,12 +188,12 @@ Implicit Arguments Vcons [A n]. Section BOOLEAN_VECTORS. (** -Un vecteur de bits est un vecteur sur l'ensemble des booléens de longueur fixe. +Un vecteur de bits est un vecteur sur l'ensemble des booléens de longueur fixe. ATTENTION : le stockage s'effectue poids FAIBLE en tête. On en extrait le bit de poids faible (head) et la fin du vecteur (tail). On calcule la négation d'un vecteur, le et, le ou et le xor bit à bit de 2 vecteurs. On calcule les décalages d'une position vers la gauche (vers les poids forts, on -utilise donc Vshiftout, vers la droite (vers les poids faibles, on utilise Vshiftin) en +utilise donc Vshiftout, vers la droite (vers les poids faibles, on utilise Vshiftin) en insérant un bit 'carry' (logique) ou en répétant le bit de poids fort (arithmétique). ATTENTION : Tous les décalages prennent la taille moins un comme paramètre (ils ne travaillent que sur des vecteurs au moins de longueur un). diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v index 03aa8baeb0..06ab77cfbb 100644 --- a/theories/Bool/Sumbool.v +++ b/theories/Bool/Sumbool.v @@ -39,18 +39,18 @@ Defined. Section connectives. Variables A B C D : Prop. - + Hypothesis H1 : {A} + {B}. Hypothesis H2 : {C} + {D}. - + Definition sumbool_and : {A /\ C} + {B \/ D}. case H1; case H2; auto. Defined. - + Definition sumbool_or : {A \/ C} + {B /\ D}. case H1; case H2; auto. Defined. - + Definition sumbool_not : {B} + {A}. case H1; auto. Defined. diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 6ce34535ed..4b9b26384c 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -18,7 +18,7 @@ Require Export Coq.Classes.Equivalence. -(** The [DecidableSetoid] class asserts decidability of a [Setoid]. It can be useful in proofs to reason more +(** The [DecidableSetoid] class asserts decidability of a [Setoid]. It can be useful in proofs to reason more classically. *) Require Import Coq.Logic.Decidable. @@ -43,8 +43,8 @@ Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70) Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } := match x with - | left H => @right _ _ H - | right H => @left _ _ H + | left H => @right _ _ H + | right H => @left _ _ H end. Open Local Scope program_scope. @@ -89,34 +89,34 @@ Obligation Tactic := unfold complement, equiv ; program_simpl. Program Instance prod_eqdec `(EqDec A eq, EqDec B eq) : ! EqDec (prod A B) eq := { equiv_dec x y := - let '(x1, x2) := x in - let '(y1, y2) := y in - if x1 == y1 then + let '(x1, x2) := x in + let '(y1, y2) := y in + if x1 == y1 then if x2 == y2 then in_left else in_right else in_right }. Program Instance sum_eqdec `(EqDec A eq, EqDec B eq) : EqDec (sum A B) eq := { - equiv_dec x y := + equiv_dec x y := match x, y with | inl a, inl b => if a == b then in_left else in_right | inr a, inr b => if a == b then in_left else in_right | inl _, inr _ | inr _, inl _ => in_right end }. -(** Objects of function spaces with countable domains like bool have decidable equality. +(** Objects of function spaces with countable domains like bool have decidable equality. Proving the reflection requires functional extensionality though. *) Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq := - { equiv_dec f g := + { equiv_dec f g := if f true == g true then if f false == g false then in_left else in_right else in_right }. Next Obligation. - Proof. + Proof. extensionality x. destruct x ; auto. Qed. @@ -124,11 +124,11 @@ Program Instance bool_function_eqdec `(EqDec A eq) : ! EqDec (bool -> A) eq := Require Import List. Program Instance list_eqdec `(eqa : EqDec A eq) : ! EqDec (list A) eq := - { equiv_dec := + { equiv_dec := fix aux (x : list A) y { struct x } := match x, y with | nil, nil => in_left - | cons hd tl, cons hd' tl' => + | cons hd tl, cons hd' tl' => if hd == hd' then if aux tl tl' then in_left else in_right else in_right diff --git a/theories/Classes/Equivalence.v b/theories/Classes/Equivalence.v index 100ddbe3ed..aa20ebd494 100644 --- a/theories/Classes/Equivalence.v +++ b/theories/Classes/Equivalence.v @@ -7,10 +7,10 @@ (************************************************************************) (* Typeclass-based setoids. Definitions on [Equivalence]. - + Author: Matthieu Sozeau Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud - 91405 Orsay, France *) + 91405 Orsay, France *) (* $Id$ *) @@ -34,7 +34,7 @@ Definition equiv `{Equivalence A R} : relation A := R. Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scope. Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope. - + Open Local Scope equiv_scope. (** Overloading for [PER]. *) @@ -60,7 +60,7 @@ Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv. (** Use the [substitute] command which substitutes an equivalence in every hypothesis. *) -Ltac setoid_subst H := +Ltac setoid_subst H := match type of H with ?x === ?y => substitute H ; clear H x end. @@ -70,7 +70,7 @@ Ltac setoid_subst_nofail := | [ H : ?x === ?y |- _ ] => setoid_subst H ; setoid_subst_nofail | _ => idtac end. - + (** [subst*] will try its best at substituting every equality in the goal. *) Tactic Notation "subst" "*" := subst_no_fail ; setoid_subst_nofail. @@ -100,19 +100,19 @@ Ltac equivify := repeat equivify_tac. Section Respecting. - (** Here we build an equivalence instance for functions which relates respectful ones only, + (** Here we build an equivalence instance for functions which relates respectful ones only, we do not export it. *) - Definition respecting `(eqa : Equivalence A (R : relation A), eqb : Equivalence B (R' : relation B)) : Type := + Definition respecting `(eqa : Equivalence A (R : relation A), eqb : Equivalence B (R' : relation B)) : Type := { morph : A -> B | respectful R R' morph morph }. - + Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') : Equivalence (fun (f g : respecting eqa eqb) => forall (x y : A), R x y -> R' (proj1_sig f x) (proj1_sig g y)). - + Solve Obligations using unfold respecting in * ; simpl_relation ; program_simpl. Next Obligation. - Proof. + Proof. unfold respecting in *. program_simpl. transitivity (y y0); auto. apply H0. reflexivity. Qed. diff --git a/theories/Classes/Functions.v b/theories/Classes/Functions.v index b92e4d1747..80d60d658c 100644 --- a/theories/Classes/Functions.v +++ b/theories/Classes/Functions.v @@ -7,7 +7,7 @@ (************************************************************************) (* Functional morphisms. - + Author: Matthieu Sozeau Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud 91405 Orsay, France *) diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index 3e2eb4f40a..7be92139e9 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* Initialization code for typeclasses, setting up the default tactic +(* Initialization code for typeclasses, setting up the default tactic for instance search. Author: Matthieu Sozeau @@ -25,7 +25,7 @@ Typeclasses Opaque id const flip compose arrow impl iff not all. Ltac class_apply c := autoapply c using typeclass_instances. -(** The unconvertible typeclass, to test that two objects of the same type are +(** The unconvertible typeclass, to test that two objects of the same type are actually different. *) Class Unconvertible (A : Type) (a b : A) := unconvertible : unit. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 595ad12975..55aad6e739 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -8,7 +8,7 @@ (************************************************************************) (* Typeclass-based morphism definition and standard, minimal instances. - + Author: Matthieu Sozeau Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud 91405 Orsay, France *) @@ -22,11 +22,11 @@ Require Export Coq.Classes.RelationClasses. (** * Morphisms. - We now turn to the definition of [Proper] and declare standard instances. + We now turn to the definition of [Proper] and declare standard instances. These will be used by the [setoid_rewrite] tactic later. *) (** A morphism for a relation [R] is a proper element of the relation. - The relation [R] will be instantiated by [respectful] and [A] by an arrow type + The relation [R] will be instantiated by [respectful] and [A] by an arrow type for usual morphisms. *) Class Proper {A} (R : relation A) (m : A) : Prop := @@ -36,12 +36,12 @@ Class Proper {A} (R : relation A) (m : A) : Prop := (** The fully dependent version, not used yet. *) -Definition respectful_hetero - (A B : Type) - (C : A -> Type) (D : B -> Type) - (R : A -> B -> Prop) - (R' : forall (x : A) (y : B), C x -> D y -> Prop) : - (forall x : A, C x) -> (forall x : B, D x) -> Prop := +Definition respectful_hetero + (A B : Type) + (C : A -> Type) (D : B -> Type) + (R : A -> B -> Prop) + (R' : forall (x : A) (y : B), C x -> D y -> Prop) : + (forall x : A, C x) -> (forall x : B, D x) -> Prop := fun f g => forall x y, R x y -> R' x y (f x) (g y). (** The non-dependent version is an instance where we forget dependencies. *) @@ -59,12 +59,12 @@ Arguments Scope respectful [type_scope type_scope signature_scope signature_scop Module ProperNotations. - Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature)) + Notation " R ++> R' " := (@respectful _ _ (R%signature) (R'%signature)) (right associativity, at level 55) : signature_scope. - + Notation " R ==> R' " := (@respectful _ _ (R%signature) (R'%signature)) (right associativity, at level 55) : signature_scope. - + Notation " R --> R' " := (@respectful _ _ (inverse (R%signature)) (R'%signature)) (right associativity, at level 55) : signature_scope. @@ -74,7 +74,7 @@ Export ProperNotations. Open Local Scope signature_scope. -(** Dependent pointwise lifting of a relation on the range. *) +(** Dependent pointwise lifting of a relation on the range. *) Definition forall_relation {A : Type} {B : A -> Type} (sig : Π a : A, relation (B a)) : relation (Π x : A, B x) := λ f g, Π a : A, sig a (f a) (g a). @@ -83,10 +83,10 @@ Arguments Scope forall_relation [type_scope type_scope signature_scope]. (** Non-dependent pointwise lifting *) -Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := +Definition pointwise_relation (A : Type) {B : Type} (R : relation B) : relation (A -> B) := Eval compute in forall_relation (B:=λ _, B) (λ _, R). -Lemma pointwise_pointwise A B (R : relation B) : +Lemma pointwise_pointwise A B (R : relation B) : relation_equivalence (pointwise_relation A R) (@eq A ==> R). Proof. intros. split. simpl_relation. firstorder. Qed. @@ -124,7 +124,7 @@ Proof. simpl_relation. apply subr. apply H. apply subl. apply H0. Qed. Lemma subrelation_refl A R : @subrelation A R R. Proof. simpl_relation. Qed. -Ltac subrelation_tac T U := +Ltac subrelation_tac T U := (is_ground T ; is_ground U ; class_apply @subrelation_refl) || class_apply @subrelation_respectful || class_apply @subrelation_refl. @@ -141,13 +141,13 @@ Qed. CoInductive apply_subrelation : Prop := do_subrelation. Ltac proper_subrelation := - match goal with + match goal with [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper end. Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. -Instance proper_subrelation_proper : +Instance proper_subrelation_proper : Proper (subrelation ++> @eq _ ==> impl) (@Proper A). Proof. reduce. subst. firstorder. Qed. @@ -176,7 +176,7 @@ Program Instance complement_proper intuition. Qed. -(** The [inverse] too, actually the [flip] instance is a bit more general. *) +(** The [inverse] too, actually the [flip] instance is a bit more general. *) Program Instance flip_proper `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : @@ -187,7 +187,7 @@ Program Instance flip_proper apply mor ; auto. Qed. -(** Every Transitive relation gives rise to a binary morphism on [impl], +(** Every Transitive relation gives rise to a binary morphism on [impl], contravariant in the first argument, covariant in the second. *) Program Instance trans_contra_co_morphism @@ -263,13 +263,13 @@ Program Instance PER_morphism `(PER A R) : Proper (R ==> R ==> iff) R | 1. Proof with auto. split ; intros. transitivity x0... transitivity x... symmetry... - + transitivity y... transitivity y0... symmetry... Qed. Lemma symmetric_equiv_inverse `(Symmetric A R) : relation_equivalence R (flip R). Proof. firstorder. Qed. - + Program Instance compose_proper A B C Râ‚€ Râ‚ Râ‚‚ : Proper ((Râ‚ ==> Râ‚‚) ==> (Râ‚€ ==> Râ‚) ==> (Râ‚€ ==> Râ‚‚)) (@compose A B C). @@ -279,7 +279,7 @@ Program Instance compose_proper A B C Râ‚€ Râ‚ Râ‚‚ : unfold compose. apply H. apply H0. apply H1. Qed. -(** Coq functions are morphisms for leibniz equality, +(** Coq functions are morphisms for leibniz equality, applied only if really needed. *) Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') : @@ -288,13 +288,13 @@ Proof. simpl_relation. Qed. (** [respectful] is a morphism for relation equivalence. *) -Instance respectful_morphism : +Instance respectful_morphism : Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B). Proof. reduce. unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. split ; intros. - + rewrite <- H0. apply H1. rewrite H. @@ -308,10 +308,10 @@ Qed. (** Every element in the carrier of a reflexive relation is a morphism for this relation. We use a proxy class for this case which is used internally to discharge reflexivity constraints. - The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of + The [Reflexive] instance will almost always be used, but it won't apply in general to any kind of [Proper (A -> B) _ _] goal, making proof-search much slower. A cleaner solution would be to be able to set different priorities in different hint bases and select a particular hint database for - resolution of a type class constraint.*) + resolution of a type class constraint.*) Class ProperProxy {A} (R : relation A) (m : A) : Prop := proper_proxy : R m m. @@ -340,7 +340,7 @@ Class PartialApplication. CoInductive normalization_done : Prop := did_normalization. -Ltac partial_application_tactic := +Ltac partial_application_tactic := let rec do_partial_apps H m := match m with | ?m' ?x => class_apply @Reflexive_partial_app_morphism ; [do_partial_apps H m'|clear H] @@ -350,7 +350,7 @@ Ltac partial_application_tactic := let rec do_partial H ar m := match ar with | 0 => do_partial_apps H m - | S ?n' => + | S ?n' => match m with ?m' ?x => do_partial H n' m' end @@ -362,18 +362,18 @@ Ltac partial_application_tactic := let v := eval compute in n in clear n ; let H := fresh in assert(H:Params m' v) by typeclasses eauto ; - let v' := eval compute in v in + let v' := eval compute in v in do_partial H v' m in match goal with | [ _ : normalization_done |- _ ] => fail 1 | [ _ : @Params _ _ _ |- _ ] => fail 1 - | [ |- @Proper ?T _ (?m ?x) ] => - match goal with - | [ _ : PartialApplication |- _ ] => + | [ |- @Proper ?T _ (?m ?x) ] => + match goal with + | [ _ : PartialApplication |- _ ] => class_apply @Reflexive_partial_app_morphism - | _ => - on_morphism (m x) || + | _ => + on_morphism (m x) || (class_apply @Reflexive_partial_app_morphism ; [ pose Build_PartialApplication | idtac ]) end @@ -391,7 +391,7 @@ Qed. (** Special-purpose class to do normalization of signatures w.r.t. inverse. *) -Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop := +Class Normalizes (A : Type) (m : relation A) (m' : relation A) : Prop := normalizes : relation_equivalence m m'. (** Current strategy: add [inverse] everywhere and reduce using [subrelation] @@ -408,7 +408,7 @@ Proof. unfold Normalizes. intros. rewrite NA, NB. firstorder. Qed. -Ltac inverse := +Ltac inverse := match goal with | [ |- Normalizes _ (respectful _ _) _ ] => class_apply @inverse_arrow | _ => class_apply @inverse_atom @@ -416,7 +416,7 @@ Ltac inverse := Hint Extern 1 (Normalizes _ _ _) => inverse : typeclass_instances. -(** Treating inverse: can't make them direct instances as we +(** Treating inverse: can't make them direct instances as we need at least a [flip] present in the goal. *) Lemma inverse1 `(subrelation A R' R) : subrelation (inverse (inverse R')) R. @@ -477,7 +477,7 @@ Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x. Proof. firstorder. Qed. -Lemma proper_eq A (x : A) : Proper (@eq A) x. +Lemma proper_eq A (x : A) : Proper (@eq A) x. Proof. intros. apply reflexive_proper. Qed. Ltac proper_reflexive := diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index b672651b92..5b61e2c079 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -7,7 +7,7 @@ (************************************************************************) (* [Proper] instances for propositional connectives. - + Author: Matthieu Sozeau Institution: LRI, CNRS UMR 8623 - Université Paris Sud 91405 Orsay, France *) @@ -25,7 +25,7 @@ Obligation Tactic := simpl_relation. Program Instance not_impl_morphism : Proper (impl --> impl) not | 1. -Program Instance not_iff_morphism : +Program Instance not_iff_morphism : Proper (iff ++> iff) not. (** Logical conjunction. *) @@ -33,15 +33,15 @@ Program Instance not_iff_morphism : Program Instance and_impl_morphism : Proper (impl ==> impl ==> impl) and | 1. -Program Instance and_iff_morphism : +Program Instance and_iff_morphism : Proper (iff ==> iff ==> iff) and. (** Logical disjunction. *) -Program Instance or_impl_morphism : +Program Instance or_impl_morphism : Proper (impl ==> impl ==> impl) or | 1. -Program Instance or_iff_morphism : +Program Instance or_iff_morphism : Proper (iff ==> iff ==> iff) or. (** Logical implication [impl] is a morphism for logical equivalence. *) @@ -54,11 +54,11 @@ Program Instance ex_iff_morphism {A : Type} : Proper (pointwise_relation A iff = Next Obligation. Proof. - unfold pointwise_relation in H. + unfold pointwise_relation in H. split ; intros. destruct H0 as [xâ‚ Hâ‚]. exists xâ‚. rewrite H in Hâ‚. assumption. - + destruct H0 as [xâ‚ Hâ‚]. exists xâ‚. rewrite H. assumption. Qed. @@ -68,20 +68,20 @@ Program Instance ex_impl_morphism {A : Type} : Next Obligation. Proof. - unfold pointwise_relation in H. + unfold pointwise_relation in H. exists H0. apply H. assumption. Qed. -Program Instance ex_inverse_impl_morphism {A : Type} : +Program Instance ex_inverse_impl_morphism {A : Type} : Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@ex A) | 1. Next Obligation. Proof. - unfold pointwise_relation in H. + unfold pointwise_relation in H. exists H0. apply H. assumption. Qed. -Program Instance all_iff_morphism {A : Type} : +Program Instance all_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@all A). Next Obligation. @@ -90,18 +90,18 @@ Program Instance all_iff_morphism {A : Type} : intuition ; specialize (H x0) ; intuition. Qed. -Program Instance all_impl_morphism {A : Type} : +Program Instance all_impl_morphism {A : Type} : Proper (pointwise_relation A impl ==> impl) (@all A) | 1. - + Next Obligation. Proof. unfold pointwise_relation, all in *. intuition ; specialize (H x0) ; intuition. Qed. -Program Instance all_inverse_impl_morphism {A : Type} : +Program Instance all_inverse_impl_morphism {A : Type} : Proper (pointwise_relation A (inverse impl) ==> inverse impl) (@all A) | 1. - + Next Obligation. Proof. unfold pointwise_relation, all in *. diff --git a/theories/Classes/Morphisms_Relations.v b/theories/Classes/Morphisms_Relations.v index b603a2e41a..e9301298e1 100644 --- a/theories/Classes/Morphisms_Relations.v +++ b/theories/Classes/Morphisms_Relations.v @@ -7,7 +7,7 @@ (************************************************************************) (* Morphism instances for relations. - + Author: Matthieu Sozeau Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud 91405 Orsay, France *) @@ -50,6 +50,6 @@ Instance subrelation_pointwise : Proof. intro. apply (predicate_implication_pointwise (cons A (cons A nil))). Qed. -Lemma inverse_pointwise_relation A (R : relation A) : +Lemma inverse_pointwise_relation A (R : relation A) : relation_equivalence (pointwise_relation A (inverse R)) (inverse (pointwise_relation A R)). Proof. intros. split; firstorder. Qed. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 5c65244814..b2f62cb87c 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -8,7 +8,7 @@ (* Typeclass-based relations, tactics and standard instances. This is the basic theory needed to formalize morphisms and setoids. - + Author: Matthieu Sozeau Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud 91405 Orsay, France *) @@ -42,18 +42,18 @@ Unset Strict Implicit. Class Reflexive {A} (R : relation A) := reflexivity : forall x, R x x. -Class Irreflexive {A} (R : relation A) := +Class Irreflexive {A} (R : relation A) := irreflexivity : Reflexive (complement R). Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclasses_instances. -Class Symmetric {A} (R : relation A) := +Class Symmetric {A} (R : relation A) := symmetry : forall x y, R x y -> R y x. -Class Asymmetric {A} (R : relation A) := +Class Asymmetric {A} (R : relation A) := asymmetry : forall x y, R x y -> R y x -> False. -Class Transitive {A} (R : relation A) := +Class Transitive {A} (R : relation A) := transitivity : forall x y z, R x y -> R y z -> R x z. Hint Resolve @irreflexivity : ord. @@ -63,7 +63,7 @@ Unset Implicit Arguments. (** A HintDb for relations. *) Ltac solve_relation := - match goal with + match goal with | [ |- ?R ?x ?x ] => reflexivity | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H end. @@ -85,7 +85,7 @@ Program Definition flip_Symmetric `(Symmetric A R) : Symmetric (flip R) := Program Definition flip_Asymmetric `(Asymmetric A R) : Asymmetric (flip R) := fun x y H H' => asymmetry (R:=R) H H'. - + Program Definition flip_Transitive `(Transitive A R) : Transitive (flip R) := fun x y z H H' => transitivity (R:=R) H' H. @@ -122,7 +122,7 @@ Tactic Notation "reduce" "in" hyp(Hid) := reduce_hyp Hid. Ltac reduce := reduce_goal. -Tactic Notation "apply" "*" constr(t) := +Tactic Notation "apply" "*" constr(t) := first [ refine t | refine (t _) | refine (t _ _) | refine (t _ _ _) | refine (t _ _ _ _) | refine (t _ _ _ _ _) | refine (t _ _ _ _ _ _) | refine (t _ _ _ _ _ _ _) ]. @@ -186,7 +186,7 @@ Program Definition flip_antiSymmetric `(Antisymmetric A eqA R) : Proof. firstorder. Qed. (** Leibinz equality [eq] is an equivalence relation. - The instance has low priority as it is always applicable + The instance has low priority as it is always applicable if only the type is constrained. *) Program Instance eq_equivalence : Equivalence (@eq A) | 10. @@ -208,8 +208,8 @@ Require Import Coq.Lists.List. (** A compact representation of non-dependent arities, with the codomain singled-out. *) -Fixpoint arrows (l : list Type) (r : Type) : Type := - match l with +Fixpoint arrows (l : list Type) (r : Type) : Type := + match l with | nil => r | A :: l' => A -> arrows l' r end. @@ -232,7 +232,7 @@ Definition unary_predicate A := predicate (cons A nil). Definition binary_relation A := predicate (cons A (cons A nil)). -(** We can close a predicate by universal or existential quantification. *) +(** We can close a predicate by universal or existential quantification. *) Fixpoint predicate_all (l : list Type) : predicate l -> Prop := match l with @@ -246,7 +246,7 @@ Fixpoint predicate_exists (l : list Type) : predicate l -> Prop := | A :: tl => fun f => exists x : A, predicate_exists tl (f x) end. -(** Pointwise extension of a binary operation on [T] to a binary operation +(** Pointwise extension of a binary operation on [T] to a binary operation on functions whose codomain is [T]. For an operator on [Prop] this lifts the operator to a binary operation. *) @@ -254,7 +254,7 @@ Fixpoint pointwise_extension {T : Type} (op : binary_operation T) (l : list Type) : binary_operation (arrows l T) := match l with | nil => fun R R' => op R R' - | A :: tl => fun R R' => + | A :: tl => fun R R' => fun x => pointwise_extension op tl (R x) (R' x) end. @@ -263,7 +263,7 @@ Fixpoint pointwise_extension {T : Type} (op : binary_operation T) Fixpoint pointwise_lifting (op : binary_relation Prop) (l : list Type) : binary_relation (predicate l) := match l with | nil => fun R R' => op R R' - | A :: tl => fun R R' => + | A :: tl => fun R R' => forall x, pointwise_lifting op tl (R x) (R' x) end. @@ -295,7 +295,7 @@ Infix "\∙/" := predicate_union (at level 85, right associativity) : predicate_ (** The always [True] and always [False] predicates. *) -Fixpoint true_predicate {l : list Type} : predicate l := +Fixpoint true_predicate {l : list Type} : predicate l := match l with | nil => True | A :: tl => fun _ => @true_predicate tl @@ -313,7 +313,7 @@ Notation "∙⊥∙" := false_predicate : predicate_scope. (** Predicate equivalence is an equivalence, and predicate implication defines a preorder. *) Program Instance predicate_equivalence_equivalence : Equivalence (@predicate_equivalence l). - Next Obligation. + Next Obligation. induction l ; firstorder. Qed. Next Obligation. @@ -333,11 +333,11 @@ Program Instance predicate_implication_preorder : Qed. Next Obligation. induction l. firstorder. - unfold predicate_implication in *. simpl in *. + unfold predicate_implication in *. simpl in *. intro. pose (IHl (x x0) (y x0) (z x0)). firstorder. Qed. -(** We define the various operations which define the algebra on binary relations, +(** We define the various operations which define the algebra on binary relations, from the general ones. *) Definition relation_equivalence {A : Type} : relation (relation A) := @@ -365,20 +365,20 @@ Proof. intro A. exact (@predicate_implication_preorder (cons A (cons A nil))). Q (** *** Partial Order. A partial order is a preorder which is additionally antisymmetric. - We give an equivalent definition, up-to an equivalence relation + We give an equivalent definition, up-to an equivalence relation on the carrier. *) Class PartialOrder {A} eqA `{equ : Equivalence A eqA} R `{preo : PreOrder A R} := partial_order_equivalence : relation_equivalence eqA (relation_conjunction R (inverse R)). -(** The equivalence proof is sufficient for proving that [R] must be a morphism +(** The equivalence proof is sufficient for proving that [R] must be a morphism for equivalence (see Morphisms). It is also sufficient to show that [R] is antisymmetric w.r.t. [eqA] *) Instance partial_order_antisym `(PartialOrder A eqA R) : ! Antisymmetric A eqA R. Proof with auto. - reduce_goal. - pose proof partial_order_equivalence as poe. do 3 red in poe. + reduce_goal. + pose proof partial_order_equivalence as poe. do 3 red in poe. apply <- poe. firstorder. Qed. @@ -392,7 +392,7 @@ Program Instance subrelation_partial_order : unfold relation_equivalence in *. firstorder. Qed. -Typeclasses Opaque arrows predicate_implication predicate_equivalence +Typeclasses Opaque arrows predicate_implication predicate_equivalence relation_equivalence pointwise_lifting. (** Rewrite relation on a given support: declares a relation as a rewrite @@ -409,7 +409,7 @@ Instance: RewriteRelation impl. Instance: RewriteRelation iff. Instance: RewriteRelation (@relation_equivalence A). -(** Any [Equivalence] declared in the context is automatically considered +(** Any [Equivalence] declared in the context is automatically considered a rewrite relation. *) Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA. diff --git a/theories/Classes/SetoidAxioms.v b/theories/Classes/SetoidAxioms.v index 469b9eae6d..ebc1d7be97 100644 --- a/theories/Classes/SetoidAxioms.v +++ b/theories/Classes/SetoidAxioms.v @@ -21,7 +21,7 @@ Unset Strict Implicit. Require Export Coq.Classes.SetoidClass. -(* Application of the extensionality axiom to turn a goal on +(* Application of the extensionality axiom to turn a goal on Leibniz equality to a setoid equivalence (use with care!). *) Axiom setoideq_eq : forall `{sa : Setoid a} (x y : a), x == y -> x = y. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 055f02f8b9..6af4b5ffe5 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -7,7 +7,7 @@ (************************************************************************) (* Typeclass-based setoids, tactics and standard instances. - + Author: Matthieu Sozeau Institution: LRI, CNRS UMR 8623 - UniversitÃcopyright Paris Sud 91405 Orsay, France *) @@ -55,7 +55,7 @@ Existing Instance setoid_trans. (* Program Instance eq_setoid : Setoid A := *) (* equiv := eq ; setoid_equiv := eq_equivalence. *) -Program Instance iff_setoid : Setoid Prop := +Program Instance iff_setoid : Setoid Prop := { equiv := iff ; setoid_equiv := iff_equivalence }. (** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *) @@ -69,7 +69,7 @@ Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : (** Use the [clsubstitute] command which substitutes an equality in every hypothesis. *) -Ltac clsubst H := +Ltac clsubst H := match type of H with ?x == ?y => substitute H ; clear H x end. @@ -79,7 +79,7 @@ Ltac clsubst_nofail := | [ H : ?x == ?y |- _ ] => clsubst H ; clsubst_nofail | _ => idtac end. - + (** [subst*] will try its best at substituting every equality in the goal. *) Tactic Notation "clsubst" "*" := clsubst_nofail. @@ -94,7 +94,7 @@ Qed. Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z. Proof. - intros; intro. + intros; intro. assert(y == x) by (symmetry ; auto). assert(y == z) by (transitivity x ; eauto). contradiction. @@ -127,7 +127,7 @@ Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper ( (** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *) -Class PartialSetoid (A : Type) := +Class PartialSetoid (A : Type) := { pequiv : relation A ; pequiv_prf :> PER pequiv }. (** Overloaded notation for partial setoid equivalence. *) diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index d68e3fd22b..71d80c9597 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -21,7 +21,7 @@ Unset Strict Implicit. Require Export Coq.Classes.SetoidClass. -(** The [DecidableSetoid] class asserts decidability of a [Setoid]. It can be useful in proofs to reason more +(** The [DecidableSetoid] class asserts decidability of a [Setoid]. It can be useful in proofs to reason more classically. *) Require Import Coq.Logic.Decidable. @@ -41,8 +41,8 @@ Notation " x == y " := (equiv_dec (x :>) (y :>)) (no associativity, at level 70) Definition swap_sumbool {A B} (x : { A } + { B }) : { B } + { A } := match x with - | left H => @right _ _ H - | right H => @left _ _ H + | left H => @right _ _ H + | right H => @left _ _ H end. Require Import Coq.Program.Program. @@ -96,9 +96,9 @@ Program Instance unit_eqdec : EqDec (eq_setoid unit) := Program Instance prod_eqdec `(! EqDec (eq_setoid A), ! EqDec (eq_setoid B)) : EqDec (eq_setoid (prod A B)) := λ x y, - let '(x1, x2) := x in - let '(y1, y2) := y in - if x1 == y1 then + let '(x1, x2) := x in + let '(y1, y2) := y in + if x1 == y1 then if x2 == y2 then in_left else in_right else in_right. diff --git a/theories/Classes/SetoidTactics.v b/theories/Classes/SetoidTactics.v index f58f227e54..12356385ce 100644 --- a/theories/Classes/SetoidTactics.v +++ b/theories/Classes/SetoidTactics.v @@ -24,8 +24,8 @@ Set Implicit Arguments. Unset Strict Implicit. (** Default relation on a given support. Can be used by tactics - to find a sensible default relation on any carrier. Users can - declare an [Instance def : DefaultRelation A RA] anywhere to + to find a sensible default relation on any carrier. Users can + declare an [Instance def : DefaultRelation A RA] anywhere to declare default relations. *) Class DefaultRelation A (R : relation A). @@ -60,80 +60,80 @@ Ltac setoidreplaceat H t occs := Tactic Notation "setoid_replace" constr(x) "with" constr(y) := setoidreplace (default_relation x y) idtac. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) "at" int_or_var_list(o) := setoidreplaceat (default_relation x y) idtac o. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) "in" hyp(id) := setoidreplacein (default_relation x y) id idtac. Tactic Notation "setoid_replace" constr(x) "with" constr(y) - "in" hyp(id) + "in" hyp(id) "at" int_or_var_list(o) := setoidreplaceinat (default_relation x y) id idtac o. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) "by" tactic3(t) := setoidreplace (default_relation x y) ltac:t. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) - "at" int_or_var_list(o) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "at" int_or_var_list(o) "by" tactic3(t) := setoidreplaceat (default_relation x y) ltac:t o. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) - "in" hyp(id) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "in" hyp(id) "by" tactic3(t) := setoidreplacein (default_relation x y) id ltac:t. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) - "in" hyp(id) - "at" int_or_var_list(o) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "in" hyp(id) + "at" int_or_var_list(o) "by" tactic3(t) := setoidreplaceinat (default_relation x y) id ltac:t o. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) := setoidreplace (rel x y) idtac. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "at" int_or_var_list(o) := setoidreplaceat (rel x y) idtac o. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) - "using" "relation" constr(rel) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) "by" tactic3(t) := setoidreplace (rel x y) ltac:t. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) - "using" "relation" constr(rel) - "at" int_or_var_list(o) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) + "at" int_or_var_list(o) "by" tactic3(t) := setoidreplaceat (rel x y) ltac:t o. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "in" hyp(id) := setoidreplacein (rel x y) id idtac. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) - "in" hyp(id) + "in" hyp(id) "at" int_or_var_list(o) := setoidreplaceinat (rel x y) id idtac o. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) "using" "relation" constr(rel) "in" hyp(id) "by" tactic3(t) := setoidreplacein (rel x y) id ltac:t. -Tactic Notation "setoid_replace" constr(x) "with" constr(y) - "using" "relation" constr(rel) +Tactic Notation "setoid_replace" constr(x) "with" constr(y) + "using" "relation" constr(rel) "in" hyp(id) - "at" int_or_var_list(o) + "at" int_or_var_list(o) "by" tactic3(t) := setoidreplaceinat (rel x y) id ltac:t o. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index bf10728c8e..189cf88ad2 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -14,8 +14,8 @@ (** * FMapAVL *) (** This module implements maps using AVL trees. - It follows the implementation from Ocaml's standard library. - + It follows the implementation from Ocaml's standard library. + See the comments at the beginning of FSetAVL for more details. *) @@ -30,8 +30,8 @@ Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. (** * The Raw functor - - Functor of pure functions + separate proofs of invariant + + Functor of pure functions + separate proofs of invariant preservation *) Module Raw (Import I:Int)(X: OrderedType). @@ -85,20 +85,20 @@ Definition is_empty m := match m with Leaf => true | _ => false end. to achieve logarithmic complexity. *) Fixpoint mem x m : bool := - match m with - | Leaf => false - | Node l y _ r _ => match X.compare x y with - | LT _ => mem x l + match m with + | Leaf => false + | Node l y _ r _ => match X.compare x y with + | LT _ => mem x l | EQ _ => true | GT _ => mem x r end end. -Fixpoint find x m : option elt := - match m with - | Leaf => None - | Node l y d r _ => match X.compare x y with - | LT _ => find x l +Fixpoint find x m : option elt := + match m with + | Leaf => None + | Node l y d r _ => match X.compare x y with + | LT _ => find x l | EQ _ => Some d | GT _ => find x r end @@ -109,7 +109,7 @@ Fixpoint find x m : option elt := (** [create l x r] creates a node, assuming [l] and [r] to be balanced and [|height l - height r| <= 2]. *) -Definition create l x e r := +Definition create l x e r := Node l x e r (max (height l) (height r) + 1). (** [bal l x e r] acts as [create], but performs one step of @@ -117,45 +117,45 @@ Definition create l x e r := Definition assert_false := create. -Fixpoint bal l x d r := - let hl := height l in +Fixpoint bal l x d r := + let hl := height l in let hr := height r in - if gt_le_dec hl (hr+2) then - match l with + if gt_le_dec hl (hr+2) then + match l with | Leaf => assert_false l x d r - | Node ll lx ld lr _ => - if ge_lt_dec (height ll) (height lr) then + | Node ll lx ld lr _ => + if ge_lt_dec (height ll) (height lr) then create ll lx ld (create lr x d r) - else - match lr with + else + match lr with | Leaf => assert_false l x d r - | Node lrl lrx lrd lrr _ => + | Node lrl lrx lrd lrr _ => create (create ll lx ld lrl) lrx lrd (create lrr x d r) end end - else - if gt_le_dec hr (hl+2) then + else + if gt_le_dec hr (hl+2) then match r with | Leaf => assert_false l x d r | Node rl rx rd rr _ => - if ge_lt_dec (height rr) (height rl) then + if ge_lt_dec (height rr) (height rl) then create (create l x d rl) rx rd rr - else + else match rl with | Leaf => assert_false l x d r - | Node rll rlx rld rlr _ => - create (create l x d rll) rlx rld (create rlr rx rd rr) + | Node rll rlx rld rlr _ => + create (create l x d rll) rlx rld (create rlr rx rd rr) end end - else + else create l x d r. (** * Insertion *) -Fixpoint add x d m := - match m with +Fixpoint add x d m := + match m with | Leaf => Node Leaf x d Leaf 1 - | Node l y d' r h => + | Node l y d' r h => match X.compare x y with | LT _ => bal (add x d l) y d' r | EQ _ => Node l y d r h @@ -165,16 +165,16 @@ Fixpoint add x d m := (** * Extraction of minimum binding - Morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x e r h]. Since we can't deal here with [assert false] - for [t=Leaf], we pre-unpack [t] (and forget about [h]). + Morally, [remove_min] is to be applied to a non-empty tree + [t = Node l x e r h]. Since we can't deal here with [assert false] + for [t=Leaf], we pre-unpack [t] (and forget about [h]). *) - -Fixpoint remove_min l x d r : t*(key*elt) := + +Fixpoint remove_min l x d r : t*(key*elt) := match l with | Leaf => (r,(x,d)) - | Node ll lx ld lr lh => - let (l',m) := remove_min ll lx ld lr in + | Node ll lx ld lr lh => + let (l',m) := remove_min ll lx ld lr in (bal l' x d r, m) end. @@ -185,18 +185,18 @@ Fixpoint remove_min l x d r : t*(key*elt) := [|height t1 - height t2| <= 2]. *) -Fixpoint merge s1 s2 := match s1,s2 with - | Leaf, _ => s2 +Fixpoint merge s1 s2 := match s1,s2 with + | Leaf, _ => s2 | _, Leaf => s1 - | _, Node l2 x2 d2 r2 h2 => - match remove_min l2 x2 d2 r2 with + | _, Node l2 x2 d2 r2 h2 => + match remove_min l2 x2 d2 r2 with (s2',(x,d)) => bal s1 x d s2' end end. (** * Deletion *) -Fixpoint remove x m := match m with +Fixpoint remove x m := match m with | Leaf => Leaf | Node l y d r h => match X.compare x y with @@ -206,26 +206,26 @@ Fixpoint remove x m := match m with end end. -(** * join - - Same as [bal] but does not assume anything regarding heights of [l] +(** * join + + Same as [bal] but does not assume anything regarding heights of [l] and [r]. *) Fixpoint join l : key -> elt -> t -> t := match l with | Leaf => add - | Node ll lx ld lr lh => fun x d => - fix join_aux (r:t) : t := match r with + | Node ll lx ld lr lh => fun x d => + fix join_aux (r:t) : t := match r with | Leaf => add x d l - | Node rl rx rd rr rh => + | Node rl rx rd rr rh => if gt_le_dec lh (rh+2) then bal ll lx ld (join lr x d r) - else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr + else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr else create l x d r end end. -(** * Splitting +(** * Splitting [split x m] returns a triple [(l, o, r)] where - [l] is the set of elements of [m] that are [< x] @@ -236,17 +236,17 @@ Fixpoint join l : key -> elt -> t -> t := Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). -Fixpoint split x m : triple := match m with +Fixpoint split x m : triple := match m with | Leaf => << Leaf, None, Leaf >> - | Node l y d r h => - match X.compare x y with + | Node l y d r h => + match X.compare x y with | LT _ => let (ll,o,rl) := split x l in << ll, o, join rl y d r >> | EQ _ => << l, Some d, r >> | GT _ => let (rl,o,rr) := split x r in << join l y d rl, o, rr >> end end. -(** * Concatenation +(** * Concatenation Same as [merge] but does not assume anything about heights. *) @@ -256,7 +256,7 @@ Definition concat m1 m2 := | Leaf, _ => m2 | _ , Leaf => m1 | _, Node l2 x2 d2 r2 _ => - let (m2',xd) := remove_min l2 x2 d2 r2 in + let (m2',xd) := remove_min l2 x2 d2 r2 in join m1 xd#1 xd#2 m2' end. @@ -277,7 +277,7 @@ Definition elements := elements_aux nil. (** * Fold *) -Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := +Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := fun a => match m with | Leaf => a | Node l x d r _ => fold f r (f x d (fold f l a)) @@ -293,11 +293,11 @@ Inductive enumeration := | End : enumeration | More : key -> elt -> t -> enumeration -> enumeration. -(** [cons m e] adds the elements of tree [m] on the head of +(** [cons m e] adds the elements of tree [m] on the head of enumeration [e]. *) -Fixpoint cons m e : enumeration := - match m with +Fixpoint cons m e : enumeration := + match m with | Leaf => e | Node l x d r h => cons l (More x d r e) end. @@ -316,7 +316,7 @@ Definition equal_more x1 d1 (cont:enumeration->bool) e2 := (** Comparison of left tree, middle element, then right tree *) -Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := +Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := match m1 with | Leaf => cont e2 | Node l1 x1 d1 r1 _ => @@ -341,8 +341,8 @@ Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). (** * Map *) -Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := - match m with +Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := + match m with | Leaf => Leaf _ | Node l x d r h => Node (map f l) x (f d) (map f r) h end. @@ -350,7 +350,7 @@ Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := (* * Mapi *) Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := - match m with + match m with | Leaf => Leaf _ | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h end. @@ -358,28 +358,28 @@ Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := (** * Map with removal *) Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) - : t elt' := - match m with + : t elt' := + match m with | Leaf => Leaf _ - | Node l x d r h => - match f x d with + | Node l x d r h => + match f x d with | Some d' => join (map_option f l) x d' (map_option f r) | None => concat (map_option f l) (map_option f r) end end. (** * Optimized map2 - - Suggestion by B. Gregoire: a [map2] function with specialized - arguments allowing to bypass some tree traversal. Instead of one - [f0] of type [key -> option elt -> option elt' -> option elt''], - we ask here for: + + Suggestion by B. Gregoire: a [map2] function with specialized + arguments allowing to bypass some tree traversal. Instead of one + [f0] of type [key -> option elt -> option elt' -> option elt''], + we ask here for: - [f] which is a specialisation of [f0] when first option isn't [None] - [mapl] treats a [tree elt] with [f0] when second option is [None] - [mapr] treats a [tree elt'] with [f0] when first option is [None] - The idea is that [mapl] and [mapr] can be instantaneous (e.g. - the identity or some constant function). + The idea is that [mapl] and [mapr] can be instantaneous (e.g. + the identity or some constant function). *) Section Map2_opt. @@ -388,13 +388,13 @@ Variable f : key -> elt -> option elt' -> option elt''. Variable mapl : t elt -> t elt''. Variable mapr : t elt' -> t elt''. -Fixpoint map2_opt m1 m2 := - match m1, m2 with - | Leaf, _ => mapr m2 +Fixpoint map2_opt m1 m2 := + match m1, m2 with + | Leaf, _ => mapr m2 | _, Leaf => mapl m1 - | Node l1 x1 d1 r1 h1, _ => + | Node l1 x1 d1 r1 h1, _ => let (l2',o2,r2') := split x1 m2 in - match f x1 d1 o2 with + match f x1 d1 o2 with | Some e => join (map2_opt l1 l2') x1 e (map2_opt r1 r2') | None => concat (map2_opt l1 l2') (map2_opt r1 r2') end @@ -403,8 +403,8 @@ Fixpoint map2_opt m1 m2 := End Map2_opt. (** * Map2 - - The [map2] function of the Map interface can be implemented + + The [map2] function of the Map interface can be implemented via [map2_opt] and [map_option]. *) @@ -412,8 +412,8 @@ Section Map2. Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. -Definition map2 : t elt -> t elt' -> t elt'' := - map2_opt +Definition map2 : t elt -> t elt' -> t elt'' := + map2_opt (fun _ d o => f (Some d) o) (map_option (fun _ d => f (Some d) None)) (map_option (fun _ d' => f None (Some d'))). @@ -432,24 +432,24 @@ Variable elt : Type. Inductive MapsTo (x : key)(e : elt) : t elt -> Prop := | MapsRoot : forall l r h y, X.eq x y -> MapsTo x e (Node l y e r h) - | MapsLeft : forall l r h y e', + | MapsLeft : forall l r h y e', MapsTo x e l -> MapsTo x e (Node l y e' r h) - | MapsRight : forall l r h y e', + | MapsRight : forall l r h y e', MapsTo x e r -> MapsTo x e (Node l y e' r h). Inductive In (x : key) : t elt -> Prop := | InRoot : forall l r h y e, X.eq x y -> In x (Node l y e r h) - | InLeft : forall l r h y e', + | InLeft : forall l r h y e', In x l -> In x (Node l y e' r h) - | InRight : forall l r h y e', + | InRight : forall l r h y e', In x r -> In x (Node l y e' r h). Definition In0 k m := exists e:elt, MapsTo k e m. (** ** Binary search trees *) -(** [lt_tree x s]: all elements in [s] are smaller than [x] +(** [lt_tree x s]: all elements in [s] are smaller than [x] (resp. greater for [gt_tree]) *) Definition lt_tree x m := forall y, In y m -> X.lt y x. @@ -459,7 +459,7 @@ Definition gt_tree x m := forall y, In y m -> X.lt x y. Inductive bst : t elt -> Prop := | BSLeaf : bst (Leaf _) - | BSNode : forall x e l r h, bst l -> bst r -> + | BSNode : forall x e l r h, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x e r h). End Invariants. @@ -474,10 +474,10 @@ Module Proofs. Functional Scheme mem_ind := Induction for mem Sort Prop. Functional Scheme find_ind := Induction for find Sort Prop. -Functional Scheme bal_ind := Induction for bal Sort Prop. +Functional Scheme bal_ind := Induction for bal Sort Prop. Functional Scheme add_ind := Induction for add Sort Prop. Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. -Functional Scheme merge_ind := Induction for merge Sort Prop. +Functional Scheme merge_ind := Induction for merge Sort Prop. Functional Scheme remove_ind := Induction for remove Sort Prop. Functional Scheme concat_ind := Induction for concat Sort Prop. Functional Scheme split_ind := Induction for split Sort Prop. @@ -489,24 +489,24 @@ Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop. Hint Constructors tree MapsTo In bst. Hint Unfold lt_tree gt_tree. -Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) - "as" ident(s) := +Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) + "as" ident(s) := set (s:=Node l x d r h) in *; clearbody s; clear l x d r h. (** A tactic for cleaning hypothesis after use of functional induction. *) Ltac clearf := - match goal with + match goal with | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf | _ => idtac end. -(** A tactic to repeat [inversion_clear] on all hyps of the +(** A tactic to repeat [inversion_clear] on all hyps of the form [(f (Node ...))] *) Ltac inv f := - match goal with + match goal with | H:f (Leaf _) |- _ => inversion_clear H; inv f | H:f _ (Leaf _) |- _ => inversion_clear H; inv f | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f @@ -518,8 +518,8 @@ Ltac inv f := | _ => idtac end. -Ltac inv_all f := - match goal with +Ltac inv_all f := + match goal with | H: f _ |- _ => inversion_clear H; inv f | H: f _ _ |- _ => inversion_clear H; inv f | H: f _ _ _ |- _ => inversion_clear H; inv f @@ -529,7 +529,7 @@ Ltac inv_all f := (** Helper tactic concerning order of elements. *) -Ltac order := match goal with +Ltac order := match goal with | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | _ => MX.order @@ -537,21 +537,21 @@ end. Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo). -(* Function/Functional Scheme can't deal with internal fix. +(* Function/Functional Scheme can't deal with internal fix. Let's do its job by hand: *) -Ltac join_tac := - intros l; induction l as [| ll _ lx ld lr Hlr lh]; +Ltac join_tac := + intros l; induction l as [| ll _ lx ld lr Hlr lh]; [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)); + [ | destruct (gt_le_dec lh (rh+2)); [ match goal with |- context [ bal ?u ?v ?w ?z ] => - replace (bal u v w z) + replace (bal u v w z) with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] - end - | destruct (gt_le_dec rh (lh+2)); - [ match goal with |- context [ bal ?u ?v ?w ?z ] => - replace (bal u v w z) - with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] + end + | destruct (gt_le_dec rh (lh+2)); + [ match goal with |- context [ bal ?u ?v ?w ?z ] => + replace (bal u v w z) + with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] end | ] ] ] ]; intros. @@ -575,7 +575,7 @@ Proof. Qed. Lemma In_alt : forall k m, In0 k m <-> In k m. -Proof. +Proof. split. intros (e,H); eauto. unfold In0; apply In_MapsTo; auto. @@ -588,14 +588,14 @@ Proof. Qed. Hint Immediate MapsTo_1. -Lemma In_1 : +Lemma In_1 : forall m x y, X.eq x y -> In x m -> In y m. Proof. intros m x y; induction m; simpl; intuition_in; eauto. Qed. -Lemma In_node_iff : - forall l x e r h y, +Lemma In_node_iff : + forall l x e r h y, In y (Node l x e r h) <-> In y l \/ X.eq y x \/ In y r. Proof. intuition_in. @@ -613,7 +613,7 @@ Proof. unfold gt_tree in |- *; intros; intuition_in. Qed. -Lemma lt_tree_node : forall x y l r e h, +Lemma lt_tree_node : forall x y l r e h, lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y e r h). Proof. unfold lt_tree in *; intuition_in; order. @@ -627,25 +627,25 @@ Qed. Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. -Lemma lt_left : forall x y l r e h, +Lemma lt_left : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x l. Proof. intuition_in. Qed. -Lemma lt_right : forall x y l r e h, +Lemma lt_right : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x r. Proof. intuition_in. Qed. -Lemma gt_left : forall x y l r e h, +Lemma gt_left : forall x y l r e h, gt_tree x (Node l y e r h) -> gt_tree x l. Proof. intuition_in. Qed. -Lemma gt_right : forall x y l r e h, +Lemma gt_right : forall x y l r e h, gt_tree x (Node l y e r h) -> gt_tree x r. Proof. intuition_in. @@ -695,39 +695,39 @@ Qed. (** * Emptyness test *) -Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. +Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. destruct m as [|r x e l h]; simpl; auto. intro H; elim (H x e); auto. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. +Proof. destruct m; simpl; intros; try discriminate; red; intuition_in. Qed. (** * Appartness *) Lemma mem_1 : forall m x, bst m -> In x m -> mem x m = true. -Proof. +Proof. intros m x; functional induction (mem x m); auto; intros; clearf; inv bst; intuition_in; order. Qed. -Lemma mem_2 : forall m x, mem x m = true -> In x m. -Proof. +Lemma mem_2 : forall m x, mem x m = true -> In x m. +Proof. intros m x; functional induction (mem x m); auto; intros; discriminate. Qed. Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e. -Proof. +Proof. intros m x; functional induction (find x m); auto; intros; clearf; - inv bst; intuition_in; simpl; auto; + inv bst; intuition_in; simpl; auto; try solve [order | absurd (X.lt x y); eauto | absurd (X.lt y x); eauto]. Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. -Proof. +Proof. intros m x; functional induction (find x m); subst; intros; clearf; try discriminate. constructor 2; auto. @@ -735,7 +735,7 @@ Proof. constructor 3; auto. Qed. -Lemma find_iff : forall m x e, bst m -> +Lemma find_iff : forall m x e, bst m -> (find x m = Some e <-> MapsTo x e m). Proof. split; auto using find_1, find_2. @@ -745,7 +745,7 @@ Lemma find_in : forall m x, find x m <> None -> In x m. Proof. intros. case_eq (find x m); [intros|congruence]. - apply MapsTo_In with e; apply find_2; auto. + apply MapsTo_In with e; apply find_2; auto. Qed. Lemma in_find : forall m x, bst m -> In x m -> find x m <> None. @@ -755,7 +755,7 @@ Proof. rewrite (find_1 H Hd); discriminate. Qed. -Lemma find_in_iff : forall m x, bst m -> +Lemma find_in_iff : forall m x, bst m -> (find x m <> None <-> In x m). Proof. split; auto using find_in, in_find. @@ -771,11 +771,11 @@ Proof. elim H0; apply find_in; congruence. Qed. -Lemma find_find : forall m m' x, - find x m = find x m' <-> +Lemma find_find : forall m m' x, + find x m = find x m' <-> (forall d, find x m = Some d <-> find x m' = Some d). Proof. - intros; destruct (find x m); destruct (find x m'); split; intros; + intros; destruct (find x m); destruct (find x m'); split; intros; try split; try congruence. rewrite H; auto. symmetry; rewrite <- H; auto. @@ -783,7 +783,7 @@ Proof. Qed. Lemma find_mapsto_equiv : forall m m' x, bst m -> bst m' -> - (find x m = find x m' <-> + (find x m = find x m' <-> (forall d, MapsTo x d m <-> MapsTo x d m')). Proof. intros m m' x Hm Hm'. @@ -793,8 +793,8 @@ Proof. rewrite 2 find_iff; auto. Qed. -Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> - find x m = find x m' -> +Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> + find x m = find x m' -> (In x m <-> In x m'). Proof. split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ]; @@ -803,27 +803,27 @@ Qed. (** * Helper functions *) -Lemma create_bst : - forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> +Lemma create_bst : + forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (create l x e r). Proof. unfold create; auto. Qed. Hint Resolve create_bst. -Lemma create_in : - forall l x e r y, +Lemma create_in : + forall l x e r y, In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r. Proof. unfold create; split; [ inversion_clear 1 | ]; intuition. Qed. -Lemma bal_bst : forall l x e r, bst l -> bst r -> +Lemma bal_bst : forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (bal l x e r). Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv bst; repeat apply create_bst; auto; unfold create; try constructor; - (apply lt_tree_node || apply gt_tree_node); auto; + (apply lt_tree_node || apply gt_tree_node); auto; (eapply lt_tree_trans || eapply gt_tree_trans); eauto. Qed. Hint Resolve bal_bst. @@ -842,7 +842,7 @@ Proof. unfold assert_false, create; intuition_in. Qed. -Lemma bal_find : forall l x e r y, +Lemma bal_find : forall l x e r y, bst l -> bst r -> lt_tree x l -> gt_tree x r -> find y (bal l x e r) = find y (create l x e r). Proof. @@ -870,32 +870,32 @@ Qed. Hint Resolve add_bst. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). -Proof. - intros m x y e; functional induction (add x e m); +Proof. + intros m x y e; functional induction (add x e m); intros; inv bst; try rewrite bal_mapsto; unfold create; eauto. Qed. -Lemma add_2 : forall m x y e e', ~X.eq x y -> +Lemma add_2 : forall m x y e e', ~X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'; induction m; simpl; auto. destruct (X.compare x k); - intros; inv bst; try rewrite bal_mapsto; unfold create; auto; + intros; inv bst; try rewrite bal_mapsto; unfold create; auto; inv MapsTo; auto; order. Qed. -Lemma add_3 : forall m x y e e', ~X.eq x y -> +Lemma add_3 : forall m x y e e', ~X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. - intros m x y e e'; induction m; simpl; auto. + intros m x y e e'; induction m; simpl; auto. intros; inv MapsTo; auto; order. - destruct (X.compare x k); intro; - try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; + destruct (X.compare x k); intro; + try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; order. Qed. -Lemma add_find : forall m x y e, bst m -> - find y (add x e m) = +Lemma add_find : forall m x y e, bst m -> + find y (add x e m) = match X.compare y x with EQ _ => Some e | _ => find y m end. Proof. intros. @@ -909,7 +909,7 @@ Qed. (** * Extraction of minimum binding *) Lemma remove_min_in : forall l x e r h y, - In y (Node l x e r h) <-> + In y (Node l x e r h) <-> X.eq y (remove_min l x e r)#2#1 \/ In y (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -919,7 +919,7 @@ Proof. Qed. Lemma remove_min_mapsto : forall l x e r h y e', - MapsTo y e' (Node l x e r h) <-> + MapsTo y e' (Node l x e r h) <-> ((X.eq y (remove_min l x e r)#2#1) /\ e' = (remove_min l x e r)#2#2) \/ MapsTo y e' (remove_min l x e r)#1. Proof. @@ -933,7 +933,7 @@ Proof. inversion_clear H3; intuition. Qed. -Lemma remove_min_bst : forall l x e r h, +Lemma remove_min_bst : forall l x e r h, bst (Node l x e r h) -> bst (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -949,8 +949,8 @@ Proof. Qed. Hint Resolve remove_min_bst. -Lemma remove_min_gt_tree : forall l x e r h, - bst (Node l x e r h) -> +Lemma remove_min_gt_tree : forall l x e r h, + bst (Node l x e r h) -> gt_tree (remove_min l x e r)#2#1 (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -968,10 +968,10 @@ Proof. Qed. Hint Resolve remove_min_gt_tree. -Lemma remove_min_find : forall l x e r h y, - bst (Node l x e r h) -> - find y (Node l x e r h) = - match X.compare y (remove_min l x e r)#2#1 with +Lemma remove_min_find : forall l x e r h y, + bst (Node l x e r h) -> + find y (Node l x e r h) = + match X.compare y (remove_min l x e r)#2#1 with | LT _ => None | EQ _ => Some (remove_min l x e r)#2#2 | GT _ => find y (remove_min l x e r)#1 @@ -990,9 +990,9 @@ Qed. (** * Merging two trees *) -Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> +Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> (In y (merge m1 m2) <-> In y m1 \/ In y m2). -Proof. +Proof. intros m1 m2; functional induction (merge m1 m2);intros; try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. @@ -1000,10 +1000,10 @@ Proof. rewrite bal_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> +Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> (MapsTo y e (merge m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2). Proof. - intros m1 m2; functional induction (merge m1 m2); intros; + intros m1 m2; functional induction (merge m1 m2); intros; try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. intuition_in. @@ -1013,12 +1013,12 @@ Proof. inversion_clear H1; intuition. Qed. -Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> - (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> - bst (merge m1 m2). +Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> + (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> + bst (merge m1 m2). Proof. intros m1 m2; functional induction (merge m1 m2); intros; auto; - try factornode _x _x0 _x1 _x2 _x3 as m1. + try factornode _x _x0 _x1 _x2 _x3 as m1. apply bal_bst; auto. generalize (remove_min_bst H0); rewrite e1; simpl in *; auto. intro; intro. @@ -1029,7 +1029,7 @@ Qed. (** * Deletion *) -Lemma remove_in : forall m x y, bst m -> +Lemma remove_in : forall m x y, bst m -> (In y (remove x m) <-> ~ X.eq y x /\ In y m). Proof. intros m x; functional induction (remove x m); simpl; intros. @@ -1049,7 +1049,7 @@ Proof. Qed. Lemma remove_bst : forall m x, bst m -> bst (remove x m). -Proof. +Proof. intros m x; functional induction (remove x m); simpl; intros. auto. (* LT *) @@ -1061,7 +1061,7 @@ Proof. (* EQ *) inv bst. apply merge_bst; eauto. - (* GT *) + (* GT *) inv bst. apply bal_bst; auto. intro; intro. @@ -1070,16 +1070,16 @@ Proof. Qed. Lemma remove_1 : forall m x y, bst m -> X.eq x y -> ~ In y (remove x m). -Proof. +Proof. intros; rewrite remove_in; intuition. Qed. -Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y -> +Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m x y e; induction m; simpl; auto. - destruct (X.compare x k); - intros; inv bst; try rewrite bal_mapsto; unfold create; auto; + destruct (X.compare x k); + intros; inv bst; try rewrite bal_mapsto; unfold create; auto; try solve [inv MapsTo; auto]. rewrite merge_mapsto; auto. inv MapsTo; auto; order. @@ -1089,7 +1089,7 @@ Lemma remove_3 : forall m x y e, bst m -> MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m x y e; induction m; simpl; auto. - destruct (X.compare x k); intros Bs; inv bst; + destruct (X.compare x k); intros Bs; inv bst; try rewrite bal_mapsto; auto; unfold create. intros; inv MapsTo; auto. rewrite merge_mapsto; intuition. @@ -1098,7 +1098,7 @@ Qed. (** * join *) -Lemma join_in : forall l x d r y, +Lemma join_in : forall l x d r y, In y (join l x d r) <-> X.eq y x \/ In y l \/ In y r. Proof. join_tac. @@ -1110,23 +1110,23 @@ Proof. apply create_in. Qed. -Lemma join_bst : forall l x d r, bst l -> bst r -> +Lemma join_bst : forall l x d r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (join l x d r). Proof. - join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; + join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; clear Hrl Hlr z; intro; intros; rewrite join_in in *. intuition; [ apply MX.lt_eq with x | ]; eauto. intuition; [ apply MX.eq_lt with x | ]; eauto. Qed. Hint Resolve join_bst. -Lemma join_find : forall l x d r y, - bst l -> bst r -> lt_tree x l -> gt_tree x r -> +Lemma join_find : forall l x d r y, + bst l -> bst r -> lt_tree x l -> gt_tree x r -> find y (join l x d r) = find y (create l x d r). Proof. join_tac; auto; inv bst; - simpl (join (Leaf elt)); - try (assert (X.lt lx x) by auto); + simpl (join (Leaf elt)); + try (assert (X.lt lx x) by auto); try (assert (X.lt x rx) by auto); rewrite ?add_find, ?bal_find; auto. @@ -1150,10 +1150,10 @@ Qed. (** * split *) -Lemma split_in_1 : forall m x, bst m -> forall y, +Lemma split_in_1 : forall m x, bst m -> forall y, (In y (split x m)#l <-> In y m /\ X.lt y x). Proof. - intros m x; functional induction (split x m); simpl; intros; + intros m x; functional induction (split x m); simpl; intros; inv bst; try clear e0. intuition_in. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. @@ -1162,10 +1162,10 @@ Proof. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_in_2 : forall m x, bst m -> forall y, +Lemma split_in_2 : forall m x, bst m -> forall y, (In y (split x m)#r <-> In y m /\ X.lt x y). -Proof. - intros m x; functional induction (split x m); subst; simpl; intros; +Proof. + intros m x; functional induction (split x m); subst; simpl; intros; inv bst; try clear e0. intuition_in. rewrite join_in. @@ -1174,18 +1174,18 @@ Proof. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_in_3 : forall m x, bst m -> +Lemma split_in_3 : forall m x, bst m -> (split x m)#o = find x m. Proof. intros m x; functional induction (split x m); subst; simpl; auto; - intros; inv bst; try clear e0; + intros; inv bst; try clear e0; destruct X.compare; try (order;fail); rewrite <-IHt, e1; auto. Qed. -Lemma split_bst : forall m x, bst m -> +Lemma split_bst : forall m x, bst m -> bst (split x m)#l /\ bst (split x m)#r. -Proof. - intros m x; functional induction (split x m); subst; simpl; intros; +Proof. + intros m x; functional induction (split x m); subst; simpl; intros; inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition; apply join_bst; auto. intros y0. @@ -1204,17 +1204,17 @@ Proof. intros m x B y Hy; rewrite split_in_2 in Hy; intuition. Qed. -Lemma split_find : forall m x y, bst m -> - find y m = match X.compare y x with +Lemma split_find : forall m x y, bst m -> + find y m = match X.compare y x with | LT _ => find y (split x m)#l | EQ _ => (split x m)#o | GT _ => find y (split x m)#r end. Proof. - intros m x; functional induction (split x m); subst; simpl; intros; - inv bst; try clear e0; try rewrite e1 in *; simpl in *; + intros m x; functional induction (split x m); subst; simpl; intros; + inv bst; try clear e0; try rewrite e1 in *; simpl in *; [ destruct X.compare; auto | .. ]; - try match goal with E:split ?x ?t = _, B:bst ?t |- _ => + try match goal with E:split ?x ?t = _, B:bst ?t |- _ => generalize (split_in_1 x B)(split_in_2 x B)(split_bst x B); rewrite E; simpl; destruct 3 end. @@ -1231,7 +1231,7 @@ Qed. (** * Concatenation *) -Lemma concat_in : forall m1 m2 y, +Lemma concat_in : forall m1 m2 y, In y (concat m1 m2) <-> In y m1 \/ In y m2. Proof. intros m1 m2; functional induction (concat m1 m2); intros; @@ -1241,11 +1241,11 @@ Proof. rewrite join_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> - (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> +Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> + (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> bst (concat m1 m2). Proof. - intros m1 m2; functional induction (concat m1 m2); intros; auto; + intros m1 m2; functional induction (concat m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. apply join_bst; auto. change (bst (m2',xd)#1); rewrite <-e1; eauto. @@ -1256,19 +1256,19 @@ Proof. Qed. Hint Resolve concat_bst. -Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> - (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> - find y (concat m1 m2) = +Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> + (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> + find y (concat m1 m2) = match find y m2 with Some d => Some d | None => find y m1 end. Proof. - intros m1 m2; functional induction (concat m1 m2); intros; auto; + intros m1 m2; functional induction (concat m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. simpl; destruct (find y m2); auto. generalize (remove_min_find y H0)(remove_min_in l2 x2 d2 r2 _x4) - (remove_min_bst H0)(remove_min_gt_tree H0); + (remove_min_bst H0)(remove_min_gt_tree H0); rewrite e1; simpl fst; simpl snd; intros. - + inv bst. rewrite H2, join_find; auto; clear H2. simpl; destruct X.compare; simpl; auto. @@ -1286,7 +1286,7 @@ Notation eqk := (PX.eqk (elt:= elt)). Notation eqke := (PX.eqke (elt:= elt)). Notation ltk := (PX.ltk (elt:= elt)). -Lemma elements_aux_mapsto : forall (s:t elt) acc x e, +Lemma elements_aux_mapsto : forall (s:t elt) acc x e, InA eqke (x,e) (elements_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc. Proof. induction s as [ | l Hl x e r Hr h ]; simpl; auto. @@ -1299,8 +1299,8 @@ Proof. destruct H0; simpl in *; subst; intuition. Qed. -Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. -Proof. +Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. +Proof. intros; generalize (elements_aux_mapsto s nil x e); intuition. inversion_clear H0. Qed. @@ -1324,7 +1324,7 @@ Proof. induction s as [ | l Hl y e r Hr h]; simpl; intuition. inv bst. apply Hl; auto. - constructor. + constructor. apply Hr; eauto. apply (InA_InfA (PX.eqke_refl (elt:=elt))); intros (y',e') H6. destruct (elements_aux_mapsto r acc y' e'); intuition. @@ -1382,7 +1382,7 @@ Qed. (** * Fold *) -Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) := +Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) := L.fold f (elements s). Lemma fold_equiv_aux : @@ -1401,14 +1401,14 @@ Lemma fold_equiv : forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A), fold f s a = fold' f s a. Proof. - unfold fold', elements in |- *. + unfold fold', elements in |- *. simple induction s; simpl in |- *; auto; intros. rewrite fold_equiv_aux. rewrite H0. simpl in |- *; auto. Qed. -Lemma fold_1 : +Lemma fold_1 : forall (s:t elt)(Hs:bst s)(A : Type)(i:A)(f : key -> elt -> A -> A), fold f s i = fold_left (fun a p => f p#1 p#2 a) (elements s) i. Proof. @@ -1421,9 +1421,9 @@ Qed. (** * Comparison *) -(** [flatten_e e] returns the list of elements of the enumeration [e] +(** [flatten_e e] returns the list of elements of the enumeration [e] i.e. the list of elements actually compared *) - + Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with | End => nil | More x e t r => (x,e) :: elements t ++ flatten_e r @@ -1431,13 +1431,13 @@ Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with Lemma flatten_e_elements : forall (l:t elt) r x d z e, - elements l ++ flatten_e (More x d r e) = + elements l ++ flatten_e (More x d r e) = elements (Node l x d r z) ++ flatten_e e. Proof. intros; simpl; apply elements_node. Qed. -Lemma cons_1 : forall (s:t elt) e, +Lemma cons_1 : forall (s:t elt) e, flatten_e (cons s e) = elements s ++ flatten_e e. Proof. induction s; simpl; auto; intros. @@ -1450,24 +1450,24 @@ Variable cmp : elt->elt->bool. Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b. -Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, - X.eq x1 x2 -> cmp d1 d2 = true -> - IfEq b l1 l2 -> +Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, + X.eq x1 x2 -> cmp d1 d2 = true -> + IfEq b l1 l2 -> IfEq b ((x1,d1)::l1) ((x2,d2)::l2). Proof. - unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; + unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; try rewrite H0; auto; order. Qed. -Lemma equal_end_IfEq : forall e2, +Lemma equal_end_IfEq : forall e2, IfEq (equal_end e2) nil (flatten_e e2). Proof. destruct e2; red; auto. Qed. -Lemma equal_more_IfEq : - forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, - IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> +Lemma equal_more_IfEq : + forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, + IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l) (flatten_e (More x2 d2 r2 e2)). Proof. @@ -1475,7 +1475,7 @@ Proof. rewrite <-andb_lazy_alt; f_equal; auto. Qed. -Lemma equal_cont_IfEq : forall m1 cont e2 l, +Lemma equal_cont_IfEq : forall m1 cont e2 l, (forall e, IfEq (cont e) l (flatten_e e)) -> IfEq (equal_cont cmp m1 cont e2) (elements m1 ++ l) (flatten_e e2). Proof. @@ -1493,18 +1493,18 @@ Lemma equal_IfEq : forall (m1 m2:t elt), Proof. intros; unfold equal. rewrite (app_nil_end (elements m1)). - replace (elements m2) with (flatten_e (cons m2 (End _))) + replace (elements m2) with (flatten_e (cons m2 (End _))) by (rewrite cons_1; simpl; rewrite <-app_nil_end; auto). apply equal_cont_IfEq. intros. apply equal_end_IfEq; auto. Qed. -Definition Equivb m m' := - (forall k, In k m <-> In k m') /\ +Definition Equivb m m' := + (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Lemma Equivb_elements : forall s s', +Lemma Equivb_elements : forall s s', Equivb s s' <-> L.Equivb cmp (elements s) (elements s'). Proof. unfold Equivb, L.Equivb; split; split; intros. @@ -1516,7 +1516,7 @@ destruct H. apply (H2 k); unfold L.PX.MapsTo; rewrite elements_mapsto; auto. Qed. -Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' -> +Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' -> (equal cmp s s' = true <-> Equivb s s'). Proof. intros s s' B B'. @@ -1526,17 +1526,17 @@ Qed. End Elt. -Section Map. +Section Map. Variable elt elt' : Type. -Variable f : elt -> elt'. +Variable f : elt -> elt'. -Lemma map_1 : forall (m: t elt)(x:key)(e:elt), +Lemma map_1 : forall (m: t elt)(x:key)(e:elt), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. induction m; simpl; inversion_clear 1; auto. Qed. -Lemma map_2 : forall (m: t elt)(x:key), +Lemma map_2 : forall (m: t elt)(x:key), In x (map f m) -> In x m. Proof. induction m; simpl; inversion_clear 1; auto. @@ -1545,7 +1545,7 @@ Qed. Lemma map_bst : forall m, bst m -> bst (map f m). Proof. induction m; simpl; auto. -inversion_clear 1; constructor; auto; +inversion_clear 1; constructor; auto; red; auto using map_2. Qed. @@ -1554,7 +1554,7 @@ Section Mapi. Variable elt elt' : Type. Variable f : key -> elt -> elt'. -Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), +Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. induction m; simpl; inversion_clear 1; auto. @@ -1565,7 +1565,7 @@ destruct (IHm2 _ _ H0). exists x0; intuition. Qed. -Lemma mapi_2 : forall (m: t elt)(x:key), +Lemma mapi_2 : forall (m: t elt)(x:key), In x (mapi f m) -> In x m. Proof. induction m; simpl; inversion_clear 1; auto. @@ -1574,7 +1574,7 @@ Qed. Lemma mapi_bst : forall m, bst m -> bst (mapi f m). Proof. induction m; simpl; auto. -inversion_clear 1; constructor; auto; +inversion_clear 1; constructor; auto; red; auto using mapi_2. Qed. @@ -1585,7 +1585,7 @@ Variable elt elt' : Type. Variable f : key -> elt -> option elt'. Hypothesis f_compat : forall x x' d, X.eq x x' -> f x d = f x' d. -Lemma map_option_2 : forall (m:t elt)(x:key), +Lemma map_option_2 : forall (m:t elt)(x:key), In x (map_option f m) -> exists d, MapsTo x d m /\ f x d <> None. Proof. intros m; functional induction (map_option f m); simpl; auto; intros. @@ -1601,9 +1601,9 @@ Qed. Lemma map_option_bst : forall m, bst m -> bst (map_option f m). Proof. -intros m; functional induction (map_option f m); simpl; auto; intros; +intros m; functional induction (map_option f m); simpl; auto; intros; inv bst. -apply join_bst; auto; intros y H; +apply join_bst; auto; intros y H; destruct (map_option_2 H) as (d0 & ? & ?); eauto using MapsTo_In. apply concat_bst; auto; intros y y' H H'. destruct (map_option_2 H) as (d0 & ? & ?). @@ -1612,22 +1612,22 @@ eapply X.lt_trans with x; eauto using MapsTo_In. Qed. Hint Resolve map_option_bst. -Ltac nonify e := - replace e with (@None elt) by +Ltac nonify e := + replace e with (@None elt) by (symmetry; rewrite not_find_iff; auto; intro; order). -Lemma map_option_find : forall (m:t elt)(x:key), - bst m -> - find x (map_option f m) = +Lemma map_option_find : forall (m:t elt)(x:key), + bst m -> + find x (map_option f m) = match (find x m) with Some d => f x d | None => None end. Proof. intros m; functional induction (map_option f m); simpl; auto; intros; - inv bst; rewrite join_find || rewrite concat_find; auto; simpl; + inv bst; rewrite join_find || rewrite concat_find; auto; simpl; try destruct X.compare; simpl; auto. rewrite (f_compat d e); auto. intros y H; destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. -intros y H; +intros y H; destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. rewrite <- IHt, IHt0; auto; nonify (find x0 r); auto. @@ -1653,21 +1653,21 @@ Variable mapr : t elt' -> t elt''. Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o. Hypothesis mapl_bst : forall m, bst m -> bst (mapl m). Hypothesis mapr_bst : forall m', bst m' -> bst (mapr m'). -Hypothesis mapl_f0 : forall x m, bst m -> - find x (mapl m) = +Hypothesis mapl_f0 : forall x m, bst m -> + find x (mapl m) = match find x m with Some d => f0 x (Some d) None | None => None end. -Hypothesis mapr_f0 : forall x m', bst m' -> - find x (mapr m') = +Hypothesis mapr_f0 : forall x m', bst m' -> + find x (mapr m') = match find x m' with Some d' => f0 x None (Some d') | None => None end. Hypothesis f0_compat : forall x x' o o', X.eq x x' -> f0 x o o' = f0 x' o o'. Notation map2_opt := (map2_opt f mapl mapr). -Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> +Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> In y (map2_opt m m') -> In y m \/ In y m'. Proof. intros m m'; functional induction (map2_opt m m'); intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; try (generalize (split_in_1 x1 H0 y)(split_in_2 x1 H0 y) (split_bst x1 H0); rewrite e1; simpl; destruct 3; inv bst). @@ -1689,12 +1689,12 @@ destruct (IHt1 y H6 H4 H'); intuition. destruct (IHt0 y H7 H5 H'); intuition. Qed. -Lemma map2_opt_bst : forall m m', bst m -> bst m' -> +Lemma map2_opt_bst : forall m m', bst m -> bst m' -> bst (map2_opt m m'). Proof. intros m m'; functional induction (map2_opt m m'); intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; - generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; + generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); rewrite e1; simpl in *; destruct 3. apply join_bst; auto. @@ -1711,31 +1711,31 @@ destruct (map2_opt_2 H2 H7 Hy'); intuition. Qed. Hint Resolve map2_opt_bst. -Ltac map2_aux := +Ltac map2_aux := match goal with - | H : In ?x _ \/ In ?x ?m, - H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => - destruct H; [ intuition_in; order | + | H : In ?x _ \/ In ?x ?m, + H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => + destruct H; [ intuition_in; order | rewrite <-(find_in_equiv B B' H'); auto ] end. -Ltac nonify t := - match t with (find ?y (map2_opt ?m ?m')) => +Ltac nonify t := + match t with (find ?y (map2_opt ?m ?m')) => replace t with (@None elt''); [ | symmetry; rewrite not_find_iff; auto; intro; destruct (@map2_opt_2 m m' y); auto; order ] end. -Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> +Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> In y m \/ In y m' -> find y (map2_opt m m') = f0 y (find y m) (find y m'). Proof. intros m m'; functional induction (map2_opt m m'); intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; try (generalize (split_in_1 x1 H0)(split_in_2 x1 H0) (split_in_3 x1 H0)(split_bst x1 H0)(split_find x1 y H0) (split_lt_tree (x:=x1) H0)(split_gt_tree (x:=x1) H0); - rewrite e1; simpl in *; destruct 4; intros; inv bst; + rewrite e1; simpl in *; destruct 4; intros; inv bst; subst o2; rewrite H7, ?join_find, ?concat_find; auto). simpl; destruct H1; [ inversion_clear H1 | ]. @@ -1777,19 +1777,19 @@ Variable f : option elt -> option elt' -> option elt''. Lemma map2_bst : forall m m', bst m -> bst m' -> bst (map2 f m m'). Proof. unfold map2; intros. -apply map2_opt_bst with (fun _ => f); auto using map_option_bst; +apply map2_opt_bst with (fun _ => f); auto using map_option_bst; intros; rewrite map_option_find; auto. Qed. -Lemma map2_1 : forall m m' y, bst m -> bst m' -> +Lemma map2_1 : forall m m' y, bst m -> bst m' -> In y m \/ In y m' -> find y (map2 f m m') = f (find y m) (find y m'). Proof. unfold map2; intros. -rewrite (map2_opt_1 (f0:=fun _ => f)); +rewrite (map2_opt_1 (f0:=fun _ => f)); auto using map_option_bst; intros; rewrite map_option_find; auto. Qed. -Lemma map2_2 : forall m m' y, bst m -> bst m' -> +Lemma map2_2 : forall m m' y, bst m -> bst m' -> In y (map2 f m m') -> In y m \/ In y m'. Proof. unfold map2; intros. @@ -1806,38 +1806,38 @@ End Raw. (** * Encapsulation - Now, in order to really provide a functor implementing [S], we + Now, in order to really provide a functor implementing [S], we need to encapsulate everything into a type of balanced binary search trees. *) Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Module E := X. - Module Raw := Raw I X. + Module Raw := Raw I X. Import Raw.Proofs. - Record bst (elt:Type) := + Record bst (elt:Type) := Bst {this :> Raw.tree elt; is_bst : Raw.bst this}. - - Definition t := bst. + + Definition t := bst. Definition key := E.t. - - Section Elt. + + Section Elt. Variable elt elt' elt'': Type. Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. + Implicit Types x y : key. + Implicit Types e : elt. Definition empty : t elt := Bst (empty_bst elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Bst (add_bst x e m.(is_bst)). - Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). + Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). Definition mem x m : bool := Raw.mem x m.(this). Definition find x m : option elt := Raw.find x m.(this). Definition map f m : t elt' := Bst (map_bst f m.(is_bst)). - Definition mapi (f:key->elt->elt') m : t elt' := + Definition mapi (f:key->elt->elt') m : t elt' := Bst (mapi_bst f m.(is_bst)). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Bst (map2_bst f m.(is_bst) m'.(is_bst)). Definition elements m : list (key*elt) := Raw.elements m.(this). Definition cardinal m := Raw.cardinal m.(this). @@ -1854,14 +1854,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. - + Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. apply m.(is_bst). Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. + + Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. Qed. @@ -1892,7 +1892,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@find_2 elt m.(this)). Qed. @@ -1901,36 +1901,36 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. - Lemma elements_1 : forall m x e, + Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. Qed. - Lemma elements_2 : forall m x e, + Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). + Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp := Equiv (Cmp cmp). - Lemma Equivb_Equivb : forall cmp m m', + Lemma Equivb_Equivb : forall cmp m m', Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. + Proof. intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. @@ -1938,23 +1938,23 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. generalize (H0 k); do 2 rewrite <- In_alt; intuition. Qed. - Lemma equal_1 : forall m m' cmp, - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; + Lemma equal_1 : forall m m' cmp, + Equivb cmp m m' -> equal cmp m m' = true. + Proof. + unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite equal_Equivb; auto. - Qed. + Qed. - Lemma equal_2 : forall m m' cmp, + Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. - unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; + Proof. + unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite <-equal_Equivb; auto. Qed. End Elt. - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. @@ -1962,10 +1962,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. apply map_2; auto. - Qed. + Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -1975,10 +1975,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. apply m.(is_bst). @@ -1986,9 +1986,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. + Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. apply m.(is_bst). @@ -1998,19 +1998,19 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. End IntMake. -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D +Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: + Sord with Module Data := D with Module MapS.E := X. Module Data := D. - Module Import MapS := IntMake(I)(X). + Module Import MapS := IntMake(I)(X). Module LO := FMapList.Make_ord(X)(D). Module R := Raw. Module P := Raw.Proofs. Definition t := MapS.t D.t. - Definition cmp e e' := + Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. (** One step of comparison of elements *) @@ -2020,9 +2020,9 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: | R.End => Gt | R.More x2 d2 r2 e2 => match X.compare x1 x2 with - | EQ _ => match D.compare d1 d2 with + | EQ _ => match D.compare d1 d2 with | EQ _ => cont (R.cons r2 e2) - | LT _ => Lt + | LT _ => Lt | GT _ => Gt end | LT _ => Lt @@ -2046,7 +2046,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: (** The complete comparison *) - Definition compare_pure s1 s2 := + Definition compare_pure s1 s2 := compare_cont s1 compare_end (R.cons s2 (Raw.End _)). (** Correctness of this comparison *) @@ -2058,7 +2058,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: | Gt => (fun l1 l2 => LO.lt_list l2 l1) end. - Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, + Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. @@ -2077,10 +2077,10 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l) (P.flatten_e (R.More x2 d2 r2 e2)). Proof. - simpl; intros; destruct X.compare; simpl; + simpl; intros; destruct X.compare; simpl; try destruct D.compare; simpl; auto; P.MX.elim_comp; auto. Qed. - + Lemma compare_cont_Cmp : forall s1 cont e2 l, (forall e, Cmp (cont e) l (P.flatten_e e)) -> Cmp (compare_cont s1 cont e2) (R.elements s1 ++ l) (P.flatten_e e2). @@ -2114,10 +2114,10 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: generalize (compare_Cmp s s'). destruct compare_pure; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. - + (* Proofs about [eq] and [lt] *) - Definition selements (m1 : t) := + Definition selements (m1 : t) := LO.MapS.Build_slist (P.elements_sort m1.(is_bst)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). @@ -2154,7 +2154,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Qed. Lemma eq_refl : forall m : t, eq m m. - Proof. + Proof. intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. Qed. @@ -2171,13 +2171,13 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. - intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; + intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; intros; eapply LO.lt_trans; eauto. Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. - intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; + intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; intros; apply LO.lt_not_eq; auto. Qed. @@ -2188,8 +2188,8 @@ End IntMake_ord. Module Make (X: OrderedType) <: S with Module E := X :=IntMake(Z_as_Int)(X). -Module Make_ord (X: OrderedType)(D: OrderedType) - <: Sord with Module Data := D +Module Make_ord (X: OrderedType)(D: OrderedType) + <: Sord with Module Data := D with Module MapS.E := X :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index e09db9b6e8..88ca717e2b 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -11,12 +11,12 @@ (** * Finite maps library *) (** This functor derives additional facts from [FMapInterface.S]. These - facts are mainly the specifications of [FMapInterface.S] written using - different styles: equivalence and boolean equalities. + facts are mainly the specifications of [FMapInterface.S] written using + different styles: equivalence and boolean equalities. *) Require Import Bool DecidableType DecidableTypeEx OrderedType Morphisms. -Require Export FMapInterface. +Require Export FMapInterface. Set Implicit Arguments. Unset Strict Implicit. @@ -46,7 +46,7 @@ destruct o; destruct o'; try rewrite H; auto. symmetry; rewrite <- H; auto. Qed. -Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), +Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), MapsTo x e m -> MapsTo x e' m -> e=e'. Proof. intros. @@ -56,7 +56,7 @@ Qed. (** ** Specifications written using equivalences *) -Section IffSpec. +Section IffSpec. Variable elt elt' elt'': Type. Implicit Type m: t elt. Implicit Type x y z: key. @@ -112,7 +112,7 @@ destruct mem; intuition. Qed. Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true. -Proof. +Proof. split; [apply equal_1|apply equal_2]. Qed. @@ -127,16 +127,16 @@ unfold In. split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition. Qed. -Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. -Proof. +Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. +Proof. split; [apply is_empty_1|apply is_empty_2]. Qed. -Lemma add_mapsto_iff : forall m x y e e', - MapsTo y e' (add x e m) <-> - (E.eq x y /\ e=e') \/ +Lemma add_mapsto_iff : forall m x y e e', + MapsTo y e' (add x e m) <-> + (E.eq x y /\ e=e') \/ (~E.eq x y /\ MapsTo y e' m). -Proof. +Proof. intros. intuition. destruct (eq_dec x y); [left|right]. @@ -147,7 +147,7 @@ subst; auto with map. Qed. Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m. -Proof. +Proof. unfold In; split. intros (e',H). destruct (eq_dec x y) as [E|E]; auto. @@ -161,13 +161,13 @@ destruct E; auto. exists e'; apply add_2; auto. Qed. -Lemma add_neq_mapsto_iff : forall m x y e e', +Lemma add_neq_mapsto_iff : forall m x y e e', ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). Proof. split; [apply add_3|apply add_2]; auto. Qed. -Lemma add_neq_in_iff : forall m x y e, +Lemma add_neq_in_iff : forall m x y e, ~ E.eq x y -> (In y (add x e m) <-> In y m). Proof. split; intros (e',H0); exists e'. @@ -175,9 +175,9 @@ apply (add_3 H H0). apply add_2; auto. Qed. -Lemma remove_mapsto_iff : forall m x y e, +Lemma remove_mapsto_iff : forall m x y e, MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. -Proof. +Proof. intros. split; intros. split. @@ -188,7 +188,7 @@ apply remove_2; intuition. Qed. Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m. -Proof. +Proof. unfold In; split. intros (e,H). split. @@ -198,13 +198,13 @@ exists e; apply remove_3 with x; auto. intros (H,(e,H0)); exists e; apply remove_2; auto. Qed. -Lemma remove_neq_mapsto_iff : forall m x y e, +Lemma remove_neq_mapsto_iff : forall m x y e, ~ E.eq x y -> (MapsTo y e (remove x m) <-> MapsTo y e m). Proof. split; [apply remove_3|apply remove_2]; auto. Qed. -Lemma remove_neq_in_iff : forall m x y, +Lemma remove_neq_in_iff : forall m x y, ~ E.eq x y -> (In y (remove x m) <-> In y m). Proof. split; intros (e',H0); exists e'. @@ -212,19 +212,19 @@ apply (remove_3 H0). apply remove_2; auto. Qed. -Lemma elements_mapsto_iff : forall m x e, +Lemma elements_mapsto_iff : forall m x e, MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m). -Proof. +Proof. split; [apply elements_1 | apply elements_2]. Qed. -Lemma elements_in_iff : forall m x, +Lemma elements_in_iff : forall m x, In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m). -Proof. +Proof. unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto. Qed. -Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), +Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. Proof. split. @@ -240,7 +240,7 @@ intros (a,(H,H0)). subst b; auto with map. Qed. -Lemma map_in_iff : forall m x (f : elt -> elt'), +Lemma map_in_iff : forall m x (f : elt -> elt'), In x (map f m) <-> In x m. Proof. split; intros; eauto with map. @@ -257,11 +257,11 @@ destruct (mapi_1 f H) as (y,(H0,H1)). exists (f y a); auto. Qed. -(** Unfortunately, we don't have simple equivalences for [mapi] - and [MapsTo]. The only correct one needs compatibility of [f]. *) +(** Unfortunately, we don't have simple equivalences for [mapi] + and [MapsTo]. The only correct one needs compatibility of [f]. *) -Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), - MapsTo x b (mapi f m) -> +Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), + MapsTo x b (mapi f m) -> exists a, exists y, E.eq y x /\ b = f y a /\ MapsTo x a m. Proof. intros; case_eq (find x m); intros. @@ -275,8 +275,8 @@ destruct (mapi_2 H1) as (a,H2). rewrite (find_1 H2) in H0; discriminate. Qed. -Lemma mapi_1bis : forall m x e (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> +Lemma mapi_1bis : forall m x e (f:key->elt->elt'), + (forall x y e, E.eq x y -> f x e = f y e) -> MapsTo x e m -> MapsTo x (f x e) (mapi f m). Proof. intros. @@ -286,7 +286,7 @@ auto. Qed. Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> + (forall x y e, E.eq x y -> f x e = f y e) -> (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). Proof. split. @@ -299,14 +299,14 @@ subst b. apply mapi_1bis; auto. Qed. -(** Things are even worse for [map2] : we don't try to state any +(** Things are even worse for [map2] : we don't try to state any equivalence, see instead boolean results below. *) End IffSpec. (** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *) - -Ltac map_iff := + +Ltac map_iff := repeat (progress ( rewrite add_mapsto_iff || rewrite add_in_iff || rewrite remove_mapsto_iff || rewrite remove_in_iff || @@ -318,7 +318,7 @@ Ltac map_iff := Section BoolSpec. -Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. +Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. Proof. intros. generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In. @@ -336,7 +336,7 @@ Implicit Types x y z : key. Implicit Types e : elt. Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m. -Proof. +Proof. intros. generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H). destruct (mem x m); destruct (mem y m); intuition. @@ -362,14 +362,14 @@ generalize (mem_2 H). rewrite empty_in_iff; intuition. Qed. -Lemma add_eq_o : forall m x y e, +Lemma add_eq_o : forall m x y e, E.eq x y -> find y (add x e m) = Some e. Proof. auto with map. Qed. -Lemma add_neq_o : forall m x y e, - ~ E.eq x y -> find y (add x e m) = find y m. +Lemma add_neq_o : forall m x y e, + ~ E.eq x y -> find y (add x e m) = find y m. Proof. intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. apply add_neq_mapsto_iff; auto. @@ -382,26 +382,26 @@ Proof. intros; destruct (eq_dec x y); auto with map. Qed. -Lemma add_eq_b : forall m x y e, +Lemma add_eq_b : forall m x y e, E.eq x y -> mem y (add x e m) = true. Proof. intros; rewrite mem_find_b; rewrite add_eq_o; auto. Qed. -Lemma add_neq_b : forall m x y e, +Lemma add_neq_b : forall m x y e, ~E.eq x y -> mem y (add x e m) = mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto. Qed. -Lemma add_b : forall m x y e, - mem y (add x e m) = eqb x y || mem y m. +Lemma add_b : forall m x y e, + mem y (add x e m) = eqb x y || mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb. destruct (eq_dec x y); simpl; auto. Qed. -Lemma remove_eq_o : forall m x y, +Lemma remove_eq_o : forall m x y, E.eq x y -> find y (remove x m) = None. Proof. intros. rewrite eq_option_alt. intro e. @@ -442,14 +442,14 @@ intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. destruct (eq_dec x y); auto. Qed. -Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := - match o with +Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := + match o with | Some a => Some (f a) | None => None end. -Lemma map_o : forall m x (f:elt->elt'), - find x (map f m) = option_map f (find x m). +Lemma map_o : forall m x (f:elt->elt'), + find x (map f m) = option_map f (find x m). Proof. intros. generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x) @@ -463,14 +463,14 @@ rewrite H0 in H2; discriminate. rewrite <- H; rewrite H1; exists e; rewrite H0; auto. Qed. -Lemma map_b : forall m x (f:elt->elt'), +Lemma map_b : forall m x (f:elt->elt'), mem x (map f m) = mem x m. Proof. intros; do 2 rewrite mem_find_b; rewrite map_o. destruct (find x m); simpl; auto. Qed. -Lemma mapi_b : forall m x (f:key->elt->elt'), +Lemma mapi_b : forall m x (f:key->elt->elt'), mem x (mapi f m) = mem x m. Proof. intros. @@ -480,12 +480,12 @@ symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto. rewrite <- H; rewrite H1; rewrite H0; auto. Qed. -Lemma mapi_o : forall m x (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> +Lemma mapi_o : forall m x (f:key->elt->elt'), + (forall x y e, E.eq x y -> f x e = f y e) -> find x (mapi f m) = option_map (f x) (find x m). Proof. intros. -generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) +generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) (fun b => mapi_mapsto_iff m x b H). destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros. rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto. @@ -496,9 +496,9 @@ rewrite H1 in H3; discriminate. rewrite <- H0; rewrite H2; exists e; rewrite H1; auto. Qed. -Lemma map2_1bis : forall (m: t elt)(m': t elt') x - (f:option elt->option elt'->option elt''), - f None None = None -> +Lemma map2_1bis : forall (m: t elt)(m': t elt') x + (f:option elt->option elt'->option elt''), + f None None = None -> find x (map2 f m m') = f (find x m) (find x m'). Proof. intros. @@ -598,7 +598,7 @@ Section Cmp. Variable eq_elt : elt->elt->Prop. Variable cmp : elt->elt->bool. -Definition compat_cmp := +Definition compat_cmp := forall e e', cmp e e' = true <-> eq_elt e e'. Lemma Equiv_Equivb : compat_cmp -> @@ -613,17 +613,17 @@ End Cmp. (** Composition of the two last results: relation between [Equal] and [Equivb]. *) -Lemma Equal_Equivb : forall cmp, - (forall e e', cmp e e' = true <-> e = e') -> +Lemma Equal_Equivb : forall cmp, + (forall e e', cmp e e' = true <-> e = e') -> forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. Proof. intros; rewrite Equal_Equiv. apply Equiv_Equivb; auto. Qed. -Lemma Equal_Equivb_eqdec : +Lemma Equal_Equivb_eqdec : forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }), - let cmp := fun e e' => if eq_elt_dec e e' then true else false in + let cmp := fun e e' => if eq_elt_dec e e' then true else false in forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. Proof. intros; apply Equal_Equivb. @@ -638,11 +638,11 @@ End Equalities. Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m. Proof. red; reflexivity. Qed. -Lemma Equal_sym : forall (elt:Type)(m m' : t elt), +Lemma Equal_sym : forall (elt:Type)(m m' : t elt), Equal m m' -> Equal m' m. Proof. unfold Equal; auto. Qed. -Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), +Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), Equal m m' -> Equal m' m'' -> Equal m m''. Proof. unfold Equal; congruence. Qed. @@ -651,15 +651,15 @@ Proof. constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans]. Qed. -Add Relation key E.eq - reflexivity proved by E.eq_refl +Add Relation key E.eq + reflexivity proved by E.eq_refl symmetry proved by E.eq_sym - transitivity proved by E.eq_trans + transitivity proved by E.eq_trans as KeySetoid. Implicit Arguments Equal [[elt]]. -Add Parametric Relation (elt : Type) : (t elt) Equal +Add Parametric Relation (elt : Type) : (t elt) Equal reflexivity proved by (@Equal_refl elt) symmetry proved by (@Equal_sym elt) transitivity proved by (@Equal_trans elt) @@ -762,7 +762,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Notation eqke := (@eq_key_elt elt). Notation eqk := (@eq_key elt). - + (** Complements about InA, NoDupA and findA *) Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l, @@ -1205,19 +1205,19 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). apply fold_Add with (eqA:=Leibniz); compute; auto. Qed. - Lemma cardinal_inv_1 : forall m : t elt, + Lemma cardinal_inv_1 : forall m : t elt, cardinal m = 0 -> Empty m. Proof. - intros; rewrite cardinal_Empty; auto. + intros; rewrite cardinal_Empty; auto. Qed. Hint Resolve cardinal_inv_1 : map. Lemma cardinal_inv_2 : forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }. - Proof. + Proof. intros; rewrite M.cardinal_1 in *. generalize (elements_mapsto_iff m). - destruct (elements m); try discriminate. + destruct (elements m); try discriminate. exists p; auto. rewrite H0; destruct p; simpl; auto. constructor; red; auto. @@ -1243,16 +1243,16 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). (** * Emulation of some functions lacking in the interface *) - Definition filter (f : key -> elt -> bool)(m : t elt) := + Definition filter (f : key -> elt -> bool)(m : t elt) := fold (fun k e m => if f k e then add k e m else m) m (empty _). - Definition for_all (f : key -> elt -> bool)(m : t elt) := + Definition for_all (f : key -> elt -> bool)(m : t elt) := fold (fun k e b => if f k e then b else false) m true. - Definition exists_ (f : key -> elt -> bool)(m : t elt) := + Definition exists_ (f : key -> elt -> bool)(m : t elt) := fold (fun k e b => if f k e then true else b) m false. - Definition partition (f : key -> elt -> bool)(m : t elt) := + Definition partition (f : key -> elt -> bool)(m : t elt) := (filter f m, filter (fun k e => negb (f k e)) m). (** [update] adds to [m1] all the bindings of [m2]. It can be seen as @@ -1762,7 +1762,7 @@ Module OrdProperties (M:S). Import F. Import M. - Section Elt. + Section Elt. Variable elt:Type. Notation eqke := (@eqke elt). @@ -1780,7 +1780,7 @@ Module OrdProperties (M:S). Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. Proof. - apply SortA_equivlistA_eqlistA; eauto; + apply SortA_equivlistA_eqlistA; eauto; unfold O.eqke, O.ltk; simpl; intuition; eauto. Qed. @@ -1788,7 +1788,7 @@ Module OrdProperties (M:S). Definition gtb (p p':key*elt) := match E.compare (fst p) (fst p') with GT _ => true | _ => false end. - Definition leb p := fun p' => negb (gtb p p'). + Definition leb p := fun p' => negb (gtb p p'). Definition elements_lt p m := List.filter (gtb p) (elements m). Definition elements_ge p m := List.filter (leb p) (elements m). @@ -1808,7 +1808,7 @@ Module OrdProperties (M:S). Lemma gtb_compat : forall p, compat_bool eqke (gtb p). Proof. red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. - generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); + generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto. unfold O.ltk in *; simpl in *; intros. symmetry; rewrite H2. @@ -1828,7 +1828,7 @@ Module OrdProperties (M:S). Hint Resolve gtb_compat leb_compat elements_3 : map. - Lemma elements_split : forall p m, + Lemma elements_split : forall p m, elements m = elements_lt p m ++ elements_ge p m. Proof. unfold elements_lt, elements_ge, leb; intros. @@ -1841,8 +1841,8 @@ Module OrdProperties (M:S). unfold O.ltk in *; simpl in *; ME.order. Qed. - Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> - eqlistA eqke (elements m') + Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> + eqlistA eqke (elements m') (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m). Proof. intros; unfold elements_lt, elements_ge. @@ -1890,8 +1890,8 @@ Module OrdProperties (M:S). right; split; auto; ME.order. Qed. - Lemma elements_Add_Above : forall m m' x e, - Above x m -> Add x e m m' -> + Lemma elements_Add_Above : forall m m' x e, + Above x m -> Add x e m m' -> eqlistA eqke (elements m') (elements m ++ (x,e)::nil). Proof. intros. @@ -1919,8 +1919,8 @@ Module OrdProperties (M:S). ME.order. Qed. - Lemma elements_Add_Below : forall m m' x e, - Below x m -> Add x e m m' -> + Lemma elements_Add_Below : forall m m' x e, + Below x m -> Add x e m m' -> eqlistA eqke (elements m') ((x,e)::elements m). Proof. intros. @@ -1949,7 +1949,7 @@ Module OrdProperties (M:S). ME.order. Qed. - Lemma elements_Equal_eqlistA : forall (m m': t elt), + Lemma elements_Equal_eqlistA : forall (m m': t elt), Equal m m' -> eqlistA eqke (elements m) (elements m'). Proof. intros. @@ -1964,15 +1964,15 @@ Module OrdProperties (M:S). Section Min_Max_Elt. (** We emulate two [max_elt] and [min_elt] functions. *) - - Fixpoint max_elt_aux (l:list (key*elt)) := match l with - | nil => None + + Fixpoint max_elt_aux (l:list (key*elt)) := match l with + | nil => None | (x,e)::nil => Some (x,e) | (x,e)::l => max_elt_aux l end. Definition max_elt m := max_elt_aux (elements m). - Lemma max_elt_Above : + Lemma max_elt_Above : forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). Proof. red; intros. @@ -2011,8 +2011,8 @@ Module OrdProperties (M:S). red; eauto. inversion H2; auto. Qed. - - Lemma max_elt_MapsTo : + + Lemma max_elt_MapsTo : forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. Proof. intros. @@ -2025,7 +2025,7 @@ Module OrdProperties (M:S). constructor 2; auto. Qed. - Lemma max_elt_Empty : + Lemma max_elt_Empty : forall m, max_elt m = None -> Empty m. Proof. intros. @@ -2036,12 +2036,12 @@ Module OrdProperties (M:S). assert (H':=IHl H); discriminate. Qed. - Definition min_elt m : option (key*elt) := match elements m with + Definition min_elt m : option (key*elt) := match elements m with | nil => None | (x,e)::_ => Some (x,e) end. - Lemma min_elt_Below : + Lemma min_elt_Below : forall m x e, min_elt m = Some (x,e) -> Below x (remove x m). Proof. unfold min_elt, Below; intros. @@ -2061,8 +2061,8 @@ Module OrdProperties (M:S). intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto. intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto. Qed. - - Lemma min_elt_MapsTo : + + Lemma min_elt_MapsTo : forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. Proof. intros. @@ -2074,7 +2074,7 @@ Module OrdProperties (M:S). injection H; intros; subst; constructor; red; auto. Qed. - Lemma min_elt_Empty : + Lemma min_elt_Empty : forall m, min_elt m = None -> Empty m. Proof. intros. @@ -2109,7 +2109,7 @@ Module OrdProperties (M:S). assert (S n = S (cardinal (remove k m))). rewrite Heqn. eapply cardinal_2; eauto with map. - inversion H1; auto. + inversion H1; auto. eapply max_elt_Above; eauto. apply X; apply max_elt_Empty; auto. @@ -2136,7 +2136,7 @@ Module OrdProperties (M:S). assert (S n = S (cardinal (remove k m))). rewrite Heqn. eapply cardinal_2; eauto with map. - inversion H1; auto. + inversion H1; auto. eapply min_elt_Below; eauto. apply X; apply min_elt_Empty; auto. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 3ebb0c1afb..52766bf967 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -12,18 +12,18 @@ (* $Id$ *) (** * FMapFullAVL - + This file contains some complements to [FMapAVL]. - - Functor [AvlProofs] proves that trees of [FMapAVL] are not only + - Functor [AvlProofs] proves that trees of [FMapAVL] are not only binary search trees, but moreover well-balanced ones. This is done by proving that all operations preserve the balancing. - - - We then pack the previous elements in a [IntMake] functor + + - We then pack the previous elements in a [IntMake] functor similar to the one of [FMapAVL], but richer. - - In final [IntMake_ord] functor, the [compare] function is - different from the one in [FMapAVL]: this non-structural + - In final [IntMake_ord] functor, the [compare] function is + different from the one in [FMapAVL]: this non-structural version is closer to the original Ocaml code. *) @@ -54,11 +54,11 @@ Implicit Types m r : t elt. Inductive avl : t elt -> Prop := | RBLeaf : avl (Leaf _) - | RBNode : forall x e l r h, + | RBNode : forall x e l r h, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - h = max (height l) (height r) + 1 -> + h = max (height l) (height r) + 1 -> avl (Node l x e r h). @@ -66,28 +66,28 @@ Inductive avl : t elt -> Prop := Hint Constructors avl. -Lemma height_non_negative : forall (s : t elt), avl s -> +Lemma height_non_negative : forall (s : t elt), avl s -> height s >= 0. Proof. induction s; simpl; intros; auto with zarith. inv avl; intuition; omega_max. Qed. -Ltac avl_nn_hyp H := +Ltac avl_nn_hyp H := let nz := fresh "nz" in assert (nz := height_non_negative H). -Ltac avl_nn h := - let t := type of h in - match type of t with +Ltac avl_nn h := + let t := type of h in + match type of t with | Prop => avl_nn_hyp h | _ => match goal with H : avl h |- _ => avl_nn_hyp H end end. -(* Repeat the previous tactic. +(* Repeat the previous tactic. Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) Ltac avl_nns := - match goal with + match goal with | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns | _ => idtac end. @@ -105,7 +105,7 @@ Hint Resolve avl_node. (** Results about [height] *) -Lemma height_0 : forall l, avl l -> height l = 0 -> +Lemma height_0 : forall l, avl l -> height l = 0 -> l = Leaf _. Proof. destruct 1; intuition; simpl in *. @@ -116,38 +116,38 @@ Qed. (** * Empty map *) Lemma empty_avl : avl (empty elt). -Proof. +Proof. unfold empty; auto. Qed. (** * Helper functions *) -Lemma create_avl : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma create_avl : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> avl (create l x e r). Proof. unfold create; auto. Qed. -Lemma create_height : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma create_height : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> height (create l x e r) = max (height l) (height r) + 1. Proof. unfold create; intros; auto. Qed. -Lemma bal_avl : forall l x e r, avl l -> avl r -> +Lemma bal_avl : forall l x e r, avl l -> avl r -> -(3) <= height l - height r <= 3 -> avl (bal l x e r). Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; - inv avl; simpl in *; + inv avl; simpl in *; match goal with |- avl (assert_false _ _ _ _) => avl_nns | _ => repeat apply create_avl; simpl in *; auto end; omega_max. Qed. -Lemma bal_height_1 : forall l x e r, avl l -> avl r -> +Lemma bal_height_1 : forall l x e r, avl l -> avl r -> -(3) <= height l - height r <= 3 -> 0 <= height (bal l x e r) - max (height l) (height r) <= 1. Proof. @@ -155,25 +155,25 @@ Proof. inv avl; avl_nns; simpl in *; omega_max. Qed. -Lemma bal_height_2 : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma bal_height_2 : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> height (bal l x e r) == max (height l) (height r) +1. Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv avl; avl_nns; simpl in *; omega_max. Qed. -Ltac omega_bal := match goal with - | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => - generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); +Ltac omega_bal := match goal with + | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => + generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); omega_max end. (** * Insertion *) -Lemma add_avl_1 : forall m x e, avl m -> +Lemma add_avl_1 : forall m x e, avl m -> avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1. -Proof. +Proof. intros m x e; functional induction (add x e m); intros; inv avl; simpl in *. intuition; try constructor; simpl; auto; try omega_max. (* LT *) @@ -198,8 +198,8 @@ Hint Resolve add_avl. (** * Extraction of minimum binding *) -Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> - avl (remove_min l x e r)#1 /\ +Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> + avl (remove_min l x e r)#1 /\ 0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -212,20 +212,20 @@ Proof. omega_bal. Qed. -Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> - avl (remove_min l x e r)#1. +Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> + avl (remove_min l x e r)#1. Proof. intros; generalize (remove_min_avl_1 H); intuition. Qed. (** * Merging two trees *) -Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> - -(2) <= height m1 - height m2 <= 2 -> - avl (merge m1 m2) /\ +Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> + -(2) <= height m1 - height m2 <= 2 -> + avl (merge m1 m2) /\ 0<= height (merge m1 m2) - max (height m1) (height m2) <=1. Proof. - intros m1 m2; functional induction (merge m1 m2); intros; + intros m1 m2; functional induction (merge m1 m2); intros; try factornode _x _x0 _x1 _x2 _x3 as m1. simpl; split; auto; avl_nns; omega_max. simpl; split; auto; avl_nns; omega_max. @@ -237,16 +237,16 @@ Proof. omega_bal. Qed. -Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> +Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2). -Proof. +Proof. intros; generalize (merge_avl_1 H H0 H1); intuition. Qed. (** * Deletion *) -Lemma remove_avl_1 : forall m x, avl m -> +Lemma remove_avl_1 : forall m x, avl m -> avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1. Proof. intros m x; functional induction (remove x m); intros. @@ -254,25 +254,25 @@ Proof. (* LT *) inv avl. destruct (IHt H0). - split. + split. apply bal_avl; auto. omega_max. omega_bal. (* EQ *) - inv avl. + inv avl. generalize (merge_avl_1 H0 H1 H2). intuition omega_max. (* GT *) inv avl. destruct (IHt H1). - split. + split. apply bal_avl; auto. omega_max. omega_bal. Qed. Lemma remove_avl : forall m x, avl m -> avl (remove x m). -Proof. +Proof. intros; generalize (remove_avl_1 x H); intuition. Qed. Hint Resolve remove_avl. @@ -280,7 +280,7 @@ Hint Resolve remove_avl. (** * Join *) -Lemma join_avl_1 : forall l x d r, avl l -> avl r -> +Lemma join_avl_1 : forall l x d r, avl l -> avl r -> avl (join l x d r) /\ 0<= height (join l x d r) - max (height l) (height r) <= 1. Proof. @@ -346,9 +346,9 @@ Hint Resolve concat_avl. (** split *) -Lemma split_avl : forall m x, avl m -> +Lemma split_avl : forall m x, avl m -> avl (split x m)#l /\ avl (split x m)#r. -Proof. +Proof. intros m x; functional induction (split x m); simpl; auto. rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. simpl; inversion_clear 1; auto. @@ -358,12 +358,12 @@ Qed. End Elt. Hint Constructors avl. -Section Map. +Section Map. Variable elt elt' : Type. -Variable f : elt -> elt'. +Variable f : elt -> elt'. Lemma map_height : forall m, height (map f m) = height m. -Proof. +Proof. destruct m; simpl; auto. Qed. @@ -377,10 +377,10 @@ End Map. Section Mapi. Variable elt elt' : Type. -Variable f : key -> elt -> elt'. +Variable f : key -> elt -> elt'. Lemma mapi_height : forall m, height (mapi f m) = height m. -Proof. +Proof. destruct m; simpl; auto. Qed. @@ -392,7 +392,7 @@ Qed. End Mapi. -Section Map_option. +Section Map_option. Variable elt elt' : Type. Variable f : key -> elt -> option elt'. @@ -414,12 +414,12 @@ Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m'). Notation map2_opt := (map2_opt f mapl mapr). -Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> +Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2_opt m1 m2). Proof. -intros m1 m2; functional induction (map2_opt m1 m2); auto; -factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; -destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl; +intros m1 m2; functional induction (map2_opt m1 m2); auto; +factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; +destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl; auto using join_avl, concat_avl. Qed. @@ -439,11 +439,11 @@ End AvlProofs. (** * Encapsulation - We can implement [S] with balanced binary search trees. + We can implement [S] with balanced binary search trees. When compared to [FMapAVL], we maintain here two invariants (bst and avl) instead of only bst, which is enough for fulfilling the FMap interface. -*) +*) Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. @@ -452,32 +452,32 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Import Raw. Import Raw.Proofs. - Record bbst (elt:Type) := + Record bbst (elt:Type) := Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}. - + Definition t := bbst. Definition key := E.t. - + Section Elt. Variable elt elt' elt'': Type. Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. + Implicit Types x y : key. + Implicit Types e : elt. Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt). Definition is_empty m : bool := is_empty m.(this). - Definition add x e m : t elt := + Definition add x e m : t elt := Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)). - Definition remove x m : t elt := + Definition remove x m : t elt := Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)). Definition mem x m : bool := mem x m.(this). Definition find x m : option elt := find x m.(this). - Definition map f m : t elt' := + Definition map f m : t elt' := Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). - Definition mapi (f:key->elt->elt') m : t elt' := + Definition mapi (f:key->elt->elt') m : t elt' := Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)). Definition elements m : list (key*elt) := elements m.(this). Definition cardinal m := cardinal m.(this). @@ -494,14 +494,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. - + Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. apply m.(is_bst). Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. + + Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. Qed. @@ -532,7 +532,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@find_2 elt m.(this)). Qed. @@ -541,36 +541,36 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. - Lemma elements_1 : forall m x e, + Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. Qed. - Lemma elements_2 : forall m x e, + Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). + Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed. Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp := Equiv (Cmp cmp). - Lemma Equivb_Equivb : forall cmp m m', + Lemma Equivb_Equivb : forall cmp m m', Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. + Proof. intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. @@ -578,23 +578,23 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. generalize (H0 k); do 2 rewrite <- In_alt; intuition. Qed. - Lemma equal_1 : forall m m' cmp, - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; + Lemma equal_1 : forall m m' cmp, + Equivb cmp m m' -> equal cmp m m' = true. + Proof. + unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite equal_Equivb; auto. - Qed. + Qed. - Lemma equal_2 : forall m m' cmp, + Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. - unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; + Proof. + unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite <-equal_Equivb; auto. Qed. End Elt. - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. @@ -602,10 +602,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. apply map_2; auto. - Qed. + Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -615,10 +615,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. apply m.(is_bst). @@ -626,9 +626,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. + Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. apply m.(is_bst). @@ -638,54 +638,54 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. End IntMake. -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D +Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: + Sord with Module Data := D with Module MapS.E := X. Module Data := D. - Module Import MapS := IntMake(I)(X). + Module Import MapS := IntMake(I)(X). Import AvlProofs. Import Raw.Proofs. Module Import MD := OrderedTypeFacts(D). Module LO := FMapList.Make_ord(X)(D). - Definition t := MapS.t D.t. + Definition t := MapS.t D.t. - Definition cmp e e' := + Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. - Definition elements (m:t) := + Definition elements (m:t) := LO.MapS.Build_slist (Raw.Proofs.elements_sort m.(is_bst)). - (** * As comparison function, we propose here a non-structural - version faithful to the code of Ocaml's Map library, instead of + (** * As comparison function, we propose here a non-structural + version faithful to the code of Ocaml's Map library, instead of the structural version of FMapAVL *) - Fixpoint cardinal_e (e:Raw.enumeration D.t) := - match e with + Fixpoint cardinal_e (e:Raw.enumeration D.t) := + match e with | Raw.End => 0%nat | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e) end. - Lemma cons_cardinal_e : forall m e, + Lemma cons_cardinal_e : forall m e, cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat. Proof. induction m; simpl; intros; auto. rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith. Qed. - Definition cardinal_e_2 ee := + Definition cardinal_e_2 ee := (cardinal_e (fst ee) + cardinal_e (snd ee))%nat. - Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t) - { measure cardinal_e_2 ee } : comparison := - match ee with + Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t) + { measure cardinal_e_2 ee } : comparison := + match ee with | (Raw.End, Raw.End) => Eq | (Raw.End, Raw.More _ _ _ _) => Lt | (Raw.More _ _ _ _, Raw.End) => Gt | (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) => match X.compare x1 x2 with - | EQ _ => match D.compare d1 d2 with + | EQ _ => match D.compare d1 d2 with | EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2) | LT _ => Lt | GT _ => Gt @@ -695,10 +695,10 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: end end. Proof. - intros; unfold cardinal_e_2; simpl; + intros; unfold cardinal_e_2; simpl; abstract (do 2 rewrite cons_cardinal_e; romega with * ). Defined. - + Definition Cmp c := match c with | Eq => LO.eq_list @@ -706,7 +706,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: | Gt => (fun l1 l2 => LO.lt_list l2 l1) end. - Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, + Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. @@ -714,23 +714,23 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Qed. Hint Resolve cons_Cmp. - Lemma compare_aux_Cmp : forall e, + Lemma compare_aux_Cmp : forall e, Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)). Proof. - intros e; functional induction (compare_aux e); simpl in *; + intros e; functional induction (compare_aux e); simpl in *; auto; intros; try clear e0; try clear e3; try MX.elim_comp; auto. rewrite 2 cons_1 in IHc; auto. Qed. - Lemma compare_Cmp : forall m1 m2, - Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) + Lemma compare_Cmp : forall m1 m2, + Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) (Raw.elements m1) (Raw.elements m2). Proof. - intros. + intros. assert (H1:=cons_1 m1 (Raw.End _)). assert (H2:=cons_1 m2 (Raw.End _)). simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2. - apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), + apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))). Qed. @@ -744,10 +744,10 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. - + (* Proofs about [eq] and [lt] *) - Definition selements (m1 : t) := + Definition selements (m1 : t) := LO.MapS.Build_slist (elements_sort m1.(is_bst)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). @@ -784,7 +784,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Qed. Lemma eq_refl : forall m : t, eq m m. - Proof. + Proof. intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. Qed. @@ -801,13 +801,13 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. - intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; + intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; intros; eapply LO.lt_trans; eauto. Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. - intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; + intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; intros; apply LO.lt_not_eq; auto. Qed. @@ -818,8 +818,8 @@ End IntMake_ord. Module Make (X: OrderedType) <: S with Module E := X :=IntMake(Z_as_Int)(X). -Module Make_ord (X: OrderedType)(D: OrderedType) - <: Sord with Module Data := D +Module Make_ord (X: OrderedType)(D: OrderedType) + <: Sord with Module Data := D with Module MapS.E := X :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index ebc99933b5..cd51b2affe 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -8,7 +8,7 @@ (* $Id$ *) -(** * Finite map library *) +(** * Finite map library *) (** This file proposes interfaces for finite maps *) @@ -16,8 +16,8 @@ Require Export Bool DecidableType OrderedType. Set Implicit Arguments. Unset Strict Implicit. -(** When compared with Ocaml Map, this signature has been split in - several parts : +(** When compared with Ocaml Map, this signature has been split in + several parts : - The first parts [WSfun] and [WS] propose signatures for weak maps, which are maps with no ordering on the key type nor the @@ -29,18 +29,18 @@ Unset Strict Implicit. (add, find, ...). The only function that asks for more is [equal], whose first argument should be a comparison on data. - - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the - case where the key type is ordered. The main novelty is that + - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the + case where the key type is ordered. The main novelty is that [elements] is required to produce sorted lists. - - Finally, [Sord] extends [S] with a complete comparison function. For - that, the data type should have a decidable total ordering as well. + - Finally, [Sord] extends [S] with a complete comparison function. For + that, the data type should have a decidable total ordering as well. If unsure, what you're looking for is probably [S]: apart from [Sord], - all other signatures are subsets of [S]. + all other signatures are subsets of [S]. + + Some additional differences with Ocaml: - Some additional differences with Ocaml: - - no [iter] function, useless since Coq is purely functional - [option] types are used instead of [Not_found] exceptions - more functions are provided: [elements] and [cardinal] and [map2] @@ -51,7 +51,7 @@ Unset Strict Implicit. Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. (** ** Weak signature for maps - + No requirements for an ordering on keys nor elements, only decidability of equality on keys. First, a functorial signature: *) @@ -61,8 +61,8 @@ Module Type WSfun (E : DecidableType). Parameter t : Type -> Type. (** the abstract type of maps *) - - Section Types. + + Section Types. Variable elt:Type. @@ -73,61 +73,61 @@ Module Type WSfun (E : DecidableType). (** Test whether a map is empty or not. *) Parameter add : key -> elt -> t elt -> t elt. - (** [add x y m] returns a map containing the same bindings as [m], - plus a binding of [x] to [y]. If [x] was already bound in [m], + (** [add x y m] returns a map containing the same bindings as [m], + plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) - Parameter find : key -> t elt -> option elt. - (** [find x m] returns the current binding of [x] in [m], + Parameter find : key -> t elt -> option elt. + (** [find x m] returns the current binding of [x] in [m], or [None] if no such binding exists. *) Parameter remove : key -> t elt -> t elt. - (** [remove x m] returns a map containing the same bindings as [m], + (** [remove x m] returns a map containing the same bindings as [m], except for [x] which is unbound in the returned map. *) Parameter mem : key -> t elt -> bool. - (** [mem x m] returns [true] if [m] contains a binding for [x], + (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) Variable elt' elt'' : Type. Parameter map : (elt -> elt') -> t elt -> t elt'. - (** [map f m] returns a map with same domain as [m], where the associated + (** [map f m] returns a map with same domain as [m], where the associated value a of all bindings of [m] has been replaced by the result of the application of [f] to [a]. Since Coq is purely functional, the order in which the bindings are passed to [f] is irrelevant. *) Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. - (** Same as [map], but the function receives as arguments both the + (** Same as [map], but the function receives as arguments both the key and the associated value for each binding of the map. *) - Parameter map2 : + Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt''. - (** [map2 f m m'] creates a new map whose bindings belong to the ones - of either [m] or [m']. The presence and value for a key [k] is - determined by [f e e'] where [e] and [e'] are the (optional) bindings + (** [map2 f m m'] creates a new map whose bindings belong to the ones + of either [m] or [m']. The presence and value for a key [k] is + determined by [f e e'] where [e] and [e'] are the (optional) bindings of [k] in [m] and [m']. *) Parameter elements : t elt -> list (key*elt). - (** [elements m] returns an assoc list corresponding to the bindings + (** [elements m] returns an assoc list corresponding to the bindings of [m], in any order. *) - Parameter cardinal : t elt -> nat. + Parameter cardinal : t elt -> nat. (** [cardinal m] returns the number of bindings in [m]. *) Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A. - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1] ... [kN] are the keys of all bindings in [m] + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1] ... [kN] are the keys of all bindings in [m] (in any order), and [d1] ... [dN] are the associated data. *) Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. - (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, - that is, contain equal keys and associate them with equal data. - [cmp] is the equality predicate used to compare the data associated + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, + that is, contain equal keys and associate them with equal data. + [cmp] is the equality predicate used to compare the data associated with the keys. *) - Section Spec. - + Section Spec. + Variable m m' m'' : t elt. Variable x y z : key. Variable e e' : elt. @@ -139,24 +139,24 @@ Module Type WSfun (E : DecidableType). Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':key*elt) := + + Definition eq_key_elt (p p':key*elt) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). (** Specification of [MapsTo] *) Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. - + (** Specification of [mem] *) Parameter mem_1 : In x m -> mem x m = true. - Parameter mem_2 : mem x m = true -> In x m. - + Parameter mem_2 : mem x m = true -> In x m. + (** Specification of [empty] *) Parameter empty_1 : Empty empty. (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty m -> is_empty m = true. + Parameter is_empty_1 : Empty m -> is_empty m = true. Parameter is_empty_2 : is_empty m = true -> Empty m. - + (** Specification of [add] *) Parameter add_1 : E.eq x y -> MapsTo y e (add x e m). Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). @@ -168,50 +168,50 @@ Module Type WSfun (E : DecidableType). Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. (** Specification of [find] *) - Parameter find_1 : MapsTo x e m -> find x m = Some e. + Parameter find_1 : MapsTo x e m -> find x m = Some e. Parameter find_2 : find x m = Some e -> MapsTo x e m. (** Specification of [elements] *) - Parameter elements_1 : + Parameter elements_1 : MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Parameter elements_2 : + Parameter elements_2 : InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - (** When compared with ordered maps, here comes the only + (** When compared with ordered maps, here comes the only property that is really weaker: *) - Parameter elements_3w : NoDupA eq_key (elements m). + Parameter elements_3w : NoDupA eq_key (elements m). (** Specification of [cardinal] *) Parameter cardinal_1 : cardinal m = length (elements m). - (** Specification of [fold] *) + (** Specification of [fold] *) Parameter fold_1 : forall (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. (** Equality of maps *) - + (** Caveat: there are at least three distinct equality predicates on maps. - - The simpliest (and maybe most natural) way is to consider keys up to - their equivalence [E.eq], but elements up to Leibniz equality, in + - The simpliest (and maybe most natural) way is to consider keys up to + their equivalence [E.eq], but elements up to Leibniz equality, in the spirit of [eq_key_elt] above. This leads to predicate [Equal]. - Unfortunately, this [Equal] predicate can't be used to describe - the [equal] function, since this function (for compatibility with - ocaml) expects a boolean comparison [cmp] that may identify more - elements than Leibniz. So logical specification of [equal] is done + the [equal] function, since this function (for compatibility with + ocaml) expects a boolean comparison [cmp] that may identify more + elements than Leibniz. So logical specification of [equal] is done via another predicate [Equivb] - This predicate [Equivb] is quite ad-hoc with its boolean [cmp], it can be generalized in a [Equiv] expecting a more general (possibly non-decidable) equality predicate on elements *) Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). (** Specification of [equal] *) - Variable cmp : elt -> elt -> bool. + Variable cmp : elt -> elt -> bool. Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true. Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'. @@ -220,26 +220,26 @@ Module Type WSfun (E : DecidableType). End Types. (** Specification of [map] *) - Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. - + (** Specification of [mapi] *) Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. (** Specification of [map2] *) Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Hint Immediate MapsTo_1 mem_2 is_empty_2 @@ -252,11 +252,11 @@ Module Type WSfun (E : DecidableType). End WSfun. -(** ** Static signature for Weak Maps +(** ** Static signature for Weak Maps Similar to [WSfun] but expressed in a self-contained way. *) -Module Type WS. +Module Type WS. Declare Module E : DecidableType. Include Type WSfun E. End WS. @@ -274,7 +274,7 @@ Module Type Sfun (E : OrderedType). Parameter elements_3 : forall m, sort lt_key (elements m). (** Remark: since [fold] is specified via [elements], this stronger specification of [elements] has an indirect impact on [fold], - which can now be proved to receive elements in increasing order. *) + which can now be proved to receive elements in increasing order. *) End elt. End Sfun. @@ -282,7 +282,7 @@ End Sfun. (** ** Maps on ordered keys, self-contained signature *) -Module Type S. +Module Type S. Declare Module E : OrderedType. Include Type Sfun E. End S. @@ -293,28 +293,28 @@ End S. Module Type Sord. - Declare Module Data : OrderedType. - Declare Module MapS : S. + Declare Module Data : OrderedType. + Declare Module MapS : S. Import MapS. - - Definition t := MapS.t Data.t. + + Definition t := MapS.t Data.t. Parameter eq : t -> t -> Prop. - Parameter lt : t -> t -> Prop. - + Parameter lt : t -> t -> Prop. + Axiom eq_refl : forall m : t, eq m m. Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. - Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end. + Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end. Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'. Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'. Parameter compare : forall m1 m2, Compare lt eq m1 m2. - (** Total ordering between maps. [Data.compare] is a total ordering + (** Total ordering between maps. [Data.compare] is a total ordering used to compare data associated with equal keys in the two maps. *) End Sord. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index a99c6a9089..4c21e17387 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -30,7 +30,7 @@ Definition t (elt:Type) := list (X.t * elt). Section Elt. Variable elt : Type. -Notation eqk := (eqk (elt:=elt)). +Notation eqk := (eqk (elt:=elt)). Notation eqke := (eqke (elt:=elt)). Notation ltk := (ltk (elt:=elt)). Notation MapsTo := (MapsTo (elt:=elt)). @@ -45,7 +45,7 @@ Definition empty : t elt := nil. Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. Lemma empty_1 : Empty empty. -Proof. +Proof. unfold Empty,empty. intros a e. intro abs. @@ -54,7 +54,7 @@ Qed. Hint Resolve empty_1. Lemma empty_sorted : Sort empty. -Proof. +Proof. unfold empty; auto. Qed. @@ -62,7 +62,7 @@ Qed. Definition is_empty (l : t elt) : bool := if l then true else false. -Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. +Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. Proof. unfold Empty, PX.MapsTo. intros m. @@ -72,7 +72,7 @@ Proof. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. +Proof. intros m. case m;auto. intros p l abs. @@ -93,12 +93,12 @@ Function mem (k : key) (s : t elt) {struct s} : bool := end. Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true. -Proof. - intros m Hm x; generalize Hm; clear Hm. +Proof. + intros m Hm x; generalize Hm; clear Hm. functional induction (mem x m);intros sorted belong1;trivial. - + inversion belong1. inversion H. - + absurd (In x ((k', _x) :: l));try assumption. apply Sort_Inf_NotIn with _x;auto. @@ -107,13 +107,13 @@ Proof. elim (In_inv belong1);auto. intro abs. absurd (X.eq x k');auto. -Qed. +Qed. -Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. +Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. Proof. intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail). - exists _x; auto. + exists _x; auto. induction IHb; auto. exists x0; auto. inversion_clear sorted; auto. @@ -124,7 +124,7 @@ Qed. Function find (k:key) (s: t elt) {struct s} : option elt := match s with | nil => None - | (k',x)::s' => + | (k',x)::s' => match X.compare k k' with | LT _ => None | EQ _ => Some x @@ -138,7 +138,7 @@ Proof. functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto. Qed. -Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. +Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. Proof. intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (find x m);simpl; subst; try clear H_eq_1. @@ -150,9 +150,9 @@ Proof. clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. clear e1;inversion_clear 2. - compute in H0; destruct H0; intuition congruence. + compute in H0; destruct H0; intuition congruence. generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. - + clear e1; do 2 inversion_clear 1; auto. compute in H2; destruct H2; order. Qed. @@ -177,10 +177,10 @@ Proof. functional induction (add x e m);simpl;auto. Qed. -Lemma add_2 : forall m x y e e', +Lemma add_2 : forall m x y e e', ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. - intros m x y e e'. + intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m) ;simpl;auto; clear e0. subst;auto. @@ -191,7 +191,7 @@ Proof. auto. intros y' e'' eqky'; inversion_clear 1; intuition. Qed. - + Lemma add_3 : forall m x y e e', ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. @@ -200,15 +200,15 @@ Proof. functional induction (add x e' m);simpl; intros. apply (In_inv_3 H0); compute; auto. apply (In_inv_3 H0); compute; auto. - constructor 2; apply (In_inv_3 H0); compute; auto. + constructor 2; apply (In_inv_3 H0); compute; auto. inversion_clear H0; auto. Qed. -Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), +Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). Proof. - induction m. + induction m. simpl; intuition. intros. destruct a as (x'',e''). @@ -227,7 +227,7 @@ Proof. simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. constructor; auto. apply Inf_eq with (x',e'); auto. -Qed. +Qed. (** * [remove] *) @@ -240,48 +240,48 @@ Function remove (k : key) (s : t elt) {struct s} : t elt := | EQ _ => l | GT _ => (k',x) :: remove k l end - end. + end. Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m). Proof. intros m Hm x y; generalize Hm; clear Hm. functional induction (remove x m);simpl;intros;subst. - + red; inversion 1; inversion H1. apply Sort_Inf_NotIn with x0; auto. clear e0;constructor; compute; order. - + clear e0;inversion_clear Hm. - apply Sort_Inf_NotIn with x0; auto. + apply Sort_Inf_NotIn with x0; auto. apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto. clear e0;inversion_clear Hm. assert (notin:~ In y (remove x l)) by auto. intros (x1,abs). - inversion_clear abs. + inversion_clear abs. compute in H2; destruct H2; order. apply notin; exists x1; auto. Qed. -Lemma remove_2 : forall m (Hm:Sort m) x y e, +Lemma remove_2 : forall m (Hm:Sort m) x y e, ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. - functional induction (remove x m);subst;auto; - match goal with + functional induction (remove x m);subst;auto; + match goal with | [H: X.compare _ _ = _ |- _ ] => clear H | _ => idtac end. inversion_clear 3; auto. compute in H1; destruct H1; order. - + inversion_clear 1; inversion_clear 2; auto. Qed. -Lemma remove_3 : forall m (Hm:Sort m) x y e, +Lemma remove_3 : forall m (Hm:Sort m) x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -289,10 +289,10 @@ Proof. inversion_clear 1; inversion_clear 1; auto. Qed. -Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), +Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), Inf (x',e') m -> Inf (x',e') (remove x m). Proof. - induction m. + induction m. simpl; intuition. intros. destruct a as (x'',e''). @@ -311,31 +311,31 @@ Proof. intros. destruct a as (x',e'). simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. -Qed. +Qed. (** * [elements] *) Definition elements (m: t elt) := m. -Lemma elements_1 : forall m x e, +Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). Proof. auto. Qed. -Lemma elements_2 : forall m x e, +Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. -Proof. +Proof. auto. Qed. -Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). -Proof. +Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). +Proof. auto. Qed. -Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). -Proof. +Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). +Proof. intros. apply Sort_NoDupA. apply elements_3; auto. @@ -351,30 +351,30 @@ Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} : A := Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. -Proof. +Proof. intros; functional induction (fold f m i); auto. Qed. (** * [equal] *) -Function equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := - match m, m' with +Function equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := + match m, m' with | nil, nil => true - | (x,e)::l, (x',e')::l' => - match X.compare x x' with + | (x,e)::l, (x',e')::l' => + match X.compare x x' with | EQ _ => cmp e e' && equal cmp l l' | _ => false - end - | _, _ => false + end + | _, _ => false end. -Definition Equivb cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). +Definition Equivb cmp m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. +Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, + Equivb cmp m m' -> equal cmp m m' = true. +Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; intuition; subst. @@ -407,7 +407,7 @@ Proof. destruct (X.compare x x'); try contradiction; clear y. destruct (H0 x). - assert (In x ((x',e')::l')). + assert (In x ((x',e')::l')). apply H; auto. exists e; auto. destruct (In_inv H3). @@ -418,7 +418,7 @@ Proof. elim (Sort_Inf_NotIn H5 H7 H4). destruct (H0 x'). - assert (In x' ((x,e)::l)). + assert (In x' ((x,e)::l)). apply H2; auto. exists e'; auto. destruct (In_inv H3). @@ -430,7 +430,7 @@ Proof. destruct m; destruct m';try contradiction. - + clear H1;destruct p as (k,e). destruct (H0 k). destruct H1. @@ -447,18 +447,18 @@ Proof. Qed. -Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, +Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. - functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; - intuition; try discriminate; subst; + functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; + intuition; try discriminate; subst; try match goal with H: X.compare _ _ = _ |- _ => clear H end. inversion H0. inversion_clear Hm;inversion_clear Hm'. - destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H); clear H. destruct (IHb H1 H3 H6). destruct (In_inv H0). exists e'; constructor; split; trivial; apply X.eq_trans with x; auto. @@ -467,7 +467,7 @@ Proof. exists e''; auto. inversion_clear Hm;inversion_clear Hm'. - destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H); clear H. destruct (IHb H1 H3 H6). destruct (In_inv H0). exists e; constructor; split; trivial; apply X.eq_trans with x'; auto. @@ -476,15 +476,15 @@ Proof. exists e''; auto. inversion_clear Hm;inversion_clear Hm'. - destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H); clear H. destruct (IHb H2 H4 H7). inversion_clear H0. destruct H9; simpl in *; subst. - inversion_clear H1. + inversion_clear H1. destruct H9; simpl in *; subst; auto. elim (Sort_Inf_NotIn H4 H5). exists e'0; apply MapsTo_eq with k; auto; order. - inversion_clear H1. + inversion_clear H1. destruct H0; simpl in *; subst; auto. elim (Sort_Inf_NotIn H2 H3). exists e0; apply MapsTo_eq with k; auto; order. @@ -494,7 +494,7 @@ Qed. (** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *) Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> - eqk x y -> cmp (snd x) (snd y) = true -> + eqk x y -> cmp (snd x) (snd y) = true -> (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). Proof. intros. @@ -517,7 +517,7 @@ Qed. Variable elt':Type. (** * [map] and [mapi] *) - + Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' := match m with | nil => nil @@ -531,24 +531,24 @@ Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' := end. End Elt. -Section Elt2. -(* A new section is necessary for previous definitions to work +Section Elt2. +(* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) - + Variable elt elt' : Type. (** Specification of [map] *) -Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), +Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. @@ -556,15 +556,15 @@ Proof. unfold MapsTo in *; auto. Qed. -Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), +Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -578,9 +578,9 @@ Proof. Qed. Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'), - lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt) (x,e) m -> lelistA (@ltk elt') (x,e') (map f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x0,e0). @@ -589,30 +589,30 @@ Qed. Hint Resolve map_lelistA. -Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), +Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), sort (@ltk elt') (map f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x',e'). inversion_clear Hm. constructor; auto. exact (map_lelistA _ _ H0). -Qed. - +Qed. + (** Specification of [mapi] *) -Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> +Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros m x e f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. exists x'. destruct H0; simpl in *. @@ -621,18 +621,18 @@ Proof. unfold eqke in *; simpl in *; intuition congruence. destruct IHm as (y, hyp); auto. exists y; intuition. -Qed. +Qed. -Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), +Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -646,9 +646,9 @@ Proof. Qed. Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'), - lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt) (x,e) m -> lelistA (@ltk elt') (x,f x e) (mapi f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x',e'). @@ -657,7 +657,7 @@ Qed. Hint Resolve mapi_lelistA. -Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), +Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), sort (@ltk elt') (mapi f m). Proof. induction m; simpl; auto. @@ -666,7 +666,7 @@ Proof. inversion_clear Hm; auto. Qed. -End Elt2. +End Elt2. Section Elt3. (** * [map2] *) @@ -674,27 +674,27 @@ Section Elt3. Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. -Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := - match o with +Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := + match o with | Some e => (k,e)::l | None => l end. -Fixpoint map2_l (m : t elt) : t elt'' := - match m with - | nil => nil +Fixpoint map2_l (m : t elt) : t elt'' := + match m with + | nil => nil | (k,e)::l => option_cons k (f (Some e) None) (map2_l l) - end. + end. -Fixpoint map2_r (m' : t elt') : t elt'' := - match m' with - | nil => nil +Fixpoint map2_r (m' : t elt') : t elt'' := + match m' with + | nil => nil | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l') - end. + end. Fixpoint map2 (m : t elt) : t elt' -> t elt'' := match m with - | nil => map2_r + | nil => map2_r | (k,e) :: l => fix map2_aux (m' : t elt') : t elt'' := match m' with @@ -706,7 +706,7 @@ Fixpoint map2 (m : t elt) : t elt' -> t elt'' := | GT _ => option_cons k' (f None (Some e')) (map2_aux l') end end - end. + end. Notation oee' := (option elt * option elt')%type. @@ -724,14 +724,14 @@ Fixpoint combine (m : t elt) : t elt' -> t oee' := | GT _ => (k',(None,Some e'))::combine_aux l' end end - end. + end. -Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := +Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := List.fold_right (fun p => f (fst p) (snd p)) i l. -Definition map2_alt m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in +Definition map2_alt m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in fold_right_pair (option_cons (A:=elt'')) m1 nil. Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'. @@ -758,20 +758,20 @@ Proof. apply IHm'. Qed. -Lemma combine_lelistA : - forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), - lelistA (@ltk elt) (x,e) m -> - lelistA (@ltk elt') (x,e') m' -> +Lemma combine_lelistA : + forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,e') m' -> lelistA (@ltk oee') (x,e'') (combine m m'). Proof. - induction m. + induction m. intros. simpl. exact (map_lelistA _ _ H0). - induction m'. + induction m'. intros. destruct a. - replace (combine ((t0, e0) :: m) nil) with + replace (combine ((t0, e0) :: m) nil) with (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. exact (map_lelistA _ _ H). intros. @@ -784,18 +784,18 @@ Proof. Qed. Hint Resolve combine_lelistA. -Lemma combine_sorted : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), +Lemma combine_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), sort (@ltk oee') (combine m m'). Proof. - induction m. + induction m. intros; clear Hm. simpl. apply map_sorted; auto. - induction m'. + induction m'. intros; clear Hm'. destruct a. - replace (combine ((t0, e) :: m) nil) with + replace (combine ((t0, e) :: m) nil) with (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. apply map_sorted; auto. intros. @@ -805,11 +805,11 @@ Proof. inversion_clear Hm. constructor; auto. assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto. - exact (combine_lelistA _ H0 H1). + exact (combine_lelistA _ H0 H1). inversion_clear Hm; inversion_clear Hm'. constructor; auto. assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto). - exact (combine_lelistA _ H0 H3). + exact (combine_lelistA _ H0 H3). inversion_clear Hm; inversion_clear Hm'. constructor; auto. change (lelistA (ltk (elt:=oee')) (k', (None, Some e')) @@ -818,8 +818,8 @@ Proof. exact (combine_lelistA _ H3 H2). Qed. -Lemma map2_sorted : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), +Lemma map2_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), sort (@ltk elt'') (map2 m m'). Proof. intros. @@ -829,7 +829,7 @@ Proof. set (l0:=combine m m') in *; clearbody l0. set (f':= fun p : oee' => f (fst p) (snd p)). assert (H1:=map_sorted (elt' := option elt'') H0 f'). - set (l1:=map f' l0) in *; clearbody l1. + set (l1:=map f' l0) in *; clearbody l1. clear f' f H0 l0 Hm Hm' m m'. induction l1. simpl; auto. @@ -848,16 +848,16 @@ Proof. apply IHl1; auto. apply Inf_lt with (t1, None (A:=elt'')); auto. Qed. - -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None + +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => Some (o,o') end. -Lemma combine_1 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), - find x (combine m m') = at_least_one (find x m) (find x m'). +Lemma combine_1 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). Proof. induction m. intros. @@ -881,32 +881,32 @@ Proof. destruct a as (k,e); destruct a0 as (k',e'); simpl. inversion Hm; inversion Hm'; subst. destruct (X.compare k k'); simpl; - destruct (X.compare x k); + destruct (X.compare x k); elim_comp || destruct (X.compare x k'); simpl; auto. rewrite IHm; auto; simpl; elim_comp; auto. rewrite IHm; auto; simpl; elim_comp; auto. rewrite IHm; auto; simpl; elim_comp; auto. change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). - rewrite IHm'; auto. + rewrite IHm'; auto. simpl find; elim_comp; auto. change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). - rewrite IHm'; auto. + rewrite IHm'; auto. simpl find; elim_comp; auto. - change (find x (combine ((k, e) :: m) m') = + change (find x (combine ((k, e) :: m) m') = at_least_one (find x m) (find x m')). - rewrite IHm'; auto. + rewrite IHm'; auto. simpl find; elim_comp; auto. Qed. -Definition at_least_one_then_f (o:option elt)(o':option elt') := - match o, o' with - | None, None => None +Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => f o o' end. -Lemma map2_0 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), - find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). +Lemma map2_0 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). Proof. intros. rewrite <- map2_alt_equiv. @@ -915,7 +915,7 @@ Proof. assert (H2:=combine_sorted Hm Hm'). set (f':= fun p : oee' => f (fst p) (snd p)). set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. + set (o:=find x m) in *; clearbody o. set (o':=find x m') in *; clearbody o'. clear Hm Hm' m m'. generalize H; clear H. @@ -984,10 +984,10 @@ Qed. (** Specification of [map2] *) -Lemma map2_1 : +Lemma map2_1 : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), - In x m \/ In x m' -> - find x (map2 m m') = f (find x m) (find x m'). + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). Proof. intros. rewrite map2_0; auto. @@ -997,10 +997,10 @@ Proof. rewrite (find_1 Hm' H). destruct (find x m); simpl; auto. Qed. - -Lemma map2_2 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), - In x (map2 m m') -> In x m \/ In x m'. + +Lemma map2_2 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. Proof. intros. destruct H as (e,H). @@ -1008,9 +1008,9 @@ Proof. rewrite (find_1 (map2_sorted Hm Hm') H). generalize (@find_2 _ m x). generalize (@find_2 _ m' x). - destruct (find x m); + destruct (find x m); destruct (find x m'); simpl; intros. - left; exists e0; auto. + left; exists e0; auto. left; exists e0; auto. right; exists e0; auto. discriminate. @@ -1020,31 +1020,31 @@ End Elt3. End Raw. Module Make (X: OrderedType) <: S with Module E := X. -Module Raw := Raw X. +Module Raw := Raw X. Module E := X. Definition key := E.t. -Record slist (elt:Type) := +Record slist (elt:Type) := {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. -Definition t (elt:Type) : Type := slist elt. +Definition t (elt:Type) : Type := slist elt. -Section Elt. - Variable elt elt' elt'':Type. +Section Elt. + Variable elt elt' elt'':Type. Implicit Types m : t elt. - Implicit Types x y : key. + Implicit Types x y : key. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_sorted elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e). Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). + Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). Definition mem x m : bool := Raw.mem x m.(this). Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f). Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)). Definition elements m : list (key*elt) := @Raw.elements elt m.(this). Definition cardinal m := length m.(this). @@ -1056,9 +1056,9 @@ Section Elt. Definition Empty m : Prop := Raw.Empty m.(this). Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. @@ -1095,7 +1095,7 @@ Section Elt. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(sorted)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. @@ -1104,9 +1104,9 @@ Section Elt. Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). + Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(sorted)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). @@ -1116,22 +1116,22 @@ Section Elt. fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. - Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. + Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -1139,58 +1139,58 @@ Section Elt. Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros elt elt' elt'' m m' x f; + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros elt elt' elt'' m m' x f; + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). Qed. End Make. -Module Make_ord (X: OrderedType)(D : OrderedType) <: -Sord with Module Data := D +Module Make_ord (X: OrderedType)(D : OrderedType) <: +Sord with Module Data := D with Module MapS.E := X. Module Data := D. -Module MapS := Make(X). +Module MapS := Make(X). Import MapS. Module MD := OrderedTypeFacts(D). Import MD. -Definition t := MapS.t D.t. +Definition t := MapS.t D.t. Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. -Fixpoint eq_list (m m' : list (X.t * D.t)) { struct m } : Prop := - match m, m' with +Fixpoint eq_list (m m' : list (X.t * D.t)) { struct m } : Prop := + match m, m' with | nil, nil => True - | (x,e)::l, (x',e')::l' => - match X.compare x x' with + | (x,e)::l, (x',e')::l' => + match X.compare x x' with | EQ _ => D.eq e e' /\ eq_list l l' | _ => False - end + end | _, _ => False end. Definition eq m m' := eq_list m.(this) m'.(this). -Fixpoint lt_list (m m' : list (X.t * D.t)) {struct m} : Prop := - match m, m' with +Fixpoint lt_list (m m' : list (X.t * D.t)) {struct m} : Prop := + match m, m' with | nil, nil => False | nil, _ => True | _, nil => False - | (x,e)::l, (x',e')::l' => - match X.compare x x' with + | (x,e)::l, (x',e')::l' => + match X.compare x x' with | LT _ => True | GT _ => False | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l') @@ -1209,9 +1209,9 @@ Proof. destruct a; unfold equal; simpl; intuition. destruct a as (x,e). destruct p as (x',e'). - unfold equal; simpl. + unfold equal; simpl. destruct (X.compare x x'); simpl; intuition. - unfold cmp at 1. + unfold cmp at 1. MD.elim_comp; clear H; simpl. inversion_clear Hl. inversion_clear Hl'. @@ -1258,7 +1258,7 @@ Qed. Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Proof. - intros (m,Hm); induction m; + intros (m,Hm); induction m; intros (m', Hm'); destruct m'; unfold eq; simpl; try destruct a as (x,e); try destruct p as (x',e'); auto. destruct (X.compare x x'); MapS.Raw.MX.elim_comp; intuition. @@ -1267,15 +1267,15 @@ Proof. Qed. Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. -Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold eq; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold eq; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare x x'); - destruct (X.compare x' x''); + destruct (X.compare x x'); + destruct (X.compare x' x''); MapS.Raw.MX.elim_comp. intuition. apply D.eq_trans with e'; auto. @@ -1285,14 +1285,14 @@ Qed. Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; - intros (m3, Hm3); destruct m3; unfold lt; simpl; - try destruct a as (x,e); - try destruct p as (x',e'); + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold lt; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare x x'); - destruct (X.compare x' x''); + destruct (X.compare x x'); + destruct (X.compare x' x''); MapS.Raw.MX.elim_comp; auto. intuition. left; apply D.lt_trans with e'; auto. @@ -1307,9 +1307,9 @@ Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; - try destruct a as (x,e); + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; + try destruct a as (x,e); try destruct p as (x',e'); try contradiction; auto. destruct (X.compare x x'); auto. intuition. @@ -1322,20 +1322,20 @@ Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto. Definition compare : forall m1 m2, Compare lt eq m1 m2. Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; [ apply EQ | apply LT | apply GT | ]; cmp_solve. - destruct a as (x,e); destruct p as (x',e'). - destruct (X.compare x x'); + destruct a as (x,e); destruct p as (x',e'). + destruct (X.compare x x'); [ apply LT | | apply GT ]; cmp_solve. - destruct (D.compare e e'); + destruct (D.compare e e'); [ apply LT | | apply GT ]; cmp_solve. assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1). inversion_clear Hm1; auto. assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2). inversion_clear Hm2; auto. - destruct (IHm1 Hm11 (Build_slist Hm22)); + destruct (IHm1 Hm11 (Build_slist Hm22)); [ apply LT | apply EQ | apply GT ]; cmp_solve. Qed. -End Make_ord. +End Make_ord. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 10c7ce4a87..112ccce30a 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre +(* Finite sets library. + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) @@ -25,16 +25,16 @@ Open Local Scope positive_scope. (** * An implementation of [FMapInterface.S] for positive keys. *) -(** This file is an adaptation to the [FMap] framework of a work by +(** This file is an adaptation to the [FMap] framework of a work by Xavier Leroy and Sandrine Blazy (used for building certified compilers). - Keys are of type [positive], and maps are binary trees: the sequence + Keys are of type [positive], and maps are binary trees: the sequence of binary digits of a positive number corresponds to a path in such a tree. - This is quite similar to the [IntMap] library, except that no path compression - is implemented, and that the current file is simple enough to be + This is quite similar to the [IntMap] library, except that no path compression + is implemented, and that the current file is simple enough to be self-contained. *) -(** Even if [positive] can be seen as an ordered type with respect to the - usual order (see [OrderedTypeEx]), we use here a lexicographic order +(** Even if [positive] can be seen as an ordered type with respect to the + usual order (see [OrderedTypeEx]), we use here a lexicographic order over bits, which is more natural here (lower bits are considered first). *) Module PositiveOrderedTypeBits <: UsualOrderedType. @@ -44,8 +44,8 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. Definition eq_sym := @sym_eq t. Definition eq_trans := @trans_eq t. - Fixpoint bits_lt (p q:positive) { struct p } : Prop := - match p, q with + Fixpoint bits_lt (p q:positive) { struct p } : Prop := + match p, q with | xH, xI _ => True | xH, _ => False | xO p, xO q => bits_lt p q @@ -63,9 +63,9 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. induction y; destruct z; simpl; eauto; intuition. induction y; destruct z; simpl; eauto; intuition. Qed. - + Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. + Proof. exact bits_lt_trans. Qed. @@ -101,7 +101,7 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. apply LT; auto. apply EQ; rewrite e; red; auto. apply GT; auto. - (* O H *) + (* O H *) apply LT; simpl; auto. (* H I *) apply LT; simpl; auto. @@ -122,7 +122,7 @@ Module PositiveOrderedTypeBits <: UsualOrderedType. End PositiveOrderedTypeBits. (** Other positive stuff *) - + Fixpoint append (i j : positive) {struct i} : positive := match i with | xH => j @@ -130,7 +130,7 @@ Fixpoint append (i j : positive) {struct i} : positive := | xO ii => xO (append ii j) end. -Lemma append_assoc_0 : +Lemma append_assoc_0 : forall (i j : positive), append i (xO j) = append (append i (xO xH)) j. Proof. induction i; intros; destruct j; simpl; @@ -140,7 +140,7 @@ Proof. auto. Qed. -Lemma append_assoc_1 : +Lemma append_assoc_1 : forall (i j : positive), append i (xI j) = append (append i (xI xH)) j. Proof. induction i; intros; destruct j; simpl; @@ -159,7 +159,7 @@ Lemma append_neutral_l : forall (i : positive), append xH i = i. Proof. simpl; auto. Qed. - + (** The module of maps over positive keys *) @@ -182,9 +182,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Implicit Arguments Leaf [A]. Definition empty : t A := Leaf. - - Fixpoint is_empty (m : t A) {struct m} : bool := - match m with + + Fixpoint is_empty (m : t A) {struct m} : bool := + match m with | Leaf => true | Node l None r => (is_empty l) && (is_empty r) | _ => false @@ -279,8 +279,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (** [cardinal] *) Fixpoint cardinal (m : t A) : nat := - match m with - | Leaf => 0%nat + match m with + | Leaf => 0%nat | Node l None r => (cardinal l + cardinal r)%nat | Node l (Some _) r => S (cardinal l + cardinal r) end. @@ -565,7 +565,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. exact (xelements_complete i xH m v H). Qed. - Lemma cardinal_1 : + Lemma cardinal_1 : forall (m: t A), cardinal m = length (elements m). Proof. unfold elements. @@ -584,13 +584,13 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m. Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':positive*A) := + + Definition eq_key_elt (p p':positive*A) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p'). - Lemma mem_find : + Lemma mem_find : forall m x, mem x m = match find x m with None => false | _ => true end. Proof. induction m; destruct x; simpl; auto. @@ -625,7 +625,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl; generalize H0; rewrite Empty_alt; auto. Qed. - Section FMapSpec. + Section FMapSpec. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. @@ -633,7 +633,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. destruct 1 as (e0,H0); rewrite H0; auto. Qed. - Lemma mem_2 : forall m x, mem x m = true -> In x m. + Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, MapsTo; intros m x; rewrite mem_find. destruct (find x m). @@ -659,7 +659,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. rewrite Empty_alt; apply gempty. Qed. - Lemma is_empty_1 : Empty m -> is_empty m = true. + Lemma is_empty_1 : Empty m -> is_empty m = true. Proof. induction m; simpl; auto. rewrite Empty_Node. @@ -699,7 +699,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma remove_1 : E.eq x y -> ~ In y (remove x m). - Proof. + Proof. intros; intro. generalize (mem_1 H0). rewrite mem_find. @@ -716,15 +716,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. - Proof. + Proof. unfold MapsTo. destruct (E.eq_dec x y). subst. rewrite grs; intros; discriminate. rewrite gro; auto. Qed. - - Lemma elements_1 : + + Lemma elements_1 : MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. unfold MapsTo. @@ -736,7 +736,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply elements_correct; auto. Qed. - Lemma elements_2 : + Lemma elements_2 : InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. unfold MapsTo. @@ -746,7 +746,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply elements_complete; auto. Qed. - Lemma xelements_bits_lt_1 : forall p p0 q m v, + Lemma xelements_bits_lt_1 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p. Proof. intros. @@ -755,7 +755,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. induction p; destruct p0; simpl; intros; eauto; try discriminate. Qed. - Lemma xelements_bits_lt_2 : forall p p0 q m v, + Lemma xelements_bits_lt_2 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0. Proof. intros. @@ -803,7 +803,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. eapply xelements_bits_lt_2; eauto. Qed. - Lemma elements_3 : sort lt_key (elements m). + Lemma elements_3 : sort lt_key (elements m). Proof. unfold elements. apply xelements_sort; auto. @@ -818,7 +818,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End FMapSpec. (** [map] and [mapi] *) - + Variable B : Type. Section Mapi. @@ -862,9 +862,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. rewrite append_neutral_l; auto. Qed. - Lemma mapi_1 : - forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> + Lemma mapi_1 : + forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros. @@ -877,8 +877,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl; auto. Qed. - Lemma mapi_2 : - forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), + Lemma mapi_2 : + forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros. @@ -891,14 +891,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl in *; discriminate. Qed. - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros; unfold map. destruct (mapi_1 (fun _ => f) H); intuition. Qed. - - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros; unfold map in *; eapply mapi_2; eauto. @@ -907,7 +907,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section map2. Variable A B C : Type. Variable f : option A -> option B -> option C. - + Implicit Arguments Leaf [A]. Fixpoint xmap2_l (m : t A) {struct m} : t C := @@ -954,14 +954,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End map2. - Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') := + Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') := _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end). Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. intros. unfold map2. rewrite gmap2; auto. @@ -974,7 +974,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. intros. @@ -1032,12 +1032,12 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. rewrite xfoldi_1; reflexivity. Qed. - Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := - match m1, m2 with + Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := + match m1, m2 with | Leaf, _ => is_empty m2 | _, Leaf => is_empty m1 - | Node l1 o1 r1, Node l2 o2 r2 => - (match o1, o2 with + | Node l1 o1 r1, Node l2 o2 r2 => + (match o1, o2 with | None, None => true | Some v1, Some v2 => cmp v1 v2 | _, _ => false @@ -1045,19 +1045,19 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. && equal cmp l1 l2 && equal cmp r1 r2 end. - Definition Equal (A:Type)(m m':t A) := + Definition Equal (A:Type)(m m':t A) := forall y, find y m = find y m'. - Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp). - Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - Equivb cmp m m' -> equal cmp m m' = true. - Proof. + Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool), + Equivb cmp m m' -> equal cmp m m' = true. + Proof. induction m. (* m = Leaf *) - destruct 1. + destruct 1. simpl. apply is_empty_1. red; red; intros. @@ -1069,7 +1069,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (* m = Node *) destruct m'. (* m' = Leaf *) - destruct 1. + destruct 1. simpl. destruct o. assert (In xH (Leaf A)). @@ -1106,9 +1106,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply andb_true_intro; split; auto. Qed. - Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), - equal cmp m m' = true -> Equivb cmp m m'. - Proof. + Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool), + equal cmp m m' = true -> Equivb cmp m m'. + Proof. induction m. (* m = Leaf *) simpl. @@ -1182,7 +1182,7 @@ Module PositiveMapAdditionalFacts. rewrite (IHi m2 v H); congruence. rewrite (IHi m1 v H); congruence. Qed. - + Lemma xmap2_lr : forall (A B : Type)(f g: option A -> option A -> option B)(m : t A), (forall (i j : option A), f i j = g j i) -> @@ -1210,7 +1210,7 @@ Module PositiveMapAdditionalFacts. auto. rewrite IHm1_1. rewrite IHm1_2. - auto. + auto. Qed. End PositiveMapAdditionalFacts. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 0c12516c4b..e29bde236b 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -8,7 +8,7 @@ (* $Id$ *) -(** * Finite map library *) +(** * Finite map library *) (** This file proposes an implementation of the non-dependant interface [FMapInterface.WS] using lists of pairs, unordered but without redundancy. *) @@ -29,7 +29,7 @@ Section Elt. Variable elt : Type. -Notation eqk := (eqk (elt:=elt)). +Notation eqk := (eqk (elt:=elt)). Notation eqke := (eqke (elt:=elt)). Notation MapsTo := (MapsTo (elt:=elt)). Notation In := (In (elt:=elt)). @@ -52,7 +52,7 @@ Qed. Hint Resolve empty_1. Lemma empty_NoDup : NoDupA empty. -Proof. +Proof. unfold empty; auto. Qed. @@ -60,7 +60,7 @@ Qed. Definition is_empty (l : t elt) : bool := if l then true else false. -Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. +Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. Proof. unfold Empty, PX.MapsTo. intros m. @@ -88,7 +88,7 @@ Function mem (k : key) (s : t elt) {struct s} : bool := Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true. Proof. - intros m Hm x; generalize Hm; clear Hm. + intros m Hm x; generalize Hm; clear Hm. functional induction (mem x m);intros NoDup belong1;trivial. inversion belong1. inversion H. inversion_clear NoDup. @@ -98,13 +98,13 @@ Proof. contradiction. apply IHb; auto. exists x0; auto. -Qed. +Qed. -Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. +Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. Proof. intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. functional induction (mem x m); intros NoDup hyp; try discriminate. - exists _x; auto. + exists _x; auto. inversion_clear NoDup. destruct IHb; auto. exists x0; auto. @@ -124,8 +124,8 @@ Proof. functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto. Qed. -Lemma find_1 : forall m (Hm:NoDupA m) x e, - MapsTo x e m -> find x m = Some e. +Lemma find_1 : forall m (Hm:NoDupA m) x e, + MapsTo x e m -> find x m = Some e. Proof. intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (find x m);simpl; subst; try clear H_eq_1. @@ -142,7 +142,7 @@ Qed. (* Not part of the exported specifications, used later for [combine]. *) -Lemma find_eq : forall m (Hm:NoDupA m) x x', +Lemma find_eq : forall m (Hm:NoDupA m) x x', X.eq x x' -> find x m = find x' m. Proof. induction m; simpl; auto; destruct a; intros. @@ -167,7 +167,7 @@ Proof. functional induction (add x e m);simpl;auto. Qed. -Lemma add_2 : forall m x y e e', +Lemma add_2 : forall m x y e e', ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'; generalize y e; clear y e; unfold PX.MapsTo. @@ -178,7 +178,7 @@ Proof. auto. intros y' e'' eqky'; inversion_clear 1; intuition. Qed. - + Lemma add_3 : forall m x y e e', ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. @@ -189,14 +189,14 @@ Proof. inversion_clear 2; auto. Qed. -Lemma add_3' : forall m x y e e', - ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. +Lemma add_3' : forall m x y e e', + ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. Proof. intros m x y e e'. generalize y e; clear y e. functional induction (add x e' m);simpl;auto. inversion_clear 2. compute in H1; elim H; auto. - inversion H1. + inversion H1. constructor 2; inversion_clear H0; auto. compute in H1; elim H; auto. inversion_clear 2; auto. @@ -218,7 +218,7 @@ Qed. (* Not part of the exported specifications, used later for [combine]. *) -Lemma add_eq : forall m (Hm:NoDupA m) x a e, +Lemma add_eq : forall m (Hm:NoDupA m) x a e, X.eq x a -> find x (add a e m) = Some e. Proof. intros. @@ -227,7 +227,7 @@ Proof. apply add_1; auto. Qed. -Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, +Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, ~X.eq x a -> find x (add a e m) = find x m. Proof. intros. @@ -250,7 +250,7 @@ Function remove (k : key) (s : t elt) {struct s} : t elt := match s with | nil => nil | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l - end. + end. Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m). Proof. @@ -265,7 +265,7 @@ Proof. destruct H0 as (e,H2); unfold PX.MapsTo in H2. apply InA_eqk with (y,e); auto. compute; apply X.eq_trans with x; auto. - + intro H2. destruct H2 as (e,H2); inversion_clear H2. compute in H0; destruct H0. @@ -274,8 +274,8 @@ Proof. elim (IHt0 H2 H). exists e; auto. Qed. - -Lemma remove_2 : forall m (Hm:NoDupA m) x y e, + +Lemma remove_2 : forall m (Hm:NoDupA m) x y e, ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -283,11 +283,11 @@ Proof. inversion_clear 3; auto. compute in H1; destruct H1. elim H; apply X.eq_trans with k'; auto. - + inversion_clear 1; inversion_clear 2; auto. Qed. -Lemma remove_3 : forall m (Hm:NoDupA m) x y e, +Lemma remove_3 : forall m (Hm:NoDupA m) x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -295,7 +295,7 @@ Proof. do 2 inversion_clear 1; auto. Qed. -Lemma remove_3' : forall m (Hm:NoDupA m) x y e, +Lemma remove_3' : forall m (Hm:NoDupA m) x y e, InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -313,7 +313,7 @@ Proof. simpl; case (X.eq_dec x x'); auto. constructor; auto. contradict H; apply remove_3' with x; auto. -Qed. +Qed. (** * [elements] *) @@ -325,12 +325,12 @@ Proof. Qed. Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. -Proof. +Proof. auto. Qed. -Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). -Proof. +Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). +Proof. auto. Qed. @@ -344,34 +344,34 @@ Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} : A := Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. -Proof. +Proof. intros; functional induction (@fold A f m i); auto. Qed. (** * [equal] *) -Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := - match find k m' with +Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := + match find k m' with | None => false | Some e' => cmp e e' end. -Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := - fold (fun k e b => andb (check cmp k e m') b) m true. - +Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + fold (fun k e b => andb (check cmp k e m') b) m true. + Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). -Definition Submap cmp m m' := - (forall k, In k m -> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). +Definition Submap cmp m m' := + (forall k, In k m -> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Definition Equivb cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). +Definition Equivb cmp m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Submap cmp m m' -> submap cmp m m' = true. +Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Submap cmp m m' -> submap cmp m m' = true. Proof. unfold Submap, submap. induction m. @@ -390,9 +390,9 @@ Proof. destruct H5 as (e'',H5); exists e''; auto. apply H0 with k; auto. Qed. - -Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - submap cmp m m' = true -> Submap cmp m m'. + +Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + submap cmp m m' = true -> Submap cmp m m'. Proof. unfold Submap, submap. induction m. @@ -400,7 +400,7 @@ Proof. intuition. destruct H0; inversion H0. inversion H0. - + destruct a; simpl; intros. inversion_clear Hm. rewrite andb_b_true in H. @@ -414,7 +414,7 @@ Proof. rewrite H2 in H. destruct (IHm H1 m' Hm' cmp H); auto. unfold check in H2. - case_eq (find t0 m'); [intros e' H5 | intros H5]; + case_eq (find t0 m'); [intros e' H5 | intros H5]; rewrite H5 in H2; try discriminate. split; intros. destruct H6 as (e0,H6); inversion_clear H6. @@ -432,15 +432,15 @@ Qed. (** Specification of [equal] *) -Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. +Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Equivb cmp m m' -> equal cmp m m' = true. +Proof. unfold Equivb, equal. intuition. apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. Qed. -Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, +Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. unfold Equivb, equal. @@ -449,12 +449,12 @@ Proof. generalize (submap_2 Hm Hm' H0). generalize (submap_2 Hm' Hm H1). firstorder. -Qed. +Qed. Variable elt':Type. (** * [map] and [mapi] *) - + Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' := match m with | nil => nil @@ -468,24 +468,24 @@ Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' := end. End Elt. -Section Elt2. -(* A new section is necessary for previous definitions to work +Section Elt2. +(* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) - + Variable elt elt' : Type. (** Specification of [map] *) -Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), +Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. @@ -493,15 +493,15 @@ Proof. unfold MapsTo in *; auto. Qed. -Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), +Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -514,9 +514,9 @@ Proof. constructor 2; auto. Qed. -Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), +Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), NoDupA (@eqk elt') (map f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x',e'). @@ -524,25 +524,25 @@ Proof. constructor; auto. contradict H. (* il faut un map_1 avec eqk au lieu de eqke *) - clear IHm H0. + clear IHm H0. induction m; simpl in *; auto. inversion H. destruct a; inversion H; auto. -Qed. - +Qed. + (** Specification of [mapi] *) -Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> +Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros m x e f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. exists x'. destruct H0; simpl in *. @@ -551,17 +551,17 @@ Proof. unfold eqke in *; simpl in *; intuition congruence. destruct IHm as (y, hyp); auto. exists y; intuition. -Qed. +Qed. -Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), +Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -574,7 +574,7 @@ Proof. constructor 2; auto. Qed. -Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), +Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), NoDupA (@eqk elt') (mapi f m). Proof. induction m; simpl; auto. @@ -589,30 +589,30 @@ Proof. destruct a; inversion_clear H; auto. Qed. -End Elt2. +End Elt2. Section Elt3. Variable elt elt' elt'' : Type. Notation oee' := (option elt * option elt')%type. - + Definition combine_l (m:t elt)(m':t elt') : t oee' := - mapi (fun k e => (Some e, find k m')) m. + mapi (fun k e => (Some e, find k m')) m. Definition combine_r (m:t elt)(m':t elt') : t oee' := - mapi (fun k e' => (find k m, Some e')) m'. + mapi (fun k e' => (find k m, Some e')) m'. -Definition fold_right_pair (A B C:Type)(f:A->B->C->C)(l:list (A*B))(i:C) := +Definition fold_right_pair (A B C:Type)(f:A->B->C->C)(l:list (A*B))(i:C) := List.fold_right (fun p => f (fst p) (snd p)) i l. -Definition combine (m:t elt)(m':t elt') : t oee' := - let l := combine_l m m' in - let r := combine_r m m' in +Definition combine (m:t elt)(m':t elt') : t oee' := + let l := combine_l m m' in + let r := combine_r m m' in fold_right_pair (add (elt:=oee')) l r. -Lemma fold_right_pair_NoDup : - forall l r (Hl: NoDupA (eqk (elt:=oee')) l) - (Hl: NoDupA (eqk (elt:=oee')) r), +Lemma fold_right_pair_NoDup : + forall l r (Hl: NoDupA (eqk (elt:=oee')) l) + (Hl: NoDupA (eqk (elt:=oee')) r), NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) l r). Proof. induction l; simpl; auto. @@ -622,8 +622,8 @@ Proof. Qed. Hint Resolve fold_right_pair_NoDup. -Lemma combine_NoDup : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), +Lemma combine_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), NoDupA (@eqk oee') (combine m m'). Proof. unfold combine, combine_r, combine_l. @@ -637,21 +637,21 @@ Proof. auto. Qed. -Definition at_least_left (o:option elt)(o':option elt') := - match o with - | None => None +Definition at_least_left (o:option elt)(o':option elt') := + match o with + | None => None | _ => Some (o,o') end. -Definition at_least_right (o:option elt)(o':option elt') := - match o' with - | None => None +Definition at_least_right (o:option elt)(o':option elt') := + match o' with + | None => None | _ => Some (o,o') end. -Lemma combine_l_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine_l m m') = at_least_left (find x m) (find x m'). +Lemma combine_l_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_l m m') = at_least_left (find x m) (find x m'). Proof. unfold combine_l. intros. @@ -668,9 +668,9 @@ Proof. rewrite (find_1 Hm H1) in H; discriminate. Qed. -Lemma combine_r_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine_r m m') = at_least_right (find x m) (find x m'). +Lemma combine_r_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_r m m') = at_least_right (find x m) (find x m'). Proof. unfold combine_r. intros. @@ -687,15 +687,15 @@ Proof. rewrite (find_1 Hm' H1) in H; discriminate. Qed. -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => Some (o,o') end. -Lemma combine_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine m m') = at_least_one (find x m) (find x m'). +Lemma combine_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). Proof. unfold combine. intros. @@ -726,19 +726,19 @@ Qed. Variable f : option elt -> option elt' -> option elt''. -Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := +Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := match o with | Some e => (k,e)::l | None => l end. -Definition map2 m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in +Definition map2 m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in fold_right_pair (option_cons (A:=elt'')) m1 nil. -Lemma map2_NoDup : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), +Lemma map2_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), NoDupA (@eqk elt'') (map2 m m'). Proof. intros. @@ -747,7 +747,7 @@ Proof. set (l0:=combine m m') in *; clearbody l0. set (f':= fun p : oee' => f (fst p) (snd p)). assert (H1:=map_NoDup (elt' := option elt'') H0 f'). - set (l1:=map f' l0) in *; clearbody l1. + set (l1:=map f' l0) in *; clearbody l1. clear f' f H0 l0 Hm Hm' m m'. induction l1. simpl; auto. @@ -763,15 +763,15 @@ Proof. inversion_clear H; auto. Qed. -Definition at_least_one_then_f (o:option elt)(o':option elt') := - match o, o' with - | None, None => None +Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => f o o' end. -Lemma map2_0 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). +Lemma map2_0 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). Proof. intros. unfold map2. @@ -779,7 +779,7 @@ Proof. assert (H2:=combine_NoDup Hm Hm'). set (f':= fun p : oee' => f (fst p) (snd p)). set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. + set (o:=find x m) in *; clearbody o. set (o':=find x m') in *; clearbody o'. clear Hm Hm' m m'. generalize H; clear H. @@ -795,14 +795,14 @@ Proof. destruct o; destruct o'; simpl in *; inversion_clear H; auto. rewrite H2. unfold f'; simpl. - destruct (f oo oo'); simpl. + destruct (f oo oo'); simpl. destruct (X.eq_dec x k); try contradict n; auto. destruct (IHm0 H1) as (_,H4); apply H4; auto. case_eq (find x m0); intros; auto. elim H0. apply InA_eqk with (x,p); auto. apply InA_eqke_eqk. - exact (find_2 H3). + exact (find_2 H3). (* k < x *) unfold f'; simpl. destruct (f oo oo'); simpl. @@ -826,10 +826,10 @@ Proof. Qed. (** Specification of [map2] *) -Lemma map2_1 : +Lemma map2_1 : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - In x m \/ In x m' -> - find x (map2 m m') = f (find x m) (find x m'). + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). Proof. intros. rewrite map2_0; auto. @@ -839,10 +839,10 @@ Proof. rewrite (find_1 Hm' H). destruct (find x m); simpl; auto. Qed. - -Lemma map2_2 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - In x (map2 m m') -> In x m \/ In x m'. + +Lemma map2_2 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. Proof. intros. destruct H as (e,H). @@ -850,9 +850,9 @@ Proof. rewrite (find_1 (map2_NoDup Hm Hm') H). generalize (@find_2 _ m x). generalize (@find_2 _ m' x). - destruct (find x m); + destruct (find x m); destruct (find x m'); simpl; intros. - left; exists e0; auto. + left; exists e0; auto. left; exists e0; auto. right; exists e0; auto. discriminate. @@ -863,31 +863,31 @@ End Raw. Module Make (X: DecidableType) <: WS with Module E:=X. - Module Raw := Raw X. + Module Raw := Raw X. Module E := X. - Definition key := E.t. + Definition key := E.t. - Record slist (elt:Type) := + Record slist (elt:Type) := {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. - Definition t (elt:Type) := slist elt. + Definition t (elt:Type) := slist elt. -Section Elt. - Variable elt elt' elt'':Type. +Section Elt. + Variable elt elt' elt'':Type. Implicit Types m : t elt. - Implicit Types x y : key. + Implicit Types x y : key. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_NoDup elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Build_slist (Raw.add_NoDup m.(NoDup) x e). Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). + Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). Definition mem x m : bool := Raw.mem x m.(this). Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f). Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)). Definition elements m : list (key*elt) := @Raw.elements elt m.(this). Definition cardinal m := length m.(this). @@ -898,9 +898,9 @@ Section Elt. Definition Empty m : Prop := Raw.Empty m.(this). Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. @@ -936,7 +936,7 @@ Section Elt. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(NoDup)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(NoDup)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. @@ -945,32 +945,32 @@ Section Elt. Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(NoDup)). Qed. - - Lemma cardinal_1 : forall m, cardinal m = length (elements m). + + Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intros; reflexivity. Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. - Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. + Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -978,18 +978,18 @@ Section Elt. Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros elt elt' elt'' m m' x f; + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros elt elt' elt'' m m' x f; + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). Qed. diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v index 10e06711f1..0f0e675ee7 100644 --- a/theories/FSets/FSetAVL.v +++ b/theories/FSets/FSetAVL.v @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre +(* Finite sets library. + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) @@ -17,14 +17,14 @@ (** This module implements sets using AVL trees. It follows the implementation from Ocaml's standard library, - + All operations given here expect and produce well-balanced trees (in the ocaml sense: heigths of subtrees shouldn't differ by more than 2), and hence has low complexities (e.g. add is logarithmic in the size of the set). But proving these balancing preservations is in fact not necessary for ensuring correct operational behavior and hence fulfilling the FSet interface. As a consequence, - balancing results are not part of this file anymore, they can + balancing results are not part of this file anymore, they can now be found in [FSetFullAVL]. Four operations ([union], [subset], [compare] and [equal]) have @@ -47,9 +47,9 @@ Unset Strict Implicit. Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. -(** * Raw - - Functor of pure functions + a posteriori proofs of invariant +(** * Raw + + Functor of pure functions + a posteriori proofs of invariant preservation *) Module Raw (Import I:Int)(X:OrderedType). @@ -89,19 +89,19 @@ Definition empty := Leaf. (** * Emptyness test *) -Definition is_empty s := +Definition is_empty s := match s with Leaf => true | _ => false end. (** * Appartness *) -(** The [mem] function is deciding appartness. It exploits the +(** The [mem] function is deciding appartness. It exploits the binary search tree invariant to achieve logarithmic complexity. *) -Fixpoint mem x s := - match s with - | Leaf => false - | Node l y r _ => match X.compare x y with - | LT _ => mem x l +Fixpoint mem x s := + match s with + | Leaf => false + | Node l y r _ => match X.compare x y with + | LT _ => mem x l | EQ _ => true | GT _ => mem x r end @@ -116,7 +116,7 @@ Definition singleton x := Node Leaf x Leaf 1. (** [create l x r] creates a node, assuming [l] and [r] to be balanced and [|height l - height r| <= 2]. *) -Definition create l x r := +Definition create l x r := Node l x r (max (height l) (height r) + 1). (** [bal l x r] acts as [create], but performs one step of @@ -124,44 +124,44 @@ Definition create l x r := Definition assert_false := create. -Definition bal l x r := - let hl := height l in +Definition bal l x r := + let hl := height l in let hr := height r in - if gt_le_dec hl (hr+2) then - match l with + if gt_le_dec hl (hr+2) then + match l with | Leaf => assert_false l x r - | Node ll lx lr _ => - if ge_lt_dec (height ll) (height lr) then + | Node ll lx lr _ => + if ge_lt_dec (height ll) (height lr) then create ll lx (create lr x r) - else - match lr with + else + match lr with | Leaf => assert_false l x r - | Node lrl lrx lrr _ => + | Node lrl lrx lrr _ => create (create ll lx lrl) lrx (create lrr x r) end end - else - if gt_le_dec hr (hl+2) then + else + if gt_le_dec hr (hl+2) then match r with | Leaf => assert_false l x r | Node rl rx rr _ => - if ge_lt_dec (height rr) (height rl) then + if ge_lt_dec (height rr) (height rl) then create (create l x rl) rx rr - else + else match rl with | Leaf => assert_false l x r - | Node rll rlx rlr _ => - create (create l x rll) rlx (create rlr rx rr) + | Node rll rlx rlr _ => + create (create l x rll) rlx (create rlr rx rr) end end - else + else create l x r. (** * Insertion *) -Fixpoint add x s := match s with +Fixpoint add x s := match s with | Leaf => Node Leaf x Leaf 1 - | Node l y r h => + | Node l y r h => match X.compare x y with | LT _ => bal (add x l) y r | EQ _ => Node l y r h @@ -171,19 +171,19 @@ Fixpoint add x s := match s with (** * Join - Same as [bal] but does not assume anything regarding heights - of [l] and [r]. + Same as [bal] but does not assume anything regarding heights + of [l] and [r]. *) Fixpoint join l : elt -> t -> t := match l with | Leaf => add - | Node ll lx lr lh => fun x => - fix join_aux (r:t) : t := match r with + | Node ll lx lr lh => fun x => + fix join_aux (r:t) : t := match r with | Leaf => add x l - | Node rl rx rr rh => + | Node rl rx rr rh => if gt_le_dec lh (rh+2) then bal ll lx (join lr x r) - else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr + else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr else create l x r end end. @@ -194,11 +194,11 @@ Fixpoint join l : elt -> t -> t := [t = Node l x r h]. Since we can't deal here with [assert false] for [t=Leaf], we pre-unpack [t] (and forget about [h]). *) - -Fixpoint remove_min l x r : t*elt := - match l with + +Fixpoint remove_min l x r : t*elt := + match l with | Leaf => (r,x) - | Node ll lx lr lh => + | Node ll lx lr lh => let (l',m) := remove_min ll lx lr in (bal l' x r, m) end. @@ -209,16 +209,16 @@ Fixpoint remove_min l x r : t*elt := [|height t1 - height t2| <= 2]. *) -Definition merge s1 s2 := match s1,s2 with - | Leaf, _ => s2 +Definition merge s1 s2 := match s1,s2 with + | Leaf, _ => s2 | _, Leaf => s1 - | _, Node l2 x2 r2 h2 => + | _, Node l2 x2 r2 h2 => let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2' end. (** * Deletion *) -Fixpoint remove x s := match s with +Fixpoint remove x s := match s with | Leaf => Leaf | Node l y r h => match X.compare x y with @@ -230,7 +230,7 @@ Fixpoint remove x s := match s with (** * Minimum element *) -Fixpoint min_elt s := match s with +Fixpoint min_elt s := match s with | Leaf => None | Node Leaf y _ _ => Some y | Node l _ _ _ => min_elt l @@ -238,7 +238,7 @@ end. (** * Maximum element *) -Fixpoint max_elt s := match s with +Fixpoint max_elt s := match s with | Leaf => None | Node _ y Leaf _ => Some y | Node _ _ r _ => max_elt r @@ -253,16 +253,16 @@ Definition choose := min_elt. Same as [merge] but does not assume anything about heights. *) -Definition concat s1 s2 := - match s1, s2 with - | Leaf, _ => s2 +Definition concat s1 s2 := + match s1, s2 with + | Leaf, _ => s2 | _, Leaf => s1 - | _, Node l2 x2 r2 _ => - let (s2',m) := remove_min l2 x2 r2 in + | _, Node l2 x2 r2 _ => + let (s2',m) := remove_min l2 x2 r2 in join s1 m s2' end. -(** * Splitting +(** * Splitting [split x s] returns a triple [(l, present, r)] where - [l] is the set of elements of [s] that are [< x] @@ -278,8 +278,8 @@ Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). Fixpoint split x s : triple := match s with | Leaf => << Leaf, false, Leaf >> - | Node l y r h => - match X.compare x y with + | Node l y r h => + match X.compare x y with | LT _ => let (ll,b,rl) := split x l in << ll, b, join rl y r >> | EQ _ => << l, true, r >> | GT _ => let (rl,b,rr) := split x r in << join l y rl, b, rr >> @@ -288,22 +288,22 @@ Fixpoint split x s : triple := match s with (** * Intersection *) -Fixpoint inter s1 s2 := match s1, s2 with +Fixpoint inter s1 s2 := match s1, s2 with | Leaf, _ => Leaf | _, Leaf => Leaf - | Node l1 x1 r1 h1, _ => - let (l2',pres,r2') := split x1 s2 in + | Node l1 x1 r1 h1, _ => + let (l2',pres,r2') := split x1 s2 in if pres then join (inter l1 l2') x1 (inter r1 r2') else concat (inter l1 l2') (inter r1 r2') end. (** * Difference *) -Fixpoint diff s1 s2 := match s1, s2 with +Fixpoint diff s1 s2 := match s1, s2 with | Leaf, _ => Leaf | _, Leaf => s1 - | Node l1 x1 r1 h1, _ => - let (l2',pres,r2') := split x1 s2 in + | Node l1 x1 r1 h1, _ => + let (l2',pres,r2') := split x1 s2 in if pres then concat (diff l1 l2') (diff r1 r2') else join (diff l1 l2') x1 (diff r1 r2') end. @@ -318,15 +318,15 @@ end. experimentally all the tests I've made in ocaml have shown this potential slowdown to be non-significant. Anyway, the exact code of ocaml has also been formalized thanks to Function+measure, see - [ocaml_union] in [FSetFullAVL]. + [ocaml_union] in [FSetFullAVL]. *) -Fixpoint union s1 s2 := - match s1, s2 with +Fixpoint union s1 s2 := + match s1, s2 with | Leaf, _ => s2 | _, Leaf => s1 - | Node l1 x1 r1 h1, _ => - let (l2',_,r2') := split x1 s2 in + | Node l1 x1 r1 h1, _ => + let (l2',_,r2') := split x1 s2 in join (union l1 l2') x1 (union r1 r2') end. @@ -347,10 +347,10 @@ Definition elements := elements_aux nil. (** * Filter *) -Fixpoint filter_acc (f:elt->bool) acc s := match s with +Fixpoint filter_acc (f:elt->bool) acc s := match s with | Leaf => acc - | Node l x r h => - filter_acc f (filter_acc f (if f x then add x acc else acc) l) r + | Node l x r h => + filter_acc f (filter_acc f (if f x then add x acc else acc) l) r end. Definition filter f := filter_acc f Leaf. @@ -358,11 +358,11 @@ Definition filter f := filter_acc f Leaf. (** * Partition *) -Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t := - match s with +Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t := + match s with | Leaf => acc - | Node l x r _ => - let (acct,accf) := acc in + | Node l x r _ => + let (acct,accf) := acc in partition_acc f (partition_acc f (if f x then (add x acct, accf) else (acct, add x accf)) l) r @@ -372,19 +372,19 @@ Definition partition f := partition_acc f (Leaf,Leaf). (** * [for_all] and [exists] *) -Fixpoint for_all (f:elt->bool) s := match s with +Fixpoint for_all (f:elt->bool) s := match s with | Leaf => true | Node l x r _ => f x &&& for_all f l &&& for_all f r end. -Fixpoint exists_ (f:elt->bool) s := match s with +Fixpoint exists_ (f:elt->bool) s := match s with | Leaf => false | Node l x r _ => f x ||| exists_ f l ||| exists_ f r end. (** * Fold *) -Fixpoint fold (A : Type) (f : elt -> A -> A)(s : tree) : A -> A := +Fixpoint fold (A : Type) (f : elt -> A -> A)(s : tree) : A -> A := fun a => match s with | Leaf => a | Node l x r _ => fold f r (f x (fold f l a)) @@ -394,43 +394,43 @@ Implicit Arguments fold [A]. (** * Subset *) -(** In ocaml, recursive calls are made on "half-trees" such as +(** In ocaml, recursive calls are made on "half-trees" such as (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these non-structural calls, we propose here two specialized functions for - these situations. This version should be almost as efficient as - the one of ocaml (closures as arguments may slow things a bit), + these situations. This version should be almost as efficient as + the one of ocaml (closures as arguments may slow things a bit), it is simply less compact. The exact ocaml version has also been - formalized (thanks to Function+measure), see [ocaml_subset] in + formalized (thanks to Function+measure), see [ocaml_subset] in [FSetFullAVL]. *) -Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool := - match s2 with +Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool := + match s2 with | Leaf => false - | Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | EQ _ => subset_l1 l2 + | Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | EQ _ => subset_l1 l2 | LT _ => subsetl subset_l1 x1 l2 | GT _ => mem x1 r2 &&& subset_l1 s2 end end. -Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool := - match s2 with +Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool := + match s2 with | Leaf => false - | Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | EQ _ => subset_r1 r2 + | Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | EQ _ => subset_r1 r2 | LT _ => mem x1 l2 &&& subset_r1 s2 | GT _ => subsetr subset_r1 x1 r2 end end. -Fixpoint subset s1 s2 : bool := match s1, s2 with +Fixpoint subset s1 s2 : bool := match s1, s2 with | Leaf, _ => true | Node _ _ _ _, Leaf => false - | Node l1 x1 r1 h1, Node l2 x2 r2 h2 => - match X.compare x1 x2 with + | Node l1 x1 r1 h1, Node l2 x2 r2 h2 => + match X.compare x1 x2 with | EQ _ => subset l1 l2 &&& subset r1 r2 | LT _ => subsetl (subset l1) x1 l2 &&& subset r1 s2 | GT _ => subsetr (subset r1) x1 r2 &&& subset l1 s2 @@ -442,8 +442,8 @@ Fixpoint subset s1 s2 : bool := match s1, s2 with Transformation in C.P.S. suggested by Benjamin Grégoire. The original ocaml code (with non-structural recursive calls) has also been formalized (thanks to Function+measure), see - [ocaml_compare] in [FSetFullAVL]. The following code with - continuations computes dramatically faster in Coq, and + [ocaml_compare] in [FSetFullAVL]. The following code with + continuations computes dramatically faster in Coq, and should be almost as efficient after extraction. *) @@ -454,11 +454,11 @@ Inductive enumeration := | More : elt -> tree -> enumeration -> enumeration. -(** [cons t e] adds the elements of tree [t] on the head of +(** [cons t e] adds the elements of tree [t] on the head of enumeration [e]. *) -Fixpoint cons s e : enumeration := - match s with +Fixpoint cons s e : enumeration := + match s with | Leaf => e | Node l x r h => cons l (More x r e) end. @@ -478,7 +478,7 @@ Definition compare_more x1 (cont:enumeration->comparison) e2 := (** Comparison of left tree, middle element, then right tree *) -Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := +Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := match s1 with | Leaf => cont e2 | Node l1 x1 r1 _ => @@ -487,7 +487,7 @@ Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := (** Initial continuation *) -Definition compare_end e2 := +Definition compare_end e2 := match e2 with End => Eq | _ => Lt end. (** The complete comparison *) @@ -496,10 +496,10 @@ Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). (** * Equality test *) -Definition equal s1 s2 : bool := - match compare s1 s2 with +Definition equal s1 s2 : bool := + match compare s1 s2 with | Eq => true - | _ => false + | _ => false end. @@ -516,7 +516,7 @@ Inductive In (x : elt) : tree -> Prop := (** ** Binary search trees *) -(** [lt_tree x s]: all elements in [s] are smaller than [x] +(** [lt_tree x s]: all elements in [s] are smaller than [x] (resp. greater for [gt_tree]) *) Definition lt_tree x s := forall y, In y s -> X.lt y x. @@ -526,7 +526,7 @@ Definition gt_tree x s := forall y, In y s -> X.lt x y. Inductive bst : tree -> Prop := | BSLeaf : bst Leaf - | BSNode : forall x l r h, bst l -> bst r -> + | BSNode : forall x l r h, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x r h). @@ -553,15 +553,15 @@ Module Proofs. Hint Constructors In bst. Hint Unfold lt_tree gt_tree. -Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h) - "as" ident(s) := +Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h) + "as" ident(s) := set (s:=Node l x r h) in *; clearbody s; clear l x r h. -(** A tactic to repeat [inversion_clear] on all hyps of the +(** A tactic to repeat [inversion_clear] on all hyps of the form [(f (Node _ _ _ _))] *) Ltac inv f := - match goal with + match goal with | H:f Leaf |- _ => inversion_clear H; inv f | H:f _ Leaf |- _ => inversion_clear H; inv f | H:f (Node _ _ _ _) |- _ => inversion_clear H; inv f @@ -573,7 +573,7 @@ Ltac intuition_in := repeat progress (intuition; inv In). (** Helper tactic concerning order of elements. *) -Ltac order := match goal with +Ltac order := match goal with | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | _ => MX.order @@ -591,8 +591,8 @@ Proof. Qed. Hint Immediate In_1. -Lemma In_node_iff : - forall l x r h y, +Lemma In_node_iff : + forall l x r h y, In y (Node l x r h) <-> In y l \/ X.eq y x \/ In y r. Proof. intuition_in. @@ -655,10 +655,10 @@ Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. (** * Inductions principles *) Functional Scheme mem_ind := Induction for mem Sort Prop. -Functional Scheme bal_ind := Induction for bal Sort Prop. +Functional Scheme bal_ind := Induction for bal Sort Prop. Functional Scheme add_ind := Induction for add Sort Prop. Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. -Functional Scheme merge_ind := Induction for merge Sort Prop. +Functional Scheme merge_ind := Induction for merge Sort Prop. Functional Scheme remove_ind := Induction for remove Sort Prop. Functional Scheme min_elt_ind := Induction for min_elt Sort Prop. Functional Scheme max_elt_ind := Induction for max_elt Sort Prop. @@ -684,14 +684,14 @@ Qed. (** * Emptyness test *) -Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. +Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. Proof. destruct s as [|r x l h]; simpl; auto. intro H; elim (H x); auto. Qed. Lemma is_empty_2 : forall s, is_empty s = true -> Empty s. -Proof. +Proof. destruct s; simpl; intros; try discriminate; red; auto. Qed. @@ -701,12 +701,12 @@ Qed. Lemma mem_1 : forall s x, bst s -> In x s -> mem x s = true. Proof. - intros s x; functional induction mem x s; auto; intros; try clear e0; + intros s x; functional induction mem x s; auto; intros; try clear e0; inv bst; intuition_in; order. Qed. -Lemma mem_2 : forall s x, mem x s = true -> In x s. -Proof. +Lemma mem_2 : forall s x, mem x s = true -> In x s. +Proof. intros s x; functional induction mem x s; auto; intros; discriminate. Qed. @@ -714,13 +714,13 @@ Qed. (** * Singleton set *) -Lemma singleton_1 : forall x y, In y (singleton x) -> X.eq x y. -Proof. +Lemma singleton_1 : forall x y, In y (singleton x) -> X.eq x y. +Proof. unfold singleton; intros; inv In; order. Qed. -Lemma singleton_2 : forall x y, X.eq x y -> In y (singleton x). -Proof. +Lemma singleton_2 : forall x y, X.eq x y -> In y (singleton x). +Proof. unfold singleton; auto. Qed. @@ -733,33 +733,33 @@ Qed. (** * Helper functions *) -Lemma create_in : +Lemma create_in : forall l x r y, In y (create l x r) <-> X.eq y x \/ In y l \/ In y r. Proof. unfold create; split; [ inversion_clear 1 | ]; intuition. Qed. -Lemma create_bst : - forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> +Lemma create_bst : + forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (create l x r). Proof. unfold create; auto. Qed. Hint Resolve create_bst. -Lemma bal_in : forall l x r y, +Lemma bal_in : forall l x r y, In y (bal l x r) <-> X.eq y x \/ In y l \/ In y r. Proof. - intros l x r; functional induction bal l x r; intros; try clear e0; + intros l x r; functional induction bal l x r; intros; try clear e0; rewrite !create_in; intuition_in. Qed. -Lemma bal_bst : forall l x r, bst l -> bst r -> +Lemma bal_bst : forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (bal l x r). Proof. intros l x r; functional induction bal l x r; intros; inv bst; repeat apply create_bst; auto; unfold create; - (apply lt_tree_node || apply gt_tree_node); auto; + (apply lt_tree_node || apply gt_tree_node); auto; (eapply lt_tree_trans || eapply gt_tree_trans); eauto. Qed. Hint Resolve bal_bst. @@ -771,14 +771,14 @@ Hint Resolve bal_bst. Lemma add_in : forall s x y, In y (add x s) <-> X.eq y x \/ In y s. Proof. - intros s x; functional induction (add x s); auto; intros; + intros s x; functional induction (add x s); auto; intros; try rewrite bal_in, IHt; intuition_in. eapply In_1; eauto. Qed. Lemma add_bst : forall s x, bst s -> bst (add x s). -Proof. - intros s x; functional induction (add x s); auto; intros; +Proof. + intros s x; functional induction (add x s); auto; intros; inv bst; apply bal_bst; auto. (* lt_tree -> lt_tree (add ...) *) red; red in H3. @@ -800,25 +800,25 @@ Hint Resolve add_bst. (** * Join *) -(* Function/Functional Scheme can't deal with internal fix. +(* Function/Functional Scheme can't deal with internal fix. Let's do its job by hand: *) -Ltac join_tac := - intro l; induction l as [| ll _ lx lr Hlr lh]; +Ltac join_tac := + intro l; induction l as [| ll _ lx lr Hlr lh]; [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)); - [ match goal with |- context b [ bal ?a ?b ?c] => - replace (bal a b c) - with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] - end - | destruct (gt_le_dec rh (lh+2)); - [ match goal with |- context b [ bal ?a ?b ?c] => - replace (bal a b c) - with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] + [ | destruct (gt_le_dec lh (rh+2)); + [ match goal with |- context b [ bal ?a ?b ?c] => + replace (bal a b c) + with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] + end + | destruct (gt_le_dec rh (lh+2)); + [ match goal with |- context b [ bal ?a ?b ?c] => + replace (bal a b c) + with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] end | ] ] ] ]; intros. -Lemma join_in : forall l x r y, +Lemma join_in : forall l x r y, In y (join l x r) <-> X.eq y x \/ In y l \/ In y r. Proof. join_tac. @@ -830,10 +830,10 @@ Proof. apply create_in. Qed. -Lemma join_bst : forall l x r, bst l -> bst r -> +Lemma join_bst : forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (join l x r). Proof. - join_tac; auto; inv bst; apply bal_bst; auto; + join_tac; auto; inv bst; apply bal_bst; auto; clear Hrl Hlr z; intro; intros; rewrite join_in in *. intuition; [ apply MX.lt_eq with x | ]; eauto. intuition; [ apply MX.eq_lt with x | ]; eauto. @@ -844,8 +844,8 @@ Hint Resolve join_bst. (** * Extraction of minimum element *) -Lemma remove_min_in : forall l x r h y, - In y (Node l x r h) <-> +Lemma remove_min_in : forall l x r h y, + In y (Node l x r h) <-> X.eq y (remove_min l x r)#2 \/ In y (remove_min l x r)#1. Proof. intros l x r; functional induction (remove_min l x r); simpl in *; intros. @@ -853,7 +853,7 @@ Proof. rewrite bal_in, In_node_iff, IHp, e0; simpl; intuition. Qed. -Lemma remove_min_bst : forall l x r h, +Lemma remove_min_bst : forall l x r h, bst (Node l x r h) -> bst (remove_min l x r)#1. Proof. intros l x r; functional induction (remove_min l x r); simpl; intros. @@ -865,7 +865,7 @@ Proof. rewrite remove_min_in, e0 in H2; simpl in H2; intuition. Qed. -Lemma remove_min_gt_tree : forall l x r h, +Lemma remove_min_gt_tree : forall l x r h, bst (Node l x r h) -> gt_tree (remove_min l x r)#2 (remove_min l x r)#1. Proof. @@ -873,8 +873,8 @@ Proof. inv bst; auto. inversion_clear H. specialize IHp with (1:=H0); rewrite e0 in IHp; simpl in IHp. - intro y; rewrite bal_in; intuition; - specialize (H2 m); rewrite remove_min_in, e0 in H2; simpl in H2; + intro y; rewrite bal_in; intuition; + specialize (H2 m); rewrite remove_min_in, e0 in H2; simpl in H2; [ apply MX.lt_eq with x | ]; eauto. Qed. Hint Resolve remove_min_bst remove_min_gt_tree. @@ -886,18 +886,18 @@ Hint Resolve remove_min_bst remove_min_gt_tree. Lemma merge_in : forall s1 s2 y, In y (merge s1 s2) <-> In y s1 \/ In y s2. Proof. - intros s1 s2; functional induction (merge s1 s2); intros; + intros s1 s2; functional induction (merge s1 s2); intros; try factornode _x _x0 _x1 _x2 as s1. intuition_in. intuition_in. rewrite bal_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma merge_bst : forall s1 s2, bst s1 -> bst s2 -> - (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> +Lemma merge_bst : forall s1 s2, bst s1 -> bst s2 -> + (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> bst (merge s1 s2). Proof. - intros s1 s2; functional induction (merge s1 s2); intros; auto; + intros s1 s2; functional induction (merge s1 s2); intros; auto; try factornode _x _x0 _x1 _x2 as s1. apply bal_bst; auto. change s2' with ((s2',m)#1); rewrite <-e1; eauto. @@ -924,7 +924,7 @@ Proof. Qed. Lemma remove_bst : forall s x, bst s -> bst (remove x s). -Proof. +Proof. intros s x; functional induction (remove x s); intros; inv bst. auto. (* LT *) @@ -932,7 +932,7 @@ Proof. intro z; rewrite remove_in; auto; destruct 1; eauto. (* EQ *) eauto. - (* GT *) + (* GT *) apply bal_bst; auto. intro z; rewrite remove_in; auto; destruct 1; eauto. Qed. @@ -941,15 +941,15 @@ Hint Resolve remove_bst. (** * Minimum element *) -Lemma min_elt_1 : forall s x, min_elt s = Some x -> In x s. -Proof. +Lemma min_elt_1 : forall s x, min_elt s = Some x -> In x s. +Proof. intro s; functional induction (min_elt s); auto; inversion 1; auto. Qed. Lemma min_elt_2 : forall s x y, bst s -> - min_elt s = Some x -> In y s -> ~ X.lt y x. + min_elt s = Some x -> In y s -> ~ X.lt y x. Proof. - intro s; functional induction (min_elt s); + intro s; functional induction (min_elt s); try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. inversion_clear 2. inversion_clear 1. @@ -963,7 +963,7 @@ Proof. assert (X.lt x y) by (apply H2; auto). inversion_clear 1; auto; order. assert (X.lt x1 y) by auto. - inversion_clear 2; auto; + inversion_clear 2; auto; (assert (~ X.lt x1 x) by auto); order. Qed. @@ -980,13 +980,13 @@ Qed. (** * Maximum element *) -Lemma max_elt_1 : forall s x, max_elt s = Some x -> In x s. -Proof. +Lemma max_elt_1 : forall s x, max_elt s = Some x -> In x s. +Proof. intro s; functional induction (max_elt s); auto; inversion 1; auto. Qed. -Lemma max_elt_2 : forall s x y, bst s -> - max_elt s = Some x -> In y s -> ~ X.lt x y. +Lemma max_elt_2 : forall s x y, bst s -> + max_elt s = Some x -> In y s -> ~ X.lt x y. Proof. intro s; functional induction (max_elt s); try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. @@ -997,7 +997,7 @@ Proof. inversion_clear H5. inversion_clear 1. assert (X.lt y x1) by auto. - inversion_clear 2; auto; + inversion_clear 2; auto; (assert (~ X.lt x x1) by auto); order. Qed. @@ -1014,17 +1014,17 @@ Qed. (** * Any element *) Lemma choose_1 : forall s x, choose s = Some x -> In x s. -Proof. +Proof. exact min_elt_1. Qed. Lemma choose_2 : forall s, choose s = None -> Empty s. -Proof. +Proof. exact min_elt_3. Qed. -Lemma choose_3 : forall s s', bst s -> bst s' -> - forall x x', choose s = Some x -> choose s' = Some x' -> +Lemma choose_3 : forall s s', bst s -> bst s' -> + forall x x', choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'. Proof. unfold choose, Equal; intros s s' Hb Hb' x x' Hx Hx' H. @@ -1040,7 +1040,7 @@ Qed. (** * Concatenation *) -Lemma concat_in : forall s1 s2 y, +Lemma concat_in : forall s1 s2 y, In y (concat s1 s2) <-> In y s1 \/ In y s2. Proof. intros s1 s2; functional induction (concat s1 s2); intros; @@ -1049,12 +1049,12 @@ Proof. intuition_in. rewrite join_in, remove_min_in, e1; simpl; intuition. Qed. - -Lemma concat_bst : forall s1 s2, bst s1 -> bst s2 -> - (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> + +Lemma concat_bst : forall s1 s2, bst s1 -> bst s2 -> + (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> bst (concat s1 s2). -Proof. - intros s1 s2; functional induction (concat s1 s2); intros; auto; +Proof. + intros s1 s2; functional induction (concat s1 s2); intros; auto; try factornode _x _x0 _x1 _x2 as s1. apply join_bst; auto. change (bst (s2',m)#1); rewrite <-e1; eauto. @@ -1068,10 +1068,10 @@ Hint Resolve concat_bst. (** * Splitting *) -Lemma split_in_1 : forall s x y, bst s -> +Lemma split_in_1 : forall s x y, bst s -> (In y (split x s)#l <-> In y s /\ X.lt y x). Proof. - intros s x; functional induction (split x s); simpl; intros; + intros s x; functional induction (split x s); simpl; intros; inv bst; try clear e0. intuition_in. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. @@ -1080,10 +1080,10 @@ Proof. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_in_2 : forall s x y, bst s -> +Lemma split_in_2 : forall s x y, bst s -> (In y (split x s)#r <-> In y s /\ X.lt x y). -Proof. - intros s x; functional induction (split x s); subst; simpl; intros; +Proof. + intros s x; functional induction (split x s); subst; simpl; intros; inv bst; try clear e0. intuition_in. rewrite join_in. @@ -1092,10 +1092,10 @@ Proof. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_in_3 : forall s x, bst s -> +Lemma split_in_3 : forall s x, bst s -> ((split x s)#b = true <-> In x s). -Proof. - intros s x; functional induction (split x s); subst; simpl; intros; +Proof. + intros s x; functional induction (split x s); subst; simpl; intros; inv bst; try clear e0. intuition_in; try discriminate. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. @@ -1103,10 +1103,10 @@ Proof. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_bst : forall s x, bst s -> +Lemma split_bst : forall s x, bst s -> bst (split x s)#l /\ bst (split x s)#r. -Proof. - intros s x; functional induction (split x s); subst; simpl; intros; +Proof. + intros s x; functional induction (split x s); subst; simpl; intros; inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition; apply join_bst; auto. intros y0. @@ -1119,15 +1119,15 @@ Qed. (** * Intersection *) -Lemma inter_bst_in : forall s1 s2, bst s1 -> bst s2 -> +Lemma inter_bst_in : forall s1 s2, bst s1 -> bst s2 -> bst (inter s1 s2) /\ (forall y, In y (inter s1 s2) <-> In y s1 /\ In y s2). Proof. - intros s1 s2; functional induction inter s1 s2; intros B1 B2; - [intuition_in|intuition_in | | ]; - factornode _x0 _x1 _x2 _x3 as s2; - generalize (split_bst x1 B2); + intros s1 s2; functional induction inter s1 s2; intros B1 B2; + [intuition_in|intuition_in | | ]; + factornode _x0 _x1 _x2 _x3 as s2; + generalize (split_bst x1 B2); rewrite e1; simpl; destruct 1; inv bst; - destruct IHt as (IHb1,IHi1); auto; + destruct IHt as (IHb1,IHi1); auto; destruct IHt0 as (IHb2,IHi2); auto; generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1) (split_in_3 x1 B2)(split_bst x1 B2); @@ -1146,31 +1146,31 @@ Proof. apply In_1 with y; auto. Qed. -Lemma inter_in : forall s1 s2 y, bst s1 -> bst s2 -> +Lemma inter_in : forall s1 s2 y, bst s1 -> bst s2 -> (In y (inter s1 s2) <-> In y s1 /\ In y s2). -Proof. +Proof. intros s1 s2 y B1 B2; destruct (inter_bst_in B1 B2); auto. Qed. Lemma inter_bst : forall s1 s2, bst s1 -> bst s2 -> bst (inter s1 s2). -Proof. +Proof. intros s1 s2 B1 B2; destruct (inter_bst_in B1 B2); auto. Qed. (** * Difference *) -Lemma diff_bst_in : forall s1 s2, bst s1 -> bst s2 -> +Lemma diff_bst_in : forall s1 s2, bst s1 -> bst s2 -> bst (diff s1 s2) /\ (forall y, In y (diff s1 s2) <-> In y s1 /\ ~In y s2). Proof. - intros s1 s2; functional induction diff s1 s2; intros B1 B2; - [intuition_in|intuition_in | | ]; - factornode _x0 _x1 _x2 _x3 as s2; - generalize (split_bst x1 B2); - rewrite e1; simpl; destruct 1; - inv avl; inv bst; - destruct IHt as (IHb1,IHi1); auto; - destruct IHt0 as (IHb2,IHi2); auto; + intros s1 s2; functional induction diff s1 s2; intros B1 B2; + [intuition_in|intuition_in | | ]; + factornode _x0 _x1 _x2 _x3 as s2; + generalize (split_bst x1 B2); + rewrite e1; simpl; destruct 1; + inv avl; inv bst; + destruct IHt as (IHb1,IHi1); auto; + destruct IHt0 as (IHb2,IHi2); auto; generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1) (split_in_3 x1 B2)(split_bst x1 B2); rewrite e1; simpl; split; intros. @@ -1189,21 +1189,21 @@ Proof. apply In_1 with y; auto. Qed. -Lemma diff_in : forall s1 s2 y, bst s1 -> bst s2 -> +Lemma diff_in : forall s1 s2 y, bst s1 -> bst s2 -> (In y (diff s1 s2) <-> In y s1 /\ ~In y s2). -Proof. +Proof. intros s1 s2 y B1 B2; destruct (diff_bst_in B1 B2); auto. Qed. -Lemma diff_bst : forall s1 s2, bst s1 -> bst s2 -> bst (diff s1 s2). -Proof. +Lemma diff_bst : forall s1 s2, bst s1 -> bst s2 -> bst (diff s1 s2). +Proof. intros s1 s2 B1 B2; destruct (diff_bst_in B1 B2); auto. Qed. (** * Union *) -Lemma union_in : forall s1 s2 y, bst s1 -> bst s2 -> +Lemma union_in : forall s1 s2 y, bst s1 -> bst s2 -> (In y (union s1 s2) <-> In y s1 \/ In y s2). Proof. intros s1 s2; functional induction union s1 s2; intros y B1 B2. @@ -1217,7 +1217,7 @@ Proof. case (X.compare y x1); intuition_in. Qed. -Lemma union_bst : forall s1 s2, bst s1 -> bst s2 -> +Lemma union_bst : forall s1 s2, bst s1 -> bst s2 -> bst (union s1 s2). Proof. intros s1 s2; functional induction union s1 s2; intros B1 B2; auto. @@ -1233,7 +1233,7 @@ Qed. (** * Elements *) -Lemma elements_aux_in : forall s acc x, +Lemma elements_aux_in : forall s acc x, InA X.eq x (elements_aux acc s) <-> In x s \/ InA X.eq x acc. Proof. induction s as [ | l Hl x r Hr h ]; simpl; auto. @@ -1245,8 +1245,8 @@ Proof. intuition; inversion_clear H3; intuition. Qed. -Lemma elements_in : forall s x, InA X.eq x (elements s) <-> In x s. -Proof. +Lemma elements_in : forall s x, InA X.eq x (elements s) <-> In x s. +Proof. intros; generalize (elements_aux_in s nil x); intuition. inversion_clear H0. Qed. @@ -1258,7 +1258,7 @@ Proof. induction s as [ | l Hl y r Hr h]; simpl; intuition. inv bst. apply Hl; auto. - constructor. + constructor. apply Hr; auto. apply MX.In_Inf; intros. destruct (elements_aux_in r acc y0); intuition. @@ -1318,10 +1318,10 @@ Qed. Section F. Variable f : elt -> bool. -Lemma filter_acc_in : forall s acc, - compat_bool X.eq f -> forall x : elt, +Lemma filter_acc_in : forall s acc, + compat_bool X.eq f -> forall x : elt, In x (filter_acc f acc s) <-> In x acc \/ In x s /\ f x = true. -Proof. +Proof. induction s; simpl; intros. intuition_in. rewrite IHs2, IHs1 by (destruct (f t); auto). @@ -1335,7 +1335,7 @@ Proof. rewrite H0 in H3; discriminate. Qed. -Lemma filter_acc_bst : forall s acc, bst s -> bst acc -> +Lemma filter_acc_bst : forall s acc, bst s -> bst acc -> bst (filter_acc f acc s). Proof. induction s; simpl; auto. @@ -1345,13 +1345,13 @@ Proof. Qed. Lemma filter_in : forall s, - compat_bool X.eq f -> forall x : elt, + compat_bool X.eq f -> forall x : elt, In x (filter f s) <-> In x s /\ f x = true. Proof. unfold filter; intros; rewrite filter_acc_in; intuition_in. Qed. -Lemma filter_bst : forall s, bst s -> bst (filter f s). +Lemma filter_bst : forall s, bst s -> bst (filter f s). Proof. unfold filter; intros; apply filter_acc_bst; auto. Qed. @@ -1360,15 +1360,15 @@ Qed. (** * Partition *) -Lemma partition_acc_in_1 : forall s acc, - compat_bool X.eq f -> forall x : elt, - In x (partition_acc f acc s)#1 <-> +Lemma partition_acc_in_1 : forall s acc, + compat_bool X.eq f -> forall x : elt, + In x (partition_acc f acc s)#1 <-> In x acc#1 \/ In x s /\ f x = true. -Proof. +Proof. induction s; simpl; intros. intuition_in. destruct acc as [acct accf]; simpl in *. - rewrite IHs2 by + rewrite IHs2 by (destruct (f t); auto; apply partition_acc_avl_1; simpl; auto). rewrite IHs1 by (destruct (f t); simpl; auto). case_eq (f t); simpl; intros. @@ -1381,15 +1381,15 @@ Proof. rewrite H0 in H3; discriminate. Qed. -Lemma partition_acc_in_2 : forall s acc, - compat_bool X.eq f -> forall x : elt, - In x (partition_acc f acc s)#2 <-> +Lemma partition_acc_in_2 : forall s acc, + compat_bool X.eq f -> forall x : elt, + In x (partition_acc f acc s)#2 <-> In x acc#2 \/ In x s /\ f x = false. -Proof. +Proof. induction s; simpl; intros. intuition_in. destruct acc as [acct accf]; simpl in *. - rewrite IHs2 by + rewrite IHs2 by (destruct (f t); auto; apply partition_acc_avl_2; simpl; auto). rewrite IHs1 by (destruct (f t); simpl; auto). case_eq (f t); simpl; intros. @@ -1403,23 +1403,23 @@ Proof. intuition. Qed. -Lemma partition_in_1 : forall s, - compat_bool X.eq f -> forall x : elt, +Lemma partition_in_1 : forall s, + compat_bool X.eq f -> forall x : elt, In x (partition f s)#1 <-> In x s /\ f x = true. Proof. - unfold partition; intros; rewrite partition_acc_in_1; + unfold partition; intros; rewrite partition_acc_in_1; simpl in *; intuition_in. -Qed. +Qed. Lemma partition_in_2 : forall s, - compat_bool X.eq f -> forall x : elt, + compat_bool X.eq f -> forall x : elt, In x (partition f s)#2 <-> In x s /\ f x = false. Proof. - unfold partition; intros; rewrite partition_acc_in_2; + unfold partition; intros; rewrite partition_acc_in_2; simpl in *; intuition_in. -Qed. +Qed. -Lemma partition_acc_bst_1 : forall s acc, bst s -> bst acc#1 -> +Lemma partition_acc_bst_1 : forall s acc, bst s -> bst acc#1 -> bst (partition_acc f acc s)#1. Proof. induction s; simpl; auto. @@ -1431,7 +1431,7 @@ Proof. apply IHs1; simpl; auto. Qed. -Lemma partition_acc_bst_2 : forall s acc, bst s -> bst acc#2 -> +Lemma partition_acc_bst_2 : forall s acc, bst s -> bst acc#2 -> bst (partition_acc f acc s)#2. Proof. induction s; simpl; auto. @@ -1443,12 +1443,12 @@ Proof. apply IHs1; simpl; auto. Qed. -Lemma partition_bst_1 : forall s, bst s -> bst (partition f s)#1. +Lemma partition_bst_1 : forall s, bst s -> bst (partition f s)#1. Proof. unfold partition; intros; apply partition_acc_bst_1; auto. Qed. -Lemma partition_bst_2 : forall s, bst s -> bst (partition f s)#2. +Lemma partition_bst_2 : forall s, bst s -> bst (partition f s)#2. Proof. unfold partition; intros; apply partition_acc_bst_2; auto. Qed. @@ -1493,10 +1493,10 @@ Qed. Lemma exists_2 : forall s, compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. -Proof. +Proof. induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *. discriminate. - destruct (orb_true_elim _ _ H0) as [H1|H1]. + destruct (orb_true_elim _ _ H0) as [H1|H1]. destruct (orb_true_elim _ _ H1) as [H2|H2]. exists t; auto. destruct (IHs1 H H2); auto; exists x; intuition. @@ -1509,7 +1509,7 @@ End F. (** * Fold *) -Definition fold' (A : Type) (f : elt -> A -> A)(s : tree) := +Definition fold' (A : Type) (f : elt -> A -> A)(s : tree) := L.fold f (elements s). Implicit Arguments fold' [A]. @@ -1529,14 +1529,14 @@ Lemma fold_equiv : forall (A : Type) (s : tree) (f : elt -> A -> A) (a : A), fold f s a = fold' f s a. Proof. - unfold fold', elements in |- *. + unfold fold', elements in |- *. simple induction s; simpl in |- *; auto; intros. rewrite fold_equiv_aux. rewrite H0. simpl in |- *; auto. Qed. -Lemma fold_1 : +Lemma fold_1 : forall (s:t)(Hs:bst s)(A : Type)(f : elt -> A -> A)(i : A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. @@ -1552,7 +1552,7 @@ Qed. Lemma subsetl_12 : forall subset_l1 l1 x1 h1 s2, bst (Node l1 x1 Leaf h1) -> bst s2 -> - (forall s, bst s -> (subset_l1 s = true <-> Subset l1 s)) -> + (forall s, bst s -> (subset_l1 s = true <-> Subset l1 s)) -> (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ). Proof. induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. @@ -1563,7 +1563,7 @@ Proof. specialize (IHr2 H H3 H1). inv bst. clear H8. destruct X.compare. - + rewrite IHl2; clear H1 IHl2 IHr2. unfold Subset. intuition_in. assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. @@ -1584,7 +1584,7 @@ Qed. Lemma subsetr_12 : forall subset_r1 r1 x1 h1 s2, bst (Node Leaf x1 r1 h1) -> bst s2 -> - (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> + (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2). Proof. induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. @@ -1606,7 +1606,7 @@ Proof. unfold Subset. intuition_in. assert (X.eq a x2) by order; intuition_in. assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - + rewrite IHr2; clear H1 IHl2 IHr2. unfold Subset. intuition_in. assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. @@ -1614,7 +1614,7 @@ Proof. Qed. -Lemma subset_12 : forall s1 s2, bst s1 -> bst s2 -> +Lemma subset_12 : forall s1 s2, bst s1 -> bst s2 -> (subset s1 s2 = true <-> Subset s1 s2). Proof. induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros. @@ -1638,7 +1638,7 @@ Proof. assert (X.eq a x2) by order; intuition_in. assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - + rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. rewrite (@subsetr_12 (subset r1) r1 x1 h1) by auto. clear IHl1 IHr1. @@ -1656,7 +1656,7 @@ Qed. Definition eq := Equal. Definition lt (s1 s2 : t) : Prop := L.lt (elements s1) (elements s2). -Lemma eq_refl : forall s : t, Equal s s. +Lemma eq_refl : forall s : t, Equal s s. Proof. unfold Equal; intuition. Qed. @@ -1666,10 +1666,10 @@ Proof. unfold Equal; intros s s' H x; destruct (H x); split; auto. Qed. -Lemma eq_trans : forall s s' s'' : t, +Lemma eq_trans : forall s s' s'' : t, Equal s s' -> Equal s' s'' -> Equal s s''. Proof. - unfold Equal; intros s s' s'' H1 H2 x; + unfold Equal; intros s s' s'' H1 H2 x; destruct (H1 x); destruct (H2 x); split; auto. Qed. @@ -1686,10 +1686,10 @@ Proof. Qed. Hint Resolve eq_L_eq L_eq_eq. -Definition lt_trans (s s' s'' : t) (h : lt s s') +Definition lt_trans (s s' s'' : t) (h : lt s s') (h' : lt s' s'') : lt s s'' := L.lt_trans h h'. -Lemma lt_not_eq : forall s s' : t, +Lemma lt_not_eq : forall s s' : t, bst s -> bst s' -> lt s s' -> ~ Equal s s'. Proof. unfold lt in |- *; intros; intro. @@ -1713,7 +1713,7 @@ Hint Resolve L_eq_cons. (** [flatten_e e] returns the list of elements of [e] i.e. the list of elements actually compared *) - + Fixpoint flatten_e (e : enumeration) : list elt := match e with | End => nil | More x t r => x :: elements t ++ flatten_e r @@ -1726,7 +1726,7 @@ Proof. intros; simpl; apply elements_node. Qed. -Lemma cons_1 : forall s e, +Lemma cons_1 : forall s e, flatten_e (cons s e) = elements s ++ flatten_e e. Proof. induction s; simpl; auto; intros. @@ -1735,37 +1735,37 @@ Qed. (** Correctness of this comparison *) -Definition Cmp c := - match c with +Definition Cmp c := + match c with | Eq => L.eq | Lt => L.lt | Gt => (fun l1 l2 => L.lt l2 l1) end. Lemma cons_Cmp : forall c x1 x2 l1 l2, X.eq x1 x2 -> - Cmp c l1 l2 -> Cmp c (x1::l1) (x2::l2). + Cmp c l1 l2 -> Cmp c (x1::l1) (x2::l2). Proof. destruct c; simpl; auto. Qed. Hint Resolve cons_Cmp. -Lemma compare_end_Cmp : +Lemma compare_end_Cmp : forall e2, Cmp (compare_end e2) nil (flatten_e e2). Proof. destruct e2; simpl; auto. apply L.eq_refl. Qed. -Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, - Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> - Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) +Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, + Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> + Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) (flatten_e (More x2 r2 e2)). Proof. simpl; intros; destruct X.compare; simpl; auto. Qed. Lemma compare_cont_Cmp : forall s1 cont e2 l, - (forall e, Cmp (cont e) l (flatten_e e)) -> + (forall e, Cmp (cont e) l (flatten_e e)) -> Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). Proof. induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto. @@ -1781,7 +1781,7 @@ Lemma compare_Cmp : forall s1 s2, Proof. intros; unfold compare. rewrite (app_nil_end (elements s1)). - replace (elements s2) with (flatten_e (cons s2 End)) by + replace (elements s2) with (flatten_e (cons s2 End)) by (rewrite cons_1; simpl; rewrite <- app_nil_end; auto). apply compare_cont_Cmp; auto. intros. @@ -1790,21 +1790,21 @@ Qed. (** * Equality test *) -Lemma equal_1 : forall s1 s2, bst s1 -> bst s2 -> +Lemma equal_1 : forall s1 s2, bst s1 -> bst s2 -> Equal s1 s2 -> equal s1 s2 = true. Proof. unfold equal; intros s1 s2 B1 B2 E. -generalize (compare_Cmp s1 s2). +generalize (compare_Cmp s1 s2). destruct (compare s1 s2); simpl in *; auto; intros. elim (lt_not_eq B1 B2 H E); auto. elim (lt_not_eq B2 B1 H (eq_sym E)); auto. Qed. -Lemma equal_2 : forall s1 s2, +Lemma equal_2 : forall s1 s2, equal s1 s2 = true -> Equal s1 s2. Proof. unfold equal; intros s1 s2 E. -generalize (compare_Cmp s1 s2); +generalize (compare_Cmp s1 s2); destruct compare; auto; discriminate. Qed. @@ -1816,10 +1816,10 @@ End Raw. (** * Encapsulation - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of binary search trees. - They also happen to be well-balanced, but this has no influence - on the correctness of operations, so we won't state this here, + Now, in order to really provide a functor implementing [S], we + need to encapsulate everything into a type of binary search trees. + They also happen to be well-balanced, but this has no influence + on the correctness of operations, so we won't state this here, see [FSetFullAVL] if you need more than just the FSet interface. *) @@ -1832,7 +1832,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Record bst := Bst {this :> Raw.t; is_bst : Raw.bst this}. Definition t := bst. Definition elt := E.t. - + Definition In (x : elt) (s : t) := Raw.In x s. Definition Equal (s s':t) := forall a : elt, In a s <-> In a s'. Definition Subset (s s':t) := forall a : elt, In a s -> In a s'. @@ -1840,15 +1840,15 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Definition For_all (P : elt -> Prop) (s:t) := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) (s:t) := exists x, In x s /\ P x. - Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. + Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. Proof. intro s; exact (@In_1 s). Qed. - + Definition mem (x:elt)(s:t) : bool := Raw.mem x s. Definition empty : t := Bst empty_bst. Definition is_empty (s:t) : bool := Raw.is_empty s. Definition singleton (x:elt) : t := Bst (singleton_bst x). - Definition add (x:elt)(s:t) : t := Bst (add_bst x (is_bst s)). + Definition add (x:elt)(s:t) : t := Bst (add_bst x (is_bst s)). Definition remove (x:elt)(s:t) : t := Bst (remove_bst x (is_bst s)). Definition inter (s s':t) : t := Bst (inter_bst (is_bst s) (is_bst s')). Definition union (s s':t) : t := Bst (union_bst (is_bst s) (is_bst s')). @@ -1859,13 +1859,13 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Definition choose (s:t) : option elt := Raw.choose s. Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := Raw.fold f s. Definition cardinal (s:t) : nat := Raw.cardinal s. - Definition filter (f : elt -> bool) (s:t) : t := + Definition filter (f : elt -> bool) (s:t) : t := Bst (filter_bst f (is_bst s)). Definition for_all (f : elt -> bool) (s:t) : bool := Raw.for_all f s. Definition exists_ (f : elt -> bool) (s:t) : bool := Raw.exists_ f s. Definition partition (f : elt -> bool) (s:t) : t * t := let p := Raw.partition f s in - (@Bst (fst p) (partition_bst_1 f (is_bst s)), + (@Bst (fst p) (partition_bst_1 f (is_bst s)), @Bst (snd p) (partition_bst_2 f (is_bst s))). Definition equal (s s':t) : bool := Raw.equal s s'. @@ -1890,13 +1890,13 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Defined. (* specs *) - Section Specs. - Variable s s' s'': t. + Section Specs. + Variable s s' s'': t. Variable x y : elt. Hint Resolve is_bst. - - Lemma mem_1 : In x s -> mem x s = true. + + Lemma mem_1 : In x s -> mem x s = true. Proof. exact (mem_1 (is_bst s)). Qed. Lemma mem_2 : mem x s = true -> In x s. Proof. exact (@mem_2 s x). Qed. @@ -1918,14 +1918,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma is_empty_1 : Empty s -> is_empty s = true. Proof. exact (@is_empty_1 s). Qed. - Lemma is_empty_2 : is_empty s = true -> Empty s. + Lemma is_empty_2 : is_empty s = true -> Empty s. Proof. exact (@is_empty_2 s). Qed. - + Lemma add_1 : E.eq x y -> In y (add x s). Proof. wrap add add_in. Qed. Lemma add_2 : In y s -> In y (add x s). Proof. wrap add add_in. Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. Proof. wrap add add_in. elim H; auto. Qed. Lemma remove_1 : E.eq x y -> ~ In y (remove x s). @@ -1935,14 +1935,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma remove_3 : In y (remove x s) -> In y s. Proof. wrap remove remove_in. Qed. - Lemma singleton_1 : In y (singleton x) -> E.eq x y. + Lemma singleton_1 : In y (singleton x) -> E.eq x y. Proof. exact (@singleton_1 x y). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). + Lemma singleton_2 : E.eq x y -> In y (singleton x). Proof. exact (@singleton_2 x y). Qed. Lemma union_1 : In x (union s s') -> In x s \/ In x s'. Proof. wrap union union_in. Qed. - Lemma union_2 : In x s -> In x (union s s'). + Lemma union_2 : In x s -> In x (union s s'). Proof. wrap union union_in. Qed. Lemma union_3 : In x s' -> In x (union s s'). Proof. wrap union union_in. Qed. @@ -1953,30 +1953,30 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. wrap inter inter_in. Qed. Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). Proof. wrap inter inter_in. Qed. - - Lemma diff_1 : In x (diff s s') -> In x s. + + Lemma diff_1 : In x (diff s s') -> In x s. Proof. wrap diff diff_in. Qed. Lemma diff_2 : In x (diff s s') -> ~ In x s'. Proof. wrap diff diff_in. Qed. Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). Proof. wrap diff diff_in. Qed. - + Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. unfold fold, elements; intros; apply fold_1; auto. Qed. Lemma cardinal_1 : cardinal s = length (elements s). - Proof. + Proof. unfold cardinal, elements; intros; apply elements_cardinal; auto. Qed. Section Filter. Variable f : elt -> bool. - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Proof. intro. wrap filter filter_in. Qed. + Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. Proof. intro. wrap filter filter_in. Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. intro. wrap filter filter_in. Qed. Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). Proof. intro. wrap filter filter_in. Qed. @@ -1990,14 +1990,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. Proof. exact (@exists_2 f s). Qed. - Lemma partition_1 : compat_bool E.eq f -> + Lemma partition_1 : compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. unfold partition, filter, Equal, In; simpl ;intros H a. rewrite partition_in_1, filter_in; intuition. Qed. - Lemma partition_2 : compat_bool E.eq f -> + Lemma partition_2 : compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. unfold partition, filter, Equal, In; simpl ;intros H a. @@ -2019,14 +2019,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma elements_3w : NoDupA E.eq (elements s). Proof. exact (elements_nodup (is_bst s)). Qed. - Lemma min_elt_1 : min_elt s = Some x -> In x s. + Lemma min_elt_1 : min_elt s = Some x -> In x s. Proof. exact (@min_elt_1 s x). Qed. Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. Proof. exact (@min_elt_2 s x y (is_bst s)). Qed. Lemma min_elt_3 : min_elt s = None -> Empty s. Proof. exact (@min_elt_3 s). Qed. - Lemma max_elt_1 : max_elt s = Some x -> In x s. + Lemma max_elt_1 : max_elt s = Some x -> In x s. Proof. exact (@max_elt_1 s x). Qed. Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. Proof. exact (@max_elt_2 s x y (is_bst s)). Qed. @@ -2037,17 +2037,17 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. exact (@choose_1 s x). Qed. Lemma choose_2 : choose s = None -> Empty s. Proof. exact (@choose_2 s). Qed. - Lemma choose_3 : choose s = Some x -> choose s' = Some y -> + Lemma choose_3 : choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed. - Lemma eq_refl : eq s s. + Lemma eq_refl : eq s s. Proof. exact (eq_refl s). Qed. Lemma eq_sym : eq s s' -> eq s' s. Proof. exact (@eq_sym s s'). Qed. Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''. Proof. exact (@eq_trans s s' s''). Qed. - + Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''. Proof. exact (@lt_trans s s' s''). Qed. Lemma lt_not_eq : lt s s' -> ~eq s s'. diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index e0e8582111..796db9f8fb 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -23,51 +23,51 @@ Set Firstorder Depth 2. Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition empty : {s : t | Empty s}. - Proof. + Proof. exists empty; auto with set. Qed. Definition is_empty : forall s : t, {Empty s} + {~ Empty s}. - Proof. + Proof. intros; generalize (is_empty_1 (s:=s)) (is_empty_2 (s:=s)). case (is_empty s); intuition. Qed. Definition mem : forall (x : elt) (s : t), {In x s} + {~ In x s}. - Proof. + Proof. intros; generalize (mem_1 (s:=s) (x:=x)) (mem_2 (s:=s) (x:=x)). case (mem x s); intuition. Qed. - + Definition Add (x : elt) (s s' : t) := forall y : elt, In y s' <-> E.eq x y \/ In y s. - + Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}. Proof. intros; exists (add x s); auto. unfold Add in |- *; intuition. elim (E.eq_dec x y); auto. - intros; right. + intros; right. eapply add_3; eauto. - Qed. - + Qed. + Definition singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. - Proof. + Proof. intros; exists (singleton x); intuition. Qed. - + Definition remove : forall (x : elt) (s : t), {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. Proof. intros; exists (remove x s); intuition. absurd (In x (remove x s)); auto with set. - apply In_1 with y; auto. + apply In_1 with y; auto. elim (E.eq_dec x y); intros; auto. absurd (In x (remove x s)); auto with set. - apply In_1 with y; auto. + apply In_1 with y; auto. eauto with set. Qed. @@ -75,47 +75,47 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. Proof. intros; exists (union s s'); intuition. - Qed. + Qed. Definition inter : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. - Proof. + Proof. intros; exists (inter s s'); intuition; eauto with set. Qed. Definition diff : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. - Proof. - intros; exists (diff s s'); intuition; eauto with set. - absurd (In x s'); eauto with set. - Qed. - + Proof. + intros; exists (diff s s'); intuition; eauto with set. + absurd (In x s'); eauto with set. + Qed. + Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}. - Proof. - intros. + Proof. + intros. generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')). case (equal s s'); intuition. Qed. Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}. - Proof. - intros. + Proof. + intros. generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')). case (subset s s'); intuition. - Qed. + Qed. Definition elements : forall s : t, {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}. Proof. - intros; exists (elements s); intuition. - Defined. + intros; exists (elements s); intuition. + Defined. Definition fold : forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), - {r : A | let (l,_) := elements s in + {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. - Proof. + Proof. intros; exists (fold (A:=A) f s i); exact (fold_1 s i f). Qed. @@ -124,10 +124,10 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. {r : nat | let (l,_) := elements s in r = length l }. Proof. intros; exists (cardinal s); exact (cardinal_1 s). - Qed. + Qed. Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) - (x : elt) := if Pdec x then true else false. + (x : elt) := if Pdec x then true else false. Lemma compat_P_aux : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}), @@ -143,7 +143,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. Proof. - intros. + intros. exists (filter (fdec Pdec) s). intro H; assert (compat_bool E.eq (fdec Pdec)); auto. intuition. @@ -160,29 +160,29 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition for_all : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. - Proof. - intros. + Proof. + intros. generalize (for_all_1 (s:=s) (f:=fdec Pdec)) (for_all_2 (s:=s) (f:=fdec Pdec)). case (for_all (fdec Pdec) s); unfold For_all in |- *; [ left | right ]; intros. assert (compat_bool E.eq (fdec Pdec)); auto. generalize (H0 H3 (refl_equal _) _ H2). - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. inversion H4. - intuition. + intuition. absurd (false = true); [ auto with bool | apply H; auto ]. intro. - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. Qed. Definition exists_ : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}. - Proof. - intros. + Proof. + intros. generalize (exists_1 (s:=s) (f:=fdec Pdec)) (exists_2 (s:=s) (f:=fdec Pdec)). case (exists_ (fdec Pdec) s); unfold Exists in |- *; [ left | right ]; @@ -190,14 +190,14 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. elim H0; auto; intros. exists x; intuition. generalize H4. - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. inversion H2. - intuition. - elim H2; intros. + intuition. + elim H2; intros. absurd (false = true); [ auto with bool | apply H; auto ]. exists x; intuition. - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. Qed. @@ -228,12 +228,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. inversion H9. generalize H; unfold For_all, Equal in |- *; intuition. elim (H0 x); intros. - cut ((fun x => negb (fdec Pdec x)) x = true). + cut ((fun x => negb (fdec Pdec x)) x = true). unfold fdec in |- *; case (Pdec x); intuition. change ((fun x => negb (fdec Pdec x)) x = true) in |- *. apply (filter_2 (s:=s) (x:=x)); auto. set (b := fdec Pdec x) in *; generalize (refl_equal b); - pattern b at -1 in |- *; case b; unfold b in |- *; + pattern b at -1 in |- *; case b; unfold b in |- *; [ left | right ]. elim (H4 x); intros _ B; apply B; auto with set. elim (H x); intros _ B; apply B; auto with set. @@ -242,16 +242,16 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B; auto. eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto. - Qed. + Qed. - Definition choose_aux: forall s : t, + Definition choose_aux: forall s : t, { x : elt | M.choose s = Some x } + { M.choose s = None }. Proof. intros. destruct (M.choose s); [left | right]; auto. exists e; auto. Qed. - + Definition choose : forall s : t, {x : elt | In x s} + {Empty s}. Proof. intros; destruct (choose_aux s) as [(x,Hx)|H]. @@ -259,12 +259,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. right; apply choose_2; auto. Defined. - Lemma choose_ok1 : - forall s x, M.choose s = Some x <-> exists H:In x s, + Lemma choose_ok1 : + forall s x, M.choose s = Some x <-> exists H:In x s, choose s = inleft _ (exist (fun x => In x s) x H). Proof. intros s x. - unfold choose; split; intros. + unfold choose; split; intros. destruct (choose_aux s) as [(y,Hy)|H']; try congruence. replace x with y in * by congruence. exists (choose_1 Hy); auto. @@ -272,10 +272,10 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. destruct (choose_aux s) as [(y,Hy)|H']; congruence. Qed. - Lemma choose_ok2 : - forall s, M.choose s = None <-> exists H:Empty s, + Lemma choose_ok2 : + forall s, M.choose s = None <-> exists H:Empty s, choose s = inright _ H. - Proof. + Proof. intros s. unfold choose; split; intros. destruct (choose_aux s) as [(y,Hy)|H']; try congruence. @@ -284,8 +284,8 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. destruct (choose_aux s) as [(y,Hy)|H']; congruence. Qed. - Lemma choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with | inleft (exist x _), inleft (exist x' _) => E.eq x x' | inright _, inright _ => True | _, _ => False @@ -306,29 +306,29 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition min_elt : forall s : t, {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. - Proof. + Proof. intros; generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)). - case (min_elt s); [ left | right ]; auto. + case (min_elt s); [ left | right ]; auto. exists e; unfold For_all in |- *; eauto. - Qed. + Qed. Definition max_elt : forall s : t, {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. - Proof. + Proof. intros; generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)). - case (max_elt s); [ left | right ]; auto. + case (max_elt s); [ left | right ]; auto. exists e; unfold For_all in |- *; eauto. - Qed. + Qed. - Module E := E. + Module E := E. Definition elt := elt. Definition t := t. - Definition In := In. + Definition In := In. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Empty s := forall a : elt, ~ In a s. @@ -336,7 +336,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. forall x : elt, In x s -> P x. Definition Exists (P : elt -> Prop) (s : t) := exists x : elt, In x s /\ P x. - + Definition eq_In := In_1. Definition eq := Equal. @@ -344,7 +344,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition eq_refl := eq_refl. Definition eq_sym := eq_sym. Definition eq_trans := eq_trans. - Definition lt_trans := lt_trans. + Definition lt_trans := lt_trans. Definition lt_not_eq := lt_not_eq. Definition compare := compare. @@ -386,7 +386,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros; unfold mem in |- *; case (M.mem x s); auto. Qed. - + Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. Proof. intros s x; unfold mem in |- *; case (M.mem x s); auto. @@ -399,26 +399,26 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. if equal s s' then true else false. Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true. - Proof. + Proof. intros; unfold equal in |- *; case M.equal; intuition. - Qed. - + Qed. + Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'. - Proof. + Proof. intros s s'; unfold equal in |- *; case (M.equal s s'); intuition; inversion H. Qed. - + Definition subset (s s' : t) : bool := if subset s s' then true else false. Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true. - Proof. + Proof. intros; unfold subset in |- *; case M.subset; intuition. - Qed. - + Qed. + Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'. - Proof. + Proof. intros s s'; unfold subset in |- *; case (M.subset s s'); intuition; inversion H. Qed. @@ -441,34 +441,34 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. intro s; unfold choose in |- *; case (M.choose s); auto. simple destruct s0; intros; discriminate H. Qed. - - Lemma choose_3 : forall s s' x x', + + Lemma choose_3 : forall s s' x x', choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'. Proof. unfold choose; intros. generalize (M.choose_equal H1); clear H1. - destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; + destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; simpl; auto; congruence. Qed. - Definition elements (s : t) : list elt := let (l, _) := elements s in l. - + Definition elements (s : t) : list elt := let (l, _) := elements s in l. + Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s). - Proof. + Proof. intros; unfold elements in |- *; case (M.elements s); firstorder. Qed. Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s. - Proof. + Proof. intros s x; unfold elements in |- *; case (M.elements s); firstorder. Qed. - Lemma elements_3 : forall s : t, sort E.lt (elements s). - Proof. + Lemma elements_3 : forall s : t, sort E.lt (elements s). + Proof. intros; unfold elements in |- *; case (M.elements s); firstorder. Qed. Hint Resolve elements_3. - + Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). Proof. auto. Qed. @@ -478,27 +478,27 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. | inright _ => None end. - Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. + Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. Proof. intros s x; unfold min_elt in |- *; case (M.min_elt s). simple destruct s0; intros; injection H; intros; subst; intuition. intros; discriminate H. - Qed. + Qed. Lemma min_elt_2 : - forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. + forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. Proof. intros s x y; unfold min_elt in |- *; case (M.min_elt s). unfold For_all in |- *; simple destruct s0; intros; injection H; intros; subst; firstorder. intros; discriminate H. - Qed. + Qed. Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. Proof. intros s; unfold min_elt in |- *; case (M.min_elt s); auto. simple destruct s0; intros; discriminate H. - Qed. + Qed. Definition max_elt (s : t) : option elt := match max_elt s with @@ -506,27 +506,27 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. | inright _ => None end. - Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. + Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. Proof. intros s x; unfold max_elt in |- *; case (M.max_elt s). simple destruct s0; intros; injection H; intros; subst; intuition. intros; discriminate H. - Qed. + Qed. Lemma max_elt_2 : - forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. + forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. Proof. intros s x y; unfold max_elt in |- *; case (M.max_elt s). unfold For_all in |- *; simple destruct s0; intros; injection H; intros; subst; firstorder. intros; discriminate H. - Qed. + Qed. Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. Proof. intros s; unfold max_elt in |- *; case (M.max_elt s); auto. simple destruct s0; intros; discriminate H. - Qed. + Qed. Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'. @@ -566,70 +566,70 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros s x y; unfold remove in |- *; case (M.remove x s); firstorder. Qed. - - Definition singleton (x : elt) : t := let (s, _) := singleton x in s. - - Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. + + Definition singleton (x : elt) : t := let (s, _) := singleton x in s. + + Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. Proof. intros x y; unfold singleton in |- *; case (M.singleton x); firstorder. Qed. - Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). + Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). Proof. intros x y; unfold singleton in |- *; case (M.singleton x); firstorder. Qed. - + Definition union (s s' : t) : t := let (s'', _) := union s s' in s''. - + Lemma union_1 : forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'. - Proof. + Proof. intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. Qed. - Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). - Proof. + Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). + Proof. intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. Qed. Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s'). - Proof. + Proof. intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. Qed. Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''. - + Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s. - Proof. + Proof. intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. Qed. Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'. - Proof. + Proof. intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. Qed. Lemma inter_3 : forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s'). - Proof. + Proof. intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. Qed. Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''. - + Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s. - Proof. + Proof. intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. Qed. Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'. - Proof. + Proof. intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. Qed. Lemma diff_3 : forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s'). - Proof. + Proof. intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. Qed. @@ -637,26 +637,26 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Lemma cardinal_1 : forall s, cardinal s = length (elements s). Proof. - intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; + intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; destruct (M.elements s); auto. Qed. - Definition fold (B : Type) (f : elt -> B -> B) (i : t) + Definition fold (B : Type) (f : elt -> B -> B) (i : t) (s : B) : B := let (fold, _) := fold f i s in fold. Lemma fold_1 : forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. - intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *; + intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *; destruct (M.elements s); auto. - Qed. + Qed. Definition f_dec : forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}. Proof. intros; case (f x); auto with bool. - Defined. + Defined. Lemma compat_P_aux : forall f : elt -> bool, @@ -666,7 +666,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Qed. Hint Resolve compat_P_aux. - + Definition filter (f : elt -> bool) (s : t) : t := let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'. @@ -680,7 +680,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Lemma filter_2 : forall (s : t) (x : elt) (f : elt -> bool), - compat_bool E.eq f -> In x (filter f s) -> f x = true. + compat_bool E.eq f -> In x (filter f s) -> f x = true. Proof. intros s x f; unfold filter in |- *; case M.filter; intuition. generalize (i (compat_P_aux H)); firstorder. @@ -688,7 +688,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Lemma filter_3 : forall (s : t) (x : elt) (f : elt -> bool), - compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). + compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). Proof. intros s x f; unfold filter in |- *; case M.filter; intuition. generalize (i (compat_P_aux H)); firstorder. @@ -697,98 +697,98 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Definition for_all (f : elt -> bool) (s : t) : bool := if for_all (P:=fun x => f x = true) (f_dec f) s then true - else false. + else false. Lemma for_all_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. - Proof. + Proof. intros s f; unfold for_all in |- *; case M.for_all; intuition; elim n; auto. Qed. - + Lemma for_all_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. - Proof. + Proof. intros s f; unfold for_all in |- *; case M.for_all; intuition; inversion H0. Qed. - + Definition exists_ (f : elt -> bool) (s : t) : bool := if exists_ (P:=fun x => f x = true) (f_dec f) s then true - else false. + else false. Lemma exists_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. + Proof. intros s f; unfold exists_ in |- *; case M.exists_; intuition; elim n; auto. Qed. - + Lemma exists_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. + Proof. intros s f; unfold exists_ in |- *; case M.exists_; intuition; inversion H0. Qed. - - Definition partition (f : elt -> bool) (s : t) : + + Definition partition (f : elt -> bool) (s : t) : t * t := let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p. - + Lemma partition_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. - intros s f; unfold partition in |- *; case M.partition. - intro p; case p; clear p; intros s1 s2 H C. + intros s f; unfold partition in |- *; case M.partition. + intro p; case p; clear p; intros s1 s2 H C. generalize (H (compat_P_aux C)); clear H; intro H. simpl in |- *; unfold Equal in |- *; intuition. - apply filter_3; firstorder. - elim (H2 a); intros. - assert (In a s). + apply filter_3; firstorder. + elim (H2 a); intros. + assert (In a s). eapply filter_1; eauto. elim H3; intros; auto. absurd (f a = true). exact (H a H6). - eapply filter_2; eauto. - Qed. - + eapply filter_2; eauto. + Qed. + Lemma partition_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. - intros s f; unfold partition in |- *; case M.partition. - intro p; case p; clear p; intros s1 s2 H C. + intros s f; unfold partition in |- *; case M.partition. + intro p; case p; clear p; intros s1 s2 H C. generalize (H (compat_P_aux C)); clear H; intro H. assert (D : compat_bool E.eq (fun x => negb (f x))). generalize C; unfold compat_bool in |- *; intros; apply (f_equal negb); auto. simpl in |- *; unfold Equal in |- *; intuition. apply filter_3; firstorder. - elim (H2 a); intros. - assert (In a s). + elim (H2 a); intros. + assert (In a s). eapply filter_1; eauto. elim H3; intros; auto. absurd (f a = true). intro. - generalize (filter_2 D H1). + generalize (filter_2 D H1). rewrite H7; intros H8; inversion H8. exact (H0 a H6). - Qed. + Qed. - Module E := E. + Module E := E. Definition elt := elt. Definition t := t. - Definition In := In. + Definition In := In. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Add (x : elt) (s s' : t) := @@ -806,7 +806,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Definition eq_refl := eq_refl. Definition eq_sym := eq_sym. Definition eq_trans := eq_trans. - Definition lt_trans := lt_trans. + Definition lt_trans := lt_trans. Definition lt_not_eq := lt_not_eq. Definition compare := compare. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index b7a1deb771..89cdc932fa 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -148,35 +148,35 @@ the above form: XXX: This tactic and the similar subsequent ones should have been defined using [autorewrite]. However, dealing - with multiples rewrite sites and side-conditions is - done more cleverly with the following explicit + with multiples rewrite sites and side-conditions is + done more cleverly with the following explicit analysis of goals. *) - Ltac or_not_l_iff P Q tac := - (rewrite (or_not_l_iff_1 P Q) by tac) || + Ltac or_not_l_iff P Q tac := + (rewrite (or_not_l_iff_1 P Q) by tac) || (rewrite (or_not_l_iff_2 P Q) by tac). - Ltac or_not_r_iff P Q tac := - (rewrite (or_not_r_iff_1 P Q) by tac) || + Ltac or_not_r_iff P Q tac := + (rewrite (or_not_r_iff_1 P Q) by tac) || (rewrite (or_not_r_iff_2 P Q) by tac). - Ltac or_not_l_iff_in P Q H tac := - (rewrite (or_not_l_iff_1 P Q) in H by tac) || + Ltac or_not_l_iff_in P Q H tac := + (rewrite (or_not_l_iff_1 P Q) in H by tac) || (rewrite (or_not_l_iff_2 P Q) in H by tac). - Ltac or_not_r_iff_in P Q H tac := - (rewrite (or_not_r_iff_1 P Q) in H by tac) || + Ltac or_not_r_iff_in P Q H tac := + (rewrite (or_not_r_iff_1 P Q) in H by tac) || (rewrite (or_not_r_iff_2 P Q) in H by tac). Tactic Notation "push" "not" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff; repeat ( match goal with | |- context [True -> False] => rewrite not_true_iff | |- context [False -> False] => rewrite not_false_iff | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => + | |- context [(?P -> False) -> (?Q -> False)] => rewrite (contrapositive P Q) by dec | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec @@ -192,23 +192,23 @@ the above form: Tactic Notation "push" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff in * |-; repeat ( match goal with | H: context [True -> False] |- _ => rewrite not_true_iff in H | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => + | H: context [(?P -> False) -> False] |- _ => rewrite (not_not_iff P) in H by dec | H: context [(?P -> False) -> (?Q -> False)] |- _ => rewrite (contrapositive P Q) in H by dec | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => + | H: context [(?P -> False) -> ?Q] |- _ => rewrite (imp_not_l P Q) in H by dec | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H - | H: context [(?P -> ?Q) -> False] |- _ => + | H: context [(?P -> ?Q) -> False] |- _ => rewrite (not_imp_iff P Q) in H by dec end); fold any not. @@ -253,7 +253,7 @@ the above form: the hypotheses and goal together. *) Tactic Notation "pull" "not" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff; repeat ( match goal with @@ -269,7 +269,7 @@ the above form: rewrite <- (not_or_iff P Q) | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec - | |- context [(?Q -> False) /\ ?P] => + | |- context [(?Q -> False) /\ ?P] => rewrite <- (not_imp_rev_iff P Q) by dec end); fold any not. @@ -279,7 +279,7 @@ the above form: Tactic Notation "pull" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff in * |-; repeat ( match goal with @@ -294,8 +294,8 @@ the above form: | H: context [(?P -> False) -> ?Q] |- _ => rewrite (imp_not_l P Q) in H by dec | H: context [(?P -> False) /\ (?Q -> False)] |- _ => - rewrite <- (not_or_iff P Q) in H - | H: context [?P -> ?Q -> False] |- _ => + rewrite <- (not_or_iff P Q) in H + | H: context [?P -> ?Q -> False] |- _ => rewrite <- (not_and_iff P Q) in H | H: context [?P /\ (?Q -> False)] |- _ => rewrite <- (not_imp_iff P Q) in H by dec diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index 7ec360a665..d843bbcd60 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -10,11 +10,11 @@ (** * Finite sets library *) -(** This module proves many properties of finite sets that - are consequences of the axiomatization in [FsetInterface] - Contrary to the functor in [FsetProperties] it uses +(** This module proves many properties of finite sets that + are consequences of the axiomatization in [FsetInterface] + Contrary to the functor in [FsetProperties] it uses sets operations instead of predicates over sets, i.e. - [mem x s=true] instead of [In x s], + [mem x s=true] instead of [In x s], [equal s s'=true] instead of [Equal s s'], etc. *) Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx. @@ -26,59 +26,59 @@ Import M. Definition Add := MP.Add. -Section BasicProperties. +Section BasicProperties. -(** Some old specifications written with boolean equalities. *) +(** Some old specifications written with boolean equalities. *) Variable s s' s'': t. Variable x y z : elt. -Lemma mem_eq: +Lemma mem_eq: E.eq x y -> mem x s=mem y s. -Proof. +Proof. intro H; rewrite H; auto. Qed. -Lemma equal_mem_1: +Lemma equal_mem_1: (forall a, mem a s=mem a s') -> equal s s'=true. -Proof. +Proof. intros; apply equal_1; unfold Equal; intros. do 2 rewrite mem_iff; rewrite H; tauto. Qed. -Lemma equal_mem_2: +Lemma equal_mem_2: equal s s'=true -> forall a, mem a s=mem a s'. -Proof. +Proof. intros; rewrite (equal_2 H); auto. Qed. -Lemma subset_mem_1: +Lemma subset_mem_1: (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. -Proof. +Proof. intros; apply subset_1; unfold Subset; intros a. do 2 rewrite mem_iff; auto. Qed. -Lemma subset_mem_2: +Lemma subset_mem_2: subset s s'=true -> forall a, mem a s=true -> mem a s'=true. -Proof. +Proof. intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. Qed. - + Lemma empty_mem: mem x empty=false. -Proof. +Proof. rewrite <- not_mem_iff; auto with set. Qed. Lemma is_empty_equal_empty: is_empty s = equal s empty. -Proof. +Proof. apply bool_1; split; intros. auto with set. rewrite <- is_empty_iff; auto with set. Qed. - + Lemma choose_mem_1: choose s=Some x -> mem x s=true. -Proof. +Proof. auto with set. Qed. @@ -90,44 +90,44 @@ Qed. Lemma add_mem_1: mem x (add x s)=true. Proof. auto with set. -Qed. - +Qed. + Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. -Proof. +Proof. apply add_neq_b. Qed. Lemma remove_mem_1: mem x (remove x s)=false. -Proof. +Proof. rewrite <- not_mem_iff; auto with set. -Qed. - +Qed. + Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. -Proof. +Proof. apply remove_neq_b. Qed. -Lemma singleton_equal_add: +Lemma singleton_equal_add: equal (singleton x) (add x empty)=true. Proof. rewrite (singleton_equal_add x); auto with set. -Qed. +Qed. -Lemma union_mem: +Lemma union_mem: mem x (union s s')=mem x s || mem x s'. -Proof. +Proof. apply union_b. Qed. -Lemma inter_mem: +Lemma inter_mem: mem x (inter s s')=mem x s && mem x s'. -Proof. +Proof. apply inter_b. Qed. -Lemma diff_mem: +Lemma diff_mem: mem x (diff s s')=mem x s && negb (mem x s'). -Proof. +Proof. apply diff_b. Qed. @@ -143,7 +143,7 @@ Proof. intros; rewrite not_mem_iff; auto. Qed. -(** Properties of [equal] *) +(** Properties of [equal] *) Lemma equal_refl: equal s s=true. Proof. @@ -155,19 +155,19 @@ Proof. intros; apply bool_1; do 2 rewrite <- equal_iff; intuition. Qed. -Lemma equal_trans: +Lemma equal_trans: equal s s'=true -> equal s' s''=true -> equal s s''=true. Proof. intros; rewrite (equal_2 H); auto. Qed. -Lemma equal_equal: +Lemma equal_equal: equal s s'=true -> equal s s''=equal s' s''. Proof. intros; rewrite (equal_2 H); auto. Qed. -Lemma equal_cardinal: +Lemma equal_cardinal: equal s s'=true -> cardinal s=cardinal s'. Proof. auto with set. @@ -175,25 +175,25 @@ Qed. (* Properties of [subset] *) -Lemma subset_refl: subset s s=true. +Lemma subset_refl: subset s s=true. Proof. auto with set. Qed. -Lemma subset_antisym: +Lemma subset_antisym: subset s s'=true -> subset s' s=true -> equal s s'=true. Proof. auto with set. Qed. -Lemma subset_trans: +Lemma subset_trans: subset s s'=true -> subset s' s''=true -> subset s s''=true. Proof. do 3 rewrite <- subset_iff; intros. apply subset_trans with s'; auto. Qed. -Lemma subset_equal: +Lemma subset_equal: equal s s'=true -> subset s s'=true. Proof. auto with set. @@ -201,7 +201,7 @@ Qed. (** Properties of [choose] *) -Lemma choose_mem_3: +Lemma choose_mem_3: is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. Proof. intros. @@ -221,13 +221,13 @@ Qed. (** Properties of [add] *) -Lemma add_mem_3: +Lemma add_mem_3: mem y s=true -> mem y (add x s)=true. Proof. auto with set. Qed. -Lemma add_equal: +Lemma add_equal: mem x s=true -> equal (add x s) s=true. Proof. auto with set. @@ -235,26 +235,26 @@ Qed. (** Properties of [remove] *) -Lemma remove_mem_3: +Lemma remove_mem_3: mem y (remove x s)=true -> mem y s=true. Proof. rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. Qed. -Lemma remove_equal: +Lemma remove_equal: mem x s=false -> equal (remove x s) s=true. Proof. intros; apply equal_1; apply remove_equal. rewrite not_mem_iff; auto. Qed. -Lemma add_remove: +Lemma add_remove: mem x s=true -> equal (add x (remove x s)) s=true. Proof. intros; apply equal_1; apply add_remove; auto with set. Qed. -Lemma remove_add: +Lemma remove_add: mem x s=false -> equal (remove x (add x s)) s=true. Proof. intros; apply equal_1; apply remove_add; auto. @@ -297,37 +297,37 @@ Proof. auto with set. Qed. -Lemma union_subset_equal: +Lemma union_subset_equal: subset s s'=true -> equal (union s s') s'=true. Proof. auto with set. Qed. -Lemma union_equal_1: +Lemma union_equal_1: equal s s'=true-> equal (union s s'') (union s' s'')=true. Proof. auto with set. Qed. -Lemma union_equal_2: +Lemma union_equal_2: equal s' s''=true-> equal (union s s') (union s s'')=true. Proof. auto with set. Qed. -Lemma union_assoc: +Lemma union_assoc: equal (union (union s s') s'') (union s (union s' s''))=true. Proof. auto with set. Qed. -Lemma add_union_singleton: +Lemma add_union_singleton: equal (add x s) (union (singleton x) s)=true. Proof. auto with set. Qed. -Lemma union_add: +Lemma union_add: equal (union (add x s) s') (add x (union s s'))=true. Proof. auto with set. @@ -346,62 +346,62 @@ auto with set. Qed. Lemma union_subset_3: - subset s s''=true -> subset s' s''=true -> + subset s s''=true -> subset s' s''=true -> subset (union s s') s''=true. Proof. intros; apply subset_1; apply union_subset_3; auto with set. Qed. -(** Properties of [inter] *) +(** Properties of [inter] *) Lemma inter_sym: equal (inter s s') (inter s' s)=true. Proof. auto with set. Qed. -Lemma inter_subset_equal: +Lemma inter_subset_equal: subset s s'=true -> equal (inter s s') s=true. Proof. auto with set. Qed. -Lemma inter_equal_1: +Lemma inter_equal_1: equal s s'=true -> equal (inter s s'') (inter s' s'')=true. Proof. auto with set. Qed. -Lemma inter_equal_2: +Lemma inter_equal_2: equal s' s''=true -> equal (inter s s') (inter s s'')=true. Proof. auto with set. Qed. -Lemma inter_assoc: +Lemma inter_assoc: equal (inter (inter s s') s'') (inter s (inter s' s''))=true. Proof. auto with set. Qed. -Lemma union_inter_1: +Lemma union_inter_1: equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. Proof. auto with set. Qed. -Lemma union_inter_2: +Lemma union_inter_2: equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. Proof. auto with set. Qed. -Lemma inter_add_1: mem x s'=true -> +Lemma inter_add_1: mem x s'=true -> equal (inter (add x s) s') (add x (inter s s'))=true. Proof. auto with set. Qed. -Lemma inter_add_2: mem x s'=false -> +Lemma inter_add_2: mem x s'=false -> equal (inter (add x s) s') (inter s s')=true. Proof. intros; apply equal_1; apply inter_add_2. @@ -421,7 +421,7 @@ auto with set. Qed. Lemma inter_subset_3: - subset s'' s=true -> subset s'' s'=true -> + subset s'' s=true -> subset s'' s'=true -> subset s'' (inter s s')=true. Proof. intros; apply subset_1; apply inter_subset_3; auto with set. @@ -440,19 +440,19 @@ Proof. auto with set. Qed. -Lemma remove_inter_singleton: +Lemma remove_inter_singleton: equal (remove x s) (diff s (singleton x))=true. Proof. auto with set. Qed. Lemma diff_inter_empty: - equal (inter (diff s s') (inter s s')) empty=true. + equal (inter (diff s s') (inter s s')) empty=true. Proof. auto with set. Qed. -Lemma diff_inter_all: +Lemma diff_inter_all: equal (union (diff s s') (inter s s')) s=true. Proof. auto with set. @@ -462,7 +462,7 @@ End BasicProperties. Hint Immediate empty_mem is_empty_equal_empty add_mem_1 remove_mem_1 singleton_equal_add union_mem inter_mem - diff_mem equal_sym add_remove remove_add : set. + diff_mem equal_sym add_remove remove_add : set. Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal subset_refl subset_equal subset_antisym @@ -472,8 +472,8 @@ Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 (** General recursion principle *) Lemma set_rec: forall (P:t->Type), - (forall s s', equal s s'=true -> P s -> P s') -> - (forall s x, mem x s=false -> P s -> P (add x s)) -> + (forall s s', equal s s'=true -> P s -> P s') -> + (forall s x, mem x s=false -> P s -> P (add x s)) -> P empty -> forall s, P s. Proof. intros. @@ -493,51 +493,51 @@ intros; do 2 rewrite mem_iff. destruct (mem x s); destruct (mem x s'); intuition. Qed. -Section Fold. +Section Fold. Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). Variables (i:A). Variables (s s':t)(x:elt). - + Lemma fold_empty: (fold f empty i) = i. -Proof. +Proof. apply fold_empty; auto. Qed. -Lemma fold_equal: +Lemma fold_equal: equal s s'=true -> eqA (fold f s i) (fold f s' i). -Proof. +Proof. intros; apply fold_equal with (eqA:=eqA); auto with set. Qed. - -Lemma fold_add: + +Lemma fold_add: mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). -Proof. +Proof. intros; apply fold_add with (eqA:=eqA); auto. rewrite not_mem_iff; auto. Qed. -Lemma add_fold: +Lemma add_fold: mem x s=true -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply add_fold with (eqA:=eqA); auto with set. Qed. -Lemma remove_fold_1: +Lemma remove_fold_1: mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. intros; apply remove_fold_1 with (eqA:=eqA); auto with set. Qed. -Lemma remove_fold_2: +Lemma remove_fold_2: mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros; apply remove_fold_2 with (eqA:=eqA); auto. rewrite not_mem_iff; auto. Qed. -Lemma fold_union: - (forall x, mem x s && mem x s'=false) -> +Lemma fold_union: + (forall x, mem x s && mem x s'=false) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. intros; apply fold_union with (eqA:=eqA); auto. @@ -548,40 +548,40 @@ End Fold. (** Properties of [cardinal] *) -Lemma add_cardinal_1: +Lemma add_cardinal_1: forall s x, mem x s=true -> cardinal (add x s)=cardinal s. Proof. auto with set. Qed. -Lemma add_cardinal_2: +Lemma add_cardinal_2: forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). Proof. intros; apply add_cardinal_2; auto. rewrite not_mem_iff; auto. Qed. -Lemma remove_cardinal_1: +Lemma remove_cardinal_1: forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. Proof. intros; apply remove_cardinal_1; auto with set. Qed. -Lemma remove_cardinal_2: +Lemma remove_cardinal_2: forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. Proof. intros; apply Equal_cardinal; apply equal_2; auto with set. Qed. -Lemma union_cardinal: - forall s s', (forall x, mem x s && mem x s'=false) -> +Lemma union_cardinal: + forall s s', (forall x, mem x s && mem x s'=false) -> cardinal (union s s')=cardinal s+cardinal s'. Proof. intros; apply union_cardinal; auto; intros. rewrite exclusive_set; auto. Qed. -Lemma subset_cardinal: +Lemma subset_cardinal: forall s s', subset s s'=true -> cardinal s<=cardinal s'. Proof. intros; apply subset_cardinal; auto with set. @@ -600,16 +600,16 @@ unfold compat_bool in *; intros; f_equal; auto. Qed. Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. -Proof. +Proof. intros; apply filter_b; auto. Qed. -Lemma for_all_filter: +Lemma for_all_filter: forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). -Proof. +Proof. intros; apply bool_1; split; intros. apply is_empty_1. -unfold Empty; intros. +unfold Empty; intros. rewrite filter_iff; auto. red; destruct 1. rewrite <- (@for_all_iff s f) in H; auto. @@ -621,10 +621,10 @@ rewrite filter_iff; auto. destruct (f x); auto. Qed. -Lemma exists_filter : +Lemma exists_filter : forall s, exists_ f s=negb (is_empty (filter f s)). -Proof. -intros; apply bool_1; split; intros. +Proof. +intros; apply bool_1; split; intros. destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). apply bool_6. red; intros; apply (@is_empty_2 _ H0 a); auto with set. @@ -636,28 +636,28 @@ intros _ H0. rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate. Qed. -Lemma partition_filter_1: +Lemma partition_filter_1: forall s, equal (fst (partition f s)) (filter f s)=true. -Proof. +Proof. auto with set. Qed. -Lemma partition_filter_2: +Lemma partition_filter_2: forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. -Proof. +Proof. auto with set. Qed. -Lemma filter_add_1 : forall s x, f x = true -> - filter f (add x s) [=] add x (filter f s). +Lemma filter_add_1 : forall s x, f x = true -> + filter f (add x s) [=] add x (filter f s). Proof. red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. intuition. rewrite <- H; apply Comp; auto. Qed. -Lemma filter_add_2 : forall s x, f x = false -> - filter f (add x s) [=] filter f s. +Lemma filter_add_2 : forall s x, f x = false -> + filter f (add x s) [=] filter f s. Proof. red; intros; do 2 (rewrite filter_iff; auto); set_iff. intuition. @@ -665,18 +665,18 @@ assert (f x = f a) by (apply Comp; auto). rewrite H in H1; rewrite H2 in H1; discriminate. Qed. -Lemma add_filter_1 : forall s s' x, +Lemma add_filter_1 : forall s s' x, f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). Proof. unfold Add, MP.Add; intros. repeat rewrite filter_iff; auto. rewrite H0; clear H0. -assert (E.eq x y -> f y = true) by +assert (E.eq x y -> f y = true) by (intro H0; rewrite <- (Comp _ _ H0); auto). tauto. Qed. -Lemma add_filter_2 : forall s s' x, +Lemma add_filter_2 : forall s s' x, f x=false -> (Add x s s') -> filter f s [=] filter f s'. Proof. unfold Add, MP.Add, Equal; intros. @@ -686,7 +686,7 @@ assert (f a = true -> ~E.eq x a). intros H0 H1. rewrite (Comp _ _ H1) in H. rewrite H in H0; discriminate. -tauto. +tauto. Qed. Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) -> @@ -711,7 +711,7 @@ Qed. (** Properties of [for_all] *) -Lemma for_all_mem_1: forall s, +Lemma for_all_mem_1: forall s, (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. Proof. intros. @@ -724,8 +724,8 @@ generalize (H a); case (mem a s);intros;auto. rewrite H0;auto. Qed. -Lemma for_all_mem_2: forall s, - (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. +Lemma for_all_mem_2: forall s, + (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. Proof. intros. rewrite for_all_filter in H; auto. @@ -737,7 +737,7 @@ rewrite H0; simpl;intros. rewrite <- negb_false_iff; auto. Qed. -Lemma for_all_mem_3: +Lemma for_all_mem_3: forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. Proof. intros. @@ -752,7 +752,7 @@ rewrite H0. simpl;auto. Qed. -Lemma for_all_mem_4: +Lemma for_all_mem_4: forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. Proof. intros. @@ -767,7 +767,7 @@ Qed. (** Properties of [exists] *) -Lemma for_all_exists: +Lemma for_all_exists: forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). Proof. intros. @@ -788,7 +788,7 @@ Proof. unfold compat_bool in *; intros; f_equal; auto. Qed. -Lemma exists_mem_1: +Lemma exists_mem_1: forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. Proof. intros. @@ -798,8 +798,8 @@ intros;generalize (H x H0);intros. rewrite negb_true_iff; auto. Qed. -Lemma exists_mem_2: - forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. +Lemma exists_mem_2: + forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. Proof. intros. rewrite for_all_exists in H; auto. @@ -808,7 +808,7 @@ rewrite <- negb_true_iff. apply for_all_mem_2 with (2:=H); auto. Qed. -Lemma exists_mem_3: +Lemma exists_mem_3: forall s x, mem x s=true -> f x=true -> exists_ f s=true. Proof. intros. @@ -818,7 +818,7 @@ apply for_all_mem_3 with x;auto. rewrite negb_false_iff; auto. Qed. -Lemma exists_mem_4: +Lemma exists_mem_4: forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. Proof. intros. @@ -836,12 +836,12 @@ Section Sum. (** Adding a valuation function on all elements of a set. *) -Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. +Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. Notation compat_opL := (compat_op E.eq (@Logic.eq _)). Notation transposeL := (transpose (@Logic.eq _)). -Lemma sum_plus : - forall f g, compat_nat E.eq f -> compat_nat E.eq g -> +Lemma sum_plus : + forall f g, compat_nat E.eq f -> compat_nat E.eq g -> forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. Proof. unfold sum. @@ -863,12 +863,12 @@ rewrite H0;simpl;omega. do 3 rewrite fold_empty;auto. Qed. -Lemma sum_filter : forall f, (compat_bool E.eq f) -> +Lemma sum_filter : forall f, (compat_bool E.eq f) -> forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). Proof. unfold sum; intros f Hf. assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). -assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). +assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). red; intros. rewrite (Hf x x' H); auto. assert (ct : transposeL (fun x => plus (if f x then 1 else 0))). @@ -891,12 +891,12 @@ unfold Empty; intros. rewrite filter_iff; auto; set_iff; tauto. Qed. -Lemma fold_compat : +Lemma fold_compat : forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f g:elt->A->A), - (compat_op E.eq eqA f) -> (transpose eqA f) -> - (compat_op E.eq eqA g) -> (transpose eqA g) -> - forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> + (compat_op E.eq eqA f) -> (transpose eqA f) -> + (compat_op E.eq eqA g) -> (transpose eqA g) -> + forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> (eqA (fold f s i) (fold g s i)). Proof. intros A eqA st f g fc ft gc gt i. @@ -916,8 +916,8 @@ symmetry; apply fold_add with (eqA:=eqA); auto. do 2 rewrite fold_empty; reflexivity. Qed. -Lemma sum_compat : - forall f g, compat_nat E.eq f -> compat_nat E.eq g -> +Lemma sum_compat : + forall f g, compat_nat E.eq f -> compat_nat E.eq g -> forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. intros. unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto. diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v index a96def34ad..412b6f5c57 100644 --- a/theories/FSets/FSetFacts.v +++ b/theories/FSets/FSetFacts.v @@ -11,8 +11,8 @@ (** * Finite sets library *) (** This functor derives additional facts from [FSetInterface.S]. These - facts are mainly the specifications of [FSetInterface.S] written using - different styles: equivalence and boolean equalities. + facts are mainly the specifications of [FSetInterface.S] written using + different styles: equivalence and boolean equalities. Moreover, we prove that [E.Eq] and [Equal] are setoid equalities. *) @@ -30,7 +30,7 @@ Definition eqb x y := if eq_dec x y then true else false. (** * Specifications written using equivalences *) -Section IffSpec. +Section IffSpec. Variable s s' s'' : t. Variable x y z : elt. @@ -50,12 +50,12 @@ rewrite mem_iff; destruct (mem x s); intuition. Qed. Lemma equal_iff : s[=]s' <-> equal s s' = true. -Proof. +Proof. split; [apply equal_1|apply equal_2]. Qed. Lemma subset_iff : s[<=]s' <-> subset s s' = true. -Proof. +Proof. split; [apply subset_1|apply subset_2]. Qed. @@ -64,8 +64,8 @@ Proof. intuition; apply (empty_1 H). Qed. -Lemma is_empty_iff : Empty s <-> is_empty s = true. -Proof. +Lemma is_empty_iff : Empty s <-> is_empty s = true. +Proof. split; [apply is_empty_1|apply is_empty_2]. Qed. @@ -75,7 +75,7 @@ split; [apply singleton_1|apply singleton_2]. Qed. Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. -Proof. +Proof. split; [ | destruct 1; [apply add_1|apply add_2]]; auto. destruct (eq_dec x y) as [E|E]; auto. intro H; right; exact (add_3 E H). @@ -116,8 +116,8 @@ Qed. Variable f : elt->bool. Lemma filter_iff : compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). -Proof. -split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. +Proof. +split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. Qed. Lemma for_all_iff : compat_bool E.eq f -> @@ -125,7 +125,7 @@ Lemma for_all_iff : compat_bool E.eq f -> Proof. split; [apply for_all_1 | apply for_all_2]; auto. Qed. - + Lemma exists_iff : compat_bool E.eq f -> (Exists (fun x => f x = true) s <-> exists_ f s = true). Proof. @@ -133,17 +133,17 @@ split; [apply exists_1 | apply exists_2]; auto. Qed. Lemma elements_iff : In x s <-> InA E.eq x (elements s). -Proof. +Proof. split; [apply elements_1 | apply elements_2]. Qed. End IffSpec. (** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) - -Ltac set_iff := + +Ltac set_iff := repeat (progress ( - rewrite add_iff || rewrite remove_iff || rewrite singleton_iff + rewrite add_iff || rewrite remove_iff || rewrite singleton_iff || rewrite union_iff || rewrite inter_iff || rewrite diff_iff || rewrite empty_iff)). @@ -154,7 +154,7 @@ Variable s s' s'' : t. Variable x y z : elt. Lemma mem_b : E.eq x y -> mem x s = mem y s. -Proof. +Proof. intros. generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). destruct (mem x s); destruct (mem y s); intuition. @@ -191,7 +191,7 @@ destruct (mem y s); destruct (mem y (remove x s)); intuition. Qed. Lemma singleton_b : mem y (singleton x) = eqb x y. -Proof. +Proof. generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. Qed. @@ -236,7 +236,7 @@ Qed. Variable f : elt->bool. Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x. -Proof. +Proof. intros. generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. @@ -264,7 +264,7 @@ rewrite H2. rewrite InA_alt; eauto. Qed. -Lemma exists_b : compat_bool E.eq f -> +Lemma exists_b : compat_bool E.eq f -> exists_ f s = existsb f (elements s). Proof. intros. @@ -297,20 +297,20 @@ constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. Qed. Definition Equal_ST : Equivalence Equal. -Proof. +Proof. constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans]. Qed. -Add Relation elt E.eq - reflexivity proved by E.eq_refl +Add Relation elt E.eq + reflexivity proved by E.eq_refl symmetry proved by E.eq_sym - transitivity proved by E.eq_trans + transitivity proved by E.eq_trans as EltSetoid. -Add Relation t Equal - reflexivity proved by eq_refl +Add Relation t Equal + reflexivity proved by eq_refl symmetry proved by eq_sym - transitivity proved by eq_trans + transitivity proved by eq_trans as EqualSetoid. Add Morphism In with signature E.eq ==> Equal ==> iff as In_m. @@ -323,7 +323,7 @@ Add Morphism is_empty : is_empty_m. Proof. unfold Equal; intros s s' H. generalize (is_empty_iff s)(is_empty_iff s'). -destruct (is_empty s); destruct (is_empty s'); +destruct (is_empty s); destruct (is_empty s'); unfold Empty; auto; intros. symmetry. rewrite <- H1; intros a Ha. @@ -388,14 +388,14 @@ do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition. Qed. Add Morphism Subset with signature Equal ==> Equal ==> iff as Subset_m. -Proof. +Proof. unfold Equal, Subset; firstorder. Qed. Add Morphism subset : subset_m. Proof. intros s s' H s'' s''' H0. -generalize (subset_iff s s'') (subset_iff s' s'''). +generalize (subset_iff s s'') (subset_iff s' s'''). destruct (subset s s''); destruct (subset s' s'''); auto; intros. rewrite H in H1; rewrite H0 in H1; intuition. rewrite H in H1; rewrite H0 in H1; intuition. @@ -467,7 +467,7 @@ Qed. (* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism without additional hypothesis on [f]. For instance: *) -Lemma filter_equal : forall f, compat_bool E.eq f -> +Lemma filter_equal : forall f, compat_bool E.eq f -> forall s s', s[=]s' -> filter f s [=] filter f s'. Proof. unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. @@ -481,7 +481,7 @@ rewrite Hff', Hss'; intuition. red; intros; rewrite <- 2 Hff'; auto. Qed. -Lemma filter_subset : forall f, compat_bool E.eq f -> +Lemma filter_subset : forall f, compat_bool E.eq f -> forall s s', s[<=]s' -> filter f s [<=] filter f s'. Proof. unfold Subset; intros; rewrite filter_iff in *; intuition. diff --git a/theories/FSets/FSetFullAVL.v b/theories/FSets/FSetFullAVL.v index 81ed9a5726..bc0d758bd8 100644 --- a/theories/FSets/FSetFullAVL.v +++ b/theories/FSets/FSetFullAVL.v @@ -6,27 +6,27 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre +(* Finite sets library. + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) (* $Id$ *) (** * FSetFullAVL - + This file contains some complements to [FSetAVL]. - - Functor [AvlProofs] proves that trees of [FSetAVL] are not only + - Functor [AvlProofs] proves that trees of [FSetAVL] are not only binary search trees, but moreover well-balanced ones. This is done by proving that all operations preserve the balancing. - - Functor [OcamlOps] contains variants of [union], [subset], + - Functor [OcamlOps] contains variants of [union], [subset], [compare] and [equal] that are faithful to the original ocaml codes, while the versions in FSetAVL have been adapted to perform only - structural recursive code. - - - Finally, we pack the previous elements in a [Make] functor + structural recursive code. + + - Finally, we pack the previous elements in a [Make] functor similar to the one of [FSetAVL], but richer. *) @@ -54,7 +54,7 @@ Inductive avl : tree -> Prop := | RBLeaf : avl Leaf | RBNode : forall x l r h, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - h = max (height l) (height r) + 1 -> + h = max (height l) (height r) + 1 -> avl (Node l x r h). (** * Automation and dedicated tactics *) @@ -64,7 +64,7 @@ Hint Constructors avl. (** A tactic for cleaning hypothesis after use of functional induction. *) Ltac clearf := - match goal with + match goal with | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf | _ => idtac @@ -77,25 +77,25 @@ Proof. induction s; simpl; intros; auto with zarith. inv avl; intuition; omega_max. Qed. -Implicit Arguments height_non_negative. +Implicit Arguments height_non_negative. (** When [H:avl r], typing [avl_nn H] or [avl_nn r] adds [height r>=0] *) -Ltac avl_nn_hyp H := +Ltac avl_nn_hyp H := let nz := fresh "nz" in assert (nz := height_non_negative H). -Ltac avl_nn h := - let t := type of h in - match type of t with +Ltac avl_nn h := + let t := type of h in + match type of t with | Prop => avl_nn_hyp h | _ => match goal with H : avl h |- _ => avl_nn_hyp H end end. -(* Repeat the previous tactic. +(* Repeat the previous tactic. Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) Ltac avl_nns := - match goal with + match goal with | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns | _ => idtac end. @@ -110,7 +110,7 @@ Qed. (** * Results about [avl] *) -Lemma avl_node : +Lemma avl_node : forall x l r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> avl (Node l x r (max (height l) (height r) + 1)). @@ -123,7 +123,7 @@ Hint Resolve avl_node. (** empty *) Lemma empty_avl : avl empty. -Proof. +Proof. auto. Qed. @@ -137,15 +137,15 @@ Qed. (** create *) -Lemma create_avl : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma create_avl : + forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> avl (create l x r). Proof. unfold create; auto. Qed. -Lemma create_height : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma create_height : + forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> height (create l x r) = max (height l) (height r) + 1. Proof. unfold create; auto. @@ -153,17 +153,17 @@ Qed. (** bal *) -Lemma bal_avl : forall l x r, avl l -> avl r -> +Lemma bal_avl : forall l x r, avl l -> avl r -> -(3) <= height l - height r <= 3 -> avl (bal l x r). Proof. intros l x r; functional induction bal l x r; intros; clearf; - inv avl; simpl in *; + inv avl; simpl in *; match goal with |- avl (assert_false _ _ _) => avl_nns | _ => repeat apply create_avl; simpl in *; auto end; omega_max. Qed. -Lemma bal_height_1 : forall l x r, avl l -> avl r -> +Lemma bal_height_1 : forall l x r, avl l -> avl r -> -(3) <= height l - height r <= 3 -> 0 <= height (bal l x r) - max (height l) (height r) <= 1. Proof. @@ -171,25 +171,25 @@ Proof. inv avl; avl_nns; simpl in *; omega_max. Qed. -Lemma bal_height_2 : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma bal_height_2 : + forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> height (bal l x r) == max (height l) (height r) +1. Proof. intros l x r; functional induction bal l x r; intros; clearf; inv avl; simpl in *; omega_max. Qed. -Ltac omega_bal := match goal with - | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?r ] => - generalize (bal_height_1 x H H') (bal_height_2 x H H'); +Ltac omega_bal := match goal with + | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?r ] => + generalize (bal_height_1 x H H') (bal_height_2 x H H'); omega_max end. (** add *) -Lemma add_avl_1 : forall s x, avl s -> +Lemma add_avl_1 : forall s x, avl s -> avl (add x s) /\ 0 <= height (add x s) - height s <= 1. -Proof. +Proof. intros s x; functional induction (add x s); subst;intros; inv avl; simpl in *. intuition; try constructor; simpl; auto; try omega_max. (* LT *) @@ -216,10 +216,10 @@ Hint Resolve add_avl. Lemma join_avl_1 : forall l x r, avl l -> avl r -> avl (join l x r) /\ 0<= height (join l x r) - max (height l) (height r) <= 1. -Proof. +Proof. join_tac. - split; simpl; auto. + split; simpl; auto. destruct (add_avl_1 x H0). avl_nns; omega_max. set (l:=Node ll lx lr lh) in *. @@ -269,8 +269,8 @@ Hint Resolve join_avl. (** remove_min *) -Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) -> - avl (remove_min l x r)#1 /\ +Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) -> + avl (remove_min l x r)#1 /\ 0 <= height (Node l x r h) - height (remove_min l x r)#1 <= 1. Proof. intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros. @@ -278,25 +278,25 @@ Proof. avl_nns; omega_max. inversion_clear H. rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto. - split; simpl in *. + split; simpl in *. apply bal_avl; auto; omega_max. omega_bal. Qed. -Lemma remove_min_avl : forall l x r h, avl (Node l x r h) -> - avl (remove_min l x r)#1. +Lemma remove_min_avl : forall l x r h, avl (Node l x r h) -> + avl (remove_min l x r)#1. Proof. intros; destruct (remove_min_avl_1 H); auto. Qed. (** merge *) -Lemma merge_avl_1 : forall s1 s2, avl s1 -> avl s2 -> - -(2) <= height s1 - height s2 <= 2 -> - avl (merge s1 s2) /\ +Lemma merge_avl_1 : forall s1 s2, avl s1 -> avl s2 -> + -(2) <= height s1 - height s2 <= 2 -> + avl (merge s1 s2) /\ 0<= height (merge s1 s2) - max (height s1) (height s2) <=1. Proof. - intros s1 s2; functional induction (merge s1 s2); intros; + intros s1 s2; functional induction (merge s1 s2); intros; try factornode _x _x0 _x1 _x2 as s1. simpl; split; auto; avl_nns; omega_max. simpl; split; auto; avl_nns; simpl in *; omega_max. @@ -308,16 +308,16 @@ Proof. simpl in *; omega_bal. Qed. -Lemma merge_avl : forall s1 s2, avl s1 -> avl s2 -> +Lemma merge_avl : forall s1 s2, avl s1 -> avl s2 -> -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2). -Proof. +Proof. intros; destruct (merge_avl_1 H H0 H1); auto. Qed. (** remove *) -Lemma remove_avl_1 : forall s x, avl s -> +Lemma remove_avl_1 : forall s x, avl s -> avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1. Proof. intros s x; functional induction (remove x s); intros. @@ -325,25 +325,25 @@ Proof. (* LT *) inv avl. destruct (IHt H0). - split. + split. apply bal_avl; auto. omega_max. omega_bal. (* EQ *) - inv avl. + inv avl. generalize (merge_avl_1 H0 H1 H2). intuition omega_max. (* GT *) inv avl. destruct (IHt H1). - split. + split. apply bal_avl; auto. omega_max. omega_bal. Qed. Lemma remove_avl : forall s x, avl s -> avl (remove x s). -Proof. +Proof. intros; destruct (remove_avl_1 x H); auto. Qed. Hint Resolve remove_avl. @@ -360,9 +360,9 @@ Hint Resolve concat_avl. (** split *) -Lemma split_avl : forall s x, avl s -> +Lemma split_avl : forall s x, avl s -> avl (split x s)#l /\ avl (split x s)#r. -Proof. +Proof. intros s x; functional induction (split x s); simpl; auto. rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. simpl; inversion_clear 1; auto. @@ -371,19 +371,19 @@ Qed. (** inter *) -Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2). +Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2). Proof. intros s1 s2; functional induction inter s1 s2; auto; intros A1 A2; - generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; + generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; inv avl; auto. Qed. (** diff *) -Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2). -Proof. +Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2). +Proof. intros s1 s2; functional induction diff s1 s2; auto; intros A1 A2; - generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; + generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; inv avl; auto. Qed. @@ -392,30 +392,30 @@ Qed. Lemma union_avl : forall s1 s2, avl s1 -> avl s2 -> avl (union s1 s2). Proof. intros s1 s2; functional induction union s1 s2; auto; intros A1 A2; - generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; + generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; inv avl; auto. Qed. (** filter *) -Lemma filter_acc_avl : forall f s acc, avl s -> avl acc -> +Lemma filter_acc_avl : forall f s acc, avl s -> avl acc -> avl (filter_acc f acc s). Proof. induction s; simpl; auto. intros. inv avl. destruct (f t); auto. -Qed. +Qed. Hint Resolve filter_acc_avl. -Lemma filter_avl : forall f s, avl s -> avl (filter f s). +Lemma filter_avl : forall f s, avl s -> avl (filter f s). Proof. unfold filter; intros; apply filter_acc_avl; auto. Qed. (** partition *) -Lemma partition_acc_avl_1 : forall f s acc, avl s -> +Lemma partition_acc_avl_1 : forall f s acc, avl s -> avl acc#1 -> avl (partition_acc f acc s)#1. Proof. induction s; simpl; auto. @@ -427,7 +427,7 @@ Proof. destruct (f t); simpl; auto. Qed. -Lemma partition_acc_avl_2 : forall f s acc, avl s -> +Lemma partition_acc_avl_2 : forall f s acc, avl s -> avl acc#2 -> avl (partition_acc f acc s)#2. Proof. induction s; simpl; auto. @@ -437,14 +437,14 @@ Proof. apply IHs2; auto. apply IHs1; auto. destruct (f t); simpl; auto. -Qed. +Qed. -Lemma partition_avl_1 : forall f s, avl s -> avl (partition f s)#1. +Lemma partition_avl_1 : forall f s, avl s -> avl (partition f s)#1. Proof. unfold partition; intros; apply partition_acc_avl_1; auto. Qed. -Lemma partition_avl_2 : forall f s, avl s -> avl (partition f s)#2. +Lemma partition_avl_2 : forall f s, avl s -> avl (partition f s)#2. Proof. unfold partition; intros; apply partition_acc_avl_2; auto. Qed. @@ -462,29 +462,29 @@ Open Local Scope nat_scope. (** Properties of cardinal *) -Lemma bal_cardinal : forall l x r, +Lemma bal_cardinal : forall l x r, cardinal (bal l x r) = S (cardinal l + cardinal r). Proof. intros l x r; functional induction bal l x r; intros; clearf; simpl; auto with arith; romega with *. Qed. -Lemma add_cardinal : forall x s, +Lemma add_cardinal : forall x s, cardinal (add x s) <= S (cardinal s). Proof. - intros; functional induction add x s; simpl; auto with arith; + intros; functional induction add x s; simpl; auto with arith; rewrite bal_cardinal; romega with *. Qed. -Lemma join_cardinal : forall l x r, +Lemma join_cardinal : forall l x r, cardinal (join l x r) <= S (cardinal l + cardinal r). Proof. join_tac; auto with arith. simpl; apply add_cardinal. simpl; destruct X.compare; simpl; auto with arith. - generalize (bal_cardinal (add x ll) lx lr) (add_cardinal x ll); + generalize (bal_cardinal (add x ll) lx lr) (add_cardinal x ll); romega with *. - generalize (bal_cardinal ll lx (add x lr)) (add_cardinal x lr); + generalize (bal_cardinal ll lx (add x lr)) (add_cardinal x lr); romega with *. generalize (bal_cardinal ll lx (join lr x (Node rl rx rr rh))) (Hlr x (Node rl rx rr rh)); simpl; romega with *. @@ -492,7 +492,7 @@ Proof. romega with *. Qed. -Lemma split_cardinal_1 : forall x s, +Lemma split_cardinal_1 : forall x s, (cardinal (split x s)#l <= cardinal s)%nat. Proof. intros x s; functional induction split x s; simpl; auto. @@ -503,7 +503,7 @@ Proof. generalize (@join_cardinal l y rl); romega with *. Qed. -Lemma split_cardinal_2 : forall x s, +Lemma split_cardinal_2 : forall x s, (cardinal (split x s)#r <= cardinal s)%nat. Proof. intros x s; functional induction split x s; simpl; auto. @@ -517,26 +517,26 @@ Qed. Definition cardinal2 (s:t*t) := (cardinal s#1 + cardinal s#2)%nat. -Ltac ocaml_union_tac := +Ltac ocaml_union_tac := intros; unfold cardinal2; simpl fst in *; simpl snd in *; - match goal with H: split ?x ?s = _ |- _ => - generalize (split_cardinal_1 x s) (split_cardinal_2 x s); + match goal with H: split ?x ?s = _ |- _ => + generalize (split_cardinal_1 x s) (split_cardinal_2 x s); rewrite H; simpl; romega with * end. Function ocaml_union (s : t * t) { measure cardinal2 s } : t := - match s with + match s with | (Leaf, Leaf) => s#2 | (Leaf, Node _ _ _ _) => s#2 | (Node _ _ _ _, Leaf) => s#1 - | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) => + | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) => if ge_lt_dec h1 h2 then if eq_dec h2 1%I then add x2 s#1 else - let (l2',_,r2') := split x1 s#2 in + let (l2',_,r2') := split x1 s#2 in join (ocaml_union (l1,l2')) x1 (ocaml_union (r1,r2')) else if eq_dec h1 1%I then add x1 s#2 else - let (l1',_,r1') := split x2 s#1 in + let (l1',_,r1') := split x2 s#1 in join (ocaml_union (l1',l2)) x2 (ocaml_union (r1',r2)) end. Proof. @@ -546,11 +546,11 @@ abstract ocaml_union_tac. abstract ocaml_union_tac. Defined. -Lemma ocaml_union_in : forall s y, +Lemma ocaml_union_in : forall s y, bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> (In y (ocaml_union s) <-> In y s#1 \/ In y s#2). Proof. - intros s; functional induction ocaml_union s; intros y B1 A1 B2 A2; + intros s; functional induction ocaml_union s; intros y B1 A1 B2 A2; simpl fst in *; simpl snd in *; try clear e0 e1. intuition_in. intuition_in. @@ -575,7 +575,7 @@ Proof. rewrite (height_0 H4); [ | avl_nn r1; omega_max]. rewrite add_in; auto; intuition_in. (* join (union (l1',l2)) x1 (union (r1',r2)) *) - generalize + generalize (split_avl x2 A1) (split_bst x2 B1) (split_in_1 x2 y B1) (split_in_2 x2 y B1). rewrite e2; simpl. @@ -589,7 +589,7 @@ Lemma ocaml_union_bst : forall s, bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> bst (ocaml_union s). Proof. intros s; functional induction ocaml_union s; intros B1 A1 B2 A2; - simpl fst in *; simpl snd in *; try clear e0 e1; + simpl fst in *; simpl snd in *; try clear e0 e1; try apply add_bst; auto. (* join (union (l1,l2')) x1 (union (r1,r2')) *) clear _x _x0; factornode l2 x2 r2 h2 as s2. @@ -613,10 +613,10 @@ Proof. intro y; rewrite ocaml_union_in, H4; intuition_in. Qed. -Lemma ocaml_union_avl : forall s, +Lemma ocaml_union_avl : forall s, avl s#1 -> avl s#2 -> avl (ocaml_union s). Proof. - intros s; functional induction ocaml_union s; + intros s; functional induction ocaml_union s; simpl fst in *; simpl snd in *; auto. intros A1 A2; generalize (split_avl x1 A2); rewrite e2; simpl. inv avl; destruct 1; auto. @@ -654,7 +654,7 @@ Proof. intros; unfold cardinal2; simpl; abstract romega with *. Defined. -Lemma ocaml_subset_12 : forall s, +Lemma ocaml_subset_12 : forall s, bst s#1 -> bst s#2 -> (ocaml_subset s = true <-> Subset s#1 s#2). Proof. @@ -685,7 +685,7 @@ Proof. assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. Qed. -Lemma ocaml_subset_alt : forall s, bst s#1 -> bst s#2 -> +Lemma ocaml_subset_alt : forall s, bst s#1 -> bst s#2 -> ocaml_subset s = subset s#1 s#2. Proof. intros. @@ -704,7 +704,7 @@ Fixpoint cardinal_e e := match e with | More _ s r => S (cardinal s + cardinal_e r) end. -Lemma cons_cardinal_e : forall s e, +Lemma cons_cardinal_e : forall s e, cardinal_e (cons s e) = cardinal s + cardinal_e e. Proof. induction s; simpl; intros; auto. @@ -713,32 +713,32 @@ Qed. Definition cardinal_e_2 e := cardinal_e e#1 + cardinal_e e#2. -Function ocaml_compare_aux - (e:enumeration*enumeration) { measure cardinal_e_2 e } : comparison := - match e with +Function ocaml_compare_aux + (e:enumeration*enumeration) { measure cardinal_e_2 e } : comparison := + match e with | (End,End) => Eq - | (End,More _ _ _) => Lt - | (More _ _ _, End) => Gt - | (More x1 r1 e1, More x2 r2 e2) => - match X.compare x1 x2 with + | (End,More _ _ _) => Lt + | (More _ _ _, End) => Gt + | (More x1 r1 e1, More x2 r2 e2) => + match X.compare x1 x2 with | EQ _ => ocaml_compare_aux (cons r1 e1, cons r2 e2) - | LT _ => Lt - | GT _ => Gt + | LT _ => Lt + | GT _ => Gt end end. Proof. -intros; unfold cardinal_e_2; simpl; +intros; unfold cardinal_e_2; simpl; abstract (do 2 rewrite cons_cardinal_e; romega with *). Defined. -Definition ocaml_compare s1 s2 := +Definition ocaml_compare s1 s2 := ocaml_compare_aux (cons s1 End, cons s2 End). -Lemma ocaml_compare_aux_Cmp : forall e, +Lemma ocaml_compare_aux_Cmp : forall e, Cmp (ocaml_compare_aux e) (flatten_e e#1) (flatten_e e#2). Proof. - intros e; functional induction ocaml_compare_aux e; simpl; intros; + intros e; functional induction ocaml_compare_aux e; simpl; intros; auto; try discriminate. apply L.eq_refl. simpl in *. @@ -756,11 +756,11 @@ Proof. apply (@ocaml_compare_aux_Cmp (cons s1 End, cons s2 End)). Qed. -Lemma ocaml_compare_alt : forall s1 s2, bst s1 -> bst s2 -> +Lemma ocaml_compare_alt : forall s1 s2, bst s1 -> bst s2 -> ocaml_compare s1 s2 = compare s1 s2. Proof. intros s1 s2 B1 B2. - generalize (ocaml_compare_Cmp s1 s2)(compare_Cmp s1 s2). + generalize (ocaml_compare_Cmp s1 s2)(compare_Cmp s1 s2). unfold Cmp. destruct ocaml_compare; destruct compare; auto; intros; elimtype False. elim (lt_not_eq B1 B2 H0); auto. @@ -781,13 +781,13 @@ Qed. (** * Equality test *) -Definition ocaml_equal s1 s2 : bool := - match ocaml_compare s1 s2 with +Definition ocaml_equal s1 s2 : bool := + match ocaml_compare s1 s2 with | Eq => true - | _ => false + | _ => false end. -Lemma ocaml_equal_1 : forall s1 s2, bst s1 -> bst s2 -> +Lemma ocaml_equal_1 : forall s1 s2, bst s1 -> bst s2 -> Equal s1 s2 -> ocaml_equal s1 s2 = true. Proof. unfold ocaml_equal; intros s1 s2 B1 B2 E. @@ -801,11 +801,11 @@ Lemma ocaml_equal_2 : forall s1 s2, ocaml_equal s1 s2 = true -> Equal s1 s2. Proof. unfold ocaml_equal; intros s1 s2 E. -generalize (ocaml_compare_Cmp s1 s2); +generalize (ocaml_compare_Cmp s1 s2); destruct ocaml_compare; auto; discriminate. Qed. -Lemma ocaml_equal_alt : forall s1 s2, bst s1 -> bst s2 -> +Lemma ocaml_equal_alt : forall s1 s2, bst s1 -> bst s2 -> ocaml_equal s1 s2 = equal s1 s2. Proof. intros; unfold ocaml_equal, equal; rewrite ocaml_compare_alt; auto. @@ -817,14 +817,14 @@ End OcamlOps. (** * Encapsulation - We can implement [S] with balanced binary search trees. + We can implement [S] with balanced binary search trees. When compared to [FSetAVL], we maintain here two invariants (bst and avl) instead of only bst, which is enough for fulfilling the FSet interface. - This encapsulation propose the non-structural variants + This encapsulation propose the non-structural variants [ocaml_union], [ocaml_subset], [ocaml_compare], [ocaml_equal]. -*) +*) Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. @@ -837,61 +837,61 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Record bbst := Bbst {this :> Raw.t; is_bst : bst this; is_avl : avl this}. Definition t := bbst. Definition elt := E.t. - + Definition In (x : elt) (s : t) : Prop := In x s. Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. Definition Empty (s:t) : Prop := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) (s:t) : Prop := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) (s:t) : Prop := exists x, In x s /\ P x. - - Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. + + Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. Proof. intro s; exact (@In_1 s). Qed. - + Definition mem (x:elt)(s:t) : bool := mem x s. Definition empty : t := Bbst empty_bst empty_avl. Definition is_empty (s:t) : bool := is_empty s. - Definition singleton (x:elt) : t := + Definition singleton (x:elt) : t := Bbst (singleton_bst x) (singleton_avl x). - Definition add (x:elt)(s:t) : t := - Bbst (add_bst x (is_bst s)) (add_avl x (is_avl s)). - Definition remove (x:elt)(s:t) : t := + Definition add (x:elt)(s:t) : t := + Bbst (add_bst x (is_bst s)) (add_avl x (is_avl s)). + Definition remove (x:elt)(s:t) : t := Bbst (remove_bst x (is_bst s)) (remove_avl x (is_avl s)). - Definition inter (s s':t) : t := + Definition inter (s s':t) : t := Bbst (inter_bst (is_bst s) (is_bst s')) (inter_avl (is_avl s) (is_avl s')). Definition union (s s':t) : t := Bbst (union_bst (is_bst s) (is_bst s')) (union_avl (is_avl s) (is_avl s')). Definition ocaml_union (s s':t) : t := - Bbst (@ocaml_union_bst (s.(this),s'.(this)) + Bbst (@ocaml_union_bst (s.(this),s'.(this)) (is_bst s) (is_avl s) (is_bst s') (is_avl s')) (@ocaml_union_avl (s.(this),s'.(this)) (is_avl s) (is_avl s')). - Definition diff (s s':t) : t := + Definition diff (s s':t) : t := Bbst (diff_bst (is_bst s) (is_bst s')) (diff_avl (is_avl s) (is_avl s')). Definition elements (s:t) : list elt := elements s. Definition min_elt (s:t) : option elt := min_elt s. Definition max_elt (s:t) : option elt := max_elt s. Definition choose (s:t) : option elt := choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := fold f s. + Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := fold f s. Definition cardinal (s:t) : nat := cardinal s. - Definition filter (f : elt -> bool) (s:t) : t := + Definition filter (f : elt -> bool) (s:t) : t := Bbst (filter_bst f (is_bst s)) (filter_avl f (is_avl s)). Definition for_all (f : elt -> bool) (s:t) : bool := for_all f s. Definition exists_ (f : elt -> bool) (s:t) : bool := exists_ f s. Definition partition (f : elt -> bool) (s:t) : t * t := let p := partition f s in - (@Bbst (fst p) (partition_bst_1 f (is_bst s)) - (partition_avl_1 f (is_avl s)), + (@Bbst (fst p) (partition_bst_1 f (is_bst s)) + (partition_avl_1 f (is_avl s)), @Bbst (snd p) (partition_bst_2 f (is_bst s)) (partition_avl_2 f (is_avl s))). Definition equal (s s':t) : bool := equal s s'. Definition ocaml_equal (s s':t) : bool := ocaml_equal s s'. Definition subset (s s':t) : bool := subset s s'. - Definition ocaml_subset (s s':t) : bool := + Definition ocaml_subset (s s':t) : bool := ocaml_subset (s.(this),s'.(this)). Definition eq (s s':t) : Prop := Equal s s'. @@ -922,13 +922,13 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Defined. (* specs *) - Section Specs. - Variable s s' s'': t. + Section Specs. + Variable s s' s'': t. Variable x y : elt. Hint Resolve is_bst is_avl. - - Lemma mem_1 : In x s -> mem x s = true. + + Lemma mem_1 : In x s -> mem x s = true. Proof. exact (mem_1 (is_bst s)). Qed. Lemma mem_2 : mem x s = true -> In x s. Proof. exact (@mem_2 s x). Qed. @@ -939,15 +939,15 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. exact (@equal_2 s s'). Qed. Lemma ocaml_equal_alt : ocaml_equal s s' = equal s s'. - Proof. + Proof. destruct s; destruct s'; unfold ocaml_equal, equal; simpl. apply ocaml_equal_alt; auto. Qed. - + Lemma ocaml_equal_1 : Equal s s' -> ocaml_equal s s' = true. Proof. exact (ocaml_equal_1 (is_bst s) (is_bst s')). Qed. Lemma ocaml_equal_2 : ocaml_equal s s' = true -> Equal s s'. - Proof. exact (@ocaml_equal_2 s s'). Qed. + Proof. exact (@ocaml_equal_2 s s'). Qed. Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition. @@ -957,7 +957,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. wrap subset subset_12. Qed. Lemma ocaml_subset_alt : ocaml_subset s s' = subset s s'. - Proof. + Proof. destruct s; destruct s'; unfold ocaml_subset, subset; simpl. rewrite ocaml_subset_alt; auto. Qed. @@ -972,14 +972,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma is_empty_1 : Empty s -> is_empty s = true. Proof. exact (@is_empty_1 s). Qed. - Lemma is_empty_2 : is_empty s = true -> Empty s. + Lemma is_empty_2 : is_empty s = true -> Empty s. Proof. exact (@is_empty_2 s). Qed. - + Lemma add_1 : E.eq x y -> In y (add x s). Proof. wrap add add_in. Qed. Lemma add_2 : In y s -> In y (add x s). Proof. wrap add add_in. Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. Proof. wrap add add_in. elim H; auto. Qed. Lemma remove_1 : E.eq x y -> ~ In y (remove x s). @@ -989,20 +989,20 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma remove_3 : In y (remove x s) -> In y s. Proof. wrap remove remove_in. Qed. - Lemma singleton_1 : In y (singleton x) -> E.eq x y. + Lemma singleton_1 : In y (singleton x) -> E.eq x y. Proof. exact (@singleton_1 x y). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). + Lemma singleton_2 : E.eq x y -> In y (singleton x). Proof. exact (@singleton_2 x y). Qed. Lemma union_1 : In x (union s s') -> In x s \/ In x s'. Proof. wrap union union_in. Qed. - Lemma union_2 : In x s -> In x (union s s'). + Lemma union_2 : In x s -> In x (union s s'). Proof. wrap union union_in. Qed. Lemma union_3 : In x s' -> In x (union s s'). Proof. wrap union union_in. Qed. Lemma ocaml_union_alt : Equal (ocaml_union s s') (union s s'). - Proof. + Proof. unfold ocaml_union, union, Equal, In. destruct s as (s0,b,a); destruct s' as (s0',b',a'); simpl. exact (@ocaml_union_alt (s0,s0') b a b' a'). @@ -1021,32 +1021,32 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. wrap inter inter_in. Qed. Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). Proof. wrap inter inter_in. Qed. - - Lemma diff_1 : In x (diff s s') -> In x s. + + Lemma diff_1 : In x (diff s s') -> In x s. Proof. wrap diff diff_in. Qed. Lemma diff_2 : In x (diff s s') -> ~ In x s'. Proof. wrap diff diff_in. Qed. Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). Proof. wrap diff diff_in. Qed. - + Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. + Proof. unfold fold, elements; intros; apply fold_1; auto. Qed. Lemma cardinal_1 : cardinal s = length (elements s). - Proof. + Proof. unfold cardinal, elements; intros; apply elements_cardinal; auto. Qed. Section Filter. Variable f : elt -> bool. - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Proof. intro. wrap filter filter_in. Qed. + Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. Proof. intro. wrap filter filter_in. Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. intro. wrap filter filter_in. Qed. Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). Proof. intro. wrap filter filter_in. Qed. @@ -1060,14 +1060,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. Proof. exact (@exists_2 f s). Qed. - Lemma partition_1 : compat_bool E.eq f -> + Lemma partition_1 : compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. unfold partition, filter, Equal, In; simpl ;intros H a. rewrite partition_in_1, filter_in; intuition. Qed. - Lemma partition_2 : compat_bool E.eq f -> + Lemma partition_2 : compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. unfold partition, filter, Equal, In; simpl ;intros H a. @@ -1089,14 +1089,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma elements_3w : NoDupA E.eq (elements s). Proof. exact (elements_nodup (is_bst s)). Qed. - Lemma min_elt_1 : min_elt s = Some x -> In x s. + Lemma min_elt_1 : min_elt s = Some x -> In x s. Proof. exact (@min_elt_1 s x). Qed. Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. Proof. exact (@min_elt_2 s x y (is_bst s)). Qed. Lemma min_elt_3 : min_elt s = None -> Empty s. Proof. exact (@min_elt_3 s). Qed. - Lemma max_elt_1 : max_elt s = Some x -> In x s. + Lemma max_elt_1 : max_elt s = Some x -> In x s. Proof. exact (@max_elt_1 s x). Qed. Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. Proof. exact (@max_elt_2 s x y (is_bst s)). Qed. @@ -1107,17 +1107,17 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. exact (@choose_1 s x). Qed. Lemma choose_2 : choose s = None -> Empty s. Proof. exact (@choose_2 s). Qed. - Lemma choose_3 : choose s = Some x -> choose s' = Some y -> + Lemma choose_3 : choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed. - Lemma eq_refl : eq s s. + Lemma eq_refl : eq s s. Proof. exact (eq_refl s). Qed. Lemma eq_sym : eq s s' -> eq s' s. Proof. exact (@eq_sym s s'). Qed. Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''. Proof. exact (@eq_trans s s' s''). Qed. - + Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''. Proof. exact (@lt_trans s s' s''). Qed. Lemma lt_not_eq : lt s s' -> ~eq s s'. diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index 1f21a2262b..d94ff7c95d 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -10,13 +10,13 @@ (** * Finite set library *) -(** Set interfaces, inspired by the one of Ocaml. When compared with - Ocaml, the main differences are: +(** Set interfaces, inspired by the one of Ocaml. When compared with + Ocaml, the main differences are: - the lack of [iter] function, useless since Coq is purely functional - the use of [option] types instead of [Not_found] exceptions - - the use of [nat] instead of [int] for the [cardinal] function + - the use of [nat] instead of [int] for the [cardinal] function - Several variants of the set interfaces are available: + Several variants of the set interfaces are available: - [WSfun] : functorial signature for weak sets, non-dependent style - [WS] : self-contained version of [WSfun] - [Sfun] : functorial signature for ordered sets, non-dependent style @@ -24,7 +24,7 @@ - [Sdep] : analog of [S] written using dependent style If unsure, [S] is probably what you're looking for: other signatures - are subsets of it, apart from [Sdep] which is isomorphic to [S] (see + are subsets of it, apart from [Sdep] which is isomorphic to [S] (see [FSetBridge]). *) @@ -34,14 +34,14 @@ Unset Strict Implicit. (** * Non-dependent signatures - The following signatures presents sets as purely informative + The following signatures presents sets as purely informative programs together with axioms *) (** ** Functorial signature for weak sets - Weak sets are sets without ordering on base elements, only + Weak sets are sets without ordering on base elements, only a decidable equality. *) Module Type WSfun (E : DecidableType). @@ -57,7 +57,7 @@ Module Type WSfun (E : DecidableType). Definition Empty s := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). @@ -137,7 +137,7 @@ Module Type WSfun (E : DecidableType). the set is empty. Which element is chosen is unspecified. Equal sets could return different elements. *) - Section Spec. + Section Spec. Variable s s' s'': t. Variable x y : elt. @@ -146,15 +146,15 @@ Module Type WSfun (E : DecidableType). Parameter In_1 : E.eq x y -> In x s -> In y s. (** Specification of [eq] *) - Parameter eq_refl : eq s s. + Parameter eq_refl : eq s s. Parameter eq_sym : eq s s' -> eq s' s. Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''. (** Specification of [mem] *) Parameter mem_1 : In x s -> mem x s = true. - Parameter mem_2 : mem x s = true -> In x s. - - (** Specification of [equal] *) + Parameter mem_2 : mem x s = true -> In x s. + + (** Specification of [equal] *) Parameter equal_1 : Equal s s' -> equal s s' = true. Parameter equal_2 : equal s s' = true -> Equal s s'. @@ -166,13 +166,13 @@ Module Type WSfun (E : DecidableType). Parameter empty_1 : Empty empty. (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty s -> is_empty s = true. + Parameter is_empty_1 : Empty s -> is_empty s = true. Parameter is_empty_2 : is_empty s = true -> Empty s. - + (** Specification of [add] *) Parameter add_1 : E.eq x y -> In y (add x s). Parameter add_2 : In y s -> In y (add x s). - Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. (** Specification of [remove] *) Parameter remove_1 : E.eq x y -> ~ In y (remove x s). @@ -180,12 +180,12 @@ Module Type WSfun (E : DecidableType). Parameter remove_3 : In y (remove x s) -> In y s. (** Specification of [singleton] *) - Parameter singleton_1 : In y (singleton x) -> E.eq x y. - Parameter singleton_2 : E.eq x y -> In y (singleton x). + Parameter singleton_1 : In y (singleton x) -> E.eq x y. + Parameter singleton_2 : E.eq x y -> In y (singleton x). (** Specification of [union] *) Parameter union_1 : In x (union s s') -> In x s \/ In x s'. - Parameter union_2 : In x s -> In x (union s s'). + Parameter union_2 : In x s -> In x (union s s'). Parameter union_3 : In x s' -> In x (union s s'). (** Specification of [inter] *) @@ -194,24 +194,24 @@ Module Type WSfun (E : DecidableType). Parameter inter_3 : In x s -> In x s' -> In x (inter s s'). (** Specification of [diff] *) - Parameter diff_1 : In x (diff s s') -> In x s. + Parameter diff_1 : In x (diff s s') -> In x s. Parameter diff_2 : In x (diff s s') -> ~ In x s'. Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - - (** Specification of [fold] *) + + (** Specification of [fold] *) Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. - (** Specification of [cardinal] *) + (** Specification of [cardinal] *) Parameter cardinal_1 : cardinal s = length (elements s). Section Filter. - + Variable f : elt -> bool. (** Specification of [filter] *) - Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. + Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. Parameter filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). @@ -243,7 +243,7 @@ Module Type WSfun (E : DecidableType). (** Specification of [elements] *) Parameter elements_1 : In x s -> InA E.eq x (elements s). Parameter elements_2 : InA E.eq x (elements s) -> In x s. - (** When compared with ordered sets, here comes the only + (** When compared with ordered sets, here comes the only property that is really weaker: *) Parameter elements_3w : NoDupA E.eq (elements s). @@ -257,11 +257,11 @@ Module Type WSfun (E : DecidableType). is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 remove_2 singleton_2 union_1 union_2 union_3 inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 - partition_1 partition_2 elements_1 elements_3w + partition_1 partition_2 elements_1 elements_3w : set. Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 - filter_1 filter_2 for_all_2 exists_2 elements_2 + filter_1 filter_2 for_all_2 exists_2 elements_2 : set. End WSfun. @@ -270,7 +270,7 @@ End WSfun. (** ** Static signature for weak sets - Similar to the functorial signature [SW], except that the + Similar to the functorial signature [SW], except that the module [E] of base elements is incorporated in the signature. *) Module Type WS. @@ -295,48 +295,48 @@ Module Type Sfun (E : OrderedType). Parameter min_elt : t -> option elt. (** Return the smallest element of the given set - (with respect to the [E.compare] ordering), + (with respect to the [E.compare] ordering), or [None] if the set is empty. *) Parameter max_elt : t -> option elt. (** Same as [min_elt], but returns the largest element of the given set. *) - Section Spec. + Section Spec. Variable s s' s'' : t. Variable x y : elt. - + (** Specification of [lt] *) Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''. Parameter lt_not_eq : lt s s' -> ~ eq s s'. (** Additional specification of [elements] *) - Parameter elements_3 : sort E.lt (elements s). + Parameter elements_3 : sort E.lt (elements s). (** Remark: since [fold] is specified via [elements], this stronger - specification of [elements] has an indirect impact on [fold], + specification of [elements] has an indirect impact on [fold], which can now be proved to receive elements in increasing order. *) (** Specification of [min_elt] *) - Parameter min_elt_1 : min_elt s = Some x -> In x s. - Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_1 : min_elt s = Some x -> In x s. + Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. Parameter min_elt_3 : min_elt s = None -> Empty s. - (** Specification of [max_elt] *) - Parameter max_elt_1 : max_elt s = Some x -> In x s. - Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + (** Specification of [max_elt] *) + Parameter max_elt_1 : max_elt s = Some x -> In x s. + Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. Parameter max_elt_3 : max_elt s = None -> Empty s. (** Additional specification of [choose] *) - Parameter choose_3 : choose s = Some x -> choose s' = Some y -> + Parameter choose_3 : choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. End Spec. Hint Resolve elements_3 : set. - Hint Immediate + Hint Immediate min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set. End Sfun. @@ -344,7 +344,7 @@ End Sfun. (** ** Static signature for sets on ordered elements - Similar to the functorial signature [Sfun], except that the + Similar to the functorial signature [Sfun], except that the module [E] of base elements is incorporated in the signature. *) Module Type S. @@ -411,7 +411,7 @@ Module Type Sdep. Parameter singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. - + Parameter remove : forall (x : elt) (s : t), @@ -433,7 +433,7 @@ Module Type Sdep. {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}. - + Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}. Parameter @@ -447,7 +447,7 @@ Module Type Sdep. forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. - + Parameter exists_ : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) @@ -474,7 +474,7 @@ Module Type Sdep. Parameter fold : forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), - {r : A | let (l,_) := elements s in + {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. Parameter @@ -494,10 +494,10 @@ Module Type Sdep. Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}. - (** The [choose_3] specification of [S] cannot be packed + (** The [choose_3] specification of [S] cannot be packed in the dependent version of [choose], so we leave it separate. *) - Parameter choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with + Parameter choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with | inleft (exist x _), inleft (exist x' _) => E.eq x x' | inright _, inright _ => True | _, _ => False diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v index 4e46610bc0..eb6f7b2227 100644 --- a/theories/FSets/FSetList.v +++ b/theories/FSets/FSetList.v @@ -10,7 +10,7 @@ (** * Finite sets library *) -(** This file proposes an implementation of the non-dependant +(** This file proposes an implementation of the non-dependant interface [FSetInterface.S] using strictly ordered list. *) Require Export FSetInterface. @@ -20,11 +20,11 @@ Unset Strict Implicit. (** * Functions over lists First, we provide sets as lists which are not necessarily sorted. - The specs are proved under the additional condition of being sorted. + The specs are proved under the additional condition of being sorted. And the functions returning sets are proved to preserve this invariant. *) Module Raw (X: OrderedType). - + Module MX := OrderedTypeFacts X. Import MX. @@ -59,7 +59,7 @@ Module Raw (X: OrderedType). end end. - Definition singleton (x : elt) : t := x :: nil. + Definition singleton (x : elt) : t := x :: nil. Fixpoint remove (x : elt) (s : t) {struct s} : t := match s with @@ -70,8 +70,8 @@ Module Raw (X: OrderedType). | EQ _ => l | GT _ => y :: remove x l end - end. - + end. + Fixpoint union (s : t) : t -> t := match s with | nil => fun s' => s' @@ -86,7 +86,7 @@ Module Raw (X: OrderedType). | GT _ => x' :: union_aux l' end end) - end. + end. Fixpoint inter (s : t) : t -> t := match s with @@ -102,8 +102,8 @@ Module Raw (X: OrderedType). | GT _ => inter_aux l' end end) - end. - + end. + Fixpoint diff (s : t) : t -> t := match s with | nil => fun _ => nil @@ -118,8 +118,8 @@ Module Raw (X: OrderedType). | GT _ => diff_aux l' end end) - end. - + end. + Fixpoint equal (s : t) : t -> bool := fun s' : t => match s, s' with @@ -144,31 +144,31 @@ Module Raw (X: OrderedType). | _, _ => false end. - Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : + Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : B -> B := fun i => match s with | nil => i | x :: l => fold f l (f x i) - end. + end. Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t := match s with | nil => nil | x :: l => if f x then x :: filter f l else filter f l - end. + end. Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool := match s with | nil => true | x :: l => if f x then for_all f l else false - end. - + end. + Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool := match s with | nil => false | x :: l => if f x then true else exists_ f l end. - Fixpoint partition (f : elt -> bool) (s : t) {struct s} : + Fixpoint partition (f : elt -> bool) (s : t) {struct s} : t * t := match s with | nil => (nil, nil) @@ -211,7 +211,7 @@ Module Raw (X: OrderedType). Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x. Lemma mem_1 : - forall (s : t) (Hs : Sort s) (x : elt), In x s -> mem x s = true. + forall (s : t) (Hs : Sort s) (x : elt), In x s -> mem x s = true. Proof. simple induction s; intros. inversion H. @@ -234,25 +234,25 @@ Module Raw (X: OrderedType). Lemma add_Inf : forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s). Proof. - simple induction s. + simple induction s. simpl; intuition. simpl; intros; case (X.compare x a); intuition; inversion H0; intuition. Qed. Hint Resolve add_Inf. - + Lemma add_sort : forall (s : t) (Hs : Sort s) (x : elt), Sort (add x s). Proof. simple induction s. simpl; intuition. simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; auto. - Qed. + Qed. Lemma add_1 : forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> In y (add x s). Proof. - simple induction s. + simple induction s. simpl; intuition. simpl; intros; case (X.compare x a); inversion_clear Hs; auto. constructor; apply X.eq_trans with x; auto. @@ -261,7 +261,7 @@ Module Raw (X: OrderedType). Lemma add_2 : forall (s : t) (Hs : Sort s) (x y : elt), In y s -> In y (add x s). Proof. - simple induction s. + simple induction s. simpl; intuition. simpl; intros; case (X.compare x a); intuition. inversion_clear Hs; inversion_clear H0; auto. @@ -271,7 +271,7 @@ Module Raw (X: OrderedType). forall (s : t) (Hs : Sort s) (x y : elt), ~ X.eq x y -> In y (add x s) -> In y s. Proof. - simple induction s. + simple induction s. simpl; inversion_clear 3; auto; order. simpl; intros a l Hrec Hs x y; case (X.compare x a); intros; inversion_clear H0; inversion_clear Hs; auto. @@ -282,7 +282,7 @@ Module Raw (X: OrderedType). Lemma remove_Inf : forall (s : t) (Hs : Sort s) (x a : elt), Inf a s -> Inf a (remove x s). Proof. - simple induction s. + simple induction s. simpl; intuition. simpl; intros; case (X.compare x a); intuition; inversion_clear H0; auto. inversion_clear Hs; apply Inf_lt with a; auto. @@ -295,14 +295,14 @@ Module Raw (X: OrderedType). simple induction s. simpl; intuition. simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; auto. - Qed. + Qed. Lemma remove_1 : forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> ~ In y (remove x s). Proof. - simple induction s. + simple induction s. simpl; red; intros; inversion H0. - simpl; intros; case (X.compare x a); intuition; inversion_clear Hs. + simpl; intros; case (X.compare x a); intuition; inversion_clear Hs. inversion_clear H1. order. generalize (Sort_Inf_In H2 H3 H4); order. @@ -316,23 +316,23 @@ Module Raw (X: OrderedType). forall (s : t) (Hs : Sort s) (x y : elt), ~ X.eq x y -> In y s -> In y (remove x s). Proof. - simple induction s. + simple induction s. simpl; intuition. simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; - inversion_clear H1; auto. + inversion_clear H1; auto. destruct H0; apply X.eq_trans with a; auto. Qed. Lemma remove_3 : forall (s : t) (Hs : Sort s) (x y : elt), In y (remove x s) -> In y s. Proof. - simple induction s. + simple induction s. simpl; intuition. simpl; intros a l Hrec Hs x y; case (X.compare x a); intuition. inversion_clear Hs; inversion_clear H; auto. constructor 2; apply Hrec with x; auto. Qed. - + Lemma singleton_sort : forall x : elt, Sort (singleton x). Proof. unfold singleton; simpl; auto. @@ -342,12 +342,12 @@ Module Raw (X: OrderedType). Proof. unfold singleton; simpl; intuition. inversion_clear H; auto; inversion H0. - Qed. + Qed. Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x). Proof. unfold singleton; simpl; auto. - Qed. + Qed. Ltac DoubleInd := simple induction s; @@ -366,15 +366,15 @@ Module Raw (X: OrderedType). case (X.compare x x'); auto. Qed. Hint Resolve union_Inf. - + Lemma union_sort : forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (union s s'). Proof. DoubleInd; case (X.compare x x'); intuition; constructor; auto. apply Inf_eq with x'; trivial; apply union_Inf; trivial; apply Inf_eq with x; auto. change (Inf x' (union (x :: l) l')); auto. - Qed. - + Qed. + Lemma union_1 : forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), In x (union s s') -> In x s \/ In x s'. @@ -389,7 +389,7 @@ Module Raw (X: OrderedType). forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), In x s -> In x (union s s'). Proof. - DoubleInd. + DoubleInd. intros i Hi; case (X.compare x x'); intuition; inversion_clear Hi; auto. Qed. @@ -397,23 +397,23 @@ Module Raw (X: OrderedType). forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), In x s' -> In x (union s s'). Proof. - DoubleInd. + DoubleInd. intros i Hi; case (X.compare x x'); inversion_clear Hi; intuition. - constructor; apply X.eq_trans with x'; auto. + constructor; apply X.eq_trans with x'; auto. Qed. - + Lemma inter_Inf : forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt), Inf a s -> Inf a s' -> Inf a (inter s s'). Proof. DoubleInd. intros i His His'; inversion His; inversion His'; subst. - case (X.compare x x'); intuition. + case (X.compare x x'); intuition. apply Inf_lt with x; auto. apply H3; auto. apply Inf_lt with x'; auto. Qed. - Hint Resolve inter_Inf. + Hint Resolve inter_Inf. Lemma inter_sort : forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (inter s s'). @@ -421,8 +421,8 @@ Module Raw (X: OrderedType). DoubleInd; case (X.compare x x'); auto. constructor; auto. apply Inf_eq with x'; trivial; apply inter_Inf; trivial; apply Inf_eq with x; auto. - Qed. - + Qed. + Lemma inter_1 : forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), In x (inter s s') -> In x s. @@ -455,7 +455,7 @@ Module Raw (X: OrderedType). inversion_clear His; auto; inversion_clear His'; auto. constructor; apply X.eq_trans with x'; auto. - change (In i (inter (x :: l) l')). + change (In i (inter (x :: l) l')). inversion_clear His'; auto. generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) His); order. Qed. @@ -473,14 +473,14 @@ Module Raw (X: OrderedType). apply H10; trivial. apply Inf_lt with x'; auto. Qed. - Hint Resolve diff_Inf. + Hint Resolve diff_Inf. Lemma diff_sort : forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (diff s s'). Proof. DoubleInd; case (X.compare x x'); auto. - Qed. - + Qed. + Lemma diff_1 : forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), In x (diff s s') -> In x s. @@ -496,18 +496,18 @@ Module Raw (X: OrderedType). In x (diff s s') -> ~ In x s'. Proof. DoubleInd. - intros; intro Abs; inversion Abs. + intros; intro Abs; inversion Abs. case (X.compare x x'); intuition. inversion_clear H. generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) H3); order. apply Hrec with (x'::l') x0; auto. - + inversion_clear H3. generalize (Sort_Inf_In H1 H2 (diff_1 H1 H5 H)); order. apply Hrec with l' x0; auto. - - inversion_clear H3. + + inversion_clear H3. generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) (diff_1 Hs H5 H)); order. apply H0 with x0; auto. Qed. @@ -519,7 +519,7 @@ Module Raw (X: OrderedType). DoubleInd. intros i His His'; elim (X.compare x x'); intuition; inversion_clear His; auto. elim His'; constructor; apply X.eq_trans with x; auto. - Qed. + Qed. Lemma equal_1 : forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), @@ -539,7 +539,7 @@ Module Raw (X: OrderedType). assert (A : In x (x' :: l')); auto; inversion_clear A. order. generalize (Sort_Inf_In H5 H6 H4); order. - + apply Hrec; intuition; elim (H a); intros. assert (A : In a (x' :: l')); auto; inversion_clear A; auto. generalize (Sort_Inf_In H1 H2 H0); order. @@ -565,8 +565,8 @@ Module Raw (X: OrderedType). elim (Hrec l' H a); intuition; inversion_clear H2; auto. constructor; apply X.eq_trans with x; auto. constructor; apply X.eq_trans with x'; auto. - Qed. - + Qed. + Lemma subset_1 : forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Subset s s' -> subset s s' = true. @@ -574,7 +574,7 @@ Module Raw (X: OrderedType). intros s s'; generalize s' s; clear s s'. simple induction s'; unfold Subset. intro s; case s; auto. - intros; elim (H e); intros; assert (A : In e nil); auto; inversion A. + intros; elim (H e); intros; assert (A : In e nil); auto; inversion A. intros x' l' Hrec s; case s. simpl; auto. intros x l Hs Hs'; inversion Hs; inversion Hs'; subst. @@ -583,14 +583,14 @@ Module Raw (X: OrderedType). assert (A : In x (x' :: l')); auto; inversion_clear A. order. generalize (Sort_Inf_In H5 H6 H0); order. - + apply Hrec; intuition. assert (A : In a (x' :: l')); auto; inversion_clear A; auto. generalize (Sort_Inf_In H1 H2 H0); order. apply Hrec; intuition. assert (A : In a (x' :: l')); auto; inversion_clear A; auto. - inversion_clear H0. + inversion_clear H0. order. generalize (Sort_Inf_In H1 H2 H4); order. Qed. @@ -604,13 +604,13 @@ Module Raw (X: OrderedType). intros x' l' Hrec s; case s. intros; inversion H0. intros x l; simpl; case (X.compare x); intros; auto. - discriminate H. + discriminate H. inversion_clear H0. constructor; apply X.eq_trans with x; auto. constructor 2; apply Hrec with l; auto. constructor 2; apply Hrec with (x::l); auto. - Qed. - + Qed. + Lemma empty_sort : Sort empty. Proof. unfold empty; constructor. @@ -619,15 +619,15 @@ Module Raw (X: OrderedType). Lemma empty_1 : Empty empty. Proof. unfold Empty, empty; intuition; inversion H. - Qed. + Qed. Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. Proof. unfold Empty; intro s; case s; simpl; intuition. elim (H e); auto. Qed. - - Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. + + Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. Proof. unfold Empty; intro s; case s; simpl; intuition; inversion H0. @@ -639,39 +639,39 @@ Module Raw (X: OrderedType). Qed. Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s. - Proof. + Proof. unfold elements; auto. Qed. - - Lemma elements_3 : forall (s : t) (Hs : Sort s), Sort (elements s). - Proof. + + Lemma elements_3 : forall (s : t) (Hs : Sort s), Sort (elements s). + Proof. unfold elements; auto. Qed. - Lemma elements_3w : forall (s : t) (Hs : Sort s), NoDupA X.eq (elements s). - Proof. + Lemma elements_3w : forall (s : t) (Hs : Sort s), NoDupA X.eq (elements s). + Proof. unfold elements; auto. Qed. - Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. + Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. Proof. intro s; case s; simpl; intros; inversion H; auto. - Qed. + Qed. Lemma min_elt_2 : forall (s : t) (Hs : Sort s) (x y : elt), - min_elt s = Some x -> In y s -> ~ X.lt y x. + min_elt s = Some x -> In y s -> ~ X.lt y x. Proof. simple induction s; simpl. intros; inversion H. - intros a l; case l; intros; inversion H0; inversion_clear H1; subst. + intros a l; case l; intros; inversion H0; inversion_clear H1; subst. order. inversion H2. order. inversion_clear Hs. inversion_clear H3. generalize (H H1 e y (refl_equal (Some e)) H2); order. - Qed. + Qed. Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. Proof. @@ -679,8 +679,8 @@ Module Raw (X: OrderedType). inversion H; inversion H0. Qed. - Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. - Proof. + Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. + Proof. simple induction s; simpl. intros; inversion H. intros x l; case l; simpl. @@ -689,10 +689,10 @@ Module Raw (X: OrderedType). intros. constructor 2; apply (H _ H0). Qed. - + Lemma max_elt_2 : forall (s : t) (Hs : Sort s) (x y : elt), - max_elt s = Some x -> In y s -> ~ X.lt x y. + max_elt s = Some x -> In y s -> ~ X.lt x y. Proof. simple induction s; simpl. intros; inversion H. @@ -706,7 +706,7 @@ Module Raw (X: OrderedType). assert (In e (e::l0)) by auto. generalize (H H2 x0 e H0 H1); order. generalize (H H2 x0 y H0 H3); order. - Qed. + Qed. Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. Proof. @@ -734,7 +734,7 @@ Module Raw (X: OrderedType). rewrite H; auto using min_elt_1. destruct (X.compare x x'); intuition. Qed. - + Lemma fold_1 : forall (s : t) (Hs : Sort s) (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. @@ -758,9 +758,9 @@ Module Raw (X: OrderedType). Inf x s -> Inf x (filter f s). Proof. simple induction s; simpl. - intuition. + intuition. intros x l Hrec Hs a f Ha; inversion_clear Hs; inversion_clear Ha. - case (f x). + case (f x). constructor; auto. apply Hrec; auto. apply Inf_lt with x; auto. @@ -774,7 +774,7 @@ Module Raw (X: OrderedType). intros x l Hrec Hs f; inversion_clear Hs. case (f x); auto. constructor; auto. - apply filter_Inf; auto. + apply filter_Inf; auto. Qed. Lemma filter_1 : @@ -793,7 +793,7 @@ Module Raw (X: OrderedType). Lemma filter_2 : forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x (filter f s) -> f x = true. + compat_bool X.eq f -> In x (filter f s) -> f x = true. Proof. simple induction s; simpl. intros; inversion H0. @@ -802,10 +802,10 @@ Module Raw (X: OrderedType). inversion_clear 2; auto. symmetry; auto. Qed. - + Lemma filter_3 : forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s). + compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s). Proof. simple induction s; simpl. intros; inversion H0. @@ -820,9 +820,9 @@ Module Raw (X: OrderedType). forall (s : t) (f : elt -> bool), compat_bool X.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. - Proof. + Proof. simple induction s; simpl; auto; unfold For_all. - intros x l Hrec f Hf. + intros x l Hrec f Hf. generalize (Hf x); case (f x); simpl. auto. intros; rewrite (H x); auto. @@ -832,11 +832,11 @@ Module Raw (X: OrderedType). forall (s : t) (f : elt -> bool), compat_bool X.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. - Proof. + Proof. simple induction s; simpl; auto; unfold For_all. intros; inversion H1. - intros x l Hrec f Hf. - intros A a; intros. + intros x l Hrec f Hf. + intros A a; intros. assert (f x = true). generalize A; case (f x); auto. rewrite H0 in A; simpl in A. @@ -850,9 +850,9 @@ Module Raw (X: OrderedType). Proof. simple induction s; simpl; auto; unfold Exists. intros. - elim H0; intuition. + elim H0; intuition. inversion H2. - intros x l Hrec f Hf. + intros x l Hrec f Hf. generalize (Hf x); case (f x); simpl. auto. destruct 2 as [a (A1,A2)]. @@ -865,7 +865,7 @@ Module Raw (X: OrderedType). Lemma exists_2 : forall (s : t) (f : elt -> bool), compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. + Proof. simple induction s; simpl; auto; unfold Exists. intros; discriminate. intros x l Hrec f Hf. @@ -880,7 +880,7 @@ Module Raw (X: OrderedType). Inf x s -> Inf x (fst (partition f s)). Proof. simple induction s; simpl. - intuition. + intuition. intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha. generalize (Hrec H f a). case (f x); case (partition f l); simpl. @@ -893,7 +893,7 @@ Module Raw (X: OrderedType). Inf x s -> Inf x (snd (partition f s)). Proof. simple induction s; simpl. - intuition. + intuition. intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha. generalize (Hrec H f a). case (f x); case (partition f l); simpl. @@ -910,7 +910,7 @@ Module Raw (X: OrderedType). generalize (Hrec H f); generalize (partition_Inf_1 H f). case (f x); case (partition f l); simpl; auto. Qed. - + Lemma partition_sort_2 : forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (snd (partition f s)). Proof. @@ -935,7 +935,7 @@ Module Raw (X: OrderedType). constructor 2; rewrite <- H; auto. constructor 2; rewrite H; auto. Qed. - + Lemma partition_2 : forall (s : t) (f : elt -> bool), compat_bool X.eq f -> @@ -943,7 +943,7 @@ Module Raw (X: OrderedType). Proof. simple induction s; simpl; auto; unfold Equal. split; auto. - intros x l Hrec f Hf. + intros x l Hrec f Hf. generalize (Hrec f Hf); clear Hrec. destruct (partition f l) as [s1 s2]; simpl; intros. case (f x); simpl; auto. @@ -951,21 +951,21 @@ Module Raw (X: OrderedType). constructor 2; rewrite <- H; auto. constructor 2; rewrite H; auto. Qed. - + Definition eq : t -> t -> Prop := Equal. - Lemma eq_refl : forall s : t, eq s s. - Proof. + Lemma eq_refl : forall s : t, eq s s. + Proof. unfold eq, Equal; intuition. Qed. Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s. - Proof. + Proof. unfold eq, Equal; intros; destruct (H a); intuition. Qed. Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. - Proof. + Proof. unfold eq, Equal; intros; destruct (H a); destruct (H0 a); intuition. Qed. @@ -977,29 +977,29 @@ Module Raw (X: OrderedType). forall (x y : elt) (s s' : t), X.eq x y -> lt s s' -> lt (x :: s) (y :: s'). Hint Constructors lt. - + Lemma lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''. - Proof. + Proof. intros s s' s'' H; generalize s''; clear s''; elim H. intros x l s'' H'; inversion_clear H'; auto. - intros x x' l l' E s'' H'; inversion_clear H'; auto. + intros x x' l l' E s'' H'; inversion_clear H'; auto. constructor; apply X.lt_trans with x'; auto. constructor; apply lt_eq with x'; auto. intros. inversion_clear H3. constructor; apply eq_lt with y; auto. - constructor 3; auto; apply X.eq_trans with y; auto. - Qed. + constructor 3; auto; apply X.eq_trans with y; auto. + Qed. Lemma lt_not_eq : forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), lt s s' -> ~ eq s s'. - Proof. - unfold eq, Equal. + Proof. + unfold eq, Equal. intros s s' Hs Hs' H; generalize Hs Hs'; clear Hs Hs'; elim H; intros; intro. elim (H0 x); intros. assert (X : In x nil); auto; inversion X. inversion_clear Hs; inversion_clear Hs'. - elim (H1 x); intros. + elim (H1 x); intros. assert (X : In x (y :: s'0)); auto; inversion_clear X. order. generalize (Sort_Inf_In H4 H5 H8); order. @@ -1019,8 +1019,8 @@ Module Raw (X: OrderedType). forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Compare lt eq s s'. Proof. simple induction s. - intros; case s'. - constructor 2; apply eq_refl. + intros; case s'. + constructor 2; apply eq_refl. constructor 1; auto. intros a l Hrec s'; case s'. constructor 3; auto. @@ -1039,25 +1039,25 @@ Module Raw (X: OrderedType). destruct (e1 a0); auto. Defined. - End ForNotations. + End ForNotations. Hint Constructors lt. End Raw. (** * Encapsulation - Now, in order to really provide a functor implementing [S], we + Now, in order to really provide a functor implementing [S], we need to encapsulate everything into a type of strictly ordered lists. *) Module Make (X: OrderedType) <: S with Module E := X. - Module Raw := Raw X. + Module Raw := Raw X. Module E := X. Record slist := {this :> Raw.t; sorted : sort E.lt this}. - Definition t := slist. + Definition t := slist. Definition elt := E.t. - + Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this). Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. @@ -1070,12 +1070,12 @@ Module Make (X: OrderedType) <: S with Module E := X. Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_sort (sorted s) x). Definition singleton (x : elt) : t := Build_slist (Raw.singleton_sort x). Definition union (s s' : t) : t := - Build_slist (Raw.union_sort (sorted s) (sorted s')). + Build_slist (Raw.union_sort (sorted s) (sorted s')). Definition inter (s s' : t) : t := - Build_slist (Raw.inter_sort (sorted s) (sorted s')). + Build_slist (Raw.inter_sort (sorted s) (sorted s')). Definition diff (s s' : t) : t := - Build_slist (Raw.diff_sort (sorted s) (sorted s')). - Definition equal (s s' : t) : bool := Raw.equal s s'. + Build_slist (Raw.diff_sort (sorted s) (sorted s')). + Definition equal (s s' : t) : bool := Raw.equal s s'. Definition subset (s s' : t) : bool := Raw.subset s s'. Definition empty : t := Build_slist Raw.empty_sort. Definition is_empty (s : t) : bool := Raw.is_empty s. @@ -1083,7 +1083,7 @@ Module Make (X: OrderedType) <: S with Module E := X. Definition min_elt (s : t) : option elt := Raw.min_elt s. Definition max_elt (s : t) : option elt := Raw.max_elt s. Definition choose (s : t) : option elt := Raw.choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. + Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. Definition cardinal (s : t) : nat := Raw.cardinal s. Definition filter (f : elt -> bool) (s : t) : t := Build_slist (Raw.filter_sort (sorted s) f). @@ -1096,18 +1096,18 @@ Module Make (X: OrderedType) <: S with Module E := X. Definition eq (s s' : t) : Prop := Raw.eq s s'. Definition lt (s s' : t) : Prop := Raw.lt s s'. - Section Spec. + Section Spec. Variable s s' s'': t. Variable x y : elt. - Lemma In_1 : E.eq x y -> In x s -> In y s. + Lemma In_1 : E.eq x y -> In x s -> In y s. Proof. exact (fun H H' => Raw.MX.In_eq H H'). Qed. - + Lemma mem_1 : In x s -> mem x s = true. Proof. exact (fun H => Raw.mem_1 s.(sorted) H). Qed. - Lemma mem_2 : mem x s = true -> In x s. + Lemma mem_2 : mem x s = true -> In x s. Proof. exact (fun H => Raw.mem_2 H). Qed. - + Lemma equal_1 : Equal s s' -> equal s s' = true. Proof. exact (Raw.equal_1 s.(sorted) s'.(sorted)). Qed. Lemma equal_2 : equal s s' = true -> Equal s s'. @@ -1121,16 +1121,16 @@ Module Make (X: OrderedType) <: S with Module E := X. Lemma empty_1 : Empty empty. Proof. exact Raw.empty_1. Qed. - Lemma is_empty_1 : Empty s -> is_empty s = true. + Lemma is_empty_1 : Empty s -> is_empty s = true. Proof. exact (fun H => Raw.is_empty_1 H). Qed. Lemma is_empty_2 : is_empty s = true -> Empty s. Proof. exact (fun H => Raw.is_empty_2 H). Qed. - + Lemma add_1 : E.eq x y -> In y (add x s). Proof. exact (fun H => Raw.add_1 s.(sorted) H). Qed. Lemma add_2 : In y s -> In y (add x s). Proof. exact (fun H => Raw.add_2 s.(sorted) x H). Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. Proof. exact (fun H => Raw.add_3 s.(sorted) H). Qed. Lemma remove_1 : E.eq x y -> ~ In y (remove x s). @@ -1140,14 +1140,14 @@ Module Make (X: OrderedType) <: S with Module E := X. Lemma remove_3 : In y (remove x s) -> In y s. Proof. exact (fun H => Raw.remove_3 s.(sorted) H). Qed. - Lemma singleton_1 : In y (singleton x) -> E.eq x y. + Lemma singleton_1 : In y (singleton x) -> E.eq x y. Proof. exact (fun H => Raw.singleton_1 H). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). + Lemma singleton_2 : E.eq x y -> In y (singleton x). Proof. exact (fun H => Raw.singleton_2 H). Qed. Lemma union_1 : In x (union s s') -> In x s \/ In x s'. Proof. exact (fun H => Raw.union_1 s.(sorted) s'.(sorted) H). Qed. - Lemma union_2 : In x s -> In x (union s s'). + Lemma union_2 : In x s -> In x (union s s'). Proof. exact (fun H => Raw.union_2 s.(sorted) s'.(sorted) H). Qed. Lemma union_3 : In x s' -> In x (union s s'). Proof. exact (fun H => Raw.union_3 s.(sorted) s'.(sorted) H). Qed. @@ -1159,13 +1159,13 @@ Module Make (X: OrderedType) <: S with Module E := X. Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). Proof. exact (fun H => Raw.inter_3 s.(sorted) s'.(sorted) H). Qed. - Lemma diff_1 : In x (diff s s') -> In x s. + Lemma diff_1 : In x (diff s s') -> In x s. Proof. exact (fun H => Raw.diff_1 s.(sorted) s'.(sorted) H). Qed. Lemma diff_2 : In x (diff s s') -> ~ In x s'. Proof. exact (fun H => Raw.diff_2 s.(sorted) s'.(sorted) H). Qed. Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). Proof. exact (fun H => Raw.diff_3 s.(sorted) s'.(sorted) H). Qed. - + Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. exact (Raw.fold_1 s.(sorted)). Qed. @@ -1174,12 +1174,12 @@ Module Make (X: OrderedType) <: S with Module E := X. Proof. exact (Raw.cardinal_1 s.(sorted)). Qed. Section Filter. - + Variable f : elt -> bool. - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. Proof. exact (@Raw.filter_1 s x f). Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. + Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. Proof. exact (@Raw.filter_2 s x f). Qed. Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). @@ -1222,16 +1222,16 @@ Module Make (X: OrderedType) <: S with Module E := X. Lemma elements_3w : NoDupA E.eq (elements s). Proof. exact (Raw.elements_3w s.(sorted)). Qed. - Lemma min_elt_1 : min_elt s = Some x -> In x s. + Lemma min_elt_1 : min_elt s = Some x -> In x s. Proof. exact (fun H => Raw.min_elt_1 H). Qed. - Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. Proof. exact (fun H => Raw.min_elt_2 s.(sorted) H). Qed. Lemma min_elt_3 : min_elt s = None -> Empty s. Proof. exact (fun H => Raw.min_elt_3 H). Qed. - Lemma max_elt_1 : max_elt s = Some x -> In x s. + Lemma max_elt_1 : max_elt s = Some x -> In x s. Proof. exact (fun H => Raw.max_elt_1 H). Qed. - Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. Proof. exact (fun H => Raw.max_elt_2 s.(sorted) H). Qed. Lemma max_elt_3 : max_elt s = None -> Empty s. Proof. exact (fun H => Raw.max_elt_3 H). Qed. @@ -1240,7 +1240,7 @@ Module Make (X: OrderedType) <: S with Module E := X. Proof. exact (fun H => Raw.choose_1 H). Qed. Lemma choose_2 : choose s = None -> Empty s. Proof. exact (fun H => Raw.choose_2 H). Qed. - Lemma choose_3 : choose s = Some x -> choose s' = Some y -> + Lemma choose_3 : choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. Proof. exact (@Raw.choose_3 _ _ s.(sorted) s'.(sorted) x y). Qed. @@ -1259,8 +1259,8 @@ Module Make (X: OrderedType) <: S with Module E := X. Definition compare : Compare lt eq s s'. Proof. elim (Raw.compare s.(sorted) s'.(sorted)); - [ constructor 1 | constructor 2 | constructor 3 ]; - auto. + [ constructor 1 | constructor 2 | constructor 3 ]; + auto. Defined. Definition eq_dec : { eq s s' } + { ~ eq s s' }. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 6a062ea14a..032f0c1b31 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -11,9 +11,9 @@ (** * Finite sets library *) (** This functor derives additional properties from [FSetInterface.S]. - Contrary to the functor in [FSetEqProperties] it uses + Contrary to the functor in [FSetEqProperties] it uses predicates over sets instead of sets operations, i.e. - [In x s] instead of [mem x s=true], + [In x s] instead of [mem x s=true], [Equal s s'] instead of [equal s s'=true], etc. *) Require Export FSetInterface. @@ -47,7 +47,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). fsetdec. fsetdec. Qed. - + Ltac expAdd := repeat rewrite Add_Equal. Section BasicProperties. @@ -64,7 +64,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. Proof. fsetdec. Qed. - Lemma subset_refl : s[<=]s. + Lemma subset_refl : s[<=]s. Proof. fsetdec. Qed. Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. @@ -84,7 +84,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. Proof. fsetdec. Qed. - + Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. Proof. fsetdec. Qed. @@ -93,7 +93,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. Proof. fsetdec. Qed. - + Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. Proof. intuition fsetdec. Qed. @@ -105,7 +105,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma add_equal : In x s -> add x s [=] s. Proof. fsetdec. Qed. - + Lemma add_add : add x (add x' s) [=] add x' (add x s). Proof. fsetdec. Qed. @@ -149,11 +149,11 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma union_add : union (add x s) s' [=] add x (union s s'). Proof. fsetdec. Qed. - Lemma union_remove_add_1 : + Lemma union_remove_add_1 : union (remove x s) (add x s') [=] union (add x s) (remove x s'). Proof. fsetdec. Qed. - Lemma union_remove_add_2 : In x s -> + Lemma union_remove_add_2 : In x s -> union (remove x s) (add x s') [=] union s s'. Proof. fsetdec. Qed. @@ -167,10 +167,10 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. fsetdec. Qed. Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. - Proof. fsetdec. Qed. + Proof. fsetdec. Qed. Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. - Proof. fsetdec. Qed. + Proof. fsetdec. Qed. Lemma empty_union_1 : Empty s -> union s s' [=] s'. Proof. fsetdec. Qed. @@ -178,7 +178,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma empty_union_2 : Empty s -> union s' s [=] s'. Proof. fsetdec. Qed. - Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). + Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). Proof. fsetdec. Qed. Lemma inter_sym : inter s s' [=] inter s' s. @@ -224,7 +224,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. Proof. fsetdec. Qed. - Lemma empty_diff_1 : Empty s -> Empty (diff s s'). + Lemma empty_diff_1 : Empty s -> Empty (diff s s'). Proof. fsetdec. Qed. Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. @@ -240,7 +240,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). remove x s [=] diff s (singleton x). Proof. fsetdec. Qed. - Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. + Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. Proof. fsetdec. Qed. Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. @@ -249,19 +249,19 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma Add_add : Add x s (add x s). Proof. expAdd; fsetdec. Qed. - Lemma Add_remove : In x s -> Add x (remove x s) s. + Lemma Add_remove : In x s -> Add x (remove x s) s. Proof. expAdd; fsetdec. Qed. Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). - Proof. expAdd; fsetdec. Qed. + Proof. expAdd; fsetdec. Qed. Lemma inter_Add : In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). - Proof. expAdd; fsetdec. Qed. + Proof. expAdd; fsetdec. Qed. Lemma union_Equal : In x s'' -> Add x s s' -> union s s'' [=] union s' s''. - Proof. expAdd; fsetdec. Qed. + Proof. expAdd; fsetdec. Qed. Lemma inter_Add_2 : ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. @@ -270,16 +270,16 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). End BasicProperties. Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. - Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym - subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 + Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym + subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal - remove_equal singleton_equal_add union_subset_equal union_equal_1 - union_equal_2 union_assoc add_union_singleton union_add union_subset_1 + remove_equal singleton_equal_add union_subset_equal union_equal_1 + union_equal_2 union_assoc add_union_singleton union_add union_subset_1 union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 - empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 - empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union - inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal + empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 + empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union + inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove Equal_remove add_add : set. @@ -504,7 +504,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). generalize H H2; clear H H2; case l; simpl; intros. reflexivity. elim (H e). - elim (H2 e); intuition. + elim (H2 e); intuition. Qed. Lemma fold_2 : @@ -514,17 +514,17 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). transpose eqA f -> ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). Proof. - intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); + intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto. eauto. rewrite <- Hl1; auto. - intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; + intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; rewrite (H2 a); intuition. Qed. - (** In fact, [fold] on empty sets is more than equivalent to + (** In fact, [fold] on empty sets is more than equivalent to the initial element, it is Leibniz-equal to it. *) Lemma fold_1b : @@ -541,7 +541,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). - Lemma fold_commutes : forall i s x, + Lemma fold_commutes : forall i s x, eqA (fold f s (f x i)) (f x (fold f s i)). Proof. intros. @@ -552,15 +552,15 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). (** ** Fold is a morphism *) - Lemma fold_init : forall i i' s, eqA i i' -> + Lemma fold_init : forall i i' s, eqA i i' -> eqA (fold f s i) (fold f s i'). Proof. intros. apply fold_rel with (R:=eqA); auto. Qed. - Lemma fold_equal : + Lemma fold_equal : forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. + Proof. intros i s; pattern s; apply set_induction; clear s; intros. transitivity i. apply fold_1; auto. @@ -576,23 +576,23 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). (** ** Fold and other set operators *) Lemma fold_empty : forall i, fold f empty i = i. - Proof. + Proof. intros i; apply fold_1b; auto with set. Qed. - Lemma fold_add : forall i s x, ~In x s -> + Lemma fold_add : forall i s x, ~In x s -> eqA (fold f (add x s) i) (f x (fold f s i)). - Proof. + Proof. intros; apply fold_2 with (eqA := eqA); auto with set. Qed. - Lemma add_fold : forall i s x, In x s -> + Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply fold_equal; auto with set. Qed. - Lemma remove_fold_1: forall i s x, In x s -> + Lemma remove_fold_1: forall i s x, In x s -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. intros. @@ -600,7 +600,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_2 with (eqA:=eqA); auto with set. Qed. - Lemma remove_fold_2: forall i s x, ~In x s -> + Lemma remove_fold_2: forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros. @@ -620,7 +620,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). symmetry; apply fold_1; auto. rename s'0 into s''. destruct (In_dec x s'). - (* In x s' *) + (* In x s' *) transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. apply fold_init; auto. apply fold_2 with (eqA:=eqA); auto with set. @@ -646,7 +646,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). symmetry; apply fold_2 with (eqA:=eqA); auto. Qed. - Lemma fold_diff_inter : forall i s s', + Lemma fold_diff_inter : forall i s s', eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). Proof. intros. @@ -659,7 +659,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_1; auto with set. Qed. - Lemma fold_union: forall i s s', + Lemma fold_union: forall i s s', (forall x, ~(In x s/\In x s')) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. @@ -696,9 +696,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma cardinal_0 : forall s, exists l : list elt, NoDupA E.eq l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ + (forall x : elt, In x s <-> InA E.eq x l) /\ cardinal s = length l. - Proof. + Proof. intros; exists (elements s); intuition; apply cardinal_1. Qed. @@ -724,32 +724,32 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). destruct (elements s); intuition; discriminate. Qed. - Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. + Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. Proof. - intros; rewrite cardinal_Empty; auto. + intros; rewrite cardinal_Empty; auto. Qed. Hint Resolve cardinal_inv_1. - + Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. - Proof. + Proof. intros; rewrite M.cardinal_1 in H. generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. + destruct (elements s); try discriminate. exists e; auto. Qed. Lemma cardinal_inv_2b : forall s, cardinal s <> 0 -> { x : elt | In x s }. Proof. - intro; generalize (@cardinal_inv_2 s); destruct cardinal; + intro; generalize (@cardinal_inv_2 s); destruct cardinal; [intuition|eauto]. Qed. (** ** Cardinal is a morphism *) Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. - Proof. + Proof. symmetry. remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. induction n; intros. @@ -794,8 +794,8 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_diff_inter with (eqA:=@Logic.eq nat); auto. Qed. - Lemma union_cardinal: - forall s s', (forall x, ~(In x s/\In x s')) -> + Lemma union_cardinal: + forall s s', (forall x, ~(In x s/\In x s')) -> cardinal (union s s')=cardinal s+cardinal s'. Proof. intros; do 3 rewrite cardinal_fold. @@ -803,7 +803,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_union; auto. Qed. - Lemma subset_cardinal : + Lemma subset_cardinal : forall s s', s[<=]s' -> cardinal s <= cardinal s' . Proof. intros. @@ -812,9 +812,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). rewrite (inter_subset_equal H); auto with arith. Qed. - Lemma subset_cardinal_lt : + Lemma subset_cardinal_lt : forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. - Proof. + Proof. intros. rewrite <- (diff_inter_cardinal s' s). rewrite (inter_sym s' s). @@ -826,7 +826,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros _. change (0 + cardinal s < S n + cardinal s). apply Plus.plus_lt_le_compat; auto with arith. - Qed. + Qed. Theorem union_inter_cardinal : forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . @@ -837,7 +837,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_union_inter with (eqA:=@Logic.eq nat); auto. Qed. - Lemma union_cardinal_inter : + Lemma union_cardinal_inter : forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). Proof. intros. @@ -846,17 +846,17 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). auto with arith. Qed. - Lemma union_cardinal_le : + Lemma union_cardinal_le : forall s s', cardinal (union s s') <= cardinal s + cardinal s'. Proof. intros; generalize (union_inter_cardinal s s'). intros; rewrite <- H; auto with arith. Qed. - Lemma add_cardinal_1 : + Lemma add_cardinal_1 : forall s x, In x s -> cardinal (add x s) = cardinal s. Proof. - auto with set. + auto with set. Qed. Lemma add_cardinal_2 : @@ -877,9 +877,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply remove_fold_1 with (eqA:=@Logic.eq nat); auto. Qed. - Lemma remove_cardinal_2 : + Lemma remove_cardinal_2 : forall s x, ~In x s -> cardinal (remove x s) = cardinal s. - Proof. + Proof. auto with set. Qed. @@ -950,7 +950,7 @@ Module OrdProperties (M:S). Qed. Hint Resolve gtb_compat leb_compat. - Lemma elements_split : forall x s, + Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. Proof. unfold elements_lt, elements_ge, leb; intros. @@ -964,8 +964,8 @@ Module OrdProperties (M:S). ME.order. Qed. - Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> - eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). + Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). Proof. intros; unfold elements_ge, elements_lt. apply sort_equivlistA_eqlistA; auto with set. @@ -1003,8 +1003,8 @@ Module OrdProperties (M:S). Definition Above x s := forall y, In y s -> E.lt y x. Definition Below x s := forall y, In y s -> E.lt x y. - Lemma elements_Add_Above : forall s s' x, - Above x s -> Add x s s' -> + Lemma elements_Add_Above : forall s s' x, + Above x s -> Add x s s' -> eqlistA E.eq (elements s') (elements s ++ x::nil). Proof. intros. @@ -1020,8 +1020,8 @@ Module OrdProperties (M:S). do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. Qed. - Lemma elements_Add_Below : forall s s' x, - Below x s -> Add x s s' -> + Lemma elements_Add_Below : forall s s' x, + Below x s -> Add x s s' -> eqlistA E.eq (elements s') (x::elements s). Proof. intros. @@ -1038,7 +1038,7 @@ Module OrdProperties (M:S). do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. Qed. - (** Two other induction principles on sets: we can be more restrictive + (** Two other induction principles on sets: we can be more restrictive on the element we add at each step. *) Lemma set_induction_max : @@ -1119,15 +1119,15 @@ Module OrdProperties (M:S). apply elements_Add_Below; auto. Qed. - (** The following results have already been proved earlier, + (** The following results have already been proved earlier, but we can now prove them with one hypothesis less: no need for [(transpose eqA f)]. *) - Section FoldOpt. + Section FoldOpt. Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f). - Lemma fold_equal : + Lemma fold_equal : forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). Proof. intros; do 2 rewrite M.fold_1. @@ -1138,13 +1138,13 @@ Module OrdProperties (M:S). red; intro a; do 2 rewrite <- elements_iff; auto. Qed. - Lemma add_fold : forall i s x, In x s -> + Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply fold_equal; auto with set. Qed. - Lemma remove_fold_2: forall i s x, ~In x s -> + Lemma remove_fold_2: forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros. @@ -1155,16 +1155,16 @@ Module OrdProperties (M:S). (** An alternative version of [choose_3] *) - Lemma choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with | Some x, Some x' => E.eq x x' | None, None => True | _, _ => False end. Proof. - intros s s' H; + intros s s' H; generalize (@choose_1 s)(@choose_2 s) - (@choose_1 s')(@choose_2 s')(@choose_3 s s'); + (@choose_1 s')(@choose_2 s')(@choose_3 s s'); destruct (choose s); destruct (choose s'); simpl; intuition. apply H5 with e; rewrite <-H; auto. apply H5 with e; rewrite H; auto. diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v index 7938beda7e..23420109cb 100644 --- a/theories/FSets/FSetToFiniteSet.v +++ b/theories/FSets/FSetToFiniteSet.v @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre +(* Finite sets library. + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) @@ -16,14 +16,14 @@ Require Import Ensembles Finite_sets. Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx. -(** * Going from [FSets] with usual Leibniz equality +(** * Going from [FSets] with usual Leibniz equality to the good old [Ensembles] and [Finite_sets] theory. *) Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). Module MP:= WProperties_fun U M. Import M MP FM Ensembles Finite_sets. - Definition mkEns : M.t -> Ensemble M.elt := + Definition mkEns : M.t -> Ensemble M.elt := fun s x => M.In x s. Notation " !! " := mkEns. @@ -115,11 +115,11 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). Proof. intro s; pattern s; apply set_induction; clear s; intros. intros; replace (!!s) with (Empty_set elt); auto with sets. - symmetry; apply Extensionality_Ensembles. + symmetry; apply Extensionality_Ensembles. apply Empty_Empty_set; auto. replace (!!s') with (Add _ (!!s) x). constructor 2; auto. - symmetry; apply Extensionality_Ensembles. + symmetry; apply Extensionality_Ensembles. apply Add_Add; auto. Qed. @@ -128,18 +128,18 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). intro s; pattern s; apply set_induction; clear s; intros. intros; replace (!!s) with (Empty_set elt); auto with sets. rewrite cardinal_1; auto with sets. - symmetry; apply Extensionality_Ensembles. + symmetry; apply Extensionality_Ensembles. apply Empty_Empty_set; auto. replace (!!s') with (Add _ (!!s) x). - rewrite (cardinal_2 H0 H1); auto with sets. - symmetry; apply Extensionality_Ensembles. + rewrite (cardinal_2 H0 H1); auto with sets. + symmetry; apply Extensionality_Ensembles. apply Add_Add; auto. Qed. - (** we can even build a function from Finite Ensemble to FSet + (** we can even build a function from Finite Ensemble to FSet ... at least in Prop. *) - Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> + Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> exists s:M.t, !!s === e. Proof. induction 1. @@ -147,7 +147,7 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). apply empty_Empty_Set. destruct IHFinite as (s,Hs). exists (M.add x s). - apply Extensionality_Ensembles in Hs. + apply Extensionality_Ensembles in Hs. rewrite <- Hs. apply add_Add. Qed. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v index d03e3bdc88..7a3e60d38f 100644 --- a/theories/FSets/FSetWeakList.v +++ b/theories/FSets/FSetWeakList.v @@ -10,7 +10,7 @@ (** * Finite sets library *) -(** This file proposes an implementation of the non-dependant +(** This file proposes an implementation of the non-dependant interface [FSetWeakInterface.S] using lists without redundancy. *) Require Import FSetInterface. @@ -20,7 +20,7 @@ Unset Strict Implicit. (** * Functions over lists First, we provide sets as lists which are (morally) without redundancy. - The specs are proved under the additional condition of no redundancy. + The specs are proved under the additional condition of no redundancy. And the functions returning sets are proved to preserve this invariant. *) Module Raw (X: DecidableType). @@ -48,7 +48,7 @@ Module Raw (X: DecidableType). if X.eq_dec x y then s else y :: add x l end. - Definition singleton (x : elt) : t := x :: nil. + Definition singleton (x : elt) : t := x :: nil. Fixpoint remove (x : elt) (s : t) {struct s} : t := match s with @@ -57,42 +57,42 @@ Module Raw (X: DecidableType). if X.eq_dec x y then l else y :: remove x l end. - Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : + Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : B -> B := fun i => match s with | nil => i | x :: l => fold f l (f x i) - end. + end. Definition union (s : t) : t -> t := fold add s. - + Definition diff (s s' : t) : t := fold remove s' s. - Definition inter (s s': t) : t := + Definition inter (s s': t) : t := fold (fun x s => if mem x s' then add x s else s) s nil. Definition subset (s s' : t) : bool := is_empty (diff s s'). - Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s). + Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s). Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t := match s with | nil => nil | x :: l => if f x then x :: filter f l else filter f l - end. + end. Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool := match s with | nil => true | x :: l => if f x then for_all f l else false - end. - + end. + Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool := match s with | nil => false | x :: l => if f x then true else exists_ f l end. - Fixpoint partition (f : elt -> bool) (s : t) {struct s} : + Fixpoint partition (f : elt -> bool) (s : t) {struct s} : t * t := match s with | nil => (nil, nil) @@ -105,14 +105,14 @@ Module Raw (X: DecidableType). Definition elements (s : t) : list elt := s. - Definition choose (s : t) : option elt := - match s with + Definition choose (s : t) : option elt := + match s with | nil => None | x::_ => Some x end. (** ** Proofs of set operation specifications. *) - Section ForNotations. + Section ForNotations. Notation NoDup := (NoDupA X.eq). Notation In := (InA X.eq). @@ -130,7 +130,7 @@ Module Raw (X: DecidableType). Hint Immediate In_eq. Lemma mem_1 : - forall (s : t)(x : elt), In x s -> mem x s = true. + forall (s : t)(x : elt), In x s -> mem x s = true. Proof. induction s; intros. inversion H. @@ -140,7 +140,7 @@ Module Raw (X: DecidableType). Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. Proof. - induction s. + induction s. intros; inversion H. intros x; simpl. destruct (X.eq_dec x a); firstorder; discriminate. @@ -149,7 +149,7 @@ Module Raw (X: DecidableType). Lemma add_1 : forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> In y (add x s). Proof. - induction s. + induction s. simpl; intuition. simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; firstorder. @@ -159,7 +159,7 @@ Module Raw (X: DecidableType). Lemma add_2 : forall (s : t) (Hs : NoDup s) (x y : elt), In y s -> In y (add x s). Proof. - induction s. + induction s. simpl; intuition. simpl; intros; case (X.eq_dec x a); intuition. inversion_clear Hs; eauto; inversion_clear H; intuition. @@ -169,18 +169,18 @@ Module Raw (X: DecidableType). forall (s : t) (Hs : NoDup s) (x y : elt), ~ X.eq x y -> In y (add x s) -> In y s. Proof. - induction s. + induction s. simpl; intuition. inversion_clear H0; firstorder; absurd (X.eq x y); auto. simpl; intros Hs x y; case (X.eq_dec x a); intros; - inversion_clear H0; inversion_clear Hs; firstorder; + inversion_clear H0; inversion_clear Hs; firstorder; absurd (X.eq x y); auto. Qed. Lemma add_unique : forall (s : t) (Hs : NoDup s)(x:elt), NoDup (add x s). Proof. - induction s. + induction s. simpl; intuition. constructor; auto. intro H0; inversion H0. @@ -197,9 +197,9 @@ Module Raw (X: DecidableType). Lemma remove_1 : forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> ~ In y (remove x s). Proof. - simple induction s. + simple induction s. simpl; red; intros; inversion H0. - simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs. + simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs. elim H2. apply In_eq with y; eauto. inversion_clear H1; eauto. @@ -209,17 +209,17 @@ Module Raw (X: DecidableType). forall (s : t) (Hs : NoDup s) (x y : elt), ~ X.eq x y -> In y s -> In y (remove x s). Proof. - simple induction s. + simple induction s. simpl; intuition. simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; - inversion_clear H1; auto. - absurd (X.eq x y); eauto. + inversion_clear H1; auto. + absurd (X.eq x y); eauto. Qed. Lemma remove_3 : forall (s : t) (Hs : NoDup s) (x y : elt), In y (remove x s) -> In y s. Proof. - simple induction s. + simple induction s. simpl; intuition. simpl; intros a l Hrec Hs x y; case (X.eq_dec x a); intuition. inversion_clear Hs; inversion_clear H; firstorder. @@ -235,7 +235,7 @@ Module Raw (X: DecidableType). constructor; auto. intro H2; elim H0. eapply remove_3; eauto. - Qed. + Qed. Lemma singleton_unique : forall x : elt, NoDup (singleton x). Proof. @@ -246,13 +246,13 @@ Module Raw (X: DecidableType). Proof. unfold singleton; simpl; intuition. inversion_clear H; auto; inversion H0. - Qed. + Qed. Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x). Proof. unfold singleton; simpl; intuition. - Qed. - + Qed. + Lemma empty_unique : NoDup empty. Proof. unfold empty; constructor. @@ -261,15 +261,15 @@ Module Raw (X: DecidableType). Lemma empty_1 : Empty empty. Proof. unfold Empty, empty; intuition; inversion H. - Qed. + Qed. Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. Proof. unfold Empty; intro s; case s; simpl; intuition. elim (H e); auto. Qed. - - Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. + + Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. Proof. unfold Empty; intro s; case s; simpl; intuition; inversion H0. @@ -281,12 +281,12 @@ Module Raw (X: DecidableType). Qed. Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s. - Proof. + Proof. unfold elements; auto. Qed. - - Lemma elements_3w : forall (s : t) (Hs : NoDup s), NoDup (elements s). - Proof. + + Lemma elements_3w : forall (s : t) (Hs : NoDup s), NoDup (elements s). + Proof. unfold elements; auto. Qed. @@ -306,7 +306,7 @@ Module Raw (X: DecidableType). apply IHs; auto. apply add_unique; auto. Qed. - + Lemma union_1 : forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), In x (union s s') -> In x s \/ In x s'. @@ -319,7 +319,7 @@ Module Raw (X: DecidableType). right; eapply add_3; eauto. Qed. - Lemma union_0 : + Lemma union_0 : forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), In x s \/ In x s' -> In x (union s s'). Proof. @@ -355,14 +355,14 @@ Module Raw (X: DecidableType). unfold inter; intros s. set (acc := nil (A:=elt)). assert (NoDup acc) by (unfold acc; auto). - clearbody acc; generalize H; clear H; generalize acc; clear acc. + clearbody acc; generalize H; clear H; generalize acc; clear acc. induction s; simpl; auto; intros. inversion_clear Hs. apply IHs; auto. destruct (mem a s'); intros; auto. apply add_unique; auto. - Qed. - + Qed. + Lemma inter_0 : forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), In x (inter s s') -> In x s /\ In x s'. @@ -373,7 +373,7 @@ Module Raw (X: DecidableType). cut ((In x s /\ In x s') \/ In x acc). destruct 1; auto. inversion H1. - clearbody acc. + clearbody acc. generalize H0 H Hs' Hs; clear H0 H Hs Hs'. generalize acc x s'; clear acc x s'. induction s; simpl; auto; intros. @@ -414,7 +414,7 @@ Module Raw (X: DecidableType). unfold inter. set (acc := nil (A:=elt)) in *. assert (NoDup acc) by (unfold acc; auto). - clearbody acc. + clearbody acc. generalize H Hs' Hs; clear H Hs Hs'. generalize acc x s'; clear acc x s'. induction s; simpl; auto; intros. @@ -446,8 +446,8 @@ Module Raw (X: DecidableType). inversion_clear Hs'. apply IHs'; auto. apply remove_unique; auto. - Qed. - + Qed. + Lemma diff_0 : forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), In x (diff s s') -> In x s /\ ~ In x s'. @@ -458,7 +458,7 @@ Module Raw (X: DecidableType). split; auto; intro H1; inversion H1. inversion_clear Hs'. destruct (IHs' (remove a s) (remove_unique Hs a) H1 x H). - split. + split. eapply remove_3; eauto. red; intros. inversion_clear H4; auto. @@ -469,14 +469,14 @@ Module Raw (X: DecidableType). forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), In x (diff s s') -> In x s. Proof. - intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. + intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. Qed. Lemma diff_2 : forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), In x (diff s s') -> ~ In x s'. Proof. - intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. + intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. Qed. Lemma diff_3 : @@ -489,8 +489,8 @@ Module Raw (X: DecidableType). apply IHs'; auto. apply remove_unique; auto. apply remove_2; auto. - Qed. - + Qed. + Lemma subset_1 : forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), Subset s s' -> subset s s' = true. @@ -504,7 +504,7 @@ Module Raw (X: DecidableType). eapply diff_1; eauto. Qed. - Lemma subset_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), + Lemma subset_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), subset s s' = true -> Subset s s'. Proof. unfold subset, Subset; intros. @@ -524,26 +524,26 @@ Module Raw (X: DecidableType). apply andb_true_intro; split; apply subset_1; firstorder. Qed. - Lemma equal_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), + Lemma equal_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), equal s s' = true -> Equal s s'. Proof. unfold Equal, equal; intros. destruct (andb_prop _ _ H); clear H. split; apply subset_2; auto. - Qed. + Qed. Definition choose_1 : forall (s : t) (x : elt), choose s = Some x -> In x s. Proof. destruct s; simpl; intros; inversion H; auto. - Qed. + Qed. Definition choose_2 : forall s : t, choose s = None -> Empty s. Proof. destruct s; simpl; intros. intros x H0; inversion H0. inversion H. - Qed. + Qed. Lemma cardinal_1 : forall (s : t) (Hs : NoDup s), cardinal s = length (elements s). @@ -567,7 +567,7 @@ Module Raw (X: DecidableType). Lemma filter_2 : forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x (filter f s) -> f x = true. + compat_bool X.eq f -> In x (filter f s) -> f x = true. Proof. simple induction s; simpl. intros; inversion H0. @@ -576,10 +576,10 @@ Module Raw (X: DecidableType). inversion_clear 2; auto. symmetry; auto. Qed. - + Lemma filter_3 : forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s). + compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s). Proof. simple induction s; simpl. intros; inversion H0. @@ -607,9 +607,9 @@ Module Raw (X: DecidableType). forall (s : t) (f : elt -> bool), compat_bool X.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. - Proof. + Proof. simple induction s; simpl; auto; unfold For_all. - intros x l Hrec f Hf. + intros x l Hrec f Hf. generalize (Hf x); case (f x); simpl. auto. intros; rewrite (H x); auto. @@ -619,11 +619,11 @@ Module Raw (X: DecidableType). forall (s : t) (f : elt -> bool), compat_bool X.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. - Proof. + Proof. simple induction s; simpl; auto; unfold For_all. intros; inversion H1. - intros x l Hrec f Hf. - intros A a; intros. + intros x l Hrec f Hf. + intros A a; intros. assert (f x = true). generalize A; case (f x); auto. rewrite H0 in A; simpl in A. @@ -637,9 +637,9 @@ Module Raw (X: DecidableType). Proof. simple induction s; simpl; auto; unfold Exists. intros. - elim H0; intuition. + elim H0; intuition. inversion H2. - intros x l Hrec f Hf. + intros x l Hrec f Hf. generalize (Hf x); case (f x); simpl. auto. destruct 2 as [a (A1,A2)]. @@ -652,7 +652,7 @@ Module Raw (X: DecidableType). Lemma exists_2 : forall (s : t) (f : elt -> bool), compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. + Proof. simple induction s; simpl; auto; unfold Exists. intros; discriminate. intros x l Hrec f Hf. @@ -671,9 +671,9 @@ Module Raw (X: DecidableType). intros x l Hrec f Hf. generalize (Hrec f Hf); clear Hrec. case (partition f l); intros s1 s2; simpl; intros. - case (f x); simpl; firstorder; inversion H0; intros; firstorder. + case (f x); simpl; firstorder; inversion H0; intros; firstorder. Qed. - + Lemma partition_2 : forall (s : t) (f : elt -> bool), compat_bool X.eq f -> @@ -681,14 +681,14 @@ Module Raw (X: DecidableType). Proof. simple induction s; simpl; auto; unfold Equal. firstorder. - intros x l Hrec f Hf. + intros x l Hrec f Hf. generalize (Hrec f Hf); clear Hrec. case (partition f l); intros s1 s2; simpl; intros. - case (f x); simpl; firstorder; inversion H0; intros; firstorder. + case (f x); simpl; firstorder; inversion H0; intros; firstorder. Qed. - Lemma partition_aux_1 : - forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), + Lemma partition_aux_1 : + forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), In x (fst (partition f s)) -> In x s. Proof. induction s; simpl; auto; intros. @@ -696,10 +696,10 @@ Module Raw (X: DecidableType). generalize (IHs H1 f x). destruct (f a); destruct (partition f s); simpl in *; auto. inversion_clear H; auto. - Qed. - - Lemma partition_aux_2 : - forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), + Qed. + + Lemma partition_aux_2 : + forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), In x (snd (partition f s)) -> In x s. Proof. induction s; simpl; auto; intros. @@ -707,8 +707,8 @@ Module Raw (X: DecidableType). generalize (IHs H1 f x). destruct (f a); destruct (partition f s); simpl in *; auto. inversion_clear H; auto. - Qed. - + Qed. + Lemma partition_unique_1 : forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (fst (partition f s)). Proof. @@ -719,7 +719,7 @@ Module Raw (X: DecidableType). generalize (Hrec H0 f). case (f x); case (partition f l); simpl; auto. Qed. - + Lemma partition_unique_2 : forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (snd (partition f s)). Proof. @@ -733,17 +733,17 @@ Module Raw (X: DecidableType). Definition eq : t -> t -> Prop := Equal. - Lemma eq_refl : forall s, eq s s. + Lemma eq_refl : forall s, eq s s. Proof. firstorder. Qed. Lemma eq_sym : forall s s', eq s s' -> eq s' s. Proof. firstorder. Qed. - Lemma eq_trans : + Lemma eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. Proof. firstorder. Qed. - Definition eq_dec : forall (s s':t)(Hs:NoDup s)(Hs':NoDup s'), + Definition eq_dec : forall (s s':t)(Hs:NoDup s)(Hs':NoDup s'), { eq s s' }+{ ~eq s s' }. Proof. intros. @@ -758,18 +758,18 @@ End Raw. (** * Encapsulation - Now, in order to really provide a functor implementing [S], we + Now, in order to really provide a functor implementing [S], we need to encapsulate everything into a type of lists without redundancy. *) Module Make (X: DecidableType) <: WS with Module E := X. - Module Raw := Raw X. + Module Raw := Raw X. Module E := X. Record slist := {this :> Raw.t; unique : NoDupA E.eq this}. - Definition t := slist. + Definition t := slist. Definition elt := E.t. - + Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this). Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. @@ -783,18 +783,18 @@ Module Make (X: DecidableType) <: WS with Module E := X. Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_unique (unique s) x). Definition singleton (x : elt) : t := Build_slist (Raw.singleton_unique x). Definition union (s s' : t) : t := - Build_slist (Raw.union_unique (unique s) (unique s')). + Build_slist (Raw.union_unique (unique s) (unique s')). Definition inter (s s' : t) : t := - Build_slist (Raw.inter_unique (unique s) (unique s')). + Build_slist (Raw.inter_unique (unique s) (unique s')). Definition diff (s s' : t) : t := - Build_slist (Raw.diff_unique (unique s) (unique s')). - Definition equal (s s' : t) : bool := Raw.equal s s'. + Build_slist (Raw.diff_unique (unique s) (unique s')). + Definition equal (s s' : t) : bool := Raw.equal s s'. Definition subset (s s' : t) : bool := Raw.subset s s'. Definition empty : t := Build_slist Raw.empty_unique. Definition is_empty (s : t) : bool := Raw.is_empty s. Definition elements (s : t) : list elt := Raw.elements s. Definition choose (s:t) : option elt := Raw.choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. + Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. Definition cardinal (s : t) : nat := Raw.cardinal s. Definition filter (f : elt -> bool) (s : t) : t := Build_slist (Raw.filter_unique (unique s) f). @@ -805,18 +805,18 @@ Module Make (X: DecidableType) <: WS with Module E := X. (Build_slist (this:=fst p) (Raw.partition_unique_1 (unique s) f), Build_slist (this:=snd p) (Raw.partition_unique_2 (unique s) f)). - Section Spec. + Section Spec. Variable s s' : t. Variable x y : elt. - Lemma In_1 : E.eq x y -> In x s -> In y s. + Lemma In_1 : E.eq x y -> In x s -> In y s. Proof. exact (fun H H' => Raw.In_eq H H'). Qed. - + Lemma mem_1 : In x s -> mem x s = true. Proof. exact (fun H => Raw.mem_1 H). Qed. - Lemma mem_2 : mem x s = true -> In x s. + Lemma mem_2 : mem x s = true -> In x s. Proof. exact (fun H => Raw.mem_2 H). Qed. - + Lemma equal_1 : Equal s s' -> equal s s' = true. Proof. exact (Raw.equal_1 s.(unique) s'.(unique)). Qed. Lemma equal_2 : equal s s' = true -> Equal s s'. @@ -830,16 +830,16 @@ Module Make (X: DecidableType) <: WS with Module E := X. Lemma empty_1 : Empty empty. Proof. exact Raw.empty_1. Qed. - Lemma is_empty_1 : Empty s -> is_empty s = true. + Lemma is_empty_1 : Empty s -> is_empty s = true. Proof. exact (fun H => Raw.is_empty_1 H). Qed. Lemma is_empty_2 : is_empty s = true -> Empty s. Proof. exact (fun H => Raw.is_empty_2 H). Qed. - + Lemma add_1 : E.eq x y -> In y (add x s). Proof. exact (fun H => Raw.add_1 s.(unique) H). Qed. Lemma add_2 : In y s -> In y (add x s). Proof. exact (fun H => Raw.add_2 s.(unique) x H). Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. Proof. exact (fun H => Raw.add_3 s.(unique) H). Qed. Lemma remove_1 : E.eq x y -> ~ In y (remove x s). @@ -849,14 +849,14 @@ Module Make (X: DecidableType) <: WS with Module E := X. Lemma remove_3 : In y (remove x s) -> In y s. Proof. exact (fun H => Raw.remove_3 s.(unique) H). Qed. - Lemma singleton_1 : In y (singleton x) -> E.eq x y. + Lemma singleton_1 : In y (singleton x) -> E.eq x y. Proof. exact (fun H => Raw.singleton_1 H). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). + Lemma singleton_2 : E.eq x y -> In y (singleton x). Proof. exact (fun H => Raw.singleton_2 H). Qed. Lemma union_1 : In x (union s s') -> In x s \/ In x s'. Proof. exact (fun H => Raw.union_1 s.(unique) s'.(unique) H). Qed. - Lemma union_2 : In x s -> In x (union s s'). + Lemma union_2 : In x s -> In x (union s s'). Proof. exact (fun H => Raw.union_2 s.(unique) s'.(unique) H). Qed. Lemma union_3 : In x s' -> In x (union s s'). Proof. exact (fun H => Raw.union_3 s.(unique) s'.(unique) H). Qed. @@ -868,13 +868,13 @@ Module Make (X: DecidableType) <: WS with Module E := X. Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). Proof. exact (fun H => Raw.inter_3 s.(unique) s'.(unique) H). Qed. - Lemma diff_1 : In x (diff s s') -> In x s. + Lemma diff_1 : In x (diff s s') -> In x s. Proof. exact (fun H => Raw.diff_1 s.(unique) s'.(unique) H). Qed. Lemma diff_2 : In x (diff s s') -> ~ In x s'. Proof. exact (fun H => Raw.diff_2 s.(unique) s'.(unique) H). Qed. Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). Proof. exact (fun H => Raw.diff_3 s.(unique) s'.(unique) H). Qed. - + Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. exact (Raw.fold_1 s.(unique)). Qed. @@ -883,12 +883,12 @@ Module Make (X: DecidableType) <: WS with Module E := X. Proof. exact (Raw.cardinal_1 s.(unique)). Qed. Section Filter. - + Variable f : elt -> bool. - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. Proof. exact (fun H => @Raw.filter_1 s x f). Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. + Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. Proof. exact (@Raw.filter_2 s x f). Qed. Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). @@ -938,20 +938,20 @@ Module Make (X: DecidableType) <: WS with Module E := X. Definition eq : t -> t -> Prop := Equal. - Lemma eq_refl : forall s, eq s s. + Lemma eq_refl : forall s, eq s s. Proof. firstorder. Qed. Lemma eq_sym : forall s s', eq s s' -> eq s' s. Proof. firstorder. Qed. - Lemma eq_trans : + Lemma eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. Proof. firstorder. Qed. - Definition eq_dec : forall (s s':t), + Definition eq_dec : forall (s s':t), { eq s s' }+{ ~eq s s' }. - Proof. - intros s s'; exact (Raw.eq_dec s.(unique) s'.(unique)). + Proof. + intros s s'; exact (Raw.eq_dec s.(unique) s'.(unique)). Defined. End Make. diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v index 8c4c6818ac..4e5d39faf2 100644 --- a/theories/FSets/OrderedType.v +++ b/theories/FSets/OrderedType.v @@ -69,22 +69,22 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_antirefl : forall x, ~ lt x x. Proof. - intros; intro; absurd (eq x x); auto. + intros; intro; absurd (eq x x); auto. Qed. Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. - Proof. + Proof. intros; destruct (compare x z); auto. elim (lt_not_eq H); apply eq_trans with z; auto. elim (lt_not_eq (lt_trans l H)); auto. - Qed. + Qed. - Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. + Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. Proof. intros; destruct (compare x z); auto. elim (lt_not_eq H0); apply eq_trans with x; auto. elim (lt_not_eq (lt_trans H0 l)); auto. - Qed. + Qed. Lemma le_eq : forall x y z, ~lt x y -> eq y z -> ~lt x z. Proof. @@ -125,23 +125,23 @@ Module OrderedTypeFacts (Import O: OrderedType). Qed. Lemma le_neq : forall x y, ~lt x y -> ~eq x y -> lt y x. - Proof. + Proof. intros; destruct (compare x y); intuition. Qed. Lemma neq_sym : forall x y, ~eq x y -> ~eq y x. - Proof. + Proof. intuition. Qed. -(* TODO concernant la tactique order: +(* TODO concernant la tactique order: * propagate_lt n'est sans doute pas complet * un propagate_le * exploiter les hypotheses negatives restant a la fin * faire que ca marche meme quand une hypothese depend d'un eq ou lt. -*) +*) -Ltac abstraction := match goal with +Ltac abstraction := match goal with (* First, some obvious simplifications *) | H : False |- _ => elim H | H : lt ?x ?x |- _ => elim (lt_antirefl H) @@ -151,43 +151,43 @@ Ltac abstraction := match goal with | |- eq ?x ?x => exact (eq_refl x) | |- lt ?x ?x => elimtype False; abstraction | |- ~ _ => intro; abstraction - | H1: ~lt ?x ?y, H2: ~eq ?x ?y |- _ => + | H1: ~lt ?x ?y, H2: ~eq ?x ?y |- _ => generalize (le_neq H1 H2); clear H1 H2; intro; abstraction - | H1: ~lt ?x ?y, H2: ~eq ?y ?x |- _ => + | H1: ~lt ?x ?y, H2: ~eq ?y ?x |- _ => generalize (le_neq H1 (neq_sym H2)); clear H1 H2; intro; abstraction (* Then, we generalize all interesting facts *) | H : ~eq ?x ?y |- _ => revert H; abstraction - | H : ~lt ?x ?y |- _ => revert H; abstraction + | H : ~lt ?x ?y |- _ => revert H; abstraction | H : lt ?x ?y |- _ => revert H; abstraction | H : eq ?x ?y |- _ => revert H; abstraction | _ => idtac end. -Ltac do_eq a b EQ := match goal with - | |- lt ?x ?y -> _ => let H := fresh "H" in - (intro H; +Ltac do_eq a b EQ := match goal with + | |- lt ?x ?y -> _ => let H := fresh "H" in + (intro H; (generalize (eq_lt (eq_sym EQ) H); clear H; intro H) || - (generalize (lt_eq H EQ); clear H; intro H) || - idtac); + (generalize (lt_eq H EQ); clear H; intro H) || + idtac); do_eq a b EQ - | |- ~lt ?x ?y -> _ => let H := fresh "H" in - (intro H; + | |- ~lt ?x ?y -> _ => let H := fresh "H" in + (intro H; (generalize (eq_le (eq_sym EQ) H); clear H; intro H) || - (generalize (le_eq H EQ); clear H; intro H) || - idtac); - do_eq a b EQ - | |- eq ?x ?y -> _ => let H := fresh "H" in - (intro H; + (generalize (le_eq H EQ); clear H; intro H) || + idtac); + do_eq a b EQ + | |- eq ?x ?y -> _ => let H := fresh "H" in + (intro H; (generalize (eq_trans (eq_sym EQ) H); clear H; intro H) || - (generalize (eq_trans H EQ); clear H; intro H) || - idtac); - do_eq a b EQ - | |- ~eq ?x ?y -> _ => let H := fresh "H" in - (intro H; + (generalize (eq_trans H EQ); clear H; intro H) || + idtac); + do_eq a b EQ + | |- ~eq ?x ?y -> _ => let H := fresh "H" in + (intro H; (generalize (eq_neq (eq_sym EQ) H); clear H; intro H) || - (generalize (neq_eq H EQ); clear H; intro H) || - idtac); - do_eq a b EQ + (generalize (neq_eq H EQ); clear H; intro H) || + idtac); + do_eq a b EQ | |- lt a ?y => apply eq_lt with b; [exact EQ|] | |- lt ?y a => apply lt_eq with b; [|exact (eq_sym EQ)] | |- eq a ?y => apply eq_trans with b; [exact EQ|] @@ -195,27 +195,27 @@ Ltac do_eq a b EQ := match goal with | _ => idtac end. -Ltac propagate_eq := abstraction; clear; match goal with +Ltac propagate_eq := abstraction; clear; match goal with (* the abstraction tactic leaves equality facts in head position...*) - | |- eq ?a ?b -> _ => - let EQ := fresh "EQ" in (intro EQ; do_eq a b EQ; clear EQ); - propagate_eq + | |- eq ?a ?b -> _ => + let EQ := fresh "EQ" in (intro EQ; do_eq a b EQ; clear EQ); + propagate_eq | _ => idtac end. -Ltac do_lt x y LT := match goal with +Ltac do_lt x y LT := match goal with (* LT *) | |- lt x y -> _ => intros _; do_lt x y LT - | |- lt y ?z -> _ => let H := fresh "H" in + | |- lt y ?z -> _ => let H := fresh "H" in (intro H; generalize (lt_trans LT H); intro); do_lt x y LT - | |- lt ?z x -> _ => let H := fresh "H" in + | |- lt ?z x -> _ => let H := fresh "H" in (intro H; generalize (lt_trans H LT); intro); do_lt x y LT | |- lt _ _ -> _ => intro; do_lt x y LT (* GE *) | |- ~lt y x -> _ => intros _; do_lt x y LT - | |- ~lt x ?z -> _ => let H := fresh "H" in + | |- ~lt x ?z -> _ => let H := fresh "H" in (intro H; generalize (le_lt_trans H LT); intro); do_lt x y LT - | |- ~lt ?z y -> _ => let H := fresh "H" in + | |- ~lt ?z y -> _ => let H := fresh "H" in (intro H; generalize (lt_le_trans LT H); intro); do_lt x y LT | |- ~lt _ _ -> _ => intro; do_lt x y LT | _ => idtac @@ -223,21 +223,21 @@ Ltac do_lt x y LT := match goal with Definition hide_lt := lt. -Ltac propagate_lt := abstraction; match goal with +Ltac propagate_lt := abstraction; match goal with (* when no [=] remains, the abstraction tactic leaves [<] facts first. *) - | |- lt ?x ?y -> _ => - let LT := fresh "LT" in (intro LT; do_lt x y LT; - change (hide_lt x y) in LT); - propagate_lt + | |- lt ?x ?y -> _ => + let LT := fresh "LT" in (intro LT; do_lt x y LT; + change (hide_lt x y) in LT); + propagate_lt | _ => unfold hide_lt in * end. -Ltac order := - intros; - propagate_eq; - propagate_lt; - auto; - propagate_lt; +Ltac order := + intros; + propagate_eq; + propagate_lt; + auto; + propagate_lt; eauto. Ltac false_order := elimtype False; order. @@ -245,22 +245,22 @@ Ltac false_order := elimtype False; order. Lemma gt_not_eq : forall x y, lt y x -> ~ eq x y. Proof. order. - Qed. - + Qed. + Lemma eq_not_lt : forall x y : t, eq x y -> ~ lt x y. - Proof. + Proof. order. Qed. Hint Resolve gt_not_eq eq_not_lt. Lemma eq_not_gt : forall x y : t, eq x y -> ~ lt y x. - Proof. + Proof. order. Qed. Lemma lt_not_gt : forall x y : t, lt x y -> ~ lt y x. - Proof. + Proof. order. Qed. @@ -269,44 +269,44 @@ Ltac false_order := elimtype False; order. Lemma elim_compare_eq : forall x y : t, eq x y -> exists H : eq x y, compare x y = EQ _ H. - Proof. + Proof. intros; case (compare x y); intros H'; try solve [false_order]. - exists H'; auto. + exists H'; auto. Qed. Lemma elim_compare_lt : forall x y : t, lt x y -> exists H : lt x y, compare x y = LT _ H. - Proof. + Proof. intros; case (compare x y); intros H'; try solve [false_order]. - exists H'; auto. + exists H'; auto. Qed. Lemma elim_compare_gt : forall x y : t, lt y x -> exists H : lt y x, compare x y = GT _ H. - Proof. + Proof. intros; case (compare x y); intros H'; try solve [false_order]. - exists H'; auto. + exists H'; auto. Qed. - Ltac elim_comp := - match goal with - | |- ?e => match e with + Ltac elim_comp := + match goal with + | |- ?e => match e with | context ctx [ compare ?a ?b ] => - let H := fresh in - (destruct (compare a b) as [H|H|H]; + let H := fresh in + (destruct (compare a b) as [H|H|H]; try solve [ intros; false_order]) end end. Ltac elim_comp_eq x y := elim (elim_compare_eq (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. Ltac elim_comp_lt x y := elim (elim_compare_lt (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. + [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. Ltac elim_comp_gt x y := elim (elim_compare_gt (x:=x) (y:=y)); @@ -314,7 +314,7 @@ Ltac false_order := elimtype False; order. (** For compatibility reasons *) Definition eq_dec := eq_dec. - + Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. Proof. intros; elim (compare x y); [ left | right | right ]; auto. @@ -322,8 +322,8 @@ Ltac false_order := elimtype False; order. Definition eqb x y : bool := if eq_dec x y then true else false. - Lemma eqb_alt : - forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. + Lemma eqb_alt : + forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. Proof. unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto. Qed. @@ -345,20 +345,20 @@ Proof. exact (In_InA eq_refl). Qed. Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. Proof. exact (InfA_ltA lt_trans). Qed. - + Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. Proof. exact (InfA_eqA eq_lt). Qed. Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. Proof. exact (SortA_InfA_InA eq_refl eq_sym lt_trans lt_eq eq_lt). Qed. - + Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. Proof. exact (@In_InfA t lt). Qed. Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. Proof. exact (InA_InfA eq_refl (ltA:=lt)). Qed. -Lemma Inf_alt : +Lemma Inf_alt : forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). Proof. exact (InfA_alt eq_refl eq_sym lt_trans lt_eq eq_lt). Qed. @@ -367,8 +367,8 @@ Proof. exact (SortA_NoDupA eq_refl eq_sym lt_trans lt_not_eq lt_eq eq_lt) . Qed. End ForNotations. -Hint Resolve ListIn_In Sort_NoDup Inf_lt. -Hint Immediate In_eq Inf_lt. +Hint Resolve ListIn_In Sort_NoDup Inf_lt. +Hint Immediate In_eq Inf_lt. End OrderedTypeFacts. @@ -382,7 +382,7 @@ Module KeyOrderedType(O:OrderedType). Notation key:=t. Definition eqk (p p':key*elt) := eq (fst p) (fst p'). - Definition eqke (p p':key*elt) := + Definition eqke (p p':key*elt) := eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition ltk (p p':key*elt) := lt (fst p) (fst p'). @@ -390,7 +390,7 @@ Module KeyOrderedType(O:OrderedType). Hint Extern 2 (eqke ?a ?b) => split. (* eqke is stricter than eqk *) - + Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. Proof. unfold eqk, eqke; intuition. @@ -406,7 +406,7 @@ Module KeyOrderedType(O:OrderedType). Hint Immediate ltk_right_r ltk_right_l. (* eqk, eqke are equalities, ltk is a strict order *) - + Lemma eqk_refl : forall e, eqk e e. Proof. auto. Qed. @@ -431,7 +431,7 @@ Module KeyOrderedType(O:OrderedType). Proof. eauto. Qed. Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. - Proof. unfold eqk, ltk; auto. Qed. + Proof. unfold eqk, ltk; auto. Qed. Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. Proof. @@ -458,10 +458,10 @@ Module KeyOrderedType(O:OrderedType). intros (k,e) (k',e') (k'',e''). unfold ltk, eqk; simpl; eauto. Qed. - Hint Resolve eqk_not_ltk. + Hint Resolve eqk_not_ltk. Hint Immediate ltk_eqk eqk_ltk. - Lemma InA_eqke_eqk : + Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. unfold eqke; induction 1; intuition. @@ -496,7 +496,7 @@ Module KeyOrderedType(O:OrderedType). Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. Proof. destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. - Qed. + Qed. Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_eqA eqk_ltk). Qed. @@ -507,13 +507,13 @@ Module KeyOrderedType(O:OrderedType). Hint Immediate Inf_eq. Hint Resolve Inf_lt. - Lemma Sort_Inf_In : + Lemma Sort_Inf_In : forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. - Proof. + Proof. exact (SortA_InfA_InA eqk_refl eqk_sym ltk_trans ltk_eqk eqk_ltk). Qed. - Lemma Sort_Inf_NotIn : + Lemma Sort_Inf_NotIn : forall l k e, Sort l -> Inf (k,e) l -> ~In k l. Proof. intros; red; intros. @@ -524,7 +524,7 @@ Module KeyOrderedType(O:OrderedType). Qed. Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. - Proof. + Proof. exact (SortA_NoDupA eqk_refl eqk_sym ltk_trans ltk_not_eqk ltk_eqk eqk_ltk). Qed. @@ -540,7 +540,7 @@ Module KeyOrderedType(O:OrderedType). left; apply Sort_In_cons_1 with l; auto. Qed. - Lemma Sort_In_cons_3 : + Lemma Sort_In_cons_3 : forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. Proof. inversion_clear 1; red; intros. @@ -552,15 +552,15 @@ Module KeyOrderedType(O:OrderedType). inversion 1. inversion_clear H0; eauto. destruct H1; simpl in *; intuition. - Qed. + Qed. - Lemma In_inv_2 : forall k k' e e' l, + Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. + Proof. inversion_clear 1; compute in H0; intuition. Qed. - Lemma In_inv_3 : forall x x' l, + Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. inversion_clear 1; compute in H0; intuition. @@ -573,7 +573,7 @@ Module KeyOrderedType(O:OrderedType). Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. Hint Immediate eqk_sym eqke_sym. - Hint Resolve eqk_not_ltk. + Hint Resolve eqk_not_ltk. Hint Immediate ltk_eqk eqk_ltk. Hint Resolve InA_eqke_eqk. Hint Unfold MapsTo In. diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/FSets/OrderedTypeAlt.v index 95c9c31a91..3a9fa1a734 100644 --- a/theories/FSets/OrderedTypeAlt.v +++ b/theories/FSets/OrderedTypeAlt.v @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre +(* Finite sets library. + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) @@ -19,23 +19,23 @@ Require Import OrderedType. inferface. *) (** NB: [comparison], defined in [Datatypes.v] is [Eq|Lt|Gt] -whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ] +whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ] *) Module Type OrderedTypeAlt. Parameter t : Type. - + Parameter compare : t -> t -> comparison. Infix "?=" := compare (at level 70, no associativity). - Parameter compare_sym : + Parameter compare_sym : forall x y, (y?=x) = CompOpp (x?=y). - Parameter compare_trans : + Parameter compare_trans : forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. -End OrderedTypeAlt. +End OrderedTypeAlt. (** From this new presentation to the original one. *) @@ -56,7 +56,7 @@ Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. Qed. Lemma eq_sym : forall x y, eq x y -> eq y x. - Proof. + Proof. unfold eq; intros. rewrite compare_sym. rewrite H; simpl; auto. @@ -88,7 +88,7 @@ Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. case (x ?= y); [ left | right | right ]; auto; discriminate. Defined. -End OrderedType_from_Alt. +End OrderedType_from_Alt. (** From the original presentation to this alternative one. *) @@ -99,30 +99,30 @@ Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt. Definition t := t. - Definition compare x y := match compare x y with + Definition compare x y := match compare x y with | LT _ => Lt | EQ _ => Eq | GT _ => Gt - end. + end. Infix "?=" := compare (at level 70, no associativity). - Lemma compare_sym : + Lemma compare_sym : forall x y, (y?=x) = CompOpp (x?=y). Proof. intros x y; unfold compare. destruct O.compare; elim_comp; simpl; auto. Qed. - - Lemma compare_trans : + + Lemma compare_trans : forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. Proof. intros c x y z. - destruct c; unfold compare; - do 2 (destruct O.compare; intros; try discriminate); + destruct c; unfold compare; + do 2 (destruct O.compare; intros; try discriminate); elim_comp; auto. Qed. End OrderedType_to_Alt. - + diff --git a/theories/FSets/OrderedTypeEx.v b/theories/FSets/OrderedTypeEx.v index e6312a1470..e76cead2dd 100644 --- a/theories/FSets/OrderedTypeEx.v +++ b/theories/FSets/OrderedTypeEx.v @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre +(* Finite sets library. + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) @@ -21,7 +21,7 @@ Require Import Compare_dec. (** * Examples of Ordered Type structures. *) -(** First, a particular case of [OrderedType] where +(** First, a particular case of [OrderedType] where the equality is the usual one of Coq. *) Module Type UsualOrderedType. @@ -80,7 +80,7 @@ Open Local Scope Z_scope. Module Z_as_OT <: UsualOrderedType. Definition t := Z. - Definition eq := @eq Z. + Definition eq := @eq Z. Definition eq_refl := @refl_equal t. Definition eq_sym := @sym_eq t. Definition eq_trans := @trans_eq t. @@ -105,7 +105,7 @@ Module Z_as_OT <: UsualOrderedType. End Z_as_OT. -(** [positive] is an ordered type with respect to the usual order on natural numbers. *) +(** [positive] is an ordered type with respect to the usual order on natural numbers. *) Open Local Scope positive_scope. @@ -117,9 +117,9 @@ Module Positive_as_OT <: UsualOrderedType. Definition eq_trans := @trans_eq t. Definition lt p q:= (p ?= q) Eq = Lt. - + Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. + Proof. unfold lt; intros x y z. change ((Zpos x < Zpos y)%Z -> (Zpos y < Zpos z)%Z -> (Zpos x < Zpos z)%Z). omega. @@ -149,7 +149,7 @@ Module Positive_as_OT <: UsualOrderedType. End Positive_as_OT. -(** [N] is an ordered type with respect to the usual order on natural numbers. *) +(** [N] is an ordered type with respect to the usual order on natural numbers. *) Open Local Scope positive_scope. @@ -180,7 +180,7 @@ Module N_as_OT <: UsualOrderedType. End N_as_OT. -(** From two ordered types, we can build a new OrderedType +(** From two ordered types, we can build a new OrderedType over their cartesian product, using the lexicographic order. *) Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. @@ -188,29 +188,29 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. Module MO2:=OrderedTypeFacts(O2). Definition t := prod O1.t O2.t. - + Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y). - Definition lt x y := - O1.lt (fst x) (fst y) \/ + Definition lt x y := + O1.lt (fst x) (fst y) \/ (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)). Lemma eq_refl : forall x : t, eq x x. - Proof. + Proof. intros (x1,x2); red; simpl; auto. Qed. Lemma eq_sym : forall x y : t, eq x y -> eq y x. - Proof. + Proof. intros (x1,x2) (y1,y2); unfold eq; simpl; intuition. Qed. Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - Proof. + Proof. intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. Qed. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. + + Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Proof. intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition. left; eauto. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 147d1e8d34..8d790d1fd7 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -98,7 +98,7 @@ Defined. (** [nat] is the datatype of natural numbers built from [O] and successor [S]; note that the constructor name is the letter O. - Numbers in [nat] can be denoted using a decimal notation; + Numbers in [nat] can be denoted using a decimal notation; e.g. [3%nat] abbreviates [S (S (S O))] *) Inductive nat : Set := @@ -166,7 +166,7 @@ Section projections. Definition snd (p:A * B) := match p with | (x, y) => y end. -End projections. +End projections. Hint Resolve pair inl inr: core. @@ -181,13 +181,13 @@ Lemma injective_projections : fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2. Proof. destruct p1; destruct p2; simpl in |- *; intros Hfst Hsnd. - rewrite Hfst; rewrite Hsnd; reflexivity. + rewrite Hfst; rewrite Hsnd; reflexivity. Qed. -Definition prod_uncurry (A B C:Type) (f:prod A B -> C) +Definition prod_uncurry (A B C:Type) (f:prod A B -> C) (x:A) (y:B) : C := f (pair x y). -Definition prod_curry (A B C:Type) (f:A -> B -> C) +Definition prod_curry (A B C:Type) (f:A -> B -> C) (p:prod A B) : C := match p with | pair x y => f x y end. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index bdec651da3..1333f3545e 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -28,7 +28,7 @@ Section identity_is_a_congruence. Variable f : A -> B. Variables x y z : A. - + Lemma identity_sym : identity x y -> identity y x. Proof. destruct 1; trivial. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 2244e1b9a9..748229b176 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -18,9 +18,9 @@ Require Import Logic. (** Subsets and Sigma-types *) -(** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset +(** [(sig A P)], or more suggestively [{x:A | P x}], denotes the subset of elements of the type [A] which satisfy the predicate [P]. - Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset + Similarly [(sig2 A P Q)], or [{x:A | P x & Q x}], denotes the subset of elements of the type [A] which satisfy both [P] and [Q]. *) Inductive sig (A:Type) (P:A -> Prop) : Type := @@ -29,7 +29,7 @@ Inductive sig (A:Type) (P:A -> Prop) : Type := Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := exist2 : forall x:A, P x -> Q x -> sig2 P Q. -(** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. +(** [(sigT A P)], or more suggestively [{x:A & (P x)}] is a Sigma-type. Similarly for [(sigT2 A P Q)], also written [{x:A & (P x) & (Q x)}]. *) Inductive sigT (A:Type) (P:A -> Type) : Type := @@ -123,7 +123,7 @@ Coercion sig_of_sigT : sigT >-> sig. Inductive sumbool (A B:Prop) : Set := | left : A -> {A} + {B} - | right : B -> {A} + {B} + | right : B -> {A} + {B} where "{ A } + { B }" := (sumbool A B) : type_scope. Add Printing If sumbool. @@ -133,7 +133,7 @@ Add Printing If sumbool. Inductive sumor (A:Type) (B:Prop) : Type := | inleft : A -> A + {B} - | inright : B -> A + {B} + | inright : B -> A + {B} where "A + { B }" := (sumor A B) : type_scope. Add Printing If sumor. @@ -186,12 +186,12 @@ Section Choice_lemmas. End Choice_lemmas. - (** A result of type [(Exc A)] is either a normal value of type [A] or + (** A result of type [(Exc A)] is either a normal value of type [A] or an [error] : [Inductive Exc [A:Type] : Type := value : A->(Exc A) | error : (Exc A)]. - It is implemented using the option type. *) + It is implemented using the option type. *) Definition Exc := option. Definition value := Some. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 39cd268d9b..0d36d40e35 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -14,38 +14,38 @@ Require Import Specif. (** * Useful tactics *) -(** A tactic for proof by contradiction. With contradict H, +(** A tactic for proof by contradiction. With contradict H, - H:~A |- B gives |- A - H:~A |- ~B gives H: B |- A - H: A |- B gives |- ~A - H: A |- ~B gives H: B |- ~A - H:False leads to a resolved subgoal. - Moreover, negations may be in unfolded forms, + Moreover, negations may be in unfolded forms, and A or B may live in Type *) Ltac contradict H := let save tac H := let x:=fresh in intro x; tac H; rename x into H - in - let negpos H := case H; clear H - in + in + let negpos H := case H; clear H + in let negneg H := save negpos H in - let pospos H := + let pospos H := let A := type of H in (elimtype False; revert H; try fold (~A)) in let posneg H := save pospos H - in - let neg H := match goal with + in + let neg H := match goal with | |- (~_) => negneg H | |- (_->False) => negneg H | |- _ => negpos H - end in - let pos H := match goal with + end in + let pos H := match goal with | |- (~_) => posneg H | |- (_->False) => posneg H | |- _ => pospos H end in - match type of H with + match type of H with | (~_) => neg H | (_->False) => neg H | _ => (elim H;fail) || pos H @@ -53,20 +53,20 @@ Ltac contradict H := (* Transforming a negative goal [ H:~A |- ~B ] into a positive one [ B |- A ]*) -Ltac swap H := +Ltac swap H := idtac "swap is OBSOLETE: use contradict instead."; intro; apply H; clear H. (* To contradict an hypothesis without copying its type. *) -Ltac absurd_hyp H := +Ltac absurd_hyp H := idtac "absurd_hyp is OBSOLETE: use contradict instead."; - let T := type of H in + let T := type of H in absurd T. (* A useful complement to contradict. Here H:A while G allows to conclude ~A *) -Ltac false_hyp H G := +Ltac false_hyp H G := let T := type of H in absurd T; [ apply G | assumption ]. (* A case with no loss of information. *) @@ -77,11 +77,11 @@ Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x. Tactic Notation "destruct_with_eqn" constr(x) := destruct x as []_eqn. -Tactic Notation "destruct_with_eqn" ident(n) := +Tactic Notation "destruct_with_eqn" ident(n) := try intros until n; destruct n as []_eqn. Tactic Notation "destruct_with_eqn" ":" ident(H) constr(x) := destruct x as []_eqn:H. -Tactic Notation "destruct_with_eqn" ":" ident(H) ident(n) := +Tactic Notation "destruct_with_eqn" ":" ident(H) ident(n) := try intros until n; destruct n as []_eqn:H. (* Rewriting in all hypothesis several times everywhere *) @@ -181,7 +181,7 @@ Ltac now_show c := change c. Set Implicit Arguments. -Lemma decide_left : forall (C:Prop) (decide:{C}+{~C}), +Lemma decide_left : forall (C:Prop) (decide:{C}+{~C}), C -> forall P:{C}+{~C}->Prop, (forall H:C, P (left _ H)) -> P decide. Proof. intros; destruct decide. apply H0. contradiction. @@ -194,8 +194,8 @@ intros; destruct decide. contradiction. apply H0. Qed. Tactic Notation "decide" constr(lemma) "with" constr(H) := - let try_to_merge_hyps H := - try (clear H; intro H) || + let try_to_merge_hyps H := + try (clear H; intro H) || (let H' := fresh H "bis" in intro H'; try clear H') || (let H' := fresh in intro H'; try clear H') in match type of H with diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index 2d35a4b237..f1baf71a7f 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -65,7 +65,7 @@ Section Well_founded. exact (fun P:A -> Prop => well_founded_induction_type P). Defined. -(** Well-founded fixpoints *) +(** Well-founded fixpoints *) Section FixPoint. @@ -80,13 +80,13 @@ Section Well_founded. Lemma Fix_F_eq : forall (x:A) (r:Acc x), F (fun (y:A) (p:R y x) => Fix_F (x:=y) (Acc_inv r p)) = Fix_F (x:=x) r. - Proof. + Proof. destruct r using Acc_inv_dep; auto. Qed. Definition Fix (x:A) := Fix_F (Rwf x). - (** Proof that [well_founded_induction] satisfies the fixpoint equation. + (** Proof that [well_founded_induction] satisfies the fixpoint equation. It requires an extra property of the functional *) Hypothesis @@ -111,7 +111,7 @@ Section Well_founded. End FixPoint. -End Well_founded. +End Well_founded. (** Well-founded fixpoints over pairs *) @@ -120,7 +120,7 @@ Section Well_founded_2. Variables A B : Type. Variable R : A * B -> A * B -> Prop. - Variable P : A -> B -> Type. + Variable P : A -> B -> Type. Section FixPoint_2. @@ -129,7 +129,7 @@ Section Well_founded_2. forall (x:A) (x':B), (forall (y:A) (y':B), R (y, y') (x, x') -> P y y') -> P x x'. - Fixpoint Fix_F_2 (x:A) (x':B) (a:Acc R (x, x')) {struct a} : + Fixpoint Fix_F_2 (x:A) (x':B) (a:Acc R (x, x')) {struct a} : P x x' := F (fun (y:A) (y':B) (h:R (y, y') (x, x')) => diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 9add5f48d4..f2961635ec 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -42,7 +42,7 @@ Section Lists. match l with | nil => default | x :: _ => x - end. + end. Definition tail (l:list) : list := match l with @@ -71,9 +71,9 @@ Section Lists. | nil => m | a :: l1 => a :: app l1 m end. - + Infix "++" := app (right associativity, at level 60) : list_scope. - + End Lists. (** Exporting list notations and tactics *) @@ -101,7 +101,7 @@ Section Facts. (** Discrimination *) Theorem nil_cons : forall (x:A) (l:list A), nil <> x :: l. - Proof. + Proof. intros; discriminate. Qed. @@ -114,9 +114,9 @@ Section Facts. right; reflexivity. left; exists a; exists tl; reflexivity. Qed. - + (** *** Head and tail *) - + Theorem head_nil : head (@nil A) = None. Proof. simpl; reflexivity. @@ -129,19 +129,19 @@ Section Facts. (************************) - (** *** Facts about [In] *) + (** *** Facts about [In] *) (************************) (** Characterization of [In] *) - + Theorem in_eq : forall (a:A) (l:list A), In a (a :: l). - Proof. + Proof. simpl in |- *; auto. Qed. - + Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l). - Proof. + Proof. simpl in |- *; auto. Qed. @@ -173,7 +173,7 @@ Section Facts. intro H; induction l as [| a0 l IHl]. right; apply in_nil. destruct (H a0 a); simpl in |- *; auto. - destruct IHl; simpl in |- *; auto. + destruct IHl; simpl in |- *; auto. right; unfold not in |- *; intros [Hc1| Hc2]; auto. Defined. @@ -199,7 +199,7 @@ Section Facts. Qed. Theorem app_nil_r : forall l:list A, l ++ nil = l. - Proof. + Proof. induction l; simpl; f_equal; auto. Qed. @@ -211,23 +211,23 @@ Section Facts. (** [app] is associative *) Theorem app_assoc : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n. - Proof. + Proof. intros l m n; induction l; simpl; f_equal; auto. Qed. Theorem app_assoc_reverse : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n. - Proof. + Proof. auto using app_assoc. Qed. Hint Resolve app_assoc_reverse. - (** [app] commutes with [cons] *) + (** [app] commutes with [cons] *) Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y. Proof. auto. Qed. - (** Facts deduced from the result of a concatenation *) + (** Facts deduced from the result of a concatenation *) Theorem app_eq_nil : forall l l':list A, l ++ l' = nil -> l = nil /\ l' = nil. Proof. @@ -261,7 +261,7 @@ Section Facts. forall (x y:list A) (a b:A), x ++ a :: nil = y ++ b :: nil -> x = y /\ a = b. Proof. induction x as [| x l IHl]; - [ destruct y as [| a l] | destruct y as [| a l0] ]; + [ destruct y as [| a l] | destruct y as [| a l0] ]; simpl in |- *; auto. intros a b H. injection H. @@ -276,7 +276,7 @@ Section Facts. generalize (app_cons_not_nil _ _ _ H2); destruct 1. intros a0 b H. injection H; intros. - destruct (IHl l0 a0 b H0). + destruct (IHl l0 a0 b H0). split; auto. rewrite <- H1; rewrite <- H2; reflexivity. Qed. @@ -290,7 +290,7 @@ Section Facts. Qed. Lemma in_app_or : forall (l m:list A) (a:A), In a (l ++ m) -> In a l \/ In a m. - Proof. + Proof. intros l m a. elim l; simpl in |- *; auto. intros a0 y H H0. @@ -302,7 +302,7 @@ Section Facts. Qed. Lemma in_or_app : forall (l m:list A) (a:A), In a l \/ In a m -> In a (l ++ m). - Proof. + Proof. intros l m a. elim l; simpl in |- *; intro H. now_show (In a m). @@ -327,12 +327,12 @@ Section Facts. Proof. induction l; simpl; auto; injection 1; auto. Qed. - + Lemma app_inv_tail: forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. Proof. intros l l1 l2; revert l1 l2 l. - induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2]; + induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2]; simpl; auto; intros l H. absurd (length (x2 :: l2 ++ l) <= length l). simpl; rewrite app_length; auto with arith. @@ -348,7 +348,7 @@ End Facts. Hint Resolve app_assoc app_assoc_reverse: datatypes v62. Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62. Hint Immediate app_eq_nil: datatypes v62. -Hint Resolve app_eq_unit app_inj_tail: datatypes v62. +Hint Resolve app_eq_unit app_inj_tail: datatypes v62. Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes v62. @@ -384,18 +384,18 @@ Section Elts. Lemma nth_in_or_default : forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}. (* Realizer nth_ok. Program_all. *) - Proof. + Proof. intros n l d; generalize n; induction l; intro n0. right; case n0; trivial. case n0; simpl in |- *. auto. - intro n1; elim (IHl n1); auto. + intro n1; elim (IHl n1); auto. Qed. Lemma nth_S_cons : forall (n:nat) (l:list A) (d a:A), In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l). - Proof. + Proof. simpl in |- *; auto. Qed. @@ -436,7 +436,7 @@ Section Elts. apply IHl; auto with arith. Qed. - Lemma nth_indep : + Lemma nth_indep : forall l n d d', n < length l -> nth n l d = nth n l d'. Proof. induction l; simpl; intros; auto. @@ -444,7 +444,7 @@ Section Elts. destruct n; simpl; auto with arith. Qed. - Lemma app_nth1 : + Lemma app_nth1 : forall l l' d n, n < length l -> nth n (l++l') d = nth n l d. Proof. induction l. @@ -455,7 +455,7 @@ Section Elts. intros; rewrite IHl; auto with arith. Qed. - Lemma app_nth2 : + Lemma app_nth2 : forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d. Proof. induction l. @@ -480,22 +480,22 @@ Section Elts. Section Remove. Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}. - + Fixpoint remove (x : A) (l : list A){struct l} : list A := match l with | nil => nil | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl) end. - + Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l). Proof. induction l as [|x l]; auto. - intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. + intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. apply IHl. unfold not; intro HF; simpl in HF; destruct HF; auto. - apply (IHl y); assumption. + apply (IHl y); assumption. Qed. - + End Remove. @@ -503,26 +503,26 @@ Section Elts. (** ** Last element of a list *) (******************************) - (** [last l d] returns the last element of the list [l], + (** [last l d] returns the last element of the list [l], or the default value [d] if [l] is empty. *) - Fixpoint last (l:list A) (d:A) {struct l} : A := - match l with - | nil => d - | a :: nil => a + Fixpoint last (l:list A) (d:A) {struct l} : A := + match l with + | nil => d + | a :: nil => a | a :: l => last l d end. (** [removelast l] remove the last element of [l] *) - Fixpoint removelast (l:list A) {struct l} : list A := - match l with - | nil => nil - | a :: nil => nil + Fixpoint removelast (l:list A) {struct l} : list A := + match l with + | nil => nil + | a :: nil => nil | a :: l => a :: removelast l end. - - Lemma app_removelast_last : + + Lemma app_removelast_last : forall l d, l<>nil -> l = removelast l ++ (last l d :: nil). Proof. induction l. @@ -531,10 +531,10 @@ Section Elts. destruct l; auto. pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate. Qed. - - Lemma exists_last : - forall l, l<>nil -> { l' : (list A) & { a : A | l = l'++a::nil}}. - Proof. + + Lemma exists_last : + forall l, l<>nil -> { l' : (list A) & { a : A | l = l'++a::nil}}. + Proof. induction l. destruct 1; auto. intros _. @@ -545,7 +545,7 @@ Section Elts. exists (a::l'); exists a'; auto. Qed. - Lemma removelast_app : + Lemma removelast_app : forall l l', l' <> nil -> removelast (l++l') = l ++ removelast l'. Proof. induction l. @@ -559,31 +559,31 @@ Section Elts. destruct (l++l'); [elim H0; auto|f_equal; auto]. Qed. - + (****************************************) (** ** Counting occurences of a element *) (****************************************) Hypotheses eqA_dec : forall x y : A, {x = y}+{x <> y}. - + Fixpoint count_occ (l : list A) (x : A){struct l} : nat := - match l with + match l with | nil => 0 - | y :: tl => - let n := count_occ tl x in + | y :: tl => + let n := count_occ tl x in if eqA_dec y x then S n else n end. - + (** Compatibility of count_occ with operations on list *) Theorem count_occ_In : forall (l : list A) (x : A), In x l <-> count_occ l x > 0. Proof. induction l as [|y l]. simpl; intros; split; [destruct 1 | apply gt_irrefl]. simpl. intro x; destruct (eqA_dec y x) as [Heq|Hneq]. - rewrite Heq; intuition. + rewrite Heq; intuition. pose (IHl x). intuition. Qed. - + Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = nil. Proof. split. @@ -600,7 +600,7 @@ Section Elts. (* Case <- *) intro H; rewrite H; simpl; reflexivity. Qed. - + Lemma count_occ_nil : forall (x : A), count_occ nil x = 0. Proof. intro x; simpl; reflexivity. @@ -611,11 +611,11 @@ Section Elts. intros l x y H; simpl. destruct (eqA_dec x y); [reflexivity | contradiction]. Qed. - + Lemma count_occ_cons_neq : forall (l : list A) (x y : A), x <> y -> count_occ (x::l) y = count_occ l y. Proof. intros l x y H; simpl. - destruct (eqA_dec x y); [contradiction | reflexivity]. + destruct (eqA_dec x y); [contradiction | reflexivity]. Qed. End Elts. @@ -697,7 +697,7 @@ Section ListOps. elim (length l); simpl; auto. Qed. - Lemma rev_nth : forall l d n, n < length l -> + Lemma rev_nth : forall l d n, n < length l -> nth n (rev l) d = nth (length l - S n) l d. Proof. induction l. @@ -720,11 +720,11 @@ Section ListOps. Qed. - (** An alternative tail-recursive definition for reverse *) + (** An alternative tail-recursive definition for reverse *) - Fixpoint rev_append (l l': list A) {struct l} : list A := - match l with - | nil => l' + Fixpoint rev_append (l l': list A) {struct l} : list A := + match l with + | nil => l' | a::l => rev_append l (a::l') end. @@ -750,11 +750,11 @@ Section ListOps. (*********************************************) (** Reverse Induction Principle on Lists *) (*********************************************) - + Section Reverse_Induction. - + Unset Implicit Arguments. - + Lemma rev_list_ind : forall P:list A-> Prop, P nil -> @@ -764,7 +764,7 @@ Section ListOps. induction l; auto. Qed. Set Implicit Arguments. - + Theorem rev_ind : forall P:list A -> Prop, P nil -> @@ -775,13 +775,13 @@ Section ListOps. intros E; rewrite <- E. apply (rev_list_ind P). auto. - + simpl in |- *. intros. apply (H0 a (rev l0)). auto. Qed. - + End Reverse_Induction. @@ -818,7 +818,7 @@ Section ListOps. Theorem Permutation_refl : forall l : list A, Permutation l l. Proof. - induction l; constructor. exact IHl. + induction l; constructor. exact IHl. Qed. Theorem Permutation_sym : forall l l' : list A, Permutation l l' -> Permutation l' l. @@ -838,7 +838,7 @@ Section ListOps. Theorem Permutation_in : forall (l l' : list A) (x : A), Permutation l l' -> In x l -> In x l'. Proof. - intros l l' x Hperm; induction Hperm; simpl; tauto. + intros l l' x Hperm; induction Hperm; simpl; tauto. Qed. Lemma Permutation_app_tail : forall (l l' tl : list A), Permutation l l' -> Permutation (l++tl) (l'++tl). @@ -863,7 +863,7 @@ Section ListOps. Theorem Permutation_app_swap : forall (l l' : list A), Permutation (l++l') (l'++l). Proof. - induction l as [|x l]. + induction l as [|x l]. simpl; intro l'; rewrite app_nil_r; trivial. induction l' as [|y l']. simpl; rewrite app_nil_r; trivial. @@ -872,7 +872,7 @@ Section ListOps. apply Permutation_trans with (l' := y :: x :: l' ++ l); constructor. apply Permutation_trans with (l' := x :: l ++ l'); auto. Qed. - + Theorem Permutation_cons_app : forall (l l1 l2:list A) a, Permutation l (l1 ++ l2) -> Permutation (a :: l) (l1 ++ a :: l2). Proof. @@ -895,7 +895,7 @@ Section ListOps. apply trans_eq with (y:= (length l')); trivial. Qed. - Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). + Theorem Permutation_rev : forall (l : list A), Permutation l (rev l). Proof. induction l as [| x l]; simpl; trivial. apply Permutation_trans with (l' := (x::nil)++rev l). @@ -903,7 +903,7 @@ Section ListOps. apply Permutation_app_swap. Qed. - Theorem Permutation_ind_bis : + Theorem Permutation_ind_bis : forall P : list A -> list A -> Prop, P (@nil A) (@nil A) -> (forall x l l', Permutation l l' -> P l l' -> P (x :: l) (x :: l')) -> @@ -922,14 +922,14 @@ Section ListOps. eauto. Qed. - Ltac break_list l x l' H := - destruct l as [|x l']; simpl in *; + Ltac break_list l x l' H := + destruct l as [|x l']; simpl in *; injection H; intros; subst; clear H. Theorem Permutation_app_inv : forall (l1 l2 l3 l4:list A) a, Permutation (l1++a::l2) (l3++a::l4) -> Permutation (l1++l2) (l3 ++ l4). Proof. - set (P:=fun l l' => + set (P:=fun l l' => forall a l1 l2 l3 l4, l=l1++a::l2 -> l'=l3++a::l4 -> Permutation (l1++l2) (l3++l4)). cut (forall l l', Permutation l l' -> P l l'). intros; apply (H _ _ H0 a); auto. @@ -951,10 +951,10 @@ Section ListOps. break_list l3' b l3'' H. auto. apply perm_trans with (c::l3''++b::l4); auto. - break_list l1' c l1'' H1. + break_list l1' c l1'' H1. auto. apply perm_trans with (b::l1''++c::l2); auto. - break_list l3' d l3'' H; break_list l1' e l1'' H1. + break_list l3' d l3'' H; break_list l1' e l1'' H1. auto. apply perm_trans with (e::a::l1''++l2); auto. apply perm_trans with (e::l1''++a::l2); auto. @@ -974,28 +974,28 @@ Section ListOps. apply (H2 _ _ _ _ _ H6 H4). Qed. - Theorem Permutation_cons_inv : + Theorem Permutation_cons_inv : forall l l' a, Permutation (a::l) (a::l') -> Permutation l l'. Proof. - intros; exact (Permutation_app_inv (@nil _) l (@nil _) l' a H). + intros; exact (Permutation_app_inv (@nil _) l (@nil _) l' a H). Qed. Theorem Permutation_cons_app_inv : forall l l1 l2 a, Permutation (a :: l) (l1 ++ a :: l2) -> Permutation l (l1 ++ l2). Proof. - intros; exact (Permutation_app_inv (@nil _) l l1 l2 a H). + intros; exact (Permutation_app_inv (@nil _) l l1 l2 a H). Qed. - - Theorem Permutation_app_inv_l : + + Theorem Permutation_app_inv_l : forall l l1 l2, Permutation (l ++ l1) (l ++ l2) -> Permutation l1 l2. - Proof. + Proof. induction l; simpl; auto. intros. apply IHl. apply Permutation_cons_inv with a; auto. Qed. - Theorem Permutation_app_inv_r : + Theorem Permutation_app_inv_r : forall l l1 l2, Permutation (l1 ++ l) (l2 ++ l) -> Permutation l1 l2. Proof. induction l. @@ -1019,9 +1019,9 @@ Section ListOps. Proof. induction l as [| x l IHl]; destruct l' as [| y l']. left; trivial. - right; apply nil_cons. + right; apply nil_cons. right; unfold not; intro HF; apply (nil_cons (sym_eq HF)). - destruct (eqA_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql']; + destruct (eqA_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql']; try (right; unfold not; intro HF; injection HF; intros; contradiction). rewrite xeqy; rewrite leql'; left; trivial. Qed. @@ -1041,21 +1041,21 @@ End ListOps. Section Map. Variables A B : Type. Variable f : A -> B. - + Fixpoint map (l:list A) : list B := match l with | nil => nil | cons a t => cons (f a) (map t) end. - + Lemma in_map : forall (l:list A) (x:A), In x l -> In (f x) (map l). - Proof. + Proof. induction l as [| a l IHl]; simpl in |- *; [ auto | destruct 1; [ left; apply f_equal with (f := f); assumption | auto ] ]. Qed. - + Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l. Proof. induction l; firstorder (subst; auto). @@ -1066,7 +1066,7 @@ Section Map. induction l; simpl; auto. Qed. - Lemma map_nth : forall l d n, + Lemma map_nth : forall l d n, nth n (map l) (f d) = f (nth n l d). Proof. induction l; simpl map; destruct n; firstorder. @@ -1078,15 +1078,15 @@ Section Map. induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto. Qed. - Lemma map_app : forall l l', + Lemma map_app : forall l l', map (l++l') = (map l)++(map l'). - Proof. + Proof. induction l; simpl; auto. intros; rewrite IHl; auto. Qed. - + Lemma map_rev : forall l, map (rev l) = rev (map l). - Proof. + Proof. induction l; simpl; auto. rewrite map_app. rewrite IHl; auto. @@ -1094,23 +1094,23 @@ Section Map. Hint Constructors Permutation. - Lemma Permutation_map : + Lemma Permutation_map : forall l l', Permutation l l' -> Permutation (map l) (map l'). - Proof. + Proof. induction 1; simpl; auto; eauto. Qed. (** [flat_map] *) - Fixpoint flat_map (f:A -> list B) (l:list A) {struct l} : + Fixpoint flat_map (f:A -> list B) (l:list A) {struct l} : list B := match l with | nil => nil | cons x t => (f x)++(flat_map f t) end. - + Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B), - In y (flat_map f l) <-> exists x, In x l /\ In y (f x). + In y (flat_map f l) <-> exists x, In x l /\ In y (f x). Proof. induction l; simpl; split; intros. contradiction. @@ -1126,7 +1126,7 @@ Section Map. exists x; auto. Qed. -End Map. +End Map. Lemma map_id : forall (A :Type) (l : list A), map (fun x => x) l = l. @@ -1134,14 +1134,14 @@ Proof. induction l; simpl; auto; rewrite IHl; auto. Qed. -Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l, +Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l, map g (map f l) = map (fun x => g (f x)) l. Proof. induction l; simpl; auto. rewrite IHl; auto. Qed. -Lemma map_ext : +Lemma map_ext : forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l. Proof. induction l; simpl; auto. @@ -1156,17 +1156,17 @@ Qed. Section Fold_Left_Recursor. Variables A B : Type. Variable f : A -> B -> A. - + Fixpoint fold_left (l:list B) (a0:A) {struct l} : A := match l with | nil => a0 | cons b t => fold_left t (f a0 b) end. - - Lemma fold_left_app : forall (l l':list B)(i:A), + + Lemma fold_left_app : forall (l l':list B)(i:A), fold_left (l++l') i = fold_left l' (fold_left l i). Proof. - induction l. + induction l. simpl; auto. intros. simpl. @@ -1175,7 +1175,7 @@ Section Fold_Left_Recursor. End Fold_Left_Recursor. -Lemma fold_left_length : +Lemma fold_left_length : forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l. Proof. intro A. @@ -1195,7 +1195,7 @@ Section Fold_Right_Recursor. Variables A B : Type. Variable f : B -> A -> A. Variable a0 : A. - + Fixpoint fold_right (l:list B) : A := match l with | nil => a0 @@ -1204,7 +1204,7 @@ Section Fold_Right_Recursor. End Fold_Right_Recursor. - Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, + Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, fold_right f i (l++l') = fold_right f (fold_right f i l') l. Proof. induction l. @@ -1213,7 +1213,7 @@ End Fold_Right_Recursor. f_equal; auto. Qed. - Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i, + Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i, fold_right f i (rev l) = fold_left (fun x y => f y x) l i. Proof. induction l. @@ -1264,20 +1264,20 @@ End Fold_Right_Recursor. (** ** Boolean operations over lists *) (*************************************) - Section Bool. + Section Bool. Variable A : Type. Variable f : A -> bool. - (** find whether a boolean function can be satisfied by an + (** find whether a boolean function can be satisfied by an elements of the list. *) - Fixpoint existsb (l:list A) {struct l}: bool := - match l with + Fixpoint existsb (l:list A) {struct l}: bool := + match l with | nil => false | a::l => f a || existsb l end. - Lemma existsb_exists : + Lemma existsb_exists : forall l, existsb l = true <-> exists x, In x l /\ f x = true. Proof. induction l; simpl; intuition. @@ -1296,11 +1296,11 @@ End Fold_Right_Recursor. inversion 1. simpl; intros. destruct (orb_false_elim _ _ H0); clear H0; auto. - destruct n ; auto. + destruct n ; auto. rewrite IHl; auto with arith. Qed. - Lemma existsb_app : forall l1 l2, + Lemma existsb_app : forall l1 l2, existsb (l1++l2) = existsb l1 || existsb l2. Proof. induction l1; intros l2; simpl. @@ -1308,16 +1308,16 @@ End Fold_Right_Recursor. case (f a); simpl; solve[auto]. Qed. - (** find whether a boolean function is satisfied by + (** find whether a boolean function is satisfied by all the elements of a list. *) - Fixpoint forallb (l:list A) {struct l} : bool := - match l with + Fixpoint forallb (l:list A) {struct l} : bool := + match l with | nil => true | a::l => f a && forallb l end. - Lemma forallb_forall : + Lemma forallb_forall : forall l, forallb l = true <-> (forall x, In x l -> f x = true). Proof. induction l; simpl; intuition. @@ -1326,7 +1326,7 @@ End Fold_Right_Recursor. destruct (andb_prop _ _ H1); auto. assert (forallb l = true). apply H0; intuition. - rewrite H1; auto. + rewrite H1; auto. Qed. Lemma forallb_app : @@ -1338,8 +1338,8 @@ End Fold_Right_Recursor. Qed. (** [filter] *) - Fixpoint filter (l:list A) : list A := - match l with + Fixpoint filter (l:list A) : list A := + match l with | nil => nil | x :: l => if f x then x::(filter l) else filter l end. @@ -1362,10 +1362,10 @@ End Fold_Right_Recursor. (** [partition] *) - Fixpoint partition (l:list A) {struct l} : list A * list A := + Fixpoint partition (l:list A) {struct l} : list A * list A := match l with | nil => (nil, nil) - | x :: tl => let (g,d) := partition tl in + | x :: tl => let (g,d) := partition tl in if f x then (x::g,d) else (g,x::d) end. @@ -1380,7 +1380,7 @@ End Fold_Right_Recursor. Section ListPairs. Variables A B : Type. - + (** [split] derives two lists from a list of pairs *) Fixpoint split (l:list (A*B)) { struct l }: list A * list B := @@ -1389,8 +1389,8 @@ End Fold_Right_Recursor. | (x,y) :: tl => let (g,d) := split tl in (x::g, y::d) end. - Lemma in_split_l : forall (l:list (A*B))(p:A*B), - In p l -> In (fst p) (fst (split l)). + Lemma in_split_l : forall (l:list (A*B))(p:A*B), + In p l -> In (fst p) (fst (split l)). Proof. induction l; simpl; intros; auto. destruct p; destruct a; destruct (split l); simpl in *. @@ -1399,8 +1399,8 @@ End Fold_Right_Recursor. right; apply (IHl (a0,b) H). Qed. - Lemma in_split_r : forall (l:list (A*B))(p:A*B), - In p l -> In (snd p) (snd (split l)). + Lemma in_split_r : forall (l:list (A*B))(p:A*B), + In p l -> In (snd p) (snd (split l)). Proof. induction l; simpl; intros; auto. destruct p; destruct a; destruct (split l); simpl in *. @@ -1409,7 +1409,7 @@ End Fold_Right_Recursor. right; apply (IHl (a0,b) H). Qed. - Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), + Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)). Proof. induction l. @@ -1421,21 +1421,21 @@ End Fold_Right_Recursor. Qed. Lemma split_length_l : forall (l:list (A*B)), - length (fst (split l)) = length l. + length (fst (split l)) = length l. Proof. induction l; simpl; auto. destruct a; destruct (split l); simpl; auto. Qed. Lemma split_length_r : forall (l:list (A*B)), - length (snd (split l)) = length l. + length (snd (split l)) = length l. Proof. induction l; simpl; auto. destruct a; destruct (split l); simpl; auto. Qed. - (** [combine] is the opposite of [split]. - Lists given to [combine] are meant to be of same length. + (** [combine] is the opposite of [split]. + Lists given to [combine] are meant to be of same length. If not, [combine] stops on the shorter list *) Fixpoint combine (l : list A) (l' : list B){struct l} : list (A*B) := @@ -1444,17 +1444,17 @@ End Fold_Right_Recursor. | _, _ => nil end. - Lemma split_combine : forall (l: list (A*B)), + Lemma split_combine : forall (l: list (A*B)), let (l1,l2) := split l in combine l1 l2 = l. Proof. induction l. simpl; auto. - destruct a; simpl. + destruct a; simpl. destruct (split l); simpl in *. f_equal; auto. Qed. - Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> + Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> split (combine l l') = (l,l'). Proof. induction l; destruct l'; simpl; intros; auto; try discriminate. @@ -1462,19 +1462,19 @@ End Fold_Right_Recursor. rewrite IHl; auto. Qed. - Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), + Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (combine l l') -> In x l. Proof. induction l. simpl; auto. destruct l'; simpl; auto; intros. - contradiction. + contradiction. destruct H. injection H; auto. right; apply IHl with l' y; auto. Qed. - Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), + Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (combine l l') -> In y l'. Proof. induction l. @@ -1485,7 +1485,7 @@ End Fold_Right_Recursor. right; apply IHl with x; auto. Qed. - Lemma combine_length : forall (l:list A)(l':list B), + Lemma combine_length : forall (l:list A)(l':list B), length (combine l l') = min (length l) (length l'). Proof. induction l. @@ -1493,8 +1493,8 @@ End Fold_Right_Recursor. destruct l'; simpl; auto. Qed. - Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), - length l = length l' -> + Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), + length l = length l' -> nth n (combine l l') (x,y) = (nth n l x, nth n l' y). Proof. induction l; destruct l'; intros; try discriminate. @@ -1503,7 +1503,7 @@ End Fold_Right_Recursor. Qed. (** [list_prod] has the same signature as [combine], but unlike - [combine], it adds every possible pairs, not only those at the + [combine], it adds every possible pairs, not only those at the same position. *) Fixpoint list_prod (l:list A) (l':list B) {struct l} : @@ -1516,7 +1516,7 @@ End Fold_Right_Recursor. Lemma in_prod_aux : forall (x:A) (y:B) (l:list B), In y l -> In (x, y) (map (fun y0:B => (x, y0)) l). - Proof. + Proof. induction l; [ simpl in |- *; auto | simpl in |- *; destruct 1 as [H1| ]; @@ -1526,15 +1526,15 @@ End Fold_Right_Recursor. Lemma in_prod : forall (l:list A) (l':list B) (x:A) (y:B), In x l -> In y l' -> In (x, y) (list_prod l l'). - Proof. + Proof. induction l; [ simpl in |- *; tauto | simpl in |- *; intros; apply in_or_app; destruct H; [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ]. Qed. - Lemma in_prod_iff : - forall (l:list A)(l':list B)(x:A)(y:B), + Lemma in_prod_iff : + forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (list_prod l l') <-> In x l /\ In y l'. Proof. split; [ | intros; apply in_prod; intuition ]. @@ -1545,9 +1545,9 @@ End Fold_Right_Recursor. destruct (H1 H0) as (z,(H2,H3)); clear H0 H1. injection H2; clear H2; intros; subst; intuition. intuition. - Qed. + Qed. - Lemma prod_length : forall (l:list A)(l':list B), + Lemma prod_length : forall (l:list A)(l':list B), length (list_prod l l') = (length l) * (length l'). Proof. induction l; simpl; auto. @@ -1581,34 +1581,34 @@ Section length_order. Variables l m n : list A. Lemma lel_refl : lel l l. - Proof. + Proof. unfold lel in |- *; auto with arith. Qed. Lemma lel_trans : lel l m -> lel m n -> lel l n. - Proof. + Proof. unfold lel in |- *; intros. now_show (length l <= length n). apply le_trans with (length m); auto with arith. Qed. Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m). - Proof. + Proof. unfold lel in |- *; simpl in |- *; auto with arith. Qed. Lemma lel_cons : lel l m -> lel l (b :: m). - Proof. + Proof. unfold lel in |- *; simpl in |- *; auto with arith. Qed. Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m. - Proof. + Proof. unfold lel in |- *; simpl in |- *; auto with arith. Qed. Lemma lel_nil : forall l':list A, lel l' nil -> nil = l'. - Proof. + Proof. intro l'; elim l'; auto with arith. intros a' y H H0. now_show (nil = a' :: y). @@ -1630,39 +1630,39 @@ Section SetIncl. Definition incl (l m:list A) := forall a:A, In a l -> In a m. Hint Unfold incl. - + Lemma incl_refl : forall l:list A, incl l l. - Proof. + Proof. auto. Qed. Hint Resolve incl_refl. - + Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m). - Proof. + Proof. auto with datatypes. Qed. Hint Immediate incl_tl. Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n. - Proof. + Proof. auto. Qed. - + Lemma incl_appl : forall l m n:list A, incl l n -> incl l (n ++ m). - Proof. + Proof. auto with datatypes. Qed. Hint Immediate incl_appl. - + Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n). - Proof. + Proof. auto with datatypes. Qed. Hint Immediate incl_appr. - + Lemma incl_cons : forall (a:A) (l m:list A), In a m -> incl l m -> incl (a :: l) m. - Proof. + Proof. unfold incl in |- *; simpl in |- *; intros a l m H H0 a0 H1. now_show (In a0 m). elim H1. @@ -1674,15 +1674,15 @@ Section SetIncl. auto. Qed. Hint Resolve incl_cons. - + Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n. - Proof. + Proof. unfold incl in |- *; simpl in |- *; intros l m n H H0 a H1. now_show (In a n). elim (in_app_or _ _ _ H1); auto. Qed. Hint Resolve incl_app. - + End SetIncl. Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons @@ -1697,24 +1697,24 @@ Section Cutting. Variable A : Type. - Fixpoint firstn (n:nat)(l:list A) {struct n} : list A := - match n with - | 0 => nil - | S n => match l with - | nil => nil + Fixpoint firstn (n:nat)(l:list A) {struct n} : list A := + match n with + | 0 => nil + | S n => match l with + | nil => nil | a::l => a::(firstn n l) end end. - - Fixpoint skipn (n:nat)(l:list A) { struct n } : list A := - match n with - | 0 => l - | S n => match l with - | nil => nil + + Fixpoint skipn (n:nat)(l:list A) { struct n } : list A := + match n with + | 0 => l + | S n => match l with + | nil => nil | a::l => skipn n l end end. - + Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l. Proof. induction n. @@ -1728,7 +1728,7 @@ Section Cutting. induction n; destruct l; simpl; auto. Qed. - Lemma removelast_firstn : forall n l, n < length l -> + Lemma removelast_firstn : forall n l, n < length l -> removelast (firstn (S n) l) = firstn n l. Proof. induction n; destruct l. @@ -1741,13 +1741,13 @@ Section Cutting. change (firstn (S n) (a::l)) with (a::firstn n l). rewrite removelast_app. rewrite IHn; auto with arith. - + clear IHn; destruct l; simpl in *; try discriminate. inversion_clear H. inversion_clear H0. Qed. - Lemma firstn_removelast : forall n l, n < length l -> + Lemma firstn_removelast : forall n l, n < length l -> firstn n (removelast l) = firstn n l. Proof. induction n; destruct l. @@ -1772,10 +1772,10 @@ End Cutting. Section ReDun. Variable A : Type. - - Inductive NoDup : list A -> Prop := - | NoDup_nil : NoDup nil - | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). + + Inductive NoDup : list A -> Prop := + | NoDup_nil : NoDup nil + | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l). Lemma NoDup_remove_1 : forall l l' a, NoDup (l++a::l') -> NoDup (l++l'). Proof. @@ -1800,10 +1800,10 @@ Section ReDun. destruct (IHl _ _ H1); auto. Qed. - Lemma NoDup_Permutation : forall l l', + Lemma NoDup_Permutation : forall l l', NoDup l -> NoDup l' -> (forall x, In x l <-> In x l') -> Permutation l l'. Proof. - induction l. + induction l. destruct l'; simpl; intros. apply perm_nil. destruct (H1 a) as (_,H2); destruct H2; auto. @@ -1823,7 +1823,7 @@ Section ReDun. subst x; destruct H2; auto. assert (In x (l'1++a::l'2)). apply in_or_app; destruct (in_app_or _ _ _ H); simpl; auto. - destruct (H1 x) as (_,H5); destruct H5; auto. + destruct (H1 x) as (_,H5); destruct H5; auto. subst x. destruct (NoDup_remove_2 _ _ _ H0 H). Qed. @@ -1837,21 +1837,21 @@ End ReDun. Section NatSeq. - (** [seq] computes the sequence of [len] contiguous integers + (** [seq] computes the sequence of [len] contiguous integers that starts at [start]. For instance, [seq 2 3] is [2::3::4::nil]. *) - - Fixpoint seq (start len:nat) {struct len} : list nat := - match len with + + Fixpoint seq (start len:nat) {struct len} : list nat := + match len with | 0 => nil | S len => start :: seq (S start) len - end. - + end. + Lemma seq_length : forall len start, length (seq start len) = len. Proof. induction len; simpl; auto. Qed. - - Lemma seq_nth : forall len start n d, + + Lemma seq_nth : forall len start n d, n < len -> nth n (seq start len) d = start+n. Proof. induction len; intros. @@ -1864,7 +1864,7 @@ Section NatSeq. Lemma seq_shift : forall len start, map S (seq start len) = seq (S start) len. - Proof. + Proof. induction len; simpl; auto. intros. rewrite IHlen. diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index 77caa9c22b..d8a8183f36 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -47,7 +47,7 @@ Section first_definitions. | right _ => set_mem a x1 end end. - + (** If [a] belongs to [x], removes [a] from [x]. If not, does nothing *) Fixpoint set_remove (a:A) (x:set) {struct x} : set := match x with @@ -72,7 +72,7 @@ Section first_definitions. | nil => x | a1 :: y1 => set_add a1 (set_union x y1) end. - + (** returns the set of all els of [x] that does not belong to [y] *) Fixpoint set_diff (x y:set) {struct x} : set := match x with @@ -80,7 +80,7 @@ Section first_definitions. | a1 :: x1 => if set_mem a1 y then set_diff x1 y else set_add a1 (set_diff x1 y) end. - + Definition set_In : A -> set -> Prop := In (A:=A). @@ -123,7 +123,7 @@ Section first_definitions. case H3; auto. Qed. - + Lemma set_mem_correct1 : forall (a:A) (x:set), set_mem a x = true -> set_In a x. Proof. @@ -191,11 +191,11 @@ Section first_definitions. Lemma set_add_intro : forall (a b:A) (x:set), a = b \/ set_In a x -> set_In a (set_add b x). - + Proof. intros a b x [H1| H2]; auto with datatypes. Qed. - + Lemma set_add_elim : forall (a b:A) (x:set), set_In a (set_add b x) -> a = b \/ set_In a x. @@ -225,7 +225,7 @@ Section first_definitions. simple induction x; simpl in |- *. discriminate. intros; elim (Aeq_dec a a0); intros; discriminate. - Qed. + Qed. Lemma set_union_intro1 : @@ -289,7 +289,7 @@ Section first_definitions. elim (set_mem a y); simpl in |- *; intros. auto with datatypes. absurd (set_In a y); auto with datatypes. - elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ]. + elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ]. Qed. Lemma set_inter_elim1 : @@ -324,7 +324,7 @@ Section first_definitions. set_In a (set_inter x y) -> set_In a x /\ set_In a y. Proof. eauto with datatypes. - Qed. + Qed. Lemma set_diff_intro : forall (a:A) (x y:set), @@ -354,7 +354,7 @@ Section first_definitions. forall (a:A) (x y:set), set_In a (set_diff x y) -> ~ set_In a y. intros a x y; elim x; simpl in |- *. intros; contradiction. - intros a0 l Hrec. + intros a0 l Hrec. apply set_mem_ind2; auto. intros H1 H2; case (set_add_elim _ _ _ H2); intros; auto. rewrite H; trivial. @@ -387,10 +387,10 @@ Section other_definitions. Definition set_fold_left : (B -> A -> B) -> set A -> B -> B := fold_left (A:=B) (B:=A). - Definition set_fold_right (f:A -> B -> B) (x:set A) + Definition set_fold_right (f:A -> B -> B) (x:set A) (b:B) : B := fold_right f b x. - + End other_definitions. Unset Implicit Arguments. diff --git a/theories/Lists/ListTactics.v b/theories/Lists/ListTactics.v index 2da70c4673..0a21a9e277 100644 --- a/theories/Lists/ListTactics.v +++ b/theories/Lists/ListTactics.v @@ -22,10 +22,10 @@ Ltac list_fold_right fcons fnil l := Ltac lazy_list_fold_right fcons fnil l := let f := match l with - | ?x :: ?tl => + | ?x :: ?tl => fun _ => fcons x ltac:(fun _ => lazy_list_fold_right fcons fnil tl) - | nil => fun _ => fnil() + | nil => fun _ => fnil() end in f(). @@ -75,7 +75,7 @@ Ltac check_is_list t := Ltac check_fv l := check_is_list l; - match type of l with + match type of l with | list _ => idtac | _ => fail 100 "anomaly: built an ill-typed list" end. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index f55043d370..20af2878b2 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -14,15 +14,15 @@ Require Export Setoid. Set Implicit Arguments. Unset Strict Implicit. -(** * Logical relations over lists with respect to a setoid equality - or ordering. *) +(** * Logical relations over lists with respect to a setoid equality + or ordering. *) -(** This can be seen as a complement of predicate [lelistA] and [sort] +(** This can be seen as a complement of predicate [lelistA] and [sort] found in [Sorting]. *) Section Type_with_equality. Variable A : Type. -Variable eqA : A -> A -> Prop. +Variable eqA : A -> A -> Prop. (** Being in a list modulo an equality relation over type [A]. *) @@ -47,7 +47,7 @@ Qed. (** An alternative definition of [InA]. *) Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l. -Proof. +Proof. induction l; intuition. inversion H. firstorder. @@ -98,10 +98,10 @@ Hint Resolve eqA_refl eqA_trans. Hint Immediate eqA_sym. Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. -Proof. +Proof. intros s x y. do 2 rewrite InA_alt. - intros H (z,(U,V)). + intros H (z,(U,V)). exists z; split; eauto. Qed. Hint Immediate InA_eqA. @@ -109,12 +109,12 @@ Hint Immediate InA_eqA. Lemma In_InA : forall l x, In x l -> InA x l. Proof. simple induction l; simpl in |- *; intuition. - subst; auto. + subst; auto. Qed. Hint Resolve In_InA. -Lemma InA_split : forall l x, InA x l -> - exists l1, exists y, exists l2, +Lemma InA_split : forall l x, InA x l -> + exists l1, exists y, exists l2, eqA x y /\ l = l1++y::l2. Proof. induction l; inversion_clear 1. @@ -144,7 +144,7 @@ Proof. apply in_or_app; auto. Qed. -Lemma InA_rev : forall p m, +Lemma InA_rev : forall p m, InA p (rev m) <-> InA p m. Proof. intros; do 2 rewrite InA_alt. @@ -173,20 +173,20 @@ Hint Constructors lelistA sort. Lemma InfA_ltA : forall l x y, ltA x y -> InfA y l -> InfA x l. Proof. - destruct l; constructor; inversion_clear H0; + destruct l; constructor; inversion_clear H0; eapply ltA_trans; eauto. Qed. - + Lemma InfA_eqA : forall l x y, eqA x y -> InfA y l -> InfA x l. Proof. intro s; case s; constructor; inversion_clear H0; eauto. Qed. -Hint Immediate InfA_ltA InfA_eqA. +Hint Immediate InfA_ltA InfA_eqA. Lemma SortA_InfA_InA : forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. -Proof. +Proof. simple induction l. intros; inversion H1. intros. @@ -194,13 +194,13 @@ Proof. eapply ltA_eqA; eauto. eauto. Qed. - + Lemma In_InfA : forall l x, (forall y, In y l -> ltA x y) -> InfA x l. Proof. simple induction l; simpl in |- *; intros; constructor; auto. Qed. - + Lemma InA_InfA : forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. Proof. @@ -209,9 +209,9 @@ Qed. (* In fact, this may be used as an alternative definition for InfA: *) -Lemma InfA_alt : +Lemma InfA_alt : forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)). -Proof. +Proof. split. intros; eapply SortA_InfA_InA; eauto. apply InA_InfA. @@ -242,14 +242,14 @@ Proof. simple induction l; auto. intros x l' H H0. inversion_clear H0. - constructor; auto. + constructor; auto. intro. assert (ltA x x) by (eapply SortA_InfA_InA; eauto). elim (ltA_not_eqA H3); auto. Qed. -Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> - (forall x, InA x l -> InA x l' -> False) -> +Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> + (forall x, InA x l -> InA x l' -> False) -> NoDupA (l++l'). Proof. induction l; simpl; auto; intros. @@ -325,14 +325,14 @@ Proof. induction 1; auto; simpl; congruence. Qed. -Lemma eqlistA_app : forall l1 l1' l2 l2', +Lemma eqlistA_app : forall l1 l1' l2 l2', eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2'). Proof. intros l1 l1' l2 l2' H; revert l2 l2'; induction H; simpl; auto. Qed. -Lemma eqlistA_rev_app : forall l1 l1', - eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' -> +Lemma eqlistA_rev_app : forall l1 l1', + eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' -> eqlistA ((rev l1)++l2) ((rev l1')++l2'). Proof. induction 1; auto. @@ -340,7 +340,7 @@ simpl; intros. do 2 rewrite app_ass; simpl; auto. Qed. -Lemma eqlistA_rev : forall l1 l1', +Lemma eqlistA_rev : forall l1 l1', eqlistA l1 l1' -> eqlistA (rev l1) (rev l1'). Proof. intros. @@ -349,12 +349,12 @@ rewrite (app_nil_end (rev l1')). apply eqlistA_rev_app; auto. Qed. -Lemma SortA_equivlistA_eqlistA : forall l l', +Lemma SortA_equivlistA_eqlistA : forall l l', SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. Proof. induction l; destruct l'; simpl; intros; auto. -destruct (H1 a); assert (H4 : InA a nil) by auto; inversion H4. -destruct (H1 a); assert (H4 : InA a nil) by auto; inversion H4. +destruct (H1 a); assert (H4 : InA a nil) by auto; inversion H4. +destruct (H1 a); assert (H4 : InA a nil) by auto; inversion H4. inversion_clear H; inversion_clear H0. assert (forall y, InA y l -> ltA a y). intros; eapply SortA_InfA_InA with (l:=l); eauto. @@ -374,10 +374,10 @@ constructor; auto. apply IHl; auto. split; intros. destruct (H1 x). -assert (H8 : InA x (a0::l')) by auto; inversion_clear H8; auto. +assert (H8 : InA x (a0::l')) by auto; inversion_clear H8; auto. elim (@ltA_not_eqA a x); eauto. destruct (H1 x). -assert (H8 : InA x (a::l)) by auto; inversion_clear H8; auto. +assert (H8 : InA x (a::l)) by auto; inversion_clear H8; auto. elim (@ltA_not_eqA a0 x); eauto. Qed. @@ -399,7 +399,7 @@ rewrite filter_In in H; destruct H. eapply SortA_InfA_InA; eauto. Qed. -Lemma filter_InA : forall f, (compat_bool f) -> +Lemma filter_InA : forall f, (compat_bool f) -> forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true. Proof. intros; do 2 rewrite InA_alt; intuition. @@ -410,8 +410,8 @@ destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition. rewrite <- (H _ _ H0); auto. Qed. -Lemma filter_split : - forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> +Lemma filter_split : + forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. Proof. induction l; simpl; intros; auto. @@ -443,7 +443,7 @@ Definition compat_op (f : A -> B -> B) := (** Two-argument functions that allow to reorder their arguments. *) Definition transpose (f : A -> B -> B) := - forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). + forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). (** A version of transpose with restriction on where it should hold *) Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) := @@ -454,16 +454,16 @@ Variable f:A->B->B. Variable i:B. Variable Comp:compat_op f. -Lemma fold_right_eqlistA : - forall s s', eqlistA s s' -> +Lemma fold_right_eqlistA : + forall s s', eqlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. induction 1; simpl; auto. reflexivity. Qed. -Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y -> - NoDupA (x::l) -> NoDupA (l1++y::l2) -> +Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y -> + NoDupA (x::l) -> NoDupA (l1++y::l2) -> equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). Proof. intros; intro a. @@ -687,7 +687,7 @@ destruct (eqA_dec x a). left; auto. destruct IHl. left; auto. -right; red; inversion_clear 1; contradiction. +right; red; inversion_clear 1; contradiction. Qed. Fixpoint removeA (x : A) (l : list A){struct l} : list A := @@ -731,16 +731,16 @@ Proof. simple induction s; simpl; intros. auto. inversion_clear H0. -destruct (eqA_dec x a); simpl; auto. +destruct (eqA_dec x a); simpl; auto. constructor; auto. rewrite removeA_InA. intuition. -Qed. +Qed. -Lemma removeA_equivlistA : forall l l' x, +Lemma removeA_equivlistA : forall l l' x, ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l'). -Proof. -unfold equivlistA; intros. +Proof. +unfold equivlistA; intros. rewrite removeA_InA. split; intros. rewrite <- H0; split; auto. @@ -761,22 +761,22 @@ End Type_with_equality. Hint Unfold compat_bool compat_nat compat_P. Hint Constructors InA NoDupA sort lelistA eqlistA. -Section Find. -Variable A B : Type. -Variable eqA : A -> A -> Prop. +Section Find. +Variable A B : Type. +Variable eqA : A -> A -> Prop. Hypothesis eqA_sym : forall x y, eqA x y -> eqA y x. Hypothesis eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z. Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. -Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := - match l with - | nil => None +Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := + match l with + | nil => None | (a,b)::l => if f a then Some b else findA f l end. -Lemma findA_NoDupA : - forall l a b, - NoDupA (fun p p' => eqA (fst p) (fst p')) l -> +Lemma findA_NoDupA : + forall l a b, + NoDupA (fun p p' => eqA (fst p) (fst p')) l -> (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <-> findA (fun a' => if eqA_dec a a' then true else false) l = Some b). Proof. @@ -808,4 +808,4 @@ constructor 2. rewrite IHl; auto. Qed. -End Find. +End Find. diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index bdbe0ecccd..e8b9358413 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -11,8 +11,8 @@ Require Import Streams. (** * Memoization *) -(** Successive outputs of a given function [f] are stored in - a stream in order to avoid duplicated computations. *) +(** Successive outputs of a given function [f] are stored in + a stream in order to avoid duplicated computations. *) Section MemoFunction. @@ -24,8 +24,8 @@ CoFixpoint memo_make (n:nat) : Stream A := Cons (f n) (memo_make (S n)). Definition memo_list := memo_make 0. Fixpoint memo_get (n:nat) (l:Stream A) : A := - match n with - | O => hd l + match n with + | O => hd l | S n1 => memo_get n1 (tl l) end. @@ -49,7 +49,7 @@ Variable g: A -> A. Hypothesis Hg_correct: forall n, f (S n) = g (f n). CoFixpoint imemo_make (fn:A) : Stream A := - let fn1 := g fn in + let fn1 := g fn in Cons fn1 (imemo_make fn1). Definition imemo_list := let f0 := f 0 in @@ -68,7 +68,7 @@ Qed. End MemoFunction. -(** For a dependent function, the previous solution is +(** For a dependent function, the previous solution is reused thanks to a temporarly hiding of the dependency in a "container" [memo_val]. *) @@ -88,7 +88,7 @@ Fixpoint is_eq (n m : nat) {struct n}: {n = m} + {True} := | S n1, S m1 => match is_eq n1 m1 with | left H => left True (f_equal S H) - | right _ => right (S n1 = S m1) I + | right _ => right (S n1 = S m1) I end end. @@ -134,7 +134,7 @@ Variable g: forall n, A n -> A (S n). Hypothesis Hg_correct: forall n, f (S n) = g n (f n). -Let mg v := match v with +Let mg v := match v with memo_mval n1 v1 => memo_mval (S n1) (g n1 v1) end. Definition dimemo_list := imemo_list _ mf mg. @@ -166,13 +166,13 @@ End DependentMemoFunction. Require Import ZArith. Open Scope Z_scope. -Fixpoint tfact (n: nat) := - match n with - | O => 1 - | S n1 => Z_of_nat n * tfact n1 +Fixpoint tfact (n: nat) := + match n with + | O => 1 + | S n1 => Z_of_nat n * tfact n1 end. -Definition lfact_list := +Definition lfact_list := dimemo_list _ tfact (fun n z => (Z_of_nat (S n) * z)). Definition lfact n := dmemo_get _ tfact n lfact_list. @@ -183,18 +183,18 @@ intros n; unfold lfact, lfact_list. rewrite dimemo_get_correct; auto. Qed. -Fixpoint nop p := +Fixpoint nop p := match p with - | xH => 0 - | xI p1 => nop p1 - | xO p1 => nop p1 + | xH => 0 + | xI p1 => nop p1 + | xO p1 => nop p1 end. -Fixpoint test z := +Fixpoint test z := match z with - | Z0 => 0 - | Zpos p1 => nop p1 - | Zneg p1 => nop p1 + | Z0 => 0 + | Zpos p1 => nop p1 + | Zneg p1 => nop p1 end. Time Eval vm_compute in test (lfact 2000). @@ -202,4 +202,4 @@ Time Eval vm_compute in test (lfact 2000). Time Eval vm_compute in test (lfact 1500). Time Eval vm_compute in (lfact 1500). *) - + diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 472265f3e3..ace157749f 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -41,7 +41,7 @@ Definition Str_nth (n:nat) (s:Stream) : A := hd (Str_nth_tl n s). Lemma unfold_Stream : forall x:Stream, x = match x with | Cons a s => Cons a s - end. + end. Proof. intro x. case x. @@ -223,7 +223,7 @@ Variable f: A -> B -> C. CoFixpoint zipWith (a:Stream A) (b:Stream B) : Stream C := Cons (f (hd a) (hd b)) (zipWith (tl a) (tl b)). -Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), +Lemma Str_nth_tl_zipWith : forall n (a:Stream A) (b:Stream B), Str_nth_tl n (zipWith a b)= zipWith (Str_nth_tl n a) (Str_nth_tl n b). Proof. induction n. diff --git a/theories/Lists/TheoryList.v b/theories/Lists/TheoryList.v index 226d071499..5185f2c539 100644 --- a/theories/Lists/TheoryList.v +++ b/theories/Lists/TheoryList.v @@ -349,7 +349,7 @@ destruct (TS_dec a) as [[c H1]| ]. left; exists c. exists a; auto. auto. -(* +(* Realizer try_find. *) Qed. @@ -359,7 +359,7 @@ End Find_sec. Section Assoc_sec. Variable B : Type. -Fixpoint assoc (a:A) (l:list (A * B)) {struct l} : +Fixpoint assoc (a:A) (l:list (A * B)) {struct l} : Exc B := match l with | nil => error diff --git a/theories/Logic/Berardi.v b/theories/Logic/Berardi.v index 27e375f629..5b2f5063b9 100644 --- a/theories/Logic/Berardi.v +++ b/theories/Logic/Berardi.v @@ -67,10 +67,10 @@ Section Retracts. Variables A B : Prop. -Record retract : Prop := +Record retract : Prop := {i : A -> B; j : B -> A; inv : forall a:A, j (i a) = a}. -Record retract_cond : Prop := +Record retract_cond : Prop := {i2 : A -> B; j2 : B -> A; inv2 : retract -> forall a:A, j2 (i2 a) = a}. @@ -94,7 +94,7 @@ Proof. intros A B. destruct (EM (retract (pow A) (pow B))) as [(f0,g0,e) | hf]. exists f0 g0; trivial. - exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; + exists (fun (x:pow A) (y:B) => F) (fun (x:pow B) (y:A) => F); intros; destruct hf; auto. Qed. diff --git a/theories/Logic/ChoiceFacts.v b/theories/Logic/ChoiceFacts.v index 3f4c4354bb..32880b2f75 100644 --- a/theories/Logic/ChoiceFacts.v +++ b/theories/Logic/ChoiceFacts.v @@ -20,7 +20,7 @@ description principles (a "type-theoretic" axiom of choice) - AC! = functional relation reification (known as axiom of unique choice in topos theory, - sometimes called principle of definite description in + sometimes called principle of definite description in the context of constructive type theory) - GAC_rel = guarded relational form of the (non extensional) axiom of choice @@ -146,16 +146,16 @@ Definition ConstructiveDefiniteDescription_on := (** GAC_rel *) -Definition GuardedRelationalChoice_on := +Definition GuardedRelationalChoice_on := forall P : A->Prop, forall R : A->B->Prop, (forall x : A, P x -> exists y : B, R x y) -> - (exists R' : A->B->Prop, + (exists R' : A->B->Prop, subrelation R' R /\ forall x, P x -> exists! y, R' x y). (** GAC_fun *) -Definition GuardedFunctionalChoice_on := - forall P : A->Prop, forall R : A->B->Prop, +Definition GuardedFunctionalChoice_on := + forall P : A->Prop, forall R : A->B->Prop, inhabited B -> (forall x : A, P x -> exists y : B, R x y) -> (exists f : A->B, forall x, P x -> R x (f x)). @@ -163,34 +163,34 @@ Definition GuardedFunctionalChoice_on := (** GFR_fun *) Definition GuardedFunctionalRelReification_on := - forall P : A->Prop, forall R : A->B->Prop, + forall P : A->Prop, forall R : A->B->Prop, inhabited B -> (forall x : A, P x -> exists! y : B, R x y) -> (exists f : A->B, forall x : A, P x -> R x (f x)). (** OAC_rel *) -Definition OmniscientRelationalChoice_on := +Definition OmniscientRelationalChoice_on := forall R : A->B->Prop, - exists R' : A->B->Prop, + exists R' : A->B->Prop, subrelation R' R /\ forall x : A, (exists y : B, R x y) -> exists! y, R' x y. (** OAC_fun *) -Definition OmniscientFunctionalChoice_on := - forall R : A->B->Prop, +Definition OmniscientFunctionalChoice_on := + forall R : A->B->Prop, inhabited B -> exists f : A->B, forall x : A, (exists y : B, R x y) -> R x (f x). (** D_epsilon *) -Definition EpsilonStatement_on := +Definition EpsilonStatement_on := forall P:A->Prop, inhabited A -> { x:A | (exists x, P x) -> P x }. (** D_iota *) -Definition IotaStatement_on := +Definition IotaStatement_on := forall P:A->Prop, inhabited A -> { x:A | (exists! x, P x) -> P x }. @@ -207,7 +207,7 @@ Notation FunctionalChoiceOnInhabitedSet := Notation FunctionalRelReification := (forall A B, FunctionalRelReification_on A B). -Notation GuardedRelationalChoice := +Notation GuardedRelationalChoice := (forall A B, GuardedRelationalChoice_on A B). Notation GuardedFunctionalChoice := (forall A B, GuardedFunctionalChoice_on A B). @@ -219,14 +219,14 @@ Notation OmniscientRelationalChoice := Notation OmniscientFunctionalChoice := (forall A B, OmniscientFunctionalChoice_on A B). -Notation ConstructiveDefiniteDescription := +Notation ConstructiveDefiniteDescription := (forall A, ConstructiveDefiniteDescription_on A). -Notation ConstructiveIndefiniteDescription := +Notation ConstructiveIndefiniteDescription := (forall A, ConstructiveIndefiniteDescription_on A). -Notation IotaStatement := +Notation IotaStatement := (forall A, IotaStatement_on A). -Notation EpsilonStatement := +Notation EpsilonStatement := (forall A, EpsilonStatement_on A). (** Subclassical schemes *) @@ -235,7 +235,7 @@ Definition ProofIrrelevance := forall (A:Prop) (a1 a2:A), a1 = a2. Definition IndependenceOfGeneralPremises := - forall (A:Type) (P:A -> Prop) (Q:Prop), + forall (A:Type) (P:A -> Prop) (Q:Prop), inhabited A -> (Q -> exists x, P x) -> exists x, Q -> P x. @@ -270,7 +270,7 @@ Proof. apply HR'R; assumption. Qed. -Lemma funct_choice_imp_rel_choice : +Lemma funct_choice_imp_rel_choice : forall A B, FunctionalChoice_on A B -> RelationalChoice_on A B. Proof. intros A B FunCh R H. @@ -283,7 +283,7 @@ Proof. trivial. Qed. -Lemma funct_choice_imp_description : +Lemma funct_choice_imp_description : forall A B, FunctionalChoice_on A B -> FunctionalRelReification_on A B. Proof. intros A B FunCh R H. @@ -297,7 +297,7 @@ Proof. Qed. Corollary FunChoice_Equiv_RelChoice_and_ParamDefinDescr : - forall A B, FunctionalChoice_on A B <-> + forall A B, FunctionalChoice_on A B <-> RelationalChoice_on A B /\ FunctionalRelReification_on A B. Proof. intros A B; split. @@ -312,7 +312,7 @@ Qed. (** We show that the guarded formulations of the axiom of choice are equivalent to their "omniscient" variant and comes from the non guarded - formulation in presence either of the independance of general premises + formulation in presence either of the independance of general premises or subset types (themselves derivable from subtypes thanks to proof- irrelevance) *) @@ -341,12 +341,12 @@ Proof. Qed. Lemma rel_choice_indep_of_general_premises_imp_guarded_rel_choice : - forall A B, inhabited B -> RelationalChoice_on A B -> + forall A B, inhabited B -> RelationalChoice_on A B -> IndependenceOfGeneralPremises -> GuardedRelationalChoice_on A B. Proof. intros A B Inh AC_rel IndPrem P R H. destruct (AC_rel (fun x y => P x -> R x y)) as (R',(HR'R,H0)). - intro x. apply IndPrem. exact Inh. intro Hx. + intro x. apply IndPrem. exact Inh. intro Hx. apply H; assumption. exists (fun x y => P x /\ R' x y). firstorder. @@ -385,7 +385,7 @@ Qed. (** ** AC_fun + IGP = GAC_fun = OAC_fun = AC_fun + Drinker *) (** AC_fun + IGP = GAC_fun *) - + Lemma guarded_fun_choice_imp_indep_of_general_premises : GuardedFunctionalChoice -> IndependenceOfGeneralPremises. Proof. @@ -446,7 +446,7 @@ Proof. Qed. Lemma fun_choice_and_small_drinker_imp_omniscient_fun_choice : - FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox + FunctionalChoiceOnInhabitedSet -> SmallDrinker'sParadox -> OmniscientFunctionalChoice. Proof. intros AC_fun Drinker A B R Inh. @@ -456,10 +456,10 @@ Proof. Qed. Corollary fun_choice_and_small_drinker_iff_omniscient_fun_choice : - FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox + FunctionalChoiceOnInhabitedSet /\ SmallDrinker'sParadox <-> OmniscientFunctionalChoice. Proof. - auto decomp using + auto decomp using omniscient_fun_choice_imp_small_drinker, omniscient_fun_choice_imp_fun_choice, fun_choice_and_small_drinker_imp_omniscient_fun_choice. @@ -510,7 +510,7 @@ Lemma constructive_indefinite_description_and_small_drinker_imp_epsilon : SmallDrinker'sParadox -> ConstructiveIndefiniteDescription -> EpsilonStatement. Proof. - intros Drinkers D_epsilon A P Inh; + intros Drinkers D_epsilon A P Inh; apply D_epsilon; apply Drinkers; assumption. Qed. @@ -542,7 +542,7 @@ Qed. We show instead that functional relation reification and the functional form of the axiom of choice are equivalent on decidable - relation with [nat] as codomain + relation with [nat] as codomain *) Require Import Wf_nat. @@ -552,10 +552,10 @@ Definition FunctionalChoice_on_rel (A B:Type) (R:A->B->Prop) := (forall x:A, exists y : B, R x y) -> exists f : A -> B, (forall x:A, R x (f x)). -Lemma classical_denumerable_description_imp_fun_choice : - forall A:Type, - FunctionalRelReification_on A nat -> - forall R:A->nat->Prop, +Lemma classical_denumerable_description_imp_fun_choice : + forall A:Type, + FunctionalRelReification_on A nat -> + forall R:A->nat->Prop, (forall x y, decidable (R x y)) -> FunctionalChoice_on_rel R. Proof. intros A Descr. @@ -563,7 +563,7 @@ Proof. set (R':= fun x y => R x y /\ forall y', R x y' -> y <= y'). destruct (Descr R') as (f,Hf). intro x. - apply (dec_inh_nat_subset_has_unique_least_element (R x)). + apply (dec_inh_nat_subset_has_unique_least_element (R x)). apply Rdec. apply (H x). exists f. @@ -582,12 +582,12 @@ Definition DependentFunctionalChoice_on (A:Type) (B:A -> Type) := (forall x:A, exists y : B x, R x y) -> (exists f : (forall x:A, B x), forall x:A, R x (f x)). -Notation DependentFunctionalChoice := +Notation DependentFunctionalChoice := (forall A (B:A->Type), DependentFunctionalChoice_on B). (** The easy part *) -Theorem dep_non_dep_functional_choice : +Theorem dep_non_dep_functional_choice : DependentFunctionalChoice -> FunctionalChoice. Proof. intros AC_depfun A B R H. @@ -606,12 +606,12 @@ Scheme eq_indd := Induction for eq Sort Prop. Definition proj1_inf (A B:Prop) (p : A/\B) := let (a,b) := p in a. -Theorem non_dep_dep_functional_choice : +Theorem non_dep_dep_functional_choice : FunctionalChoice -> DependentFunctionalChoice. Proof. intros AC_fun A B R H. - pose (B' := { x:A & B x }). - pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). + pose (B' := { x:A & B x }). + pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). destruct (AC_fun A B' R') as (f,Hf). intros x. destruct (H x) as (y,Hy). exists (existT (fun x => B x) x y). split; trivial. @@ -633,7 +633,7 @@ Notation DependentFunctionalRelReification := (** The easy part *) -Theorem dep_non_dep_functional_rel_reification : +Theorem dep_non_dep_functional_rel_reification : DependentFunctionalRelReification -> FunctionalRelReification. Proof. intros DepFunReify A B R H. @@ -646,12 +646,12 @@ Qed. conjunction projections and dependent elimination of conjunction and equality *) -Theorem non_dep_dep_functional_rel_reification : +Theorem non_dep_dep_functional_rel_reification : FunctionalRelReification -> DependentFunctionalRelReification. Proof. intros AC_fun A B R H. - pose (B' := { x:A & B x }). - pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). + pose (B' := { x:A & B x }). + pose (R' := fun (x:A) (y:B') => projT1 y = x /\ R (projT1 y) (projT2 y)). destruct (AC_fun A B' R') as (f,Hf). intros x. destruct (H x) as (y,(Hy,Huni)). exists (existT (fun x => B x) x y). repeat split; trivial. @@ -665,7 +665,7 @@ Proof. destruct Heq using eq_indd; trivial. Qed. -Corollary dep_iff_non_dep_functional_rel_reification : +Corollary dep_iff_non_dep_functional_rel_reification : FunctionalRelReification <-> DependentFunctionalRelReification. Proof. auto decomp using @@ -786,11 +786,11 @@ Proof. intros [|] [|] H1 H2; simpl in *; reflexivity || contradiction. left; trivial. right; trivial. -Qed. +Qed. Corollary fun_reification_descr_computational_excluded_middle_in_prop_context : FunctionalRelReification -> - (forall P:Prop, P \/ ~ P) -> + (forall P:Prop, P \/ ~ P) -> forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C. Proof. intros FunReify EM C; auto decomp using diff --git a/theories/Logic/ClassicalDescription.v b/theories/Logic/ClassicalDescription.v index dad60fb779..2b9df6d977 100644 --- a/theories/Logic/ClassicalDescription.v +++ b/theories/Logic/ClassicalDescription.v @@ -30,12 +30,12 @@ Axiom constructive_definite_description : Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}. Proof. -apply - (constructive_definite_descr_excluded_middle +apply + (constructive_definite_descr_excluded_middle constructive_definite_description classic). Qed. -Theorem classical_definite_description : +Theorem classical_definite_description : forall (A : Type) (P : A->Prop), inhabited A -> { x : A | (exists! x : A, P x) -> P x }. Proof. @@ -54,7 +54,7 @@ Qed. Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A := proj1_sig (classical_definite_description P i). -Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : +Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : (exists! x:A, P x) -> P (iota i P) := proj2_sig (classical_definite_description P i). diff --git a/theories/Logic/ClassicalEpsilon.v b/theories/Logic/ClassicalEpsilon.v index c45aeb6f91..0d65a89ba3 100644 --- a/theories/Logic/ClassicalEpsilon.v +++ b/theories/Logic/ClassicalEpsilon.v @@ -22,11 +22,11 @@ Require Import ChoiceFacts. Set Implicit Arguments. Axiom constructive_indefinite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists x, P x) -> { x : A | P x }. Lemma constructive_definite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists! x, P x) -> { x : A | P x }. Proof. intros; apply constructive_indefinite_description; firstorder. @@ -34,18 +34,18 @@ Qed. Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}. Proof. - apply - (constructive_definite_descr_excluded_middle + apply + (constructive_definite_descr_excluded_middle constructive_definite_description classic). Qed. -Theorem classical_indefinite_description : +Theorem classical_indefinite_description : forall (A : Type) (P : A->Prop), inhabited A -> { x : A | (exists x, P x) -> P x }. Proof. intros A P i. destruct (excluded_middle_informative (exists x, P x)) as [Hex|HnonP]. - apply constructive_indefinite_description + apply constructive_indefinite_description with (P:= fun x => (exists x, P x) -> P x). destruct Hex as (x,Hx). exists x; intros _; exact Hx. @@ -60,7 +60,7 @@ Defined. Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A := proj1_sig (classical_indefinite_description P i). -Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : +Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : (exists x, P x) -> P (epsilon i P) := proj2_sig (classical_indefinite_description P i). @@ -76,7 +76,7 @@ Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : the actual proof that the domain of [P] is inhabited (proof idea kindly provided by Pierre Castéran) *) -Lemma epsilon_inh_irrelevance : +Lemma epsilon_inh_irrelevance : forall (A:Type) (i j : inhabited A) (P:A->Prop), (exists x, P x) -> epsilon i P = epsilon j P. Proof. diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index d4ba4a3a7b..9ec916a7dc 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -111,7 +111,7 @@ Qed. (** We successively show that: [prop_extensionality] - implies equality of [A] and [A->A] for inhabited [A], which + implies equality of [A] and [A->A] for inhabited [A], which implies the existence of a (trivial) retract from [A->A] to [A] (just take the identity), which implies the existence of a fixpoint operator in [A] @@ -128,7 +128,7 @@ Proof. apply (Ext (A -> A) A); split; [ exact (fun _ => a) | exact (fun _ _ => a) ]. Qed. -Record retract (A B:Prop) : Prop := +Record retract (A B:Prop) : Prop := {f1 : A -> B; f2 : B -> A; f1_o_f2 : forall x:B, f1 (f2 x) = x}. Lemma prop_ext_retract_A_A_imp_A : @@ -140,7 +140,7 @@ Proof. reflexivity. Qed. -Record has_fixpoint (A:Prop) : Prop := +Record has_fixpoint (A:Prop) : Prop := {F : (A -> A) -> A; Fix : forall f:A -> A, F f = f (F f)}. Lemma ext_prop_fixpoint : @@ -224,7 +224,7 @@ End Proof_irrelevance_gen. *) Section Proof_irrelevance_Prop_Ext_CC. - + Definition BoolP := forall C:Prop, C -> C -> C. Definition TrueP : BoolP := fun C c1 c2 => c1. Definition FalseP : BoolP := fun C c1 c2 => c2. @@ -233,10 +233,10 @@ Section Proof_irrelevance_Prop_Ext_CC. c1 = BoolP_elim C c1 c2 TrueP := refl_equal c1. Definition BoolP_elim_redr (C:Prop) (c1 c2:C) : c2 = BoolP_elim C c1 c2 FalseP := refl_equal c2. - + Definition BoolP_dep_induction := forall P:BoolP -> Prop, P TrueP -> P FalseP -> forall b:BoolP, P b. - + Lemma ext_prop_dep_proof_irrel_cc : prop_extensionality -> BoolP_dep_induction -> proof_irrelevance. Proof. @@ -248,7 +248,7 @@ End Proof_irrelevance_Prop_Ext_CC. (** Remark: [prop_extensionality] can be replaced in lemma [ext_prop_dep_proof_irrel_gen] by the weakest property - [provable_prop_extensionality]. + [provable_prop_extensionality]. *) (************************************************************************) @@ -260,7 +260,7 @@ End Proof_irrelevance_Prop_Ext_CC. *) Section Proof_irrelevance_CIC. - + Inductive boolP : Prop := | trueP : boolP | falseP : boolP. @@ -269,7 +269,7 @@ Section Proof_irrelevance_CIC. Definition boolP_elim_redr (C:Prop) (c1 c2:C) : c2 = boolP_ind C c1 c2 falseP := refl_equal c2. Scheme boolP_indd := Induction for boolP Sort Prop. - + Lemma ext_prop_dep_proof_irrel_cic : prop_extensionality -> proof_irrelevance. Proof. exact (fun pe => @@ -316,7 +316,7 @@ End Proof_irrelevance_CIC. Require Import Hurkens. Section Proof_irrelevance_EM_CC. - + Variable or : Prop -> Prop -> Prop. Variable or_introl : forall A B:Prop, A -> or A B. Variable or_intror : forall A B:Prop, B -> or A B. @@ -334,11 +334,11 @@ Section Proof_irrelevance_EM_CC. forall (A B:Prop) (P:or A B -> Prop), (forall a:A, P (or_introl A B a)) -> (forall b:B, P (or_intror A B b)) -> forall b:or A B, P b. - + Hypothesis em : forall A:Prop, or A (~ A). Variable B : Prop. Variables b1 b2 : B. - + (** [p2b] and [b2p] form a retract if [~b1=b2] *) Definition p2b A := or_elim A (~ A) B (fun _ => b1) (fun _ => b2) (em A). @@ -392,13 +392,13 @@ End Proof_irrelevance_EM_CC. Section Proof_irrelevance_CCI. Hypothesis em : forall A:Prop, A \/ ~ A. - - Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) + + Definition or_elim_redl (A B C:Prop) (f:A -> C) (g:B -> C) (a:A) : f a = or_ind f g (or_introl B a) := refl_equal (f a). - Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) + Definition or_elim_redr (A B C:Prop) (f:A -> C) (g:B -> C) (b:B) : g b = or_ind f g (or_intror A b) := refl_equal (g b). Scheme or_indd := Induction for or Sort Prop. - + Theorem proof_irrelevance_cci : forall (B:Prop) (b1 b2:B), b1 = b2. Proof. exact (proof_irrelevance_cc or or_introl or_intror or_ind or_elim_redl @@ -438,7 +438,7 @@ Definition weak_excluded_middle := [weak_generalized_excluded_middle] is that it holds even in logic without a primitive [False] connective (like Gödel-Dummett axiom) *) -Definition weak_generalized_excluded_middle := +Definition weak_generalized_excluded_middle := forall A B:Prop, ((A -> B) -> B) \/ (A -> B). (** ** Gödel-Dummett axiom *) @@ -473,7 +473,7 @@ Lemma Godel_Dummett_iff_right_distr_implication_over_disjunction : Proof. split. intros GD A B C HCAB. - destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC; + destruct (GD B A) as [HBA|HAB]; [left|right]; intro HC; destruct (HCAB HC) as [HA|HB]; [ | apply HBA | apply HAB | ]; assumption. intros Distr A B. destruct (Distr A B (A\/B)) as [HABA|HABB]. @@ -484,7 +484,7 @@ Qed. (** [(A->B) \/ (B->A)] is stronger than the weak excluded middle *) -Lemma Godel_Dummett_weak_excluded_middle : +Lemma Godel_Dummett_weak_excluded_middle : GodelDummett -> weak_excluded_middle. Proof. intros GD A. destruct (GD (~A) A) as [HnotAA|HAnotA]. @@ -539,10 +539,10 @@ Qed. (** Independence of general premises is equivalent to the drinker's paradox *) Definition DrinkerParadox := - forall (A:Type) (P:A -> Prop), + forall (A:Type) (P:A -> Prop), inhabited A -> exists x, (exists x, P x) -> P x. -Lemma independence_general_premises_drinker : +Lemma independence_general_premises_drinker : IndependenceOfGeneralPremises <-> DrinkerParadox. Proof. split. @@ -551,14 +551,14 @@ Proof. exists x; intro HQ; apply (Hx (H HQ)). Qed. -(** Independence of general premises is weaker than (generalized) +(** Independence of general premises is weaker than (generalized) excluded middle Remark: generalized excluded middle is preferred here to avoid relying on the "ex falso quodlibet" property (i.e. [False -> forall A, A]) *) -Definition generalized_excluded_middle := +Definition generalized_excluded_middle := forall A B:Prop, A \/ (A -> B). Lemma excluded_middle_independence_general_premises : @@ -569,4 +569,4 @@ Proof. exists x; intro; exact Hx. exists x0; exact Hnot. Qed. - + diff --git a/theories/Logic/ClassicalUniqueChoice.v b/theories/Logic/ClassicalUniqueChoice.v index 2e739dd511..c1f9881faa 100644 --- a/theories/Logic/ClassicalUniqueChoice.v +++ b/theories/Logic/ClassicalUniqueChoice.v @@ -80,4 +80,4 @@ destruct (f P). discriminate. assumption. Qed. - + diff --git a/theories/Logic/Classical_Pred_Type.v b/theories/Logic/Classical_Pred_Type.v index ce94bec14f..b30308af5e 100644 --- a/theories/Logic/Classical_Pred_Type.v +++ b/theories/Logic/Classical_Pred_Type.v @@ -44,7 +44,7 @@ Proof. (* Intuitionistic *) unfold not in |- *; intros P notex n abs. apply notex. exists n; trivial. -Qed. +Qed. Lemma not_ex_not_all : forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n. diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index 8d2e946de5..df732959f3 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -22,7 +22,7 @@ unfold not in |- *; intros; elim (classic p); auto. intro NP; elim (H NP). Qed. -(** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P]. +(** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P]. Thanks to [forall P, False -> P], it is equivalent to the following form *) @@ -95,11 +95,11 @@ Proof proof_irrelevance_cci classic. (* classical_left transforms |- A \/ B into ~B |- A *) (* classical_right transforms |- A \/ B into ~A |- B *) -Ltac classical_right := match goal with +Ltac classical_right := match goal with | _:_ |-?X1 \/ _ => (elim (classic X1);intro;[left;trivial|right]) end. -Ltac classical_left := match goal with +Ltac classical_left := match goal with | _:_ |- _ \/?X1 => (elim (classic X1);intro;[right;trivial|left]) end. @@ -107,7 +107,7 @@ Require Export EqdepFacts. Module Eq_rect_eq. -Lemma eq_rect_eq : +Lemma eq_rect_eq : forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. Proof. intros; rewrite proof_irrelevance with (p1:=h) (p2:=refl_equal p); reflexivity. diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index 6129128de0..c6d32d9bef 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -13,7 +13,7 @@ Definition decidable (P:Prop) := P \/ ~ P. Theorem dec_not_not : forall P:Prop, decidable P -> (~ P -> False) -> P. Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. Theorem dec_True : decidable True. @@ -29,27 +29,27 @@ Qed. Theorem dec_or : forall A B:Prop, decidable A -> decidable B -> decidable (A \/ B). Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. Theorem dec_and : forall A B:Prop, decidable A -> decidable B -> decidable (A /\ B). Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. Theorem dec_not : forall A:Prop, decidable A -> decidable (~ A). Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. Theorem dec_imp : forall A B:Prop, decidable A -> decidable B -> decidable (A -> B). Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. -Theorem dec_iff : +Theorem dec_iff : forall A B:Prop, decidable A -> decidable B -> decidable (A<->B). Proof. unfold decidable; tauto. @@ -67,7 +67,7 @@ Qed. Theorem not_and : forall A B:Prop, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B. Proof. -unfold decidable; tauto. +unfold decidable; tauto. Qed. Theorem not_imp : forall A B:Prop, decidable A -> ~ (A -> B) -> A /\ ~ B. @@ -80,16 +80,16 @@ Proof. unfold decidable; tauto. Qed. -Theorem not_iff : - forall A B:Prop, decidable A -> decidable B -> +Theorem not_iff : + forall A B:Prop, decidable A -> decidable B -> ~ (A <-> B) -> (A /\ ~ B) \/ (~ A /\ B). Proof. unfold decidable; tauto. Qed. -(** Results formulated with iff, used in FSetDecide. - Negation are expanded since it is unclear whether setoid rewrite - will always perform conversion. *) +(** Results formulated with iff, used in FSetDecide. + Negation are expanded since it is unclear whether setoid rewrite + will always perform conversion. *) (** We begin with lemmas that, when read from left to right, can be understood as ways to eliminate uses of [not]. *) diff --git a/theories/Logic/DecidableType.v b/theories/Logic/DecidableType.v index fed25ad742..625f776bfa 100644 --- a/theories/Logic/DecidableType.v +++ b/theories/Logic/DecidableType.v @@ -14,7 +14,7 @@ Unset Strict Implicit. (** * Types with Equalities, and nothing more (for subtyping purpose) *) -Module Type EqualityType. +Module Type EqualityType. Parameter Inline t : Type. @@ -27,11 +27,11 @@ Module Type EqualityType. Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans. -End EqualityType. +End EqualityType. (** * Types with decidable Equalities (but no ordering) *) -Module Type DecidableType. +Module Type DecidableType. Parameter Inline t : Type. @@ -46,7 +46,7 @@ Module Type DecidableType. Hint Immediate eq_sym. Hint Resolve eq_refl eq_trans. -End DecidableType. +End DecidableType. (** * Additional notions about keys and datas used in FMap *) @@ -58,21 +58,21 @@ Module KeyDecidableType(D:DecidableType). Notation key:=t. Definition eqk (p p':key*elt) := eq (fst p) (fst p'). - Definition eqke (p p':key*elt) := + Definition eqke (p p':key*elt) := eq (fst p) (fst p') /\ (snd p) = (snd p'). Hint Unfold eqk eqke. Hint Extern 2 (eqke ?a ?b) => split. (* eqke is stricter than eqk *) - + Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. Proof. unfold eqk, eqke; intuition. Qed. (* eqk, eqke are equalities *) - + Lemma eqk_refl : forall e, eqk e e. Proof. auto. Qed. @@ -96,7 +96,7 @@ Module KeyDecidableType(D:DecidableType). Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. Hint Immediate eqk_sym eqke_sym. - Lemma InA_eqke_eqk : + Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. unfold eqke; induction 1; intuition. @@ -134,22 +134,22 @@ Module KeyDecidableType(D:DecidableType). Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. Proof. destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. - Qed. + Qed. Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. inversion 1. inversion_clear H0; eauto. destruct H1; simpl in *; intuition. - Qed. + Qed. - Lemma In_inv_2 : forall k k' e e' l, + Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. + Proof. inversion_clear 1; compute in H0; intuition. Qed. - Lemma In_inv_3 : forall x x' l, + Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. inversion_clear 1; compute in H0; intuition. diff --git a/theories/Logic/DecidableTypeEx.v b/theories/Logic/DecidableTypeEx.v index 57a2248b36..022102f70d 100644 --- a/theories/Logic/DecidableTypeEx.v +++ b/theories/Logic/DecidableTypeEx.v @@ -14,7 +14,7 @@ Unset Strict Implicit. (** * Examples of Decidable Type structures. *) -(** A particular case of [DecidableType] where +(** A particular case of [DecidableType] where the equality is the usual one of Coq. *) Module Type UsualDecidableType. @@ -32,13 +32,13 @@ Module UDT_to_DT (U:UsualDecidableType) <: DecidableType := U. (** an shortcut for easily building a UsualDecidableType *) -Module Type MiniDecidableType. +Module Type MiniDecidableType. Parameter Inline t : Type. Parameter eq_dec : forall x y:t, { x=y }+{ x<>y }. -End MiniDecidableType. +End MiniDecidableType. Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType. - Definition t:=M.t. + Definition t:=M.t. Definition eq := @eq t. Definition eq_refl := @refl_equal t. Definition eq_sym := @sym_eq t. @@ -57,7 +57,7 @@ Module Positive_as_DT <: UsualDecidableType := Positive_as_OT. Module N_as_DT <: UsualDecidableType := N_as_OT. Module Z_as_DT <: UsualDecidableType := Z_as_OT. -(** From two decidable types, we can build a new DecidableType +(** From two decidable types, we can build a new DecidableType over their cartesian product. *) Module PairDecidableType(D1 D2:DecidableType) <: DecidableType. @@ -67,17 +67,17 @@ Module PairDecidableType(D1 D2:DecidableType) <: DecidableType. Definition eq x y := D1.eq (fst x) (fst y) /\ D2.eq (snd x) (snd y). Lemma eq_refl : forall x : t, eq x x. - Proof. + Proof. intros (x1,x2); red; simpl; auto. Qed. Lemma eq_sym : forall x y : t, eq x y -> eq y x. - Proof. + Proof. intros (x1,x2) (y1,y2); unfold eq; simpl; intuition. Qed. Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - Proof. + Proof. intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. Qed. @@ -99,10 +99,10 @@ Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. Definition eq_trans := @trans_eq t. Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. Proof. - intros (x1,x2) (y1,y2); - destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); - unfold eq, D1.eq, D2.eq in *; simpl; - (left; f_equal; auto; fail) || + intros (x1,x2) (y1,y2); + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); + unfold eq, D1.eq, D2.eq in *; simpl; + (left; f_equal; auto; fail) || (right; intro H; injection H; auto). Defined. diff --git a/theories/Logic/Description.v b/theories/Logic/Description.v index 41cde8aa56..a8a56ae740 100644 --- a/theories/Logic/Description.v +++ b/theories/Logic/Description.v @@ -17,5 +17,5 @@ Require Import ChoiceFacts. Set Implicit Arguments. Axiom constructive_definite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists! x, P x) -> { x : A | P x }. diff --git a/theories/Logic/Diaconescu.v b/theories/Logic/Diaconescu.v index 95a07f2f3c..18f3181b66 100644 --- a/theories/Logic/Diaconescu.v +++ b/theories/Logic/Diaconescu.v @@ -59,7 +59,7 @@ Definition PredicateExtensionality := Require Import ClassicalFacts. Variable pred_extensionality : PredicateExtensionality. - + Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B. Proof. intros A B H. @@ -99,11 +99,11 @@ Lemma AC_bool_subset_to_bool : (exists b : bool, P b) -> exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')). Proof. - destruct (guarded_rel_choice _ _ + destruct (guarded_rel_choice _ _ (fun Q:bool -> Prop => exists y : _, Q y) (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)). exact (fun _ H => H). - exists R; intros P HP. + exists R; intros P HP. destruct (HR P HP) as (y,(Hy,Huni)). exists y; firstorder. Qed. @@ -190,7 +190,7 @@ Lemma projT1_injective : a1=a2 -> a1'=a2'. Proof. intro Heq ; unfold a1', a2', A'. rewrite Heq. - replace (or_introl (a2=a2) (refl_equal a2)) + replace (or_introl (a2=a2) (refl_equal a2)) with (or_intror (a2=a2) (refl_equal a2)). reflexivity. apply proof_irrelevance. @@ -210,10 +210,10 @@ Qed. Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2. Proof. - destruct - (rel_choice A' bool + destruct + (rel_choice A' bool (fun x y => projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false)) - as (R,(HRsub,HR)). + as (R,(HRsub,HR)). apply decide. destruct (HR a1') as (b1,(Ha1'b1,_Huni1)). destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)]. @@ -235,18 +235,18 @@ Declare Implicit Tactic auto. Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2. Proof. - assert (decide: forall x:A, x=a1 \/ x=a2 -> + assert (decide: forall x:A, x=a1 \/ x=a2 -> exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false). intros a [Ha1|Ha2]; [exists true | exists false]; auto. - assert (guarded_rel_choice := - rel_choice_and_proof_irrel_imp_guarded_rel_choice - rel_choice + assert (guarded_rel_choice := + rel_choice_and_proof_irrel_imp_guarded_rel_choice + rel_choice proof_irrelevance). - destruct - (guarded_rel_choice A bool + destruct + (guarded_rel_choice A bool (fun x => x=a1 \/ x=a2) (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false)) - as (R,(HRsub,HR)). + as (R,(HRsub,HR)). apply decide. destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity. destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)]. @@ -273,8 +273,8 @@ Section ExtensionalEpsilon_imp_EM. Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A. -Hypothesis epsilon_spec : - forall (A:Type) (i:inhabited A) (P:A->Prop), +Hypothesis epsilon_spec : + forall (A:Type) (i:inhabited A) (P:A->Prop), (exists x, P x) -> P (epsilon A i P). Hypothesis epsilon_extensionality : @@ -288,9 +288,9 @@ Proof. intro P. pose (B := fun y => y=false \/ P). pose (C := fun y => y=true \/ P). - assert (B (eps B)) as [Hfalse|HP] + assert (B (eps B)) as [Hfalse|HP] by (apply epsilon_spec; exists false; left; reflexivity). - assert (C (eps C)) as [Htrue|HP] + assert (C (eps C)) as [Htrue|HP] by (apply epsilon_spec; exists true; left; reflexivity). right; intro HP. assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption). diff --git a/theories/Logic/Epsilon.v b/theories/Logic/Epsilon.v index ead91c9eca..d433be944b 100644 --- a/theories/Logic/Epsilon.v +++ b/theories/Logic/Epsilon.v @@ -17,12 +17,12 @@ Set Implicit Arguments. (** Hilbert's epsilon: operator and specification in one statement *) -Axiom epsilon_statement : +Axiom epsilon_statement : forall (A : Type) (P : A->Prop), inhabited A -> { x : A | (exists x, P x) -> P x }. Lemma constructive_indefinite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists x, P x) -> { x : A | P x }. Proof. apply epsilon_imp_constructive_indefinite_description. @@ -45,7 +45,7 @@ Proof. Qed. Lemma constructive_definite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists! x, P x) -> { x : A | P x }. Proof. apply iota_imp_constructive_definite_description. @@ -57,7 +57,7 @@ Qed. Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A := proj1_sig (epsilon_statement P i). -Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : +Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : (exists x, P x) -> P (epsilon i P) := proj2_sig (epsilon_statement P i). @@ -66,7 +66,7 @@ Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) : Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A := proj1_sig (iota_statement P i). -Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : +Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) : (exists! x:A, P x) -> P (iota i P) := proj2_sig (iota_statement P i). diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 74d9726a65..a4b4b5b4a7 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -45,7 +45,7 @@ Table of contents: (** * Definition of dependent equality and equivalence with equality of dependent pairs *) Section Dependent_Equality. - + Variable U : Type. Variable P : U -> Type. @@ -119,7 +119,7 @@ Lemma equiv_eqex_eqdep : forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), existT P p x = existT P q y <-> eq_dep p x q y. Proof. - split. + split. (* -> *) apply eq_sigT_eq_dep. (* <- *) @@ -142,27 +142,27 @@ Hint Immediate eq_dep_sym: core. (** * Eq_rect_eq <-> Eq_dep_eq <-> UIP <-> UIP_refl <-> K *) Section Equivalences. - + Variable U:Type. - + (** Invariance by Substitution of Reflexive Equality Proofs *) - - Definition Eq_rect_eq := + + Definition Eq_rect_eq := forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. - + (** Injectivity of Dependent Equality *) - - Definition Eq_dep_eq := + + Definition Eq_dep_eq := forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y. - + (** Uniqueness of Identity Proofs (UIP) *) - - Definition UIP_ := + + Definition UIP_ := forall (x y:U) (p1 p2:x = y), p1 = p2. - + (** Uniqueness of Reflexive Identity Proofs *) - Definition UIP_refl_ := + Definition UIP_refl_ := forall (x:U) (p:x = x), p = refl_equal x. (** Streicher's axiom K *) @@ -198,7 +198,7 @@ Section Equivalences. elim p1 using eq_indd. apply eq_dep_intro. Qed. - + (** Uniqueness of Reflexive Identity Proofs is a direct instance of UIP *) Lemma UIP__UIP_refl : UIP_ -> UIP_refl_. @@ -216,7 +216,7 @@ Section Equivalences. (** We finally recover from K the Invariance by Substitution of Reflexive Equality Proofs *) - + Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq. Proof. intro Streicher_K; red; intros. @@ -233,20 +233,20 @@ Section Equivalences. Typically, [eq_rect_eq] allows to prove UIP and Streicher's K what does not seem possible with [eq_rec_eq]. In particular, the proof of [UIP] requires to use [eq_rect_eq] on [fun y -> x=y] which is in [Type] but not - in [Set]. + in [Set]. *) End Equivalences. Section Corollaries. - + Variable U:Type. - + (** UIP implies the injectivity of equality on dependent pairs in Type *) - + Definition Inj_dep_pair := forall (P:U -> Type) (p:U) (x y:P p), existT P p x = existT P p y -> x = y. - + Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair. Proof. intro eq_dep_eq; red; intros. @@ -260,7 +260,7 @@ End Corollaries. Notation Inj_dep_pairS := Inj_dep_pair. Notation Inj_dep_pairT := Inj_dep_pair. Notation eq_dep_eq__inj_pairT2 := eq_dep_eq__inj_pair2. - + (************************************************************************) (** * Definition of the functor that builds properties of dependent equalities assuming axiom eq_rect_eq *) @@ -274,11 +274,11 @@ Module Type EqdepElimination. End EqdepElimination. Module EqdepTheory (M:EqdepElimination). - + Section Axioms. - + Variable U:Type. - + (** Invariance by Substitution of Reflexive Equality Proofs *) Lemma eq_rect_eq : diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 1943c16298..c7cb9b0d45 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -38,7 +38,7 @@ Set Implicit Arguments. Section EqdepDec. Variable A : Type. - + Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' := eq_ind _ (fun a => a = y') eq2 _ eq1. @@ -49,7 +49,7 @@ Section EqdepDec. Qed. Variable eq_dec : forall x y:A, x = y \/ x <> y. - + Variable x : A. Let nu (y:A) (u:x = y) : x = y := @@ -63,13 +63,13 @@ Section EqdepDec. unfold nu in |- *. case (eq_dec x y); intros. reflexivity. - + case n; trivial. Qed. Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (refl_equal x)) v. - + Remark nu_left_inv : forall (y:A) (u:x = y), nu_inv (nu u) = u. Proof. @@ -88,7 +88,7 @@ Section EqdepDec. reflexivity. Qed. - Theorem K_dec : + Theorem K_dec : forall P:x = x -> Prop, P (refl_equal x) -> forall p:x = x, P p. Proof. intros. @@ -118,10 +118,10 @@ Section EqdepDec. case (eq_dec x x). intro e. elim e using K_dec; trivial. - + intros. case n; trivial. - + case H. reflexivity. Qed. @@ -173,13 +173,13 @@ Unset Implicit Arguments. (** The signature of decidable sets in [Type] *) Module Type DecidableType. - + Parameter U:Type. Axiom eq_dec : forall x y:U, {x = y} + {x <> y}. End DecidableType. -(** The module [DecidableEqDep] collects equality properties for decidable +(** The module [DecidableEqDep] collects equality properties for decidable set in [Type] *) Module DecidableEqDep (M:DecidableType). @@ -247,7 +247,7 @@ Module Type DecidableSet. End DecidableSet. -(** The module [DecidableEqDepSet] collects equality properties for decidable +(** The module [DecidableEqDepSet] collects equality properties for decidable set in [Set] *) Module DecidableEqDepSet (M:DecidableSet). @@ -307,11 +307,11 @@ End DecidableEqDepSet. (** From decidability to inj_pair2 **) Lemma inj_pair2_eq_dec : forall A:Type, (forall x y:A, {x=y}+{x<>y}) -> ( forall (P:A -> Type) (p:A) (x y:P p), existT P p x = existT P p y -> x = y ). -Proof. +Proof. intros A eq_dec. apply eq_dep_eq__inj_pair2. apply eq_rect_eq__eq_dep_eq. - unfold Eq_rect_eq. + unfold Eq_rect_eq. apply eq_rect_eq_dec. apply eq_dec. Qed. diff --git a/theories/Logic/FunctionalExtensionality.v b/theories/Logic/FunctionalExtensionality.v index 31b633c25d..bf29c63dda 100644 --- a/theories/Logic/FunctionalExtensionality.v +++ b/theories/Logic/FunctionalExtensionality.v @@ -13,7 +13,7 @@ (** The converse of functional extensionality. *) -Lemma equal_f : forall {A B : Type} {f g : A -> B}, +Lemma equal_f : forall {A B : Type} {f g : A -> B}, f = g -> forall x, f x = g x. Proof. intros. @@ -23,11 +23,11 @@ Qed. (** Statements of functional extensionality for simple and dependent functions. *) -Axiom functional_extensionality_dep : forall {A} {B : A -> Type}, - forall (f g : forall x : A, B x), +Axiom functional_extensionality_dep : forall {A} {B : A -> Type}, + forall (f g : forall x : A, B x), (forall x, f x = g x) -> f = g. -Lemma functional_extensionality {A B} (f g : A -> B) : +Lemma functional_extensionality {A B} (f g : A -> B) : (forall x, f x = g x) -> f = g. Proof. intros ; eauto using @functional_extensionality_dep. @@ -37,8 +37,8 @@ Qed. Tactic Notation "extensionality" ident(x) := match goal with - [ |- ?X = ?Y ] => - (apply (@functional_extensionality _ _ X Y) || + [ |- ?X = ?Y ] => + (apply (@functional_extensionality _ _ X Y) || apply (@functional_extensionality_dep _ _ X Y)) ; intro x end. @@ -51,7 +51,7 @@ Proof. extensionality x. reflexivity. Qed. - + Lemma eta_expansion {A B} (f : A -> B) : f = fun x => f x. Proof. intros A B f. apply (eta_expansion_dep f). diff --git a/theories/Logic/IndefiniteDescription.v b/theories/Logic/IndefiniteDescription.v index ce9405f85a..3651c1b2fa 100644 --- a/theories/Logic/IndefiniteDescription.v +++ b/theories/Logic/IndefiniteDescription.v @@ -19,11 +19,11 @@ Require Import ChoiceFacts. Set Implicit Arguments. Axiom constructive_indefinite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists x, P x) -> { x : A | P x }. Lemma constructive_definite_description : - forall (A : Type) (P : A->Prop), + forall (A : Type) (P : A->Prop), (exists! x, P x) -> { x : A | P x }. Proof. intros; apply constructive_indefinite_description; firstorder. diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 7d9e11296f..127be11348 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -43,13 +43,13 @@ Qed. Axiom JMeq_eq : forall (A:Type) (x y:A), JMeq x y -> x = y. -Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop), +Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y, JMeq x y -> P y. Proof. intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. Qed. -Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set), +Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set), P x -> forall y, JMeq x y -> P y. Proof. intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. @@ -61,7 +61,7 @@ Proof. intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. Qed. -Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), +Lemma JMeq_ind_r : forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y, JMeq y x -> P y. Proof. intros A x P H y H'; case JMeq_eq with (1 := JMeq_sym H'); trivial. diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v index dd3178ebec..4c48d95cd8 100644 --- a/theories/Logic/ProofIrrelevanceFacts.v +++ b/theories/Logic/ProofIrrelevanceFacts.v @@ -21,8 +21,8 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). (** Proof-irrelevance implies uniqueness of reflexivity proofs *) Module Eq_rect_eq. - Lemma eq_rect_eq : - forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), + Lemma eq_rect_eq : + forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. Proof. intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=refl_equal p). diff --git a/theories/Logic/RelationalChoice.v b/theories/Logic/RelationalChoice.v index 9ad6b7220d..49fa122248 100644 --- a/theories/Logic/RelationalChoice.v +++ b/theories/Logic/RelationalChoice.v @@ -13,5 +13,5 @@ Axiom relational_choice : forall (A B : Type) (R : A->B->Prop), (forall x : A, exists y : B, R x y) -> - exists R' : A->B->Prop, + exists R' : A->B->Prop, subrelation R' R /\ forall x : A, exists! y : B, R' x y. diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index eaf3f126ab..e02f2817ce 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -45,7 +45,7 @@ Definition Ndouble_plus_one x := (** Operation x -> 2*x *) -Definition Ndouble n := +Definition Ndouble n := match n with | N0 => N0 | Npos p => Npos (xO p) @@ -130,12 +130,12 @@ Infix ">" := Ngt : N_scope. (** Min and max *) -Definition Nmin (n n' : N) := match Ncompare n n' with +Definition Nmin (n n' : N) := match Ncompare n n' with | Lt | Eq => n | Gt => n' end. -Definition Nmax (n n' : N) := match Ncompare n n' with +Definition Nmax (n n' : N) := match Ncompare n n' with | Lt | Eq => n' | Gt => n end. @@ -149,7 +149,7 @@ Lemma N_ind_double : (forall a, P a -> P (Ndouble_plus_one a)) -> P a. Proof. intros; elim a. trivial. - simple induction p. intros. + simple induction p. intros. apply (H1 (Npos p0)); trivial. intros; apply (H0 (Npos p0)); trivial. intros; apply (H1 N0); assumption. @@ -162,7 +162,7 @@ Lemma N_rec_double : (forall a, P a -> P (Ndouble_plus_one a)) -> P a. Proof. intros; elim a. trivial. - simple induction p. intros. + simple induction p. intros. apply (H1 (Npos p0)); trivial. intros; apply (H0 (Npos p0)); trivial. intros; apply (H1 N0); assumption. @@ -354,7 +354,7 @@ destruct p; intros Hp H. contradiction Hp; reflexivity. destruct n; destruct m; reflexivity || (try discriminate H). injection H; clear H; intro H; rewrite Pmult_reg_r with (1 := H); reflexivity. -Qed. +Qed. (** Properties of comparison *) @@ -373,7 +373,7 @@ Qed. Theorem Ncompare_eq_correct : forall n m:N, (n ?= m) = Eq <-> n = m. Proof. -split; intros; +split; intros; [ apply Ncompare_Eq_eq; auto | subst; apply Ncompare_refl ]. Qed. diff --git a/theories/NArith/BinPos.v b/theories/NArith/BinPos.v index af281b73f1..21ff55c195 100644 --- a/theories/NArith/BinPos.v +++ b/theories/NArith/BinPos.v @@ -32,15 +32,15 @@ Bind Scope positive_scope with positive. Arguments Scope xO [positive_scope]. Arguments Scope xI [positive_scope]. -(** Postfix notation for positive numbers, allowing to mimic - the position of bits in a big-endian representation. - For instance, we can write 1~1~0 instead of (xO (xI xH)) +(** Postfix notation for positive numbers, allowing to mimic + the position of bits in a big-endian representation. + For instance, we can write 1~1~0 instead of (xO (xI xH)) for the number 6 (which is 110 in binary notation). *) -Notation "p ~ 1" := (xI p) +Notation "p ~ 1" := (xI p) (at level 7, left associativity, format "p '~' '1'") : positive_scope. -Notation "p ~ 0" := (xO p) +Notation "p ~ 0" := (xO p) (at level 7, left associativity, format "p '~' '0'") : positive_scope. Open Local Scope positive_scope. @@ -76,7 +76,7 @@ Fixpoint Pplus (x y:positive) : positive := | 1, q~0 => q~1 | 1, 1 => 1~0 end - + with Pplus_carry (x y:positive) : positive := match x, y with | p~1, q~1 => (Pplus_carry p q)~1 @@ -178,7 +178,7 @@ Fixpoint Pminus_mask (x y:positive) {struct y} : positive_mask := | 1, 1 => IsNul | 1, _ => IsNeg end - + with Pminus_mask_carry (x y:positive) {struct y} : positive_mask := match x, y with | p~1, q~1 => Pdouble_plus_one_mask (Pminus_mask_carry p q) @@ -255,13 +255,13 @@ Notation "x < y < z" := (x < y /\ y < z) : positive_scope. Notation "x < y <= z" := (x < y /\ y <= z) : positive_scope. -Definition Pmin (p p' : positive) := match Pcompare p p' Eq with - | Lt | Eq => p +Definition Pmin (p p' : positive) := match Pcompare p p' Eq with + | Lt | Eq => p | Gt => p' end. -Definition Pmax (p p' : positive) := match Pcompare p p' Eq with - | Lt | Eq => p' +Definition Pmax (p p' : positive) := match Pcompare p p' Eq with + | Lt | Eq => p' | Gt => p end. @@ -380,14 +380,14 @@ Theorem Pplus_comm : forall p q:positive, p + q = q + p. Proof. induction p; destruct q; simpl; f_equal; auto. rewrite 2 Pplus_carry_spec; f_equal; auto. -Qed. +Qed. (** Permutation of [Pplus] and [Psucc] *) Theorem Pplus_succ_permute_r : forall p q:positive, p + Psucc q = Psucc (p + q). Proof. - induction p; destruct q; simpl; f_equal; + induction p; destruct q; simpl; f_equal; auto using Pplus_one_succ_r; rewrite Pplus_carry_spec; auto. Qed. @@ -432,10 +432,10 @@ Qed. Lemma Pplus_reg_r : forall p q r:positive, p + r = q + r -> p = q. Proof. intros p q r; revert p q; induction r. - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; - f_equal; auto using Pplus_carry_plus; + intros [p|p| ] [q|q| ] H; simpl; destr_eq H; + f_equal; auto using Pplus_carry_plus; contradict H; auto using Pplus_carry_no_neutral. - intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto; + intros [p|p| ] [q|q| ] H; simpl; destr_eq H; f_equal; auto; contradict H; auto using Pplus_no_neutral. intros p q H; apply Psucc_inj; do 2 rewrite Pplus_one_succ_r; assumption. Qed. @@ -465,11 +465,11 @@ Qed. Theorem Pplus_assoc : forall p q r:positive, p + (q + r) = p + q + r. Proof. induction p. - intros [q|q| ] [r|r| ]; simpl; f_equal; auto; - rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, + intros [q|q| ] [r|r| ]; simpl; f_equal; auto; + rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, ?Pplus_succ_permute_l, ?Pplus_one_succ_r; f_equal; auto. intros [q|q| ] [r|r| ]; simpl; f_equal; auto; - rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, + rewrite ?Pplus_carry_spec, ?Pplus_succ_permute_r, ?Pplus_succ_permute_l, ?Pplus_one_succ_r; f_equal; auto. intros p r; rewrite <- 2 Pplus_one_succ_l, Pplus_succ_permute_l; auto. Qed. @@ -493,7 +493,7 @@ Lemma Pplus_xO_double_minus_one : forall p q:positive, Pdouble_minus_one (p + q) = p~0 + Pdouble_minus_one q. Proof. induction p as [p IHp| p IHp| ]; destruct q; simpl; - rewrite ?Pplus_carry_spec, ?Pdouble_minus_one_o_succ_eq_xI, + rewrite ?Pplus_carry_spec, ?Pdouble_minus_one_o_succ_eq_xI, ?Pplus_xI_double_minus_one; try reflexivity. rewrite IHp; auto. rewrite <- Psucc_o_double_minus_one_eq_xO, Pplus_one_succ_l; reflexivity. @@ -503,7 +503,7 @@ Qed. Lemma Pplus_diag : forall p:positive, p + p = p~0. Proof. - induction p as [p IHp| p IHp| ]; simpl; + induction p as [p IHp| p IHp| ]; simpl; try rewrite ?Pplus_carry_spec, ?IHp; reflexivity. Qed. @@ -534,10 +534,10 @@ Fixpoint peanoView p : PeanoView p := | p~1 => peanoView_xI p (peanoView p) end. -Definition PeanoView_iter (P:positive->Type) +Definition PeanoView_iter (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p)) := (fix iter p (q:PeanoView p) : P p := - match q in PeanoView p return P p with + match q in PeanoView p return P p with | PeanoOne => a | PeanoSucc _ q => f _ (iter _ q) end). @@ -545,23 +545,23 @@ Definition PeanoView_iter (P:positive->Type) Require Import Eqdep_dec EqdepFacts. Theorem eq_dep_eq_positive : - forall (P:positive->Type) (p:positive) (x y:P p), + forall (P:positive->Type) (p:positive) (x y:P p), eq_dep positive P p x p y -> x = y. Proof. apply eq_dep_eq_dec. decide equality. Qed. -Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'. +Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'. Proof. - intros. + intros. induction q as [ | p q IHq ]. apply eq_dep_eq_positive. cut (1=1). pattern 1 at 1 2 5, q'. destruct q'. trivial. destruct p0; intros; discriminate. trivial. apply eq_dep_eq_positive. - cut (Psucc p=Psucc p). pattern (Psucc p) at 1 2 5, q'. destruct q'. + cut (Psucc p=Psucc p). pattern (Psucc p) at 1 2 5, q'. destruct q'. intro. destruct p; discriminate. intro. unfold p0 in H. apply Psucc_inj in H. generalize q'. rewrite H. intro. @@ -570,12 +570,12 @@ Proof. trivial. Qed. -Definition Prect (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p)) +Definition Prect (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p)) (p:positive) := PeanoView_iter P a f p (peanoView p). -Theorem Prect_succ : forall (P:positive->Type) (a:P 1) - (f:forall p, P p -> P (Psucc p)) (p:positive), +Theorem Prect_succ : forall (P:positive->Type) (a:P 1) + (f:forall p, P p -> P (Psucc p)) (p:positive), Prect P a f (Psucc p) = f _ (Prect P a f p). Proof. intros. @@ -584,7 +584,7 @@ Proof. trivial. Qed. -Theorem Prect_base : forall (P:positive->Type) (a:P 1) +Theorem Prect_base : forall (P:positive->Type) (a:P 1) (f:forall p, P p -> P (Psucc p)), Prect P a f 1 = a. Proof. trivial. @@ -744,7 +744,7 @@ Qed. Theorem Pcompare_Eq_eq : forall p q:positive, (p ?= q) Eq = Eq -> p = q. Proof. - induction p; intros [q| q| ] H; simpl in *; auto; + induction p; intros [q| q| ] H; simpl in *; auto; try discriminate H; try (f_equal; auto; fail). destruct (Pcompare_not_Eq p q) as (H',_); elim H'; auto. destruct (Pcompare_not_Eq p q) as (_,H'); elim H'; auto. @@ -821,7 +821,7 @@ Lemma Pcompare_antisym : forall (p q:positive) (r:comparison), CompOpp ((p ?= q) r) = (q ?= p) (CompOpp r). Proof. - induction p as [p IHp|p IHp| ]; intros [q|q| ] r; simpl; auto; + induction p as [p IHp|p IHp| ]; intros [q|q| ] r; simpl; auto; rewrite IHp; auto. Qed. @@ -949,14 +949,14 @@ Qed. Theorem Pminus_mask_carry_spec : forall p q : positive, Pminus_mask_carry p q = Ppred_mask (Pminus_mask p q). Proof. - induction p as [p IHp|p IHp| ]; destruct q; simpl; + induction p as [p IHp|p IHp| ]; destruct q; simpl; try reflexivity; try rewrite IHp; destruct (Pminus_mask p q) as [|[r|r| ]|] || destruct p; auto. Qed. Theorem Pminus_succ_r : forall p q : positive, p - (Psucc q) = Ppred (p - q). Proof. - intros p q; unfold Pminus; + intros p q; unfold Pminus; rewrite Pminus_mask_succ_r, Pminus_mask_carry_spec. destruct (Pminus_mask p q) as [|[r|r| ]|]; auto. Qed. @@ -995,11 +995,11 @@ Proof. induction p as [p IHp| p IHp| ]; simpl; try rewrite IHp; auto. Qed. -Lemma Pminus_mask_IsNeg : forall p q:positive, +Lemma Pminus_mask_IsNeg : forall p q:positive, Pminus_mask p q = IsNeg -> Pminus_mask_carry p q = IsNeg. Proof. - induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *; auto; - try discriminate; unfold Pdouble_mask, Pdouble_plus_one_mask in H; + induction p as [p IHp|p IHp| ]; intros [q|q| ] H; simpl in *; auto; + try discriminate; unfold Pdouble_mask, Pdouble_plus_one_mask in H; specialize IHp with q. destruct (Pminus_mask p q); try discriminate; rewrite IHp; auto. destruct (Pminus_mask p q); simpl; auto; try discriminate. @@ -1028,9 +1028,9 @@ Lemma Pminus_mask_Gt : Pminus_mask p q = IsPos h /\ q + h = p /\ (h = 1 \/ Pminus_mask_carry p q = IsPos (Ppred h)). Proof. - induction p as [p IHp| p IHp| ]; intros [q| q| ] H; simpl in *; + induction p as [p IHp| p IHp| ]; intros [q| q| ] H; simpl in *; try discriminate H. - (* p~1, q~1 *) + (* p~1, q~1 *) destruct (IHp q H) as (r & U & V & W); exists (r~0); rewrite ?U, ?V; auto. repeat split; auto; right. destruct (ZL11 r) as [EQ|NE]; [|destruct W as [|W]; [elim NE; auto|]]. @@ -1091,10 +1091,10 @@ Qed. (** Number of digits in a number *) -Fixpoint Psize (p:positive) : nat := - match p with +Fixpoint Psize (p:positive) : nat := + match p with | 1 => S O - | p~1 => S (Psize p) + | p~1 => S (Psize p) | p~0 => S (Psize p) end. diff --git a/theories/NArith/Ndec.v b/theories/NArith/Ndec.v index e9bc4b2669..ef381c7f26 100644 --- a/theories/NArith/Ndec.v +++ b/theories/NArith/Ndec.v @@ -45,7 +45,7 @@ Proof. Qed. Lemma Pcompare_Peqb : forall p p', Pcompare p p' Eq = Eq -> Peqb p p' = true. -Proof. +Proof. intros; rewrite <- (Pcompare_Eq_eq _ _ H). apply Peqb_correct. Qed. @@ -69,7 +69,7 @@ Proof. Qed. Lemma Ncompare_Neqb : forall n n', Ncompare n n' = Eq -> Neqb n n' = true. -Proof. +Proof. intros; rewrite <- (Ncompare_Eq_eq _ _ H). apply Neqb_correct. Qed. @@ -107,7 +107,7 @@ Lemma Nodd_not_double : Nodd a -> forall a0, Neqb (Ndouble a0) a = false. Proof. intros. elim (sumbool_of_bool (Neqb (Ndouble a0) a)). intro H0. - rewrite <- (Neqb_complete _ _ H0) in H. + rewrite <- (Neqb_complete _ _ H0) in H. unfold Nodd in H. rewrite (Ndouble_bit0 a0) in H. discriminate H. trivial. @@ -128,7 +128,7 @@ Lemma Neven_not_double_plus_one : Neven a -> forall a0, Neqb (Ndouble_plus_one a0) a = false. Proof. intros. elim (sumbool_of_bool (Neqb (Ndouble_plus_one a0) a)). intro H0. - rewrite <- (Neqb_complete _ _ H0) in H. + rewrite <- (Neqb_complete _ _ H0) in H. unfold Neven in H. rewrite (Ndouble_plus_one_bit0 a0) in H. discriminate H. @@ -391,8 +391,8 @@ Lemma Nmin_Nmin' : forall a b, Nmin a b = Nmin' a b. Proof. unfold Nmin, Nmin', Nleb; intros. rewrite nat_of_Ncompare. - generalize (leb_compare (nat_of_N a) (nat_of_N b)); - destruct (nat_compare (nat_of_N a) (nat_of_N b)); + generalize (leb_compare (nat_of_N a) (nat_of_N b)); + destruct (nat_compare (nat_of_N a) (nat_of_N b)); destruct (leb (nat_of_N a) (nat_of_N b)); intuition. lapply H1; intros; discriminate. lapply H1; intros; discriminate. @@ -421,7 +421,7 @@ Qed. Lemma Nmin_le_3 : forall a b c, Nleb a (Nmin b c) = true -> Nleb a b = true. Proof. - intros; rewrite Nmin_Nmin' in *. + intros; rewrite Nmin_Nmin' in *. unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. assumption. intro H0. rewrite H0 in H. apply Nltb_leb_weak. apply Nleb_ltb_trans with (b := c); assumption. @@ -430,7 +430,7 @@ Qed. Lemma Nmin_le_4 : forall a b c, Nleb a (Nmin b c) = true -> Nleb a c = true. Proof. - intros; rewrite Nmin_Nmin' in *. + intros; rewrite Nmin_Nmin' in *. unfold Nmin' in *; elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. apply Nleb_trans with (b := b); assumption. intro H0. rewrite H0 in H. assumption. @@ -447,7 +447,7 @@ Qed. Lemma Nmin_lt_3 : forall a b c, Nleb (Nmin b c) a = false -> Nleb b a = false. Proof. - intros; rewrite Nmin_Nmin' in *. + intros; rewrite Nmin_Nmin' in *. unfold Nmin' in *. intros. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. assumption. intro H0. rewrite H0 in H. apply Nltb_trans with (b := c); assumption. @@ -456,7 +456,7 @@ Qed. Lemma Nmin_lt_4 : forall a b c, Nleb (Nmin b c) a = false -> Nleb c a = false. Proof. - intros; rewrite Nmin_Nmin' in *. + intros; rewrite Nmin_Nmin' in *. unfold Nmin' in *. elim (sumbool_of_bool (Nleb b c)). intro H0. rewrite H0 in H. apply Nltb_leb_trans with (b := b); assumption. intro H0. rewrite H0 in H. assumption. diff --git a/theories/NArith/Ndigits.v b/theories/NArith/Ndigits.v index ea5f02bba9..b1f2668e6a 100644 --- a/theories/NArith/Ndigits.v +++ b/theories/NArith/Ndigits.v @@ -27,7 +27,7 @@ Fixpoint Pxor (p1 p2:positive) {struct p1} : N := | xO p1, xI p2 => Ndouble_plus_one (Pxor p1 p2) | xI p1, xH => Npos (xO p1) | xI p1, xO p2 => Ndouble_plus_one (Pxor p1 p2) - | xI p1, xI p2 => Ndouble (Pxor p1 p2) + | xI p1, xI p2 => Ndouble (Pxor p1 p2) end. Definition Nxor (n n':N) := @@ -65,7 +65,7 @@ Proof. simpl. rewrite IHp; reflexivity. Qed. -(** Checking whether a particular bit is set on not *) +(** Checking whether a particular bit is set on not *) Fixpoint Pbit (p:positive) : nat -> bool := match p with @@ -134,13 +134,13 @@ Qed. (** End of auxilliary results *) -(** This part is aimed at proving that if two numbers produce +(** This part is aimed at proving that if two numbers produce the same stream of bits, then they are equal. *) Lemma Nbit_faithful_1 : forall a:N, eqf (Nbit N0) (Nbit a) -> N0 = a. Proof. destruct a. trivial. - induction p as [p IHp| p IHp| ]; intro H. + induction p as [p IHp| p IHp| ]; intro H. absurd (N0 = Npos p). discriminate. exact (IHp (fun n => H (S n))). absurd (N0 = Npos p). discriminate. @@ -196,7 +196,7 @@ Proof. assert (Npos p = Npos p') by exact (IHp (Npos p') H0). inversion H1. reflexivity. assumption. - intros. apply Nbit_faithful_3. intros. + intros. apply Nbit_faithful_3. intros. assert (Npos p = Npos p') by exact (IHp (Npos p') H0). inversion H1. reflexivity. assumption. @@ -257,7 +257,7 @@ Proof. generalize (fun p1 p2 => H (Npos p1) (Npos p2)); clear H; intro H. unfold xorf in *. destruct a as [|p]. simpl Nbit; rewrite false_xorb. reflexivity. - destruct a' as [|p0]. + destruct a' as [|p0]. simpl Nbit; rewrite xorb_false. reflexivity. destruct p. destruct p0; simpl Nbit in *. rewrite <- H; simpl; case (Pxor p p0); trivial. @@ -273,13 +273,13 @@ Qed. Lemma Nxor_semantics : forall a a':N, eqf (Nbit (Nxor a a')) (xorf (Nbit a) (Nbit a')). Proof. - unfold eqf. intros; generalize a, a'. induction n. + unfold eqf. intros; generalize a, a'. induction n. apply Nxor_sem_5. apply Nxor_sem_6; assumption. Qed. -(** Consequences: +(** Consequences: - only equal numbers lead to a null xor - - xor is associative + - xor is associative *) Lemma Nxor_eq : forall a a':N, Nxor a a' = N0 -> a = a'. @@ -306,7 +306,7 @@ Proof. apply eqf_sym, Nxor_semantics. Qed. -(** Checking whether a number is odd, i.e. +(** Checking whether a number is odd, i.e. if its lower bit is set. *) Definition Nbit0 (n:N) := @@ -380,8 +380,8 @@ Lemma Nneg_bit0 : forall a a':N, Nbit0 (Nxor a a') = true -> Nbit0 a = negb (Nbit0 a'). Proof. - intros. - rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false. + intros. + rewrite <- true_xorb, <- H, Nxor_bit0, xorb_assoc, xorb_nilpotent, xorb_false. reflexivity. Qed. @@ -402,7 +402,7 @@ Lemma Nsame_bit0 : forall (a a':N) (p:positive), Nxor a a' = Npos (xO p) -> Nbit0 a = Nbit0 a'. Proof. - intros. rewrite <- (xorb_false (Nbit0 a)). + intros. rewrite <- (xorb_false (Nbit0 a)). assert (H0: Nbit0 (Npos (xO p)) = false) by reflexivity. rewrite <- H0, <- H, Nxor_bit0, <- xorb_assoc, xorb_nilpotent, false_xorb. reflexivity. Qed. @@ -430,7 +430,7 @@ Proof. assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity). rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1. simpl. rewrite H, H0. reflexivity. - assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). + assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2. Qed. @@ -443,7 +443,7 @@ Proof. assert (H1: Nbit0 (Nxor a a') = false) by (rewrite H2; reflexivity). rewrite (Nxor_bit0 a a'), H, H0 in H1. discriminate H1. simpl. rewrite H, H0. reflexivity. - assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). + assert (H2: Nbit0 (Nxor a a') = false) by (rewrite H1; reflexivity). rewrite (Nxor_bit0 a a'), H, H0 in H2. discriminate H2. Qed. @@ -534,7 +534,7 @@ Proof. rewrite (Nless_def_2 a' a'') in H0. rewrite (Nless_def_2 a a') in H. rewrite (Nless_def_2 a a''). exact (IHa _ _ H H0). Qed. - + Lemma Nless_total : forall a a', {Nless a a' = true} + {Nless a' a = true} + {a = a'}. Proof. @@ -558,7 +558,7 @@ Qed. (** Number of digits in a number *) -Definition Nsize (n:N) : nat := match n with +Definition Nsize (n:N) : nat := match n with | N0 => 0%nat | Npos p => Psize p end. @@ -566,35 +566,35 @@ Definition Nsize (n:N) : nat := match n with (** conversions between N and bit vectors. *) -Fixpoint P2Bv (p:positive) : Bvector (Psize p) := - match p return Bvector (Psize p) with +Fixpoint P2Bv (p:positive) : Bvector (Psize p) := + match p return Bvector (Psize p) with | xH => Bvect_true 1%nat | xO p => Bcons false (Psize p) (P2Bv p) | xI p => Bcons true (Psize p) (P2Bv p) end. Definition N2Bv (n:N) : Bvector (Nsize n) := - match n as n0 return Bvector (Nsize n0) with + match n as n0 return Bvector (Nsize n0) with | N0 => Bnil | Npos p => P2Bv p end. -Fixpoint Bv2N (n:nat)(bv:Bvector n) {struct bv} : N := - match bv with +Fixpoint Bv2N (n:nat)(bv:Bvector n) {struct bv} : N := + match bv with | Vnil => N0 | Vcons false n bv => Ndouble (Bv2N n bv) - | Vcons true n bv => Ndouble_plus_one (Bv2N n bv) + | Vcons true n bv => Ndouble_plus_one (Bv2N n bv) end. Lemma Bv2N_N2Bv : forall n, Bv2N _ (N2Bv n) = n. -Proof. +Proof. destruct n. simpl; auto. induction p; simpl in *; auto; rewrite IHp; simpl; auto. Qed. -(** The opposite composition is not so simple: if the considered - bit vector has some zeros on its right, they will disappear during +(** The opposite composition is not so simple: if the considered + bit vector has some zeros on its right, they will disappear during the return [Bv2N] translation: *) Lemma Bv2N_Nsize : forall n (bv:Bvector n), Nsize (Bv2N n bv) <= n. @@ -603,16 +603,16 @@ induction n; intros. rewrite (V0_eq _ bv); simpl; auto. rewrite (VSn_eq _ _ bv); simpl. specialize IHn with (Vtail _ _ bv). -destruct (Vhead _ _ bv); - destruct (Bv2N n (Vtail bool n bv)); +destruct (Vhead _ _ bv); + destruct (Bv2N n (Vtail bool n bv)); simpl; auto with arith. Qed. (** In the previous lemma, we can only replace the inequality by an equality whenever the highest bit is non-null. *) -Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)), - Bsign _ bv = true <-> +Lemma Bv2N_Nsize_1 : forall n (bv:Bvector (S n)), + Bsign _ bv = true <-> Nsize (Bv2N _ bv) = (S n). Proof. induction n; intro. @@ -621,18 +621,18 @@ rewrite (V0_eq _ (Vtail _ _ bv)); simpl. destruct (Vhead _ _ bv); simpl; intuition; try discriminate. rewrite (VSn_eq _ _ bv); simpl. generalize (IHn (Vtail _ _ bv)); clear IHn. -destruct (Vhead _ _ bv); - destruct (Bv2N (S n) (Vtail bool (S n) bv)); +destruct (Vhead _ _ bv); + destruct (Bv2N (S n) (Vtail bool (S n) bv)); simpl; intuition; try discriminate. Qed. -(** To state nonetheless a second result about composition of - conversions, we define a conversion on a given number of bits : *) +(** To state nonetheless a second result about composition of + conversions, we define a conversion on a given number of bits : *) -Fixpoint N2Bv_gen (n:nat)(a:N) { struct n } : Bvector n := - match n return Bvector n with +Fixpoint N2Bv_gen (n:nat)(a:N) { struct n } : Bvector n := + match n return Bvector n with | 0 => Bnil - | S n => match a with + | S n => match a with | N0 => Bvect_false (S n) | Npos xH => Bcons true _ (Bvect_false n) | Npos (xO p) => Bcons false _ (N2Bv_gen n (Npos p)) @@ -649,10 +649,10 @@ auto. induction p; simpl; intros; auto; congruence. Qed. -(** In fact, if [k] is large enough, [N2Bv_gen k a] contains all digits of +(** In fact, if [k] is large enough, [N2Bv_gen k a] contains all digits of [a] plus some zeros. *) -Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat), +Lemma N2Bv_N2Bv_gen_above : forall (a:N)(k:nat), N2Bv_gen (Nsize a + k) a = Vextend _ _ _ (N2Bv a) (Bvect_false k). Proof. destruct a; simpl. @@ -662,7 +662,7 @@ Qed. (** Here comes now the second composition result. *) -Lemma N2Bv_Bv2N : forall n (bv:Bvector n), +Lemma N2Bv_Bv2N : forall n (bv:Bvector n), N2Bv_gen n (Bv2N n bv) = bv. Proof. induction n; intros. @@ -670,21 +670,21 @@ rewrite (V0_eq _ bv); simpl; auto. rewrite (VSn_eq _ _ bv); simpl. generalize (IHn (Vtail _ _ bv)); clear IHn. unfold Bcons. -destruct (Bv2N _ (Vtail _ _ bv)); - destruct (Vhead _ _ bv); intro H; rewrite <- H; simpl; trivial; +destruct (Bv2N _ (Vtail _ _ bv)); + destruct (Vhead _ _ bv); intro H; rewrite <- H; simpl; trivial; induction n; simpl; auto. Qed. (** accessing some precise bits. *) -Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), +Lemma Nbit0_Blow : forall n, forall (bv:Bvector (S n)), Nbit0 (Bv2N _ bv) = Blow _ bv. Proof. intros. unfold Blow. rewrite (VSn_eq _ _ bv) at 1. simpl. -destruct (Bv2N n (Vtail bool n bv)); simpl; +destruct (Bv2N n (Vtail bool n bv)); simpl; destruct (Vhead bool n bv); auto. Qed. @@ -699,7 +699,7 @@ Proof. apply (IHbv p); auto with arith. Defined. -Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p a = N0. Proof. - simple induction a; trivial. + simple induction a; trivial. unfold Nplength in |- *; intros; discriminate H. Qed. @@ -42,7 +42,7 @@ Lemma Nplength_zeros : forall (a:N) (n:nat), Nplength a = ni n -> forall k:nat, k < n -> Nbit a k = false. Proof. - simple induction a; trivial. + simple induction a; trivial. simple induction p. simple induction n. intros. inversion H1. simple induction k. simpl in H1. discriminate H1. intros. simpl in H1. discriminate H1. @@ -116,11 +116,11 @@ Qed. Lemma ni_min_assoc : forall d d' d'':natinf, ni_min (ni_min d d') d'' = ni_min d (ni_min d' d''). Proof. - simple induction d; trivial. simple induction d'; trivial. + simple induction d; trivial. simple induction d'; trivial. simple induction d''; trivial. unfold ni_min in |- *. intro. cut (min (min n n0) n1 = min n (min n0 n1)). intro. rewrite H. reflexivity. - generalize n0 n1. elim n; trivial. + generalize n0 n1. elim n; trivial. simple induction n3; trivial. simple induction n5; trivial. intros. simpl in |- *. auto. Qed. @@ -250,10 +250,10 @@ Proof. Qed. -(** We define an ultrametric distance between [N] numbers: - $d(a,a')=1/2^pd(a,a')$, - where $pd(a,a')$ is the number of identical bits at the beginning - of $a$ and $a'$ (infinity if $a=a'$). +(** We define an ultrametric distance between [N] numbers: + $d(a,a')=1/2^pd(a,a')$, + where $pd(a,a')$ is the number of identical bits at the beginning + of $a$ and $a'$ (infinity if $a=a'$). Instead of working with $d$, we work with $pd$, namely [Npdist]: *) @@ -286,7 +286,7 @@ Qed. This follows from the fact that $a ~Ra~|a| = 1/2^{\texttt{Nplength}}(a))$ is an ultrametric norm, i.e. that $|a-a'| \leq max (|a-a''|, |a''-a'|)$, or equivalently that $|a+b|<=max(|a|,|b|)$, i.e. that - min $(\texttt{Nplength}(a), \texttt{Nplength}(b)) \leq + min $(\texttt{Nplength}(a), \texttt{Nplength}(b)) \leq \texttt{Nplength} (a~\texttt{xor}~ b)$ (lemma [Nplength_ultra]). *) diff --git a/theories/NArith/Nnat.v b/theories/NArith/Nnat.v index 36a1f1d8ff..0016d035fc 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -39,7 +39,7 @@ Definition N_of_nat (n:nat) := Lemma N_of_nat_of_N : forall a:N, N_of_nat (nat_of_N a) = a. Proof. destruct a as [| p]. reflexivity. - simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *. + simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *. rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H. rewrite nat_of_P_inj with (1 := H). reflexivity. Qed. @@ -66,14 +66,14 @@ Proof. apply N_of_nat_of_N. Qed. -Lemma nat_of_Ndouble_plus_one : +Lemma nat_of_Ndouble_plus_one : forall a, nat_of_N (Ndouble_plus_one a) = S (2*(nat_of_N a)). Proof. destruct a; simpl nat_of_N; auto. apply nat_of_P_xI. Qed. -Lemma N_of_double_plus_one : +Lemma N_of_double_plus_one : forall n, N_of_nat (S (2*n)) = Ndouble_plus_one (N_of_nat n). Proof. intros. @@ -97,14 +97,14 @@ Proof. apply N_of_nat_of_N. Qed. -Lemma nat_of_Nplus : +Lemma nat_of_Nplus : forall a a', nat_of_N (Nplus a a') = (nat_of_N a)+(nat_of_N a'). Proof. destruct a; destruct a'; simpl; auto. apply nat_of_P_plus_morphism. Qed. -Lemma N_of_plus : +Lemma N_of_plus : forall n n', N_of_nat (n+n') = Nplus (N_of_nat n) (N_of_nat n'). Proof. intros. @@ -138,14 +138,14 @@ Proof. apply N_of_nat_of_N. Qed. -Lemma nat_of_Nmult : +Lemma nat_of_Nmult : forall a a', nat_of_N (Nmult a a') = (nat_of_N a)*(nat_of_N a'). Proof. destruct a; destruct a'; simpl; auto. apply nat_of_P_mult_morphism. Qed. -Lemma N_of_mult : +Lemma N_of_mult : forall n n', N_of_nat (n*n') = Nmult (N_of_nat n) (N_of_nat n'). Proof. intros. @@ -155,7 +155,7 @@ Proof. apply N_of_nat_of_N. Qed. -Lemma nat_of_Ndiv2 : +Lemma nat_of_Ndiv2 : forall a, nat_of_N (Ndiv2 a) = div2 (nat_of_N a). Proof. destruct a; simpl in *; auto. @@ -164,9 +164,9 @@ Proof. rewrite div2_double_plus_one; auto. rewrite nat_of_P_xO. rewrite div2_double; auto. -Qed. +Qed. -Lemma N_of_div2 : +Lemma N_of_div2 : forall n, N_of_nat (div2 n) = Ndiv2 (N_of_nat n). Proof. intros. @@ -175,7 +175,7 @@ Proof. apply N_of_nat_of_N. Qed. -Lemma nat_of_Ncompare : +Lemma nat_of_Ncompare : forall a a', Ncompare a a' = nat_compare (nat_of_N a) (nat_of_N a'). Proof. destruct a; destruct a'; simpl. @@ -187,7 +187,7 @@ Proof. apply nat_of_P_compare_morphism. Qed. -Lemma N_of_nat_compare : +Lemma N_of_nat_compare : forall n n', nat_compare n n' = Ncompare (N_of_nat n) (N_of_nat n'). Proof. intros. @@ -321,17 +321,17 @@ Qed. Lemma Z_of_N_of_nat : forall n:nat, Z_of_N (N_of_nat n) = Z_of_nat n. Proof. destruct n; simpl; auto. -Qed. +Qed. Lemma Z_of_N_pos : forall p:positive, Z_of_N (Npos p) = Zpos p. Proof. destruct p; simpl; auto. -Qed. +Qed. Lemma Z_of_N_abs : forall z:Z, Z_of_N (Zabs_N z) = Zabs z. Proof. destruct z; simpl; auto. -Qed. +Qed. Lemma Z_of_N_le_0 : forall n, (0 <= Z_of_N n)%Z. Proof. @@ -348,22 +348,22 @@ Proof. destruct n; destruct m; auto. Qed. -Lemma Z_of_N_minus : forall n m:N, Z_of_N (n-m) = Zmax 0 (Z_of_N n - Z_of_N m). +Lemma Z_of_N_minus : forall n m:N, Z_of_N (n-m) = Zmax 0 (Z_of_N n - Z_of_N m). Proof. intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nminus; apply inj_minus. Qed. -Lemma Z_of_N_succ : forall n:N, Z_of_N (Nsucc n) = Zsucc (Z_of_N n). +Lemma Z_of_N_succ : forall n:N, Z_of_N (Nsucc n) = Zsucc (Z_of_N n). Proof. intros; do 2 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nsucc; apply inj_S. Qed. -Lemma Z_of_N_min : forall n m:N, Z_of_N (Nmin n m) = Zmin (Z_of_N n) (Z_of_N m). +Lemma Z_of_N_min : forall n m:N, Z_of_N (Nmin n m) = Zmin (Z_of_N n) (Z_of_N m). Proof. intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmin; apply inj_min. Qed. -Lemma Z_of_N_max : forall n m:N, Z_of_N (Nmax n m) = Zmax (Z_of_N n) (Z_of_N m). +Lemma Z_of_N_max : forall n m:N, Z_of_N (Nmax n m) = Zmax (Z_of_N n) (Z_of_N m). Proof. intros; do 3 rewrite <- Z_of_nat_of_N; rewrite nat_of_Nmax; apply inj_max. Qed. diff --git a/theories/NArith/Pnat.v b/theories/NArith/Pnat.v index bf42c5e994..f989e01d01 100644 --- a/theories/NArith/Pnat.v +++ b/theories/NArith/Pnat.v @@ -11,7 +11,7 @@ Require Import BinPos. (**********************************************************************) -(** Properties of the injection from binary positive numbers to Peano +(** Properties of the injection from binary positive numbers to Peano natural numbers *) (** Original development by Pierre Crégut, CNET, Lannion, France *) @@ -50,7 +50,7 @@ Proof. intro x; induction x as [p IHp| p IHp| ]; intro y; [ destruct y as [p0| p0| ] | destruct y as [p0| p0| ] - | destruct y as [p| p| ] ]; simpl in |- *; auto with arith; + | destruct y as [p| p| ] ]; simpl in |- *; auto with arith; intro m; [ rewrite IHp; rewrite plus_assoc; trivial with arith | rewrite IHp; rewrite plus_assoc; trivial with arith @@ -75,11 +75,11 @@ intro x; induction x as [p IHp| p IHp| ]; intro y; | destruct y as [p| p| ] ]; simpl in |- *; auto with arith; [ intros m; rewrite Pmult_nat_plus_carry_morphism; rewrite IHp; rewrite plus_assoc_reverse; rewrite plus_assoc_reverse; - rewrite (plus_permute m (Pmult_nat p (m + m))); + rewrite (plus_permute m (Pmult_nat p (m + m))); trivial with arith | intros m; rewrite IHp; apply plus_assoc | intros m; rewrite Pmult_nat_succ_morphism; - rewrite (plus_comm (m + Pmult_nat p (m + m))); + rewrite (plus_comm (m + Pmult_nat p (m + m))); apply plus_assoc_reverse | intros m; rewrite IHp; apply plus_permute | intros m; rewrite Pmult_nat_succ_morphism; apply plus_assoc_reverse ]. @@ -110,7 +110,7 @@ Proof. intro p; change 2 with (1 + 1) in |- *; rewrite Pmult_nat_r_plus_morphism; trivial. Qed. - + (** [nat_of_P] is a morphism for multiplication *) Theorem nat_of_P_mult_morphism : @@ -133,11 +133,11 @@ Proof. intro y; induction y as [p H| p H| ]; [ destruct H as [x H1]; exists (S x + S x); unfold nat_of_P in |- *; simpl in |- *; change 2 with (1 + 1) in |- *; - rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H1; + rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H1; rewrite H1; auto with arith | destruct H as [x H2]; exists (x + S x); unfold nat_of_P in |- *; simpl in |- *; change 2 with (1 + 1) in |- *; - rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H2; + rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H2; rewrite H2; auto with arith | exists 0; auto with arith ]. Qed. @@ -182,7 +182,7 @@ intro x; induction x as [p H| p H| ]; intro y; destruct y as [q| q| ]; apply ZL7; apply H; assumption | simpl in |- *; discriminate H2 | unfold nat_of_P in |- *; simpl in |- *; apply lt_n_S; rewrite ZL6; - elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *; + elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *; apply lt_O_Sn | unfold nat_of_P in |- *; simpl in |- *; rewrite ZL6; elim (ZL4 q); intros h H3; rewrite H3; simpl in |- *; rewrite <- plus_n_Sm; @@ -314,7 +314,7 @@ Proof. Qed. (**********************************************************************) -(** Properties of the shifted injection from Peano natural numbers to +(** Properties of the shifted injection from Peano natural numbers to binary positive numbers *) (** Composition of [P_of_succ_nat] and [nat_of_P] is successor on [nat] *) @@ -366,7 +366,7 @@ intros; rewrite P_of_succ_nat_o_nat_of_P_eq_succ, Ppred_succ; auto. Qed. (**********************************************************************) -(** Extra properties of the injection from binary positive numbers to Peano +(** Extra properties of the injection from binary positive numbers to Peano natural numbers *) (** [nat_of_P] is a morphism for subtraction on positive numbers *) @@ -384,14 +384,14 @@ Qed. Lemma ZL16 : forall p q:positive, nat_of_P p - nat_of_P q < nat_of_P p. Proof. intros p q; elim (ZL4 p); elim (ZL4 q); intros h H1 i H2; rewrite H1; - rewrite H2; simpl in |- *; unfold lt in |- *; apply le_n_S; + rewrite H2; simpl in |- *; unfold lt in |- *; apply le_n_S; apply le_minus. Qed. Lemma ZL17 : forall p q:positive, nat_of_P p < nat_of_P (p + q). Proof. intros p q; rewrite nat_of_P_plus_morphism; unfold lt in |- *; elim (ZL4 q); - intros k H; rewrite H; rewrite plus_comm; simpl in |- *; + intros k H; rewrite H; rewrite plus_comm; simpl in |- *; apply le_n_S; apply le_plus_r. Qed. @@ -410,7 +410,7 @@ intros; apply nat_of_P_lt_Lt_compare_complement_morphism; [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p); rewrite plus_assoc; rewrite le_plus_minus_r; [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l; - apply nat_of_P_lt_Lt_compare_morphism; + apply nat_of_P_lt_Lt_compare_morphism; assumption | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption ] @@ -454,7 +454,7 @@ intros x y z H; apply nat_of_P_inj; rewrite nat_of_P_mult_morphism; [ do 2 rewrite nat_of_P_mult_morphism; do 3 rewrite (mult_comm (nat_of_P x)); apply mult_minus_distr_r | apply nat_of_P_gt_Gt_compare_complement_morphism; - do 2 rewrite nat_of_P_mult_morphism; unfold gt in |- *; + do 2 rewrite nat_of_P_mult_morphism; unfold gt in |- *; elim (ZL4 x); intros h H1; rewrite H1; apply mult_S_lt_compat_l; exact (nat_of_P_gt_Gt_compare_morphism y z H) ] | assumption ]. diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v index a08c6e62f9..3a64a8dc11 100644 --- a/theories/Numbers/BigNumPrelude.v +++ b/theories/Numbers/BigNumPrelude.v @@ -30,8 +30,8 @@ Declare ML Module "numbers_syntax_plugin". *) -Open Local Scope Z_scope. - +Open Local Scope Z_scope. + (* For compatibility of scripts, weaker version of some lemmas of Zdiv *) Lemma Zlt0_not_eq : forall n, 0 n<>0. @@ -45,14 +45,14 @@ Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H (* Automation *) -Hint Extern 2 (Zle _ _) => +Hint Extern 2 (Zle _ _) => (match goal with |- Zpos _ <= Zpos _ => exact (refl_equal _) | H: _ <= ?p |- _ <= ?p => apply Zle_trans with (2 := H) | H: _ < ?p |- _ <= ?p => apply Zlt_le_weak; apply Zle_lt_trans with (2 := H) end). -Hint Extern 2 (Zlt _ _) => +Hint Extern 2 (Zlt _ _) => (match goal with |- Zpos _ < Zpos _ => exact (refl_equal _) | H: _ <= ?p |- _ <= ?p => apply Zlt_le_trans with (2 := H) @@ -62,13 +62,13 @@ Hint Extern 2 (Zlt _ _) => Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. -(************************************** +(************************************** Properties of order and product **************************************) - Theorem beta_lex: forall a b c d beta, - a * beta + b <= c * beta + d -> - 0 <= b < beta -> 0 <= d < beta -> + Theorem beta_lex: forall a b c d beta, + a * beta + b <= c * beta + d -> + 0 <= b < beta -> 0 <= d < beta -> a <= c. Proof. intros a b c d beta H1 (H3, H4) (H5, H6). @@ -80,15 +80,15 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. Theorem beta_lex_inv: forall a b c d beta, a < c -> 0 <= b < beta -> - 0 <= d < beta -> - a * beta + b < c * beta + d. + 0 <= d < beta -> + a * beta + b < c * beta + d. Proof. intros a b c d beta H1 (H3, H4) (H5, H6). case (Zle_or_lt (c * beta + d) (a * beta + b)); auto with zarith. intros H7; contradict H1;apply Zle_not_lt;apply beta_lex with (1 := H7);auto. Qed. - Lemma beta_mult : forall h l beta, + Lemma beta_mult : forall h l beta, 0 <= h < beta -> 0 <= l < beta -> 0 <= h*beta+l < beta^2. Proof. intros h l beta H1 H2;split. auto with zarith. @@ -96,7 +96,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. apply beta_lex_inv;auto with zarith. Qed. - Lemma Zmult_lt_b : + Lemma Zmult_lt_b : forall b x y, 0 <= x < b -> 0 <= y < b -> 0 <= x * y <= b^2 - 2*b + 1. Proof. intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith. @@ -106,17 +106,17 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. Qed. Lemma sum_mul_carry : forall xh xl yh yl wc cc beta, - 1 < beta -> + 1 < beta -> 0 <= wc < beta -> 0 <= xh < beta -> 0 <= xl < beta -> 0 <= yh < beta -> 0 <= yl < beta -> 0 <= cc < beta^2 -> - wc*beta^2 + cc = xh*yl + xl*yh -> + wc*beta^2 + cc = xh*yl + xl*yh -> 0 <= wc <= 1. Proof. - intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7. + intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7. assert (H8 := Zmult_lt_b beta xh yl H2 H5). assert (H9 := Zmult_lt_b beta xl yh H3 H4). split;auto with zarith. @@ -134,7 +134,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. apply Zle_lt_trans with ((beta-1)*(beta-1)+(beta-1)); auto with zarith. apply Zplus_le_compat; auto with zarith. apply Zmult_le_compat; auto with zarith. - repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); + repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); rewrite Zpower_2; auto with zarith. Qed. @@ -149,7 +149,7 @@ Hint Resolve Zlt_gt Zle_ge Z_div_pos: zarith. apply Zle_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith. apply Zplus_le_compat; auto with zarith. apply Zmult_le_compat; auto with zarith. - repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); + repeat (rewrite Zmult_minus_distr_l || rewrite Zmult_minus_distr_r); rewrite Zpower_2; auto with zarith. Qed. @@ -201,9 +201,9 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. apply Zplus_le_lt_compat; auto with zarith. replace b with ((b - a) + a); try ring. rewrite Zpower_exp; auto with zarith. - pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); + pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); try rewrite <- Zmult_minus_distr_r. - rewrite (Zmult_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; + rewrite (Zmult_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; auto with zarith. rewrite (Zmult_comm (2 ^a)); apply Zmult_le_compat_r; auto with zarith. match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; @@ -224,22 +224,22 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. split; auto with zarith. assert (0 <= 2 ^a * r); auto with zarith. apply Zplus_le_0_compat; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; auto with zarith. pattern (2 ^ b) at 2;replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); try ring. apply Zplus_le_lt_compat; auto with zarith. replace b with ((b - a) + a); try ring. rewrite Zpower_exp; auto with zarith. - pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); + pattern (2 ^a) at 4; rewrite <- (Zmult_1_l (2 ^a)); try rewrite <- Zmult_minus_distr_r. repeat rewrite (fun x => Zmult_comm x (2 ^ a)); rewrite Zmult_mod_distr_l; auto with zarith. apply Zmult_le_compat_l; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; auto with zarith. Qed. - Theorem Zdiv_shift_r: + Theorem Zdiv_shift_r: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> (r * 2 ^a + t) / (2 ^ b) = (r * 2 ^a) / (2 ^ b). Proof. @@ -253,7 +253,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. rewrite <- Zmod_shift_r; auto with zarith. rewrite (Zmult_comm (2 ^ b)); rewrite Z_div_plus_full_l; auto with zarith. rewrite (fun x y => @Zdiv_small (x mod y)); auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; + match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; auto with zarith. Qed. @@ -264,8 +264,8 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. a * 2^p = a / 2^(n - p) * 2^n + (a*2^p) mod 2^n. Proof. intros n p a H1 H2. - pattern (a*2^p) at 1;replace (a*2^p) with - (a*2^p/2^n * 2^n + a*2^p mod 2^n). + pattern (a*2^p) at 1;replace (a*2^p) with + (a*2^p/2^n * 2^n + a*2^p mod 2^n). 2:symmetry;rewrite (Zmult_comm (a*2^p/2^n));apply Z_div_mod_eq. replace (a * 2 ^ p / 2 ^ n) with (a / 2 ^ (n - p));trivial. replace (2^n) with (2^(n-p)*2^p). @@ -279,8 +279,8 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. Qed. - Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> - ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = + Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> + ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = a mod 2 ^ p. Proof. intros. @@ -312,16 +312,16 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. Proof. intros p x Hle;destruct (Z_le_gt_dec 0 p). - apply Zdiv_le_lower_bound;auto with zarith. + apply Zdiv_le_lower_bound;auto with zarith. replace (2^p) with 0. destruct x;compute;intro;discriminate. destruct p;trivial;discriminate z. Qed. - + Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. Proof. intros p x y H;destruct (Z_le_gt_dec 0 p). - apply Zdiv_lt_upper_bound;auto with zarith. + apply Zdiv_lt_upper_bound;auto with zarith. apply Zlt_le_trans with y;auto with zarith. rewrite <- (Zmult_1_r y);apply Zmult_le_compat;auto with zarith. assert (0 < 2^p);auto with zarith. @@ -357,7 +357,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. compute; auto. Qed. - Lemma Zdiv_gcd_zero : forall a b, b / Zgcd a b = 0 -> b <> 0 -> + Lemma Zdiv_gcd_zero : forall a b, b / Zgcd a b = 0 -> b <> 0 -> Zgcd a b = 0. Proof. intros. @@ -369,7 +369,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. intros; subst k; simpl in *; subst b; elim H0; auto. Qed. - Lemma Zgcd_mult_rel_prime : forall a b c, + Lemma Zgcd_mult_rel_prime : forall a b c, Zgcd a c = 1 -> Zgcd b c = 1 -> Zgcd (a*b) c = 1. Proof. intros. @@ -378,7 +378,7 @@ Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. Qed. Lemma Zcompare_gt : forall (A:Type)(a a':A)(p q:Z), - match (p?=q)%Z with Gt => a | _ => a' end = + match (p?=q)%Z with Gt => a | _ => a' end = if Z_le_gt_dec p q then a' else a. Proof. intros. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index b7a427532d..32d1503314 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -12,8 +12,8 @@ (** * Signature and specification of a bounded integer structure *) -(** This file specifies how to represent [Z/nZ] when [n=2^d], - [d] being the number of digits of these bounded integers. *) +(** This file specifies how to represent [Z/nZ] when [n=2^d], + [d] being the number of digits of these bounded integers. *) Set Implicit Arguments. @@ -33,7 +33,7 @@ Section Z_nZ_Op. Record znz_op := mk_znz_op { (* Conversion functions with Z *) - znz_digits : positive; + znz_digits : positive; znz_zdigits: znz; znz_to_Z : znz -> Z; znz_of_pos : positive -> N * znz; (* Euclidean division by [2^digits] *) @@ -78,12 +78,12 @@ Section Z_nZ_Op. znz_div : znz -> znz -> znz * znz; znz_mod_gt : znz -> znz -> znz; (* specialized version of [znz_mod] *) - znz_mod : znz -> znz -> znz; + znz_mod : znz -> znz -> znz; znz_gcd_gt : znz -> znz -> znz; (* specialized version of [znz_gcd] *) - znz_gcd : znz -> znz -> znz; + znz_gcd : znz -> znz -> znz; (* [znz_add_mul_div p i j] is a combination of the [(digits-p)] - low bits of [i] above the [p] high bits of [j]: + low bits of [i] above the [p] high bits of [j]: [znz_add_mul_div p i j = i*2^p+j/2^(digits-p)] *) znz_add_mul_div : znz -> znz -> znz -> znz; (* [znz_pos_mod p i] is [i mod 2^p] *) @@ -135,7 +135,7 @@ Section Z_nZ_Spec. Let w_mul_c := w_op.(znz_mul_c). Let w_mul := w_op.(znz_mul). Let w_square_c := w_op.(znz_square_c). - + Let w_div21 := w_op.(znz_div21). Let w_div_gt := w_op.(znz_div_gt). Let w_div := w_op.(znz_div). @@ -229,25 +229,25 @@ Section Z_nZ_Spec. spec_div : forall a b, 0 < [|b|] -> let (q,r) := w_div a b in [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]; - + 0 <= [|r|] < [|b|]; + spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> [|w_mod_gt a b|] = [|a|] mod [|b|]; spec_mod : forall a b, 0 < [|b|] -> [|w_mod a b|] = [|a|] mod [|b|]; - + spec_gcd_gt : forall a b, [|a|] > [|b|] -> Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]; spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|w_gcd a b|]; - + (* shift operations *) spec_head00: forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits; spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB; + wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB; spec_tail00: forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits; - spec_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|w_tail0 x|]) ; + spec_tail0 : forall x, 0 < [|x|] -> + exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|w_tail0 x|]) ; spec_add_mul_div : forall x y p, [|p|] <= Zpos w_digits -> [| w_add_mul_div p x y |] = @@ -272,23 +272,23 @@ End Z_nZ_Spec. (** Generic construction of double words *) Section WW. - + Variable w : Type. Variable w_op : znz_op w. Variable op_spec : znz_spec w_op. - + Let wB := base w_op.(znz_digits). Let w_to_Z := w_op.(znz_to_Z). Let w_eq0 := w_op.(znz_eq0). Let w_0 := w_op.(znz_0). - Definition znz_W0 h := + Definition znz_W0 h := if w_eq0 h then W0 else WW h w_0. - Definition znz_0W l := + Definition znz_0W l := if w_eq0 l then W0 else WW w_0 l. - Definition znz_WW h l := + Definition znz_WW h l := if w_eq0 h then znz_0W l else WW h l. Lemma spec_W0 : forall h, @@ -300,7 +300,7 @@ Section WW. unfold w_0; rewrite op_spec.(spec_0); auto with zarith. Qed. - Lemma spec_0W : forall l, + Lemma spec_0W : forall l, zn2z_to_Z wB w_to_Z (znz_0W l) = w_to_Z l. Proof. unfold zn2z_to_Z, znz_0W, w_to_Z; simpl; intros. @@ -309,7 +309,7 @@ Section WW. unfold w_0; rewrite op_spec.(spec_0); auto with zarith. Qed. - Lemma spec_WW : forall h l, + Lemma spec_WW : forall h l, zn2z_to_Z wB w_to_Z (znz_WW h l) = (w_to_Z h)*wB + w_to_Z l. Proof. unfold znz_WW, w_to_Z; simpl; intros. @@ -324,7 +324,7 @@ End WW. (** Injecting [Z] numbers into a cyclic structure *) Section znz_of_pos. - + Variable w : Type. Variable w_op : znz_op w. Variable op_spec : znz_spec w_op. @@ -349,7 +349,7 @@ Section znz_of_pos. apply Zle_trans with X; auto with zarith end. match goal with |- ?X <= _ => - pattern X at 1; rewrite <- (Zmult_1_l); + pattern X at 1; rewrite <- (Zmult_1_l); apply Zmult_le_compat_r; auto with zarith end. case p1; simpl; intros; red; simpl; intros; discriminate. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index 125fd3f127..5891593903 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -17,9 +17,9 @@ Require Import CyclicAxioms. (** * From [CyclicType] to [NZAxiomsSig] *) -(** A [Z/nZ] representation given by a module type [CyclicType] - implements [NZAxiomsSig], e.g. the common properties between - N and Z with no ordering. Notice that the [n] in [Z/nZ] is +(** A [Z/nZ] representation given by a module type [CyclicType] + implements [NZAxiomsSig], e.g. the common properties between + N and Z with no ordering. Notice that the [n] in [Z/nZ] is a power of 2. *) @@ -98,7 +98,7 @@ Notation "x * y" := (NZmul x y) : IntScope. Theorem gt_wB_1 : 1 < wB. Proof. -unfold base. +unfold base. apply Zpower_gt_1; unfold Zlt; auto with zarith. Qed. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v index d60af33ecb..b4f6a81604 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v @@ -36,10 +36,10 @@ Section DoubleAdd. Definition ww_succ_c x := match x with | W0 => C0 ww_1 - | WW xh xl => + | WW xh xl => match w_succ_c xl with | C0 l => C0 (WW xh l) - | C1 l => + | C1 l => match w_succ_c xh with | C0 h => C0 (WW h w_0) | C1 h => C1 W0 @@ -47,13 +47,13 @@ Section DoubleAdd. end end. - Definition ww_succ x := + Definition ww_succ x := match x with | W0 => ww_1 | WW xh xl => match w_succ_c xl with | C0 l => WW xh l - | C1 l => w_W0 (w_succ xh) + | C1 l => w_W0 (w_succ xh) end end. @@ -63,12 +63,12 @@ Section DoubleAdd. | _, W0 => C0 x | WW xh xl, WW yh yl => match w_add_c xl yl with - | C0 l => + | C0 l => match w_add_c xh yh with | C0 h => C0 (WW h l) | C1 h => C1 (w_WW h l) - end - | C1 l => + end + | C1 l => match w_add_carry_c xh yh with | C0 h => C0 (WW h l) | C1 h => C1 (w_WW h l) @@ -85,12 +85,12 @@ Section DoubleAdd. | _, W0 => f0 x | WW xh xl, WW yh yl => match w_add_c xl yl with - | C0 l => + | C0 l => match w_add_c xh yh with | C0 h => f0 (WW h l) | C1 h => f1 (w_WW h l) - end - | C1 l => + end + | C1 l => match w_add_carry_c xh yh with | C0 h => f0 (WW h l) | C1 h => f1 (w_WW h l) @@ -118,12 +118,12 @@ Section DoubleAdd. | WW xh xl, W0 => ww_succ_c (WW xh xl) | WW xh xl, WW yh yl => match w_add_carry_c xl yl with - | C0 l => + | C0 l => match w_add_c xh yh with | C0 h => C0 (WW h l) | C1 h => C1 (WW h l) end - | C1 l => + | C1 l => match w_add_carry_c xh yh with | C0 h => C0 (WW h l) | C1 h => C1 (w_WW h l) @@ -131,7 +131,7 @@ Section DoubleAdd. end end. - Definition ww_add_carry x y := + Definition ww_add_carry x y := match x, y with | W0, W0 => ww_1 | W0, WW yh yl => ww_succ (WW yh yl) @@ -146,7 +146,7 @@ Section DoubleAdd. (*Section DoubleProof.*) Variable w_digits : positive. Variable w_to_Z : w -> Z. - + Notation wB := (base w_digits). Notation wwB := (base (ww_digits w_digits)). @@ -157,11 +157,11 @@ Section DoubleAdd. (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). Variable spec_w_0 : [|w_0|] = 0. @@ -172,7 +172,7 @@ Section DoubleAdd. Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. Variable spec_w_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1. Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add_carry_c : + Variable spec_w_add_carry_c : forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. @@ -187,11 +187,11 @@ Section DoubleAdd. rewrite <- Zplus_assoc;rewrite <- H;rewrite Zmult_1_l. assert ([|l|] = 0). generalize (spec_to_Z xl)(spec_to_Z l);omega. rewrite H0;generalize (spec_w_succ_c xh);destruct (w_succ_c xh) as [h|h]; - intro H1;unfold interp_carry in H1. + intro H1;unfold interp_carry in H1. simpl;rewrite H1;rewrite spec_w_0;ring. unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB. assert ([|xh|] = wB - 1). generalize (spec_to_Z xh)(spec_to_Z h);omega. - rewrite H2;ring. + rewrite H2;ring. Qed. Lemma spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. @@ -222,12 +222,12 @@ Section DoubleAdd. Proof. destruct x as [ |xh xl];simpl;trivial. apply spec_f0;trivial. - destruct y as [ |yh yl];simpl. + destruct y as [ |yh yl];simpl. apply spec_f0;simpl;rewrite Zplus_0_r;trivial. generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; intros H;unfold interp_carry in H. generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *. + intros H1;unfold interp_carry in *. apply spec_f0. simpl;rewrite H;rewrite H1;ring. apply spec_f1. simpl;rewrite spec_w_WW;rewrite H. rewrite Zplus_assoc;rewrite wwB_wBwB. rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. @@ -236,12 +236,12 @@ Section DoubleAdd. as [h|h]; intros H1;unfold interp_carry in *. apply spec_f0;simpl;rewrite H1. rewrite Zmult_plus_distr_l. rewrite <- Zplus_assoc;rewrite H;ring. - apply spec_f1. simpl;rewrite spec_w_WW;rewrite wwB_wBwB. - rewrite Zplus_assoc; rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. + apply spec_f1. simpl;rewrite spec_w_WW;rewrite wwB_wBwB. + rewrite Zplus_assoc; rewrite Zpower_2; rewrite <- Zmult_plus_distr_l. rewrite Zmult_1_l in H1;rewrite H1. rewrite Zmult_plus_distr_l. rewrite <- Zplus_assoc;rewrite H;ring. Qed. - + End Cont. Lemma spec_ww_add_carry_c : @@ -251,16 +251,16 @@ Section DoubleAdd. exact (spec_ww_succ_c y). destruct y as [ |yh yl];simpl. rewrite Zplus_0_r;exact (spec_ww_succ_c (WW xh xl)). - replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) + replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. - generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) + generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) as [l|l];intros H;unfold interp_carry in H;rewrite <- H. generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. unfold interp_carry;repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring. rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. + generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) + as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. unfold interp_carry;rewrite spec_w_WW; repeat rewrite Zmult_1_l;simpl;rewrite wwB_wBwB;ring. Qed. @@ -287,9 +287,9 @@ Section DoubleAdd. rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. destruct y as [ |yh yl]. change [[W0]] with 0;rewrite Zplus_0_r. - rewrite Zmod_small;trivial. + rewrite Zmod_small;trivial. exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)). - simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) + simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; unfold interp_carry;intros H;simpl;rewrite <- H. @@ -305,14 +305,14 @@ Section DoubleAdd. exact (spec_ww_succ y). destruct y as [ |yh yl]. change [[W0]] with 0;rewrite Zplus_0_r. exact (spec_ww_succ (WW xh xl)). - simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) + simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. - generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) + generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) as [l|l];unfold interp_carry;intros H;rewrite <- H;simpl ww_to_Z. rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. - Qed. + Qed. (* End DoubleProof. *) End DoubleAdd. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v index 37b9f47b49..82480fa2ef 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v @@ -29,8 +29,8 @@ Section DoubleBase. Variable w_zdigits: w. Variable w_add: w -> w -> zn2z w. Variable w_to_Z : w -> Z. - Variable w_compare : w -> w -> comparison. - + Variable w_compare : w -> w -> comparison. + Definition ww_digits := xO w_digits. Definition ww_zdigits := w_add w_zdigits w_zdigits. @@ -46,7 +46,7 @@ Section DoubleBase. | W0, W0 => W0 | _, _ => WW xh xl end. - + Definition ww_W0 h : zn2z (zn2z w) := match h with | W0 => W0 @@ -58,10 +58,10 @@ Section DoubleBase. | W0 => W0 | _ => WW W0 l end. - - Definition double_WW (n:nat) := - match n return word w n -> word w n -> word w (S n) with - | O => w_WW + + Definition double_WW (n:nat) := + match n return word w n -> word w n -> word w (S n) with + | O => w_WW | S n => fun (h l : zn2z (word w n)) => match h, l with @@ -70,8 +70,8 @@ Section DoubleBase. end end. - Fixpoint double_digits (n:nat) : positive := - match n with + Fixpoint double_digits (n:nat) : positive := + match n with | O => w_digits | S n => xO (double_digits n) end. @@ -80,7 +80,7 @@ Section DoubleBase. Fixpoint double_to_Z (n:nat) : word w n -> Z := match n return word w n -> Z with - | O => w_to_Z + | O => w_to_Z | S n => zn2z_to_Z (double_wB n) (double_to_Z n) end. @@ -98,21 +98,21 @@ Section DoubleBase. end. Definition double_0 n : word w n := - match n return word w n with + match n return word w n with | O => w_0 | S _ => W0 end. - + Definition double_split (n:nat) (x:zn2z (word w n)) := - match x with - | W0 => - match n return word w n * word w n with + match x with + | W0 => + match n return word w n * word w n with | O => (w_0,w_0) | S _ => (W0, W0) end | WW h l => (h,l) end. - + Definition ww_compare x y := match x, y with | W0, W0 => Eq @@ -148,15 +148,15 @@ Section DoubleBase. end end. - + Section DoubleProof. Notation wB := (base w_digits). Notation wwB := (base ww_digits). Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z x) (at level 0, x at level 99). - Notation "[+[ c ]]" := + Notation "[+[ c ]]" := (interp_carry 1 wwB ww_to_Z c) (at level 0, x at level 99). - Notation "[-[ c ]]" := + Notation "[-[ c ]]" := (interp_carry (-1) wwB ww_to_Z c) (at level 0, x at level 99). Notation "[! n | x !]" := (double_to_Z n x) (at level 0, x at level 99). @@ -188,7 +188,7 @@ Section DoubleBase. Proof. simpl;rewrite spec_w_Bm1;rewrite wwB_wBwB;ring. Qed. Lemma lt_0_wB : 0 < wB. - Proof. + Proof. unfold base;apply Zpower_gt_0. unfold Zlt;reflexivity. unfold Zle;intros H;discriminate H. Qed. @@ -197,25 +197,25 @@ Section DoubleBase. Proof. rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_lt_0_compat;apply lt_0_wB. Qed. Lemma wB_pos: 1 < wB. - Proof. + Proof. unfold base;apply Zlt_le_trans with (2^1). unfold Zlt;reflexivity. apply Zpower_le_monotone. unfold Zlt;reflexivity. split;unfold Zle;intros H. discriminate H. clear spec_w_0W w_0W spec_w_Bm1 spec_to_Z spec_w_WW w_WW. destruct w_digits; discriminate H. Qed. - - Lemma wwB_pos: 1 < wwB. + + Lemma wwB_pos: 1 < wwB. Proof. assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Zmult_1_r 1). rewrite Zpower_2. apply Zmult_lt_compat2;(split;[unfold Zlt;reflexivity|trivial]). - apply Zlt_le_weak;trivial. + apply Zlt_le_weak;trivial. Qed. Theorem wB_div_2: 2 * (wB / 2) = wB. Proof. - clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W + clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W spec_to_Z;unfold base. assert (2 ^ Zpos w_digits = 2 * (2 ^ (Zpos w_digits - 1))). pattern 2 at 2; rewrite <- Zpower_1_r. @@ -228,7 +228,7 @@ Section DoubleBase. Theorem wwB_div_2 : wwB / 2 = wB / 2 * wB. Proof. - clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W + clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W spec_to_Z. rewrite wwB_wBwB; rewrite Zpower_2. pattern wB at 1; rewrite <- wB_div_2; auto. @@ -236,11 +236,11 @@ Section DoubleBase. repeat (rewrite (Zmult_comm 2); rewrite Z_div_mult); auto with zarith. Qed. - Lemma mod_wwB : forall z x, + Lemma mod_wwB : forall z x, (z*wB + [|x|]) mod wwB = (z mod wB)*wB + [|x|]. Proof. intros z x. - rewrite Zplus_mod. + rewrite Zplus_mod. pattern wwB at 1;rewrite wwB_wBwB; rewrite Zpower_2. rewrite Zmult_mod_distr_r;try apply lt_0_wB. rewrite (Zmod_small [|x|]). @@ -260,8 +260,8 @@ Section DoubleBase. destruct (spec_to_Z x);trivial. Qed. - Lemma wB_div_plus : forall x y p, - 0 <= p -> + Lemma wB_div_plus : forall x y p, + 0 <= p -> ([|x|]*wB + [|y|]) / 2^(Zpos w_digits + p) = [|x|] / 2^p. Proof. clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. @@ -277,7 +277,7 @@ Section DoubleBase. assert (0 < Zpos w_digits). compute;reflexivity. unfold ww_digits;rewrite Zpos_xO;auto with zarith. Qed. - + Lemma w_to_Z_wwB : forall x, x < wB -> x < wwB. Proof. intros x H;apply Zlt_trans with wB;trivial;apply lt_wB_wwB. @@ -298,7 +298,7 @@ Section DoubleBase. Proof. intros n;unfold double_wB;simpl. unfold base;rewrite (Zpos_xO (double_digits n)). - replace (2 * Zpos (double_digits n)) with + replace (2 * Zpos (double_digits n)) with (Zpos (double_digits n) + Zpos (double_digits n)). symmetry; apply Zpower_exp;intro;discriminate. ring. @@ -327,7 +327,7 @@ Section DoubleBase. unfold base; auto with zarith. Qed. - Lemma spec_double_to_Z : + Lemma spec_double_to_Z : forall n (x:word w n), 0 <= [!n | x!] < double_wB n. Proof. clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. @@ -347,7 +347,7 @@ Section DoubleBase. Qed. Lemma spec_get_low: - forall n x, + forall n x, [!n | x!] < wB -> [|get_low n x|] = [!n | x!]. Proof. clear spec_w_1 spec_w_Bm1. @@ -380,19 +380,19 @@ Section DoubleBase. Qed. Lemma spec_extend_aux : forall n x, [!S n|extend_aux n x!] = [[x]]. - Proof. induction n;simpl;trivial. Qed. + Proof. induction n;simpl;trivial. Qed. Lemma spec_extend : forall n x, [!S n|extend n x!] = [|x|]. - Proof. + Proof. intros n x;assert (H:= spec_w_0W x);unfold extend. - destruct (w_0W x);simpl;trivial. + destruct (w_0W x);simpl;trivial. rewrite <- H;exact (spec_extend_aux n (WW w0 w1)). Qed. Lemma spec_double_0 : forall n, [!n|double_0 n!] = 0. Proof. destruct n;trivial. Qed. - Lemma spec_double_split : forall n x, + Lemma spec_double_split : forall n x, let (h,l) := double_split n x in [!S n|x!] = [!n|h!] * double_wB n + [!n|l!]. Proof. @@ -401,9 +401,9 @@ Section DoubleBase. rewrite spec_w_0;trivial. Qed. - Lemma wB_lex_inv: forall a b c d, - a < c -> - a * wB + [|b|] < c * wB + [|d|]. + Lemma wB_lex_inv: forall a b c d, + a < c -> + a * wB + [|b|] < c * wB + [|d|]. Proof. intros a b c d H1; apply beta_lex_inv with (1 := H1); auto. Qed. @@ -420,7 +420,7 @@ Section DoubleBase. intros H;rewrite spec_w_0 in H. rewrite <- H;simpl;rewrite <- spec_w_0;apply spec_w_compare. change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0. - apply wB_lex_inv;trivial. + apply wB_lex_inv;trivial. absurd (0 <= [|yh|]). apply Zgt_not_le;trivial. destruct (spec_to_Z yh);trivial. generalize (spec_w_compare xh w_0);destruct (w_compare xh w_0); @@ -429,8 +429,8 @@ Section DoubleBase. absurd (0 <= [|xh|]). apply Zgt_not_le;apply Zlt_gt;trivial. destruct (spec_to_Z xh);trivial. apply Zlt_gt;change 0 with (0*wB+0);pattern 0 at 2;rewrite <- spec_w_0. - apply wB_lex_inv;apply Zgt_lt;trivial. - + apply wB_lex_inv;apply Zgt_lt;trivial. + generalize (spec_w_compare xh yh);destruct (w_compare xh yh);intros H. rewrite H;generalize (spec_w_compare xl yl);destruct (w_compare xl yl); intros H1;[rewrite H1|apply Zplus_lt_compat_l|apply Zplus_gt_compat_l]; @@ -439,7 +439,7 @@ Section DoubleBase. apply Zlt_gt;apply wB_lex_inv;apply Zgt_lt;trivial. Qed. - + End DoubleProof. End DoubleBase. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v index b590e9b3ce..db3b622b00 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v @@ -22,7 +22,7 @@ Require Import DoubleMul. Require Import DoubleSqrt. Require Import DoubleLift. Require Import DoubleDivn1. -Require Import DoubleDiv. +Require Import DoubleDiv. Require Import CyclicAxioms. Open Local Scope Z_scope. @@ -80,7 +80,7 @@ Section Z_2nZ. Let w_gcd_gt := w_op.(znz_gcd_gt). Let w_gcd := w_op.(znz_gcd). - Let w_add_mul_div := w_op.(znz_add_mul_div). + Let w_add_mul_div := w_op.(znz_add_mul_div). Let w_pos_mod := w_op.(znz_pos_mod). @@ -93,7 +93,7 @@ Section Z_2nZ. Let wB := base w_digits. Let w_Bm2 := w_pred w_Bm1. - + Let ww_1 := ww_1 w_0 w_1. Let ww_Bm1 := ww_Bm1 w_Bm1. @@ -112,16 +112,16 @@ Section Z_2nZ. Let ww_of_pos p := match w_of_pos p with | (N0, l) => (N0, WW w_0 l) - | (Npos ph,l) => + | (Npos ph,l) => let (n,h) := w_of_pos ph in (n, w_WW h l) end. Let head0 := - Eval lazy beta delta [ww_head0] in + Eval lazy beta delta [ww_head0] in ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits. Let tail0 := - Eval lazy beta delta [ww_tail0] in + Eval lazy beta delta [ww_tail0] in ww_tail0 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits. Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW w). @@ -132,7 +132,7 @@ Section Z_2nZ. Let compare := Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare. - Let eq0 (x:zn2z w) := + Let eq0 (x:zn2z w) := match x with | W0 => true | _ => false @@ -147,7 +147,7 @@ Section Z_2nZ. Let opp_carry := Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry. - + (* ** Additions ** *) Let succ_c := @@ -157,16 +157,16 @@ Section Z_2nZ. Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c. Let add_carry_c := - Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in + Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c. - Let succ := + Let succ := Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ. Let add := Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry. - Let add_carry := + Let add_carry := Eval lazy beta iota delta [ww_add_carry ww_succ] in ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry. @@ -174,9 +174,9 @@ Section Z_2nZ. Let pred_c := Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c. - + Let sub_c := - Eval lazy beta iota delta [ww_sub_c ww_opp_c] in + Eval lazy beta iota delta [ww_sub_c ww_opp_c] in ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c. Let sub_carry_c := @@ -186,8 +186,8 @@ Section Z_2nZ. Let pred := Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred. - Let sub := - Eval lazy beta iota delta [ww_sub ww_opp] in + Let sub := + Eval lazy beta iota delta [ww_sub ww_opp] in ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry. Let sub_carry := @@ -204,7 +204,7 @@ Section Z_2nZ. Let karatsuba_c := Eval lazy beta iota delta [ww_karatsuba_c double_mul_c kara_prod] in - ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c + ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c add_c add add_carry sub_c sub. Let mul := @@ -219,7 +219,7 @@ Section Z_2nZ. Let div32 := Eval lazy beta iota delta [w_div32] in - w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c + w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c. Let div21 := @@ -234,40 +234,40 @@ Section Z_2nZ. Let div_gt := Eval lazy beta delta [ww_div_gt] in - ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp + ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits. Let div := Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt. - + Let mod_gt := Eval lazy beta delta [ww_mod_gt] in ww_mod_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div w_zdigits. - Let mod_ := + Let mod_ := Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt. - Let pos_mod := - Eval lazy beta delta [ww_pos_mod] in + Let pos_mod := + Eval lazy beta delta [ww_pos_mod] in ww_pos_mod w_0 w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits. - Let is_even := + Let is_even := Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even. - Let sqrt2 := + Let sqrt2 := Eval lazy beta delta [ww_sqrt2] in ww_sqrt2 w_is_even w_compare w_0 w_1 w_Bm1 w_0W w_sub w_square_c w_div21 w_add_mul_div w_zdigits w_add_c w_sqrt2 w_pred pred_c pred add_c add sub_c add_mul_div. - Let sqrt := + Let sqrt := Eval lazy beta delta [ww_sqrt] in ww_sqrt w_is_even w_0 w_sub w_add_mul_div w_zdigits _ww_zdigits w_sqrt2 pred add_mul_div head0 compare low. - Let gcd_gt_fix := + Let gcd_gt_fix := Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in ww_gcd_gt_aux w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt @@ -278,7 +278,7 @@ Section Z_2nZ. Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare. Let gcd_gt := - Eval lazy beta delta [ww_gcd_gt] in + Eval lazy beta delta [ww_gcd_gt] in ww_gcd_gt w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. Let gcd := @@ -286,18 +286,18 @@ Section Z_2nZ. ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. (* ** Record of operators on 2 words *) - - Definition mk_zn2z_op := + + Definition mk_zn2z_op := mk_znz_op _ww_digits _ww_zdigits to_Z ww_of_pos head0 tail0 W0 ww_1 ww_Bm1 compare eq0 opp_c opp opp_carry - succ_c add_c add_carry_c - succ add add_carry - pred_c sub_c sub_carry_c + succ_c add_c add_carry_c + succ add add_carry + pred_c sub_c sub_carry_c pred sub sub_carry - mul_c mul square_c + mul_c mul square_c div21 div_gt div mod_gt mod_ gcd_gt gcd @@ -307,17 +307,17 @@ Section Z_2nZ. sqrt2 sqrt. - Definition mk_zn2z_op_karatsuba := + Definition mk_zn2z_op_karatsuba := mk_znz_op _ww_digits _ww_zdigits to_Z ww_of_pos head0 tail0 W0 ww_1 ww_Bm1 compare eq0 opp_c opp opp_carry - succ_c add_c add_carry_c - succ add add_carry - pred_c sub_c sub_carry_c + succ_c add_c add_carry_c + succ add add_carry + pred_c sub_c sub_carry_c pred sub sub_carry - karatsuba_c mul square_c + karatsuba_c mul square_c div21 div_gt div mod_gt mod_ gcd_gt gcd @@ -330,7 +330,7 @@ Section Z_2nZ. (* Proof *) Variable op_spec : znz_spec w_op. - Hint Resolve + Hint Resolve (spec_to_Z op_spec) (spec_of_pos op_spec) (spec_0 op_spec) @@ -358,13 +358,13 @@ Section Z_2nZ. (spec_square_c op_spec) (spec_div21 op_spec) (spec_div_gt op_spec) - (spec_div op_spec) + (spec_div op_spec) (spec_mod_gt op_spec) - (spec_mod op_spec) + (spec_mod op_spec) (spec_gcd_gt op_spec) - (spec_gcd op_spec) - (spec_head0 op_spec) - (spec_tail0 op_spec) + (spec_gcd op_spec) + (spec_head0 op_spec) + (spec_tail0 op_spec) (spec_add_mul_div op_spec) (spec_pos_mod) (spec_is_even) @@ -417,20 +417,20 @@ Section Z_2nZ. Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1. Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. - Let spec_ww_compare : + Let spec_ww_compare : forall x y, match compare x y with | Eq => [|x|] = [|y|] | Lt => [|x|] < [|y|] | Gt => [|x|] > [|y|] end. - Proof. - refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto. - exact (spec_compare op_spec). + Proof. + refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);auto. + exact (spec_compare op_spec). Qed. Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0. - Proof. destruct x;simpl;intros;trivial;discriminate. Qed. + Proof. destruct x;simpl;intros;trivial;discriminate. Qed. Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|]. Proof. @@ -440,7 +440,7 @@ Section Z_2nZ. Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB. Proof. - refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp + refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp w_digits w_to_Z _ _ _ _ _); auto. Qed. @@ -480,25 +480,25 @@ Section Z_2nZ. Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB. Proof. - refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ + refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto. Qed. Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1. Proof. - refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z + refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z _ _ _ _ _);wwauto. Qed. Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. Proof. - refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c + refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);wwauto. Qed. Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1. Proof. - refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c + refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto. Qed. @@ -533,17 +533,17 @@ Section Z_2nZ. _ _ _ _ _ _ _ _ _ _ _ _); wwauto. unfold w_digits; apply spec_more_than_1_digit; auto. exact (spec_compare op_spec). - Qed. + Qed. Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB. Proof. refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _); - wwauto. + wwauto. Qed. Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|]. Proof. - refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add + refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);wwauto. Qed. @@ -574,7 +574,7 @@ Section Z_2nZ. 0 <= [|r|] < [|b|]. Proof. refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z - _ _ _ _ _ _ _);wwauto. + _ _ _ _ _ _ _);wwauto. Qed. Let spec_add2: forall x y, @@ -602,7 +602,7 @@ Section Z_2nZ. unfold wB, base; auto with zarith. Qed. - Let spec_ww_digits: + Let spec_ww_digits: [|_ww_zdigits|] = Zpos (xO w_digits). Proof. unfold w_to_Z, _ww_zdigits. @@ -615,7 +615,7 @@ Section Z_2nZ. Let spec_ww_head00 : forall x, [|x|] = 0 -> [|head0 x|] = Zpos _ww_digits. Proof. - refine (spec_ww_head00 w_0 w_0W + refine (spec_ww_head00 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); auto. exact (spec_compare op_spec). @@ -626,8 +626,8 @@ Section Z_2nZ. Let spec_ww_head0 : forall x, 0 < [|x|] -> wwB/ 2 <= 2 ^ [|head0 x|] * [|x|] < wwB. Proof. - refine (spec_ww_head0 w_0 w_0W w_compare w_head0 - w_add2 w_zdigits _ww_zdigits + refine (spec_ww_head0 w_0 w_0W w_compare w_head0 + w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto. exact (spec_compare op_spec). exact (spec_zdigits op_spec). @@ -635,7 +635,7 @@ Section Z_2nZ. Let spec_ww_tail00 : forall x, [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits. Proof. - refine (spec_ww_tail00 w_0 w_0W + refine (spec_ww_tail00 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ (refl_equal _ww_digits) _ _ _ _); wwauto. exact (spec_compare op_spec). @@ -647,7 +647,7 @@ Section Z_2nZ. Let spec_ww_tail0 : forall x, 0 < [|x|] -> exists y, 0 <= y /\ [|x|] = (2 * y + 1) * 2 ^ [|tail0 x|]. Proof. - refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0 + refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto. exact (spec_compare op_spec). exact (spec_zdigits op_spec). @@ -659,19 +659,19 @@ Section Z_2nZ. ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos _ww_digits) - [|p|]))) mod wwB. Proof. - refine (@spec_ww_add_mul_div w w_0 w_WW w_W0 w_0W compare w_add_mul_div + refine (@spec_ww_add_mul_div w w_0 w_WW w_W0 w_0W compare w_add_mul_div sub w_digits w_zdigits low w_to_Z _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_zdigits op_spec). Qed. - Let spec_ww_div_gt : forall a b, + Let spec_ww_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> let (q,r) := div_gt a b in [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. Proof. -refine -(@spec_ww_div_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 +refine +(@spec_ww_div_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ @@ -707,14 +707,14 @@ refine refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);auto. Qed. - Let spec_ww_mod_gt : forall a b, + Let spec_ww_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> [|mod_gt a b|] = [|a|] mod [|b|]. Proof. - refine (@spec_ww_mod_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 + refine (@spec_ww_mod_gt w w_digits w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div - w_zdigits w_to_Z + w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div + w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_compare op_spec). exact (spec_div_gt op_spec). @@ -731,12 +731,12 @@ refine Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] -> Zis_gcd [|a|] [|b|] [|gcd_gt a b|]. Proof. - refine (@spec_ww_gcd_gt w w_digits W0 w_to_Z _ + refine (@spec_ww_gcd_gt w w_digits W0 w_to_Z _ w_0 w_0 w_eq0 w_gcd_gt _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 - w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z + w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_compare op_spec). exact (spec_div21 op_spec). @@ -753,7 +753,7 @@ refine _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);auto. refine (@spec_ww_gcd_gt_aux w w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 - w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z + w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_compare op_spec). exact (spec_div21 op_spec). @@ -798,7 +798,7 @@ refine Let spec_ww_sqrt : forall x, [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. Proof. - refine (@spec_ww_sqrt w w_is_even w_0 w_1 w_Bm1 + refine (@spec_ww_sqrt w w_is_even w_0 w_1 w_Bm1 w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits w_sqrt2 pred add_mul_div head0 compare _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. @@ -814,7 +814,7 @@ refine apply mk_znz_spec;auto. exact spec_ww_add_mul_div. - refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW + refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_pos_mod op_spec). @@ -828,7 +828,7 @@ refine Proof. apply mk_znz_spec;auto. exact spec_ww_add_mul_div. - refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW + refine (@spec_ww_pos_mod w w_0 w_digits w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z _ _ _ _ _ _ _ _ _ _ _ _);wwauto. exact (spec_pos_mod op_spec). @@ -838,10 +838,10 @@ refine rewrite <- Zpos_xO; exact spec_ww_digits. Qed. -End Z_2nZ. - +End Z_2nZ. + Section MulAdd. - + Variable w: Type. Variable op: znz_op w. Variable sop: znz_spec op. @@ -870,7 +870,7 @@ Section MulAdd. End MulAdd. -(** Modular versions of DoubleCyclic *) +(** Modular versions of DoubleCyclic *) Module DoubleCyclic (C:CyclicType) <: CyclicType. Definition w := zn2z C.w. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v index d3dfd2505c..03c6114422 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v @@ -41,13 +41,13 @@ Section POS_MOD. Variable ww_zdigits : zn2z w. - Definition ww_pos_mod p x := + Definition ww_pos_mod p x := let zdigits := w_0W w_zdigits in match x with | W0 => W0 | WW xh xl => match ww_compare p zdigits with - | Eq => w_WW w_0 xl + | Eq => w_WW w_0 xl | Lt => w_WW w_0 (w_pos_mod (low p) xl) | Gt => match ww_compare p ww_zdigits with @@ -87,7 +87,7 @@ Section POS_MOD. | Lt => [[x]] < [[y]] | Gt => [[x]] > [[y]] end. - Variable spec_ww_sub: forall x y, + Variable spec_ww_sub: forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. @@ -106,7 +106,7 @@ Section POS_MOD. unfold ww_pos_mod; case w1. simpl; rewrite Zmod_small; split; auto with zarith. intros xh xl; generalize (spec_ww_compare p (w_0W w_zdigits)); - case ww_compare; + case ww_compare; rewrite spec_w_0W; rewrite spec_zdigits; fold wB; intros H1. rewrite H1; simpl ww_to_Z. @@ -135,13 +135,13 @@ Section POS_MOD. autorewrite with w_rewrite rm10. rewrite Zmod_mod; auto with zarith. generalize (spec_ww_compare p ww_zdigits); - case ww_compare; rewrite spec_ww_zdigits; + case ww_compare; rewrite spec_ww_zdigits; rewrite spec_zdigits; intros H2. replace (2^[[p]]) with wwB. rewrite Zmod_small; auto with zarith. unfold base; rewrite H2. rewrite spec_ww_digits; auto. - assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] = + assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] = [[p]] - Zpos w_digits). rewrite spec_low. rewrite spec_ww_sub. @@ -152,11 +152,11 @@ generalize (spec_ww_compare p ww_zdigits); apply Zlt_le_trans with (Zpos w_digits); auto with zarith. unfold base; apply Zpower2_le_lin; auto with zarith. exists wB; unfold base; rewrite <- Zpower_exp; auto with zarith. - rewrite spec_ww_digits; + rewrite spec_ww_digits; apply f_equal with (f := Zpower 2); rewrite Zpos_xO; auto with zarith. simpl ww_to_Z; autorewrite with w_rewrite. rewrite spec_pos_mod; rewrite HH0. - pattern [|xh|] at 2; + pattern [|xh|] at 2; rewrite Z_div_mod_eq with (b := 2 ^ ([[p]] - Zpos w_digits)); auto with zarith. rewrite (fun x => (Zmult_comm (2 ^ x))); rewrite Zmult_plus_distr_l. @@ -196,7 +196,7 @@ generalize (spec_ww_compare p ww_zdigits); split; auto with zarith. rewrite Zpos_xO; auto with zarith. Qed. - + End POS_MOD. Section DoubleDiv32. @@ -222,24 +222,24 @@ Section DoubleDiv32. match w_compare a1 b1 with | Lt => let (q,r) := w_div21 a1 a2 b1 in - match ww_sub_c (w_WW r a3) (w_mul_c q b2) with + match ww_sub_c (w_WW r a3) (w_mul_c q b2) with | C0 r1 => (q,r1) | C1 r1 => let q := w_pred q in - ww_add_c_cont w_WW w_add_c w_add_carry_c + ww_add_c_cont w_WW w_add_c w_add_carry_c (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) (fun r2 => (q,r2)) r1 (WW b1 b2) end | Eq => - ww_add_c_cont w_WW w_add_c w_add_carry_c + ww_add_c_cont w_WW w_add_c w_add_carry_c (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) (fun r => (w_Bm1,r)) (WW (w_sub a2 b2) a3) (WW b1 b2) | Gt => (w_0, W0) (* cas absurde *) end. - (* Proof *) + (* Proof *) Variable w_digits : positive. Variable w_to_Z : w -> Z. @@ -253,8 +253,8 @@ Section DoubleDiv32. (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). @@ -273,7 +273,7 @@ Section DoubleDiv32. | Gt => [|x|] > [|y|] end. Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add_carry_c : + Variable spec_w_add_carry_c : forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. @@ -315,8 +315,8 @@ Section DoubleDiv32. wB/2 <= [|b1|] -> [[WW a1 a2]] < [[WW b1 b2]] -> let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ 0 <= [[r]] < [|b1|] * wB + [|b2|]. Proof. intros a1 a2 a3 b1 b2 Hle Hlt. @@ -327,17 +327,17 @@ Section DoubleDiv32. match w_compare a1 b1 with | Lt => let (q,r) := w_div21 a1 a2 b1 in - match ww_sub_c (w_WW r a3) (w_mul_c q b2) with + match ww_sub_c (w_WW r a3) (w_mul_c q b2) with | C0 r1 => (q,r1) | C1 r1 => let q := w_pred q in - ww_add_c_cont w_WW w_add_c w_add_carry_c + ww_add_c_cont w_WW w_add_c w_add_carry_c (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) (fun r2 => (q,r2)) r1 (WW b1 b2) end | Eq => - ww_add_c_cont w_WW w_add_c w_add_carry_c + ww_add_c_cont w_WW w_add_c w_add_carry_c (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) (fun r => (w_Bm1,r)) (WW (w_sub a2 b2) a3) (WW b1 b2) @@ -360,7 +360,7 @@ Section DoubleDiv32. [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ 0 <= [[r]] < [|b1|] * wB + [|b2|]);eauto. rewrite H0;intros r. - repeat + repeat (rewrite spec_ww_add;eauto || rewrite spec_w_Bm1 || rewrite spec_w_Bm2); simpl ww_to_Z;try rewrite Zmult_1_l;intros H1. assert (0<= ([[r]] + ([|b1|] * wB + [|b2|])) - wwB < [|b1|] * wB + [|b2|]). @@ -385,7 +385,7 @@ Section DoubleDiv32. 1 ([[r]] + ([|b1|] * wB + [|b2|]) - wwB));zarith;try (ring;fail). split. rewrite H1;rewrite Hcmp;ring. trivial. Spec_ww_to_Z (WW b1 b2). simpl in HH4;zarith. - rewrite H0;intros r;repeat + rewrite H0;intros r;repeat (rewrite spec_w_Bm1 || rewrite spec_w_Bm2); simpl ww_to_Z;try rewrite Zmult_1_l;intros H1. assert ([[r]]=([|a2|]-[|b2|])*wB+[|a3|]+([|b1|]*wB+[|b2|])). zarith. @@ -409,7 +409,7 @@ Section DoubleDiv32. as [r1|r1];repeat (rewrite spec_w_WW || rewrite spec_mul_c); unfold interp_carry;intros H1. rewrite H1. - split. ring. split. + split. ring. split. rewrite <- H1;destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z r1);trivial. apply Zle_lt_trans with ([|r|] * wB + [|a3|]). assert ( 0 <= [|q|] * [|b2|]);zarith. @@ -418,7 +418,7 @@ Section DoubleDiv32. rewrite <- H1;ring. Spec_ww_to_Z r1; assert (0 <= [|r|]*wB). zarith. assert (0 < [|q|] * [|b2|]). zarith. - assert (0 < [|q|]). + assert (0 < [|q|]). apply Zmult_lt_0_reg_r_2 with [|b2|];zarith. eapply spec_ww_add_c_cont with (P := fun (x y:zn2z w) (res:w*zn2z w) => @@ -440,18 +440,18 @@ Section DoubleDiv32. wwB * 1 + ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2 * ([|b1|] * wB + [|b2|]))). rewrite H7;rewrite H2;ring. - assert - ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) + assert + ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) < [|b1|]*wB + [|b2|]). Spec_ww_to_Z r2;omega. Spec_ww_to_Z (WW b1 b2). simpl in HH5. - assert - (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) + assert + (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) < wwB). split;try omega. replace (2*([|b1|]*wB+[|b2|])) with ((2*[|b1|])*wB+2*[|b2|]). 2:ring. assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). rewrite wwB_wBwB; rewrite Zpower_2; zarith. omega. - rewrite <- (Zmod_unique + rewrite <- (Zmod_unique ([[r2]] + ([|b1|] * wB + [|b2|])) wwB 1 @@ -486,7 +486,7 @@ Section DoubleDiv21. Definition ww_div21 a1 a2 b := match a1 with - | W0 => + | W0 => match ww_compare a2 b with | Gt => (ww_1, ww_sub a2 b) | Eq => (ww_1, W0) @@ -529,8 +529,8 @@ Section DoubleDiv21. Notation wwB := (base (ww_digits w_digits)). Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). Variable spec_w_0 : [|w_0|] = 0. @@ -540,8 +540,8 @@ Section DoubleDiv21. wB/2 <= [|b1|] -> [[WW a1 a2]] < [[WW b1 b2]] -> let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ 0 <= [[r]] < [|b1|] * wB + [|b2|]. Variable spec_ww_1 : [[ww_1]] = 1. Variable spec_ww_compare : forall x y, @@ -591,10 +591,10 @@ Section DoubleDiv21. intros Hlt H; match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); intros q1 r H0 - end; (assert (Eq1: wB / 2 <= [|b1|]);[ + end; (assert (Eq1: wB / 2 <= [|b1|]);[ apply (@beta_lex (wB / 2) 0 [|b1|] [|b2|] wB); auto with zarith; autorewrite with rm10;repeat rewrite (Zmult_comm wB); - rewrite <- wwB_div_2; trivial + rewrite <- wwB_div_2; trivial | generalize (H0 Eq1 Hlt);clear H0;destruct r as [ |r1 r2];simpl; try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Zplus_0_r; intros (H1,H2) ]). @@ -611,10 +611,10 @@ Section DoubleDiv21. rewrite <- wwB_wBwB;rewrite H1. rewrite spec_w_0 in H4;rewrite Zplus_0_r in H4. repeat rewrite Zmult_plus_distr_l. rewrite <- (Zmult_assoc [|r1|]). - rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring. + rewrite <- Zpower_2; rewrite <- wwB_wBwB;rewrite H4;simpl;ring. split;[rewrite wwB_wBwB | split;zarith]. - replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|])) - with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]). + replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|])) + with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]). rewrite H1;ring. rewrite wwB_wBwB;ring. change [|a4|] with (0*wB+[|a4|]);apply beta_lex_inv;zarith. assert (1 <= wB/2);zarith. @@ -624,7 +624,7 @@ Section DoubleDiv21. intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. split;trivial. replace (([|a1h|] * wB + [|a1l|]) * wwB + ([|a3|] * wB + [|a4|])) with - (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]); + (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]); [rewrite H1 | rewrite wwB_wBwB;ring]. replace (([|q1|]*([|b1|]*wB+[|b2|])+([|r1|]*wB+[|r2|]))*wB+[|a4|]) with (([|q1|]*([|b1|]*wB+[|b2|]))*wB+([|r1|]*wwB+[|r2|]*wB+[|a4|])); @@ -666,22 +666,22 @@ Section DoubleDivGt. Eval lazy beta iota delta [ww_sub ww_opp] in let p := w_head0 bh in match w_compare p w_0 with - | Gt => + | Gt => let b1 := w_add_mul_div p bh bl in let b2 := w_add_mul_div p bl w_0 in let a1 := w_add_mul_div p w_0 ah in let a2 := w_add_mul_div p ah al in let a3 := w_add_mul_div p al w_0 in let (q,r) := w_div32 a1 a2 a3 b1 b2 in - (WW w_0 q, ww_add_mul_div + (WW w_0 q, ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) end. - Definition ww_div_gt a b := - Eval lazy beta iota delta [ww_div_gt_aux double_divn1 + Definition ww_div_gt a b := + Eval lazy beta iota delta [ww_div_gt_aux double_divn1 double_divn1_p double_divn1_p_aux double_divn1_0 double_divn1_0_aux double_split double_0 double_WW] in match a, b with @@ -691,11 +691,11 @@ Section DoubleDivGt. if w_eq0 ah then let (q,r) := w_div_gt al bl in (WW w_0 q, w_0W r) - else + else match w_compare w_0 bh with - | Eq => + | Eq => let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 a bl in (q, w_0W r) | Lt => ww_div_gt_aux ah al bh bl @@ -707,7 +707,7 @@ Section DoubleDivGt. Eval lazy beta iota delta [ww_sub ww_opp] in let p := w_head0 bh in match w_compare p w_0 with - | Gt => + | Gt => let b1 := w_add_mul_div p bh bl in let b2 := w_add_mul_div p bl w_0 in let a1 := w_add_mul_div p w_0 ah in @@ -716,13 +716,13 @@ Section DoubleDivGt. let (q,r) := w_div32 a1 a2 a3 b1 b2 in ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r - | _ => + | _ => ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry (WW ah al) (WW bh bl) end. - Definition ww_mod_gt a b := - Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 + Definition ww_mod_gt a b := + Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux double_split double_0 double_WW snd] in match a, b with @@ -730,10 +730,10 @@ Section DoubleDivGt. | _, W0 => W0 | WW ah al, WW bh bl => if w_eq0 ah then w_0W (w_mod_gt al bl) - else + else match w_compare w_0 bh with - | Eq => - w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + | Eq => + w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 a bl) | Lt => ww_mod_gt_aux ah al bh bl | Gt => W0 (* cas absurde *) @@ -741,14 +741,14 @@ Section DoubleDivGt. end. Definition ww_gcd_gt_body (cont: w->w->w->w->zn2z w) (ah al bh bl: w) := - Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 + Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux double_split double_0 double_WW snd] in match w_compare w_0 bh with | Eq => match w_compare w_0 bl with | Eq => WW ah al (* normalement n'arrive pas si forme normale *) - | Lt => + | Lt => let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW ah al) bl in WW w_0 (w_gcd_gt bl m) @@ -757,14 +757,14 @@ Section DoubleDivGt. | Lt => let m := ww_mod_gt_aux ah al bh bl in match m with - | W0 => WW bh bl + | W0 => WW bh bl | WW mh ml => match w_compare w_0 mh with | Eq => match w_compare w_0 ml with | Eq => WW bh bl - | _ => - let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + | _ => + let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW bh bl) ml in WW w_0 (w_gcd_gt ml r) end @@ -779,18 +779,18 @@ Section DoubleDivGt. end | Gt => W0 (* absurde *) end. - - Fixpoint ww_gcd_gt_aux - (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w) + + Fixpoint ww_gcd_gt_aux + (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w) {struct p} : zn2z w := - ww_gcd_gt_body + ww_gcd_gt_body (fun mh ml rh rl => match p with | xH => cont mh ml rh rl | xO p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl | xI p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl end) ah al bh bl. - + (* Proof *) Variable w_to_Z : w -> Z. @@ -816,7 +816,7 @@ Section DoubleDivGt. | Gt => [|x|] > [|y|] end. Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. - + Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. @@ -854,8 +854,8 @@ Section DoubleDivGt. wB/2 <= [|b1|] -> [[WW a1 a2]] < [[WW b1 b2]] -> let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ + [|a1|] * wwB + [|a2|] * wB + [|a3|] = + [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ 0 <= [[r]] < [|b1|] * wB + [|b2|]. Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. @@ -899,14 +899,14 @@ Section DoubleDivGt. change (let (q, r) := let p := w_head0 bh in match w_compare p w_0 with - | Gt => + | Gt => let b1 := w_add_mul_div p bh bl in let b2 := w_add_mul_div p bl w_0 in let a1 := w_add_mul_div p w_0 ah in let a2 := w_add_mul_div p ah al in let a3 := w_add_mul_div p al w_0 in let (q,r) := w_div32 a1 a2 a3 b1 b2 in - (WW w_0 q, ww_add_mul_div + (WW w_0 q, ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c @@ -945,11 +945,11 @@ Section DoubleDivGt. (spec_add_mul_div bl w_0 Hb); rewrite spec_w_0; repeat rewrite Zmult_0_l;repeat rewrite Zplus_0_l; rewrite Zdiv_0_l;repeat rewrite Zplus_0_r. - Spec_w_to_Z ah;Spec_w_to_Z bh. + Spec_w_to_Z ah;Spec_w_to_Z bh. unfold base;repeat rewrite Zmod_shift_r;zarith. assert (H3:=to_Z_div_minus_p ah HHHH);assert(H4:=to_Z_div_minus_p al HHHH); assert (H5:=to_Z_div_minus_p bl HHHH). - rewrite Zmult_comm in Hh. + rewrite Zmult_comm in Hh. assert (2^[|w_head0 bh|] < wB). unfold base;apply Zpower_lt_monotone;zarith. unfold base in H0;rewrite Zmod_small;zarith. fold wB; rewrite (Zmod_small ([|bh|] * 2 ^ [|w_head0 bh|]));zarith. @@ -964,15 +964,15 @@ Section DoubleDivGt. (w_add_mul_div (w_head0 bh) al w_0) (w_add_mul_div (w_head0 bh) bh bl) (w_add_mul_div (w_head0 bh) bl w_0)) as (q,r). - rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l. - rewrite <- (Zplus_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)). + rewrite V1;rewrite V2. rewrite Zmult_plus_distr_l. + rewrite <- (Zplus_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)). unfold base;rewrite <- shift_unshift_mod;zarith. fold wB. replace ([|bh|] * 2 ^ [|w_head0 bh|] * wB + [|bl|] * 2 ^ [|w_head0 bh|]) with ([[WW bh bl]] * 2^[|w_head0 bh|]). 2:simpl;ring. fold wwB. rewrite wwB_wBwB. rewrite Zpower_2. rewrite U1;rewrite U2;rewrite U3. - rewrite Zmult_assoc. rewrite Zmult_plus_distr_l. + rewrite Zmult_assoc. rewrite Zmult_plus_distr_l. rewrite (Zplus_assoc ([|ah|] / 2^(Zpos(w_digits) - [|w_head0 bh|])*wB * wB)). - rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. + rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. unfold base;repeat rewrite <- shift_unshift_mod;zarith. fold wB. replace ([|ah|] * 2 ^ [|w_head0 bh|] * wB + [|al|] * 2 ^ [|w_head0 bh|]) with ([[WW ah al]] * 2^[|w_head0 bh|]). 2:simpl;ring. @@ -1027,7 +1027,7 @@ Section DoubleDivGt. [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]. Proof. - intros a b Hgt Hpos;unfold ww_div_gt. + intros a b Hgt Hpos;unfold ww_div_gt. change (let (q,r) := match a, b with | W0, _ => (W0,W0) | _, W0 => (W0,W0) @@ -1035,23 +1035,23 @@ Section DoubleDivGt. if w_eq0 ah then let (q,r) := w_div_gt al bl in (WW w_0 q, w_0W r) - else + else match w_compare w_0 bh with - | Eq => + | Eq => let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 a bl in (q, w_0W r) | Lt => ww_div_gt_aux ah al bh bl | Gt => (W0,W0) (* cas absurde *) end - end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]). + end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]). destruct a as [ |ah al]. simpl in Hgt;omega. destruct b as [ |bh bl]. simpl in Hpos;omega. Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). simpl ww_to_Z;rewrite H;trivial. simpl in Hgt;rewrite H in Hgt;trivial. - assert ([|bh|] <= 0). + assert ([|bh|] <= 0). apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;rewrite H1;simpl in Hgt. simpl. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. @@ -1066,7 +1066,7 @@ Section DoubleDivGt. w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hpos). unfold double_to_Z,double_wB,double_digits in H2. - destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW ah al) bl). rewrite spec_w_0W;unfold ww_to_Z;trivial. @@ -1104,26 +1104,26 @@ Section DoubleDivGt. rewrite Zmult_comm in H;destruct H. symmetry;apply Zmod_unique with [|q|];trivial. Qed. - + Lemma spec_ww_mod_gt_eq : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> [[ww_mod_gt a b]] = [[snd (ww_div_gt a b)]]. Proof. intros a b Hgt Hpos. - change (ww_mod_gt a b) with + change (ww_mod_gt a b) with (match a, b with | W0, _ => W0 | _, W0 => W0 | WW ah al, WW bh bl => if w_eq0 ah then w_0W (w_mod_gt al bl) - else + else match w_compare w_0 bh with - | Eq => - w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + | Eq => + w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 a bl) | Lt => ww_mod_gt_aux ah al bh bl | Gt => W0 (* cas absurde *) end end). - change (ww_div_gt a b) with + change (ww_div_gt a b) with (match a, b with | W0, _ => (W0,W0) | _, W0 => (W0,W0) @@ -1131,11 +1131,11 @@ Section DoubleDivGt. if w_eq0 ah then let (q,r) := w_div_gt al bl in (WW w_0 q, w_0W r) - else + else match w_compare w_0 bh with - | Eq => + | Eq => let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 + double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 a bl in (q, w_0W r) | Lt => ww_div_gt_aux ah al bh bl @@ -1147,7 +1147,7 @@ Section DoubleDivGt. Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). simpl in Hgt;rewrite H in Hgt;trivial. - assert ([|bh|] <= 0). + assert ([|bh|] <= 0). apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. @@ -1155,7 +1155,7 @@ Section DoubleDivGt. destruct (w_div_gt al bl);simpl;rewrite spec_w_0W;trivial. clear H. assert (H2 := spec_compare w_0 bh);destruct (w_compare w_0 bh). - rewrite (@spec_double_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div + rewrite (@spec_double_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub w_to_Z spec_w_0 spec_compare 1 (WW ah al) bl). destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW ah al) bl);simpl;trivial. @@ -1174,7 +1174,7 @@ Section DoubleDivGt. rewrite Zmult_comm;trivial. Qed. - Lemma Zis_gcd_mod : forall a b d, + Lemma Zis_gcd_mod : forall a b d, 0 < b -> Zis_gcd b (a mod b) d -> Zis_gcd a b d. Proof. intros a b d H H1; apply Zis_gcd_for_euclid with (a/b). @@ -1182,12 +1182,12 @@ Section DoubleDivGt. ring_simplify (b * (a / b) + a mod b - a / b * b);trivial. zarith. Qed. - Lemma spec_ww_gcd_gt_aux_body : + Lemma spec_ww_gcd_gt_aux_body : forall ah al bh bl n cont, - [[WW bh bl]] <= 2^n -> + [[WW bh bl]] <= 2^n -> [[WW ah al]] > [[WW bh bl]] -> - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) -> + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) -> Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_body cont ah al bh bl]]. Proof. @@ -1196,7 +1196,7 @@ Section DoubleDivGt. | Eq => match w_compare w_0 bl with | Eq => WW ah al (* normalement n'arrive pas si forme normale *) - | Lt => + | Lt => let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW ah al) bl in WW w_0 (w_gcd_gt bl m) @@ -1205,14 +1205,14 @@ Section DoubleDivGt. | Lt => let m := ww_mod_gt_aux ah al bh bl in match m with - | W0 => WW bh bl + | W0 => WW bh bl | WW mh ml => match w_compare w_0 mh with | Eq => match w_compare w_0 ml with | Eq => WW bh bl - | _ => - let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 + | _ => + let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 w_compare w_sub 1 (WW bh bl) ml in WW w_0 (w_gcd_gt ml r) end @@ -1227,10 +1227,10 @@ Section DoubleDivGt. end | Gt => W0 (* absurde *) end). - assert (Hbh := spec_compare w_0 bh);destruct (w_compare w_0 bh). + assert (Hbh := spec_compare w_0 bh);destruct (w_compare w_0 bh). simpl ww_to_Z in *. rewrite spec_w_0 in Hbh;rewrite <- Hbh; rewrite Zmult_0_l;rewrite Zplus_0_l. - assert (Hbl := spec_compare w_0 bl); destruct (w_compare w_0 bl). + assert (Hbl := spec_compare w_0 bl); destruct (w_compare w_0 bl). rewrite spec_w_0 in Hbl;rewrite <- Hbl;apply Zis_gcd_0. simpl;rewrite spec_w_0;rewrite Zmult_0_l;rewrite Zplus_0_l. rewrite spec_w_0 in Hbl. @@ -1239,54 +1239,54 @@ Section DoubleDivGt. rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hbl). - apply spec_gcd_gt. - rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. - apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + apply spec_gcd_gt. + rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. + apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. rewrite spec_w_0 in Hbl;Spec_w_to_Z bl;elimtype False;omega. rewrite spec_w_0 in Hbh;assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh). - assert (H2 : 0 < [[WW bh bl]]). + assert (H2 : 0 < [[WW bh bl]]). simpl;Spec_w_to_Z bl. apply Zlt_le_trans with ([|bh|]*wB);zarith. apply Zmult_lt_0_compat;zarith. apply Zis_gcd_mod;trivial. rewrite <- H. simpl in *;destruct (ww_mod_gt_aux ah al bh bl) as [ |mh ml]. - simpl;apply Zis_gcd_0;zarith. - assert (Hmh := spec_compare w_0 mh);destruct (w_compare w_0 mh). + simpl;apply Zis_gcd_0;zarith. + assert (Hmh := spec_compare w_0 mh);destruct (w_compare w_0 mh). simpl;rewrite spec_w_0 in Hmh; rewrite <- Hmh;simpl. - assert (Hml := spec_compare w_0 ml);destruct (w_compare w_0 ml). + assert (Hml := spec_compare w_0 ml);destruct (w_compare w_0 ml). rewrite <- Hml;rewrite spec_w_0;simpl;apply Zis_gcd_0. - simpl;rewrite spec_w_0;simpl. + simpl;rewrite spec_w_0;simpl. rewrite spec_w_0 in Hml. apply Zis_gcd_mod;zarith. change ([|bh|] * wB + [|bl|]) with (double_to_Z w_digits w_to_Z 1 (WW bh bl)). rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW bh bl) ml Hml). - apply spec_gcd_gt. - rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. - apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + apply spec_gcd_gt. + rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. + apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. rewrite spec_w_0 in Hml;Spec_w_to_Z ml;elimtype False;omega. rewrite spec_w_0 in Hmh. assert ([[WW bh bl]] > [[WW mh ml]]). - rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + rewrite H;simpl; apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. assert (H1:= spec_ww_mod_gt_aux _ _ _ H0 Hmh). - assert (H3 : 0 < [[WW mh ml]]). + assert (H3 : 0 < [[WW mh ml]]). simpl;Spec_w_to_Z ml. apply Zlt_le_trans with ([|mh|]*wB);zarith. apply Zmult_lt_0_compat;zarith. apply Zis_gcd_mod;zarith. simpl in *;rewrite <- H1. destruct (ww_mod_gt_aux bh bl mh ml) as [ |rh rl]. simpl; apply Zis_gcd_0. simpl;apply Hcont. simpl in H1;rewrite H1. - apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => + apply Zlt_gt;match goal with | |- ?x mod ?y < ?y => destruct (Z_mod_lt x y);zarith end. - apply Zle_trans with (2^n/2). - apply Zdiv_le_lower_bound;zarith. + apply Zle_trans with (2^n/2). + apply Zdiv_le_lower_bound;zarith. apply Zle_trans with ([|bh|] * wB + [|bl|]);zarith. assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Zlt_gt _ _ H3)). assert (H4' : 0 <= [[WW bh bl]]/[[WW mh ml]]). apply Zge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1. pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3'. destruct (Zle_lt_or_eq _ _ H4'). - assert (H6' : [[WW bh bl]] mod [[WW mh ml]] = + assert (H6' : [[WW bh bl]] mod [[WW mh ml]] = [[WW bh bl]] - [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). simpl;pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3';ring. simpl in H6'. assert ([[WW mh ml]] <= [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). @@ -1304,10 +1304,10 @@ Section DoubleDivGt. rewrite spec_w_0 in Hbh;Spec_w_to_Z bh;elimtype False;zarith. Qed. - Lemma spec_ww_gcd_gt_aux : + Lemma spec_ww_gcd_gt_aux : forall p cont n, - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^n -> Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> @@ -1334,7 +1334,7 @@ Section DoubleDivGt. apply Zle_trans with (2 ^ (Zpos p + n -1));zarith. apply Zpower_le_monotone2;zarith. apply Zle_trans with (2 ^ (2*Zpos p + n -1));zarith. - apply Zpower_le_monotone2;zarith. + apply Zpower_le_monotone2;zarith. apply spec_ww_gcd_gt_aux_body with (n := n+1);trivial. rewrite Zplus_comm;trivial. ring_simplify (n + 1 - 1);trivial. @@ -1352,16 +1352,16 @@ Section DoubleDiv. Variable ww_div_gt : zn2z w -> zn2z w -> zn2z w * zn2z w. Variable ww_mod_gt : zn2z w -> zn2z w -> zn2z w. - Definition ww_div a b := - match ww_compare a b with - | Gt => ww_div_gt a b + Definition ww_div a b := + match ww_compare a b with + | Gt => ww_div_gt a b | Eq => (ww_1, W0) | Lt => (W0, a) end. - Definition ww_mod a b := - match ww_compare a b with - | Gt => ww_mod_gt a b + Definition ww_mod a b := + match ww_compare a b with + | Gt => ww_mod_gt a b | Eq => W0 | Lt => a end. @@ -1401,7 +1401,7 @@ Section DoubleDiv. Proof. intros a b Hpos;unfold ww_div. assert (H:=spec_ww_compare a b);destruct (ww_compare a b). - simpl;rewrite spec_ww_1;split;zarith. + simpl;rewrite spec_ww_1;split;zarith. simpl;split;[ring|Spec_ww_to_Z a;zarith]. apply spec_ww_div_gt;trivial. Qed. @@ -1409,7 +1409,7 @@ Section DoubleDiv. Lemma spec_ww_mod : forall a b, 0 < [[b]] -> [[ww_mod a b]] = [[a]] mod [[b]]. Proof. - intros a b Hpos;unfold ww_mod. + intros a b Hpos;unfold ww_mod. assert (H := spec_ww_compare a b);destruct (ww_compare a b). simpl;apply Zmod_unique with 1;try rewrite H;zarith. Spec_ww_to_Z a;symmetry;apply Zmod_small;zarith. @@ -1424,8 +1424,8 @@ Section DoubleDiv. Variable w_gcd_gt : w -> w -> w. Variable _ww_digits : positive. Variable spec_ww_digits_ : _ww_digits = xO w_digits. - Variable ww_gcd_gt_fix : - positive -> (w -> w -> w -> w -> zn2z w) -> + Variable ww_gcd_gt_fix : + positive -> (w -> w -> w -> w -> zn2z w) -> w -> w -> w -> w -> zn2z w. Variable spec_w_0 : [|w_0|] = 0. @@ -1440,10 +1440,10 @@ Section DoubleDiv. Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. - Variable spec_gcd_gt_fix : + Variable spec_gcd_gt_fix : forall p cont n, - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> + (forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^n -> Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> @@ -1451,20 +1451,20 @@ Section DoubleDiv. Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_fix p cont ah al bh bl]]. - Definition gcd_cont (xh xl yh yl:w) := + Definition gcd_cont (xh xl yh yl:w) := match w_compare w_1 yl with - | Eq => ww_1 + | Eq => ww_1 | _ => WW xh xl end. - Lemma spec_gcd_cont : forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> + Lemma spec_gcd_cont : forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 1 -> Zis_gcd [[WW xh xl]] [[WW yh yl]] [[gcd_cont xh xl yh yl]]. Proof. intros xh xl yh yl Hgt' Hle. simpl in Hle. assert ([|yh|] = 0). - change 1 with (0*wB+1) in Hle. + change 1 with (0*wB+1) in Hle. assert (0 <= 1 < wB). split;zarith. apply wB_pos. assert (H1:= beta_lex _ _ _ _ _ Hle (spec_to_Z yl) H). Spec_w_to_Z yh;zarith. @@ -1478,15 +1478,15 @@ Section DoubleDiv. rewrite H0;simpl;apply Zis_gcd_0;trivial. Qed. - + Variable cont : w -> w -> w -> w -> zn2z w. - Variable spec_cont : forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> + Variable spec_cont : forall xh xl yh yl, + [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 1 -> Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]. - - Definition ww_gcd_gt a b := - match a, b with + + Definition ww_gcd_gt a b := + match a, b with | W0, _ => b | _, W0 => a | WW ah al, WW bh bl => @@ -1509,8 +1509,8 @@ Section DoubleDiv. destruct a as [ |ah al]. simpl;apply Zis_gcd_sym;apply Zis_gcd_0. destruct b as [ |bh bl]. simpl;apply Zis_gcd_0. simpl in Hgt. generalize (@spec_eq0 ah);destruct (w_eq0 ah);intros. - simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl. - assert ([|bh|] <= 0). + simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl. + assert ([|bh|] <= 0). apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. Spec_w_to_Z bh;assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. rewrite H1;simpl;auto. clear H. @@ -1522,7 +1522,7 @@ Section DoubleDiv. Lemma spec_ww_gcd : forall a b, Zis_gcd [[a]] [[b]] [[ww_gcd a b]]. Proof. intros a b. - change (ww_gcd a b) with + change (ww_gcd a b) with (match ww_compare a b with | Gt => ww_gcd_gt a b | Eq => a diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v index 1f1d609f1d..fd6718e4e9 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v @@ -31,19 +31,19 @@ Section GENDIVN1. Variable w_div21 : w -> w -> w -> w * w. Variable w_compare : w -> w -> comparison. Variable w_sub : w -> w -> w. - - + + (* ** For proofs ** *) Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). + + Notation wB := (base w_digits). Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) + Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) (at level 0, x at level 99). Notation "[[ x ]]" := (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). - + Variable spec_to_Z : forall x, 0 <= [| x |] < wB. Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. Variable spec_0 : [|w_0|] = 0. @@ -68,10 +68,10 @@ Section GENDIVN1. | Lt => [|x|] < [|y|] | Gt => [|x|] > [|y|] end. - Variable spec_sub: forall x y, + Variable spec_sub: forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - + Section DIVAUX. Variable b2p : w. @@ -85,10 +85,10 @@ Section GENDIVN1. Fixpoint double_divn1_0 (n:nat) : w -> word w n -> word w n * w := match n return w -> word w n -> word w n * w with - | O => fun r x => w_div21 r x b2p - | S n => double_divn1_0_aux n (double_divn1_0 n) + | O => fun r x => w_div21 r x b2p + | S n => double_divn1_0_aux n (double_divn1_0 n) end. - + Lemma spec_split : forall (n : nat) (x : zn2z (word w n)), let (h, l) := double_split w_0 n x in [!S n | x!] = [!n | h!] * double_wB w_digits n + [!n | l!]. @@ -132,11 +132,11 @@ Section GENDIVN1. induction n;simpl;intros;trivial. unfold double_modn1_0_aux, double_divn1_0_aux. destruct (double_split w_0 n x) as (hh,hl). - rewrite (IHn r hh). + rewrite (IHn r hh). destruct (double_divn1_0 n r hh) as (qh,rh);simpl. rewrite IHn. destruct (double_divn1_0 n rh hl);trivial. Qed. - + Variable p : w. Variable p_bounded : [|p|] <= Zpos w_digits. @@ -148,18 +148,18 @@ Section GENDIVN1. intros;apply spec_add_mul_div;auto. Qed. - Definition double_divn1_p_aux n - (divn1 : w -> word w n -> word w n -> word w n * w) r h l := + Definition double_divn1_p_aux n + (divn1 : w -> word w n -> word w n -> word w n * w) r h l := let (hh,hl) := double_split w_0 n h in - let (lh,ll) := double_split w_0 n l in + let (lh,ll) := double_split w_0 n l in let (qh,rh) := divn1 r hh hl in let (ql,rl) := divn1 rh hl lh in (double_WW w_WW n qh ql, rl). Fixpoint double_divn1_p (n:nat) : w -> word w n -> word w n -> word w n * w := match n return w -> word w n -> word w n -> word w n * w with - | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p - | S n => double_divn1_p_aux n (double_divn1_p n) + | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p + | S n => double_divn1_p_aux n (double_divn1_p n) end. Lemma p_lt_double_digits : forall n, [|p|] <= Zpos (double_digits w_digits n). @@ -175,8 +175,8 @@ Section GENDIVN1. Lemma spec_double_divn1_p : forall n r h l, [|r|] < [|b2p|] -> let (q,r') := double_divn1_p n r h l in - [|r|] * double_wB w_digits n + - ([!n|h!]*2^[|p|] + + [|r|] * double_wB w_digits n + + ([!n|h!]*2^[|p|] + [!n|l!] / (2^(Zpos(double_digits w_digits n) - [|p|]))) mod double_wB w_digits n = [!n|q!] * [|b2p|] + [|r'|] /\ 0 <= [|r'|] < [|b2p|]. @@ -198,26 +198,26 @@ Section GENDIVN1. ([!n|lh!] * double_wB w_digits n + [!n|ll!]) / 2^(Zpos (double_digits w_digits (S n)) - [|p|])) mod (double_wB w_digits n * double_wB w_digits n)) with - (([|r|] * double_wB w_digits n + ([!n|hh!] * 2^[|p|] + + (([|r|] * double_wB w_digits n + ([!n|hh!] * 2^[|p|] + [!n|hl!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod double_wB w_digits n) * double_wB w_digits n + - ([!n|hl!] * 2^[|p|] + - [!n|lh!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod + ([!n|hl!] * 2^[|p|] + + [!n|lh!] / 2^(Zpos (double_digits w_digits n) - [|p|])) mod double_wB w_digits n). generalize (IHn r hh hl H);destruct (double_divn1_p n r hh hl) as (qh,rh); intros (H3,H4);rewrite H3. - assert ([|rh|] < [|b2p|]). omega. + assert ([|rh|] < [|b2p|]). omega. replace (([!n|qh!] * [|b2p|] + [|rh|]) * double_wB w_digits n + ([!n|hl!] * 2 ^ [|p|] + [!n|lh!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])) mod - double_wB w_digits n) with + double_wB w_digits n) with ([!n|qh!] * [|b2p|] *double_wB w_digits n + ([|rh|]*double_wB w_digits n + ([!n|hl!] * 2 ^ [|p|] + [!n|lh!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])) mod double_wB w_digits n)). 2:ring. generalize (IHn rh hl lh H0);destruct (double_divn1_p n rh hl lh) as (ql,rl); intros (H5,H6);rewrite H5. - split;[rewrite spec_double_WW;trivial;ring|trivial]. + split;[rewrite spec_double_WW;trivial;ring|trivial]. assert (Uhh := spec_double_to_Z w_digits w_to_Z spec_to_Z n hh); unfold double_wB,base in Uhh. assert (Uhl := spec_double_to_Z w_digits w_to_Z spec_to_Z n hl); @@ -228,37 +228,37 @@ Section GENDIVN1. unfold double_wB,base in Ull. unfold double_wB,base. assert (UU:=p_lt_double_digits n). - rewrite Zdiv_shift_r;auto with zarith. - 2:change (Zpos (double_digits w_digits (S n))) + rewrite Zdiv_shift_r;auto with zarith. + 2:change (Zpos (double_digits w_digits (S n))) with (2*Zpos (double_digits w_digits n));auto with zarith. replace (2 ^ (Zpos (double_digits w_digits (S n)) - [|p|])) with (2^(Zpos (double_digits w_digits n) - [|p|])*2^Zpos (double_digits w_digits n)). rewrite Zdiv_mult_cancel_r;auto with zarith. - rewrite Zmult_plus_distr_l with (p:= 2^[|p|]). + rewrite Zmult_plus_distr_l with (p:= 2^[|p|]). pattern ([!n|hl!] * 2^[|p|]) at 2; rewrite (shift_unshift_mod (Zpos(double_digits w_digits n))([|p|])([!n|hl!])); auto with zarith. - rewrite Zplus_assoc. - replace + rewrite Zplus_assoc. + replace ([!n|hh!] * 2^Zpos (double_digits w_digits n)* 2^[|p|] + ([!n|hl!] / 2^(Zpos (double_digits w_digits n)-[|p|])* 2^Zpos(double_digits w_digits n))) - with - (([!n|hh!] *2^[|p|] + double_to_Z w_digits w_to_Z n hl / + with + (([!n|hh!] *2^[|p|] + double_to_Z w_digits w_to_Z n hl / 2^(Zpos (double_digits w_digits n)-[|p|])) * 2^Zpos(double_digits w_digits n));try (ring;fail). rewrite <- Zplus_assoc. rewrite <- (Zmod_shift_r ([|p|]));auto with zarith. - replace + replace (2 ^ Zpos (double_digits w_digits n) * 2 ^ Zpos (double_digits w_digits n)) with (2 ^ (Zpos (double_digits w_digits n) + Zpos (double_digits w_digits n))). rewrite (Zmod_shift_r (Zpos (double_digits w_digits n)));auto with zarith. replace (2 ^ (Zpos (double_digits w_digits n) + Zpos (double_digits w_digits n))) - with (2^Zpos(double_digits w_digits n) *2^Zpos(double_digits w_digits n)). + with (2^Zpos(double_digits w_digits n) *2^Zpos(double_digits w_digits n)). rewrite (Zmult_comm (([!n|hh!] * 2 ^ [|p|] + [!n|hl!] / 2 ^ (Zpos (double_digits w_digits n) - [|p|])))). rewrite Zmult_mod_distr_l;auto with zarith. - ring. + ring. rewrite Zpower_exp;auto with zarith. assert (0 < Zpos (double_digits w_digits n)). unfold Zlt;reflexivity. auto with zarith. @@ -267,24 +267,24 @@ Section GENDIVN1. split;auto with zarith. apply Zdiv_lt_upper_bound;auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace ([|p|] + (Zpos (double_digits w_digits n) - [|p|])) with + replace ([|p|] + (Zpos (double_digits w_digits n) - [|p|])) with (Zpos(double_digits w_digits n));auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (double_digits w_digits (S n)) - [|p|]) with - (Zpos (double_digits w_digits n) - [|p|] + + replace (Zpos (double_digits w_digits (S n)) - [|p|]) with + (Zpos (double_digits w_digits n) - [|p|] + Zpos (double_digits w_digits n));trivial. - change (Zpos (double_digits w_digits (S n))) with + change (Zpos (double_digits w_digits (S n))) with (2*Zpos (double_digits w_digits n)). ring. Qed. Definition double_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:= let (hh,hl) := double_split w_0 n h in - let (lh,ll) := double_split w_0 n l in + let (lh,ll) := double_split w_0 n l in modn1 (modn1 r hh hl) hl lh. Fixpoint double_modn1_p (n:nat) : w -> word w n -> word w n -> w := match n return w -> word w n -> word w n -> w with - | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p) + | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p) | S n => double_modn1_p_aux n (double_modn1_p n) end. @@ -302,8 +302,8 @@ Section GENDIVN1. Fixpoint high (n:nat) : word w n -> w := match n return word w n -> w with - | O => fun a => a - | S n => + | O => fun a => a + | S n => fun (a:zn2z (word w n)) => match a with | W0 => w_0 @@ -314,20 +314,20 @@ Section GENDIVN1. Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (double_digits w_digits n). Proof. induction n;simpl;auto with zarith. - change (Zpos (xO (double_digits w_digits n))) with + change (Zpos (xO (double_digits w_digits n))) with (2*Zpos (double_digits w_digits n)). assert (0 < Zpos w_digits);auto with zarith. exact (refl_equal Lt). Qed. - Lemma spec_high : forall n (x:word w n), + Lemma spec_high : forall n (x:word w n), [|high n x|] = [!n|x!] / 2^(Zpos (double_digits w_digits n) - Zpos w_digits). Proof. induction n;intros. unfold high,double_digits,double_to_Z. replace (Zpos w_digits - Zpos w_digits) with 0;try ring. simpl. rewrite <- (Zdiv_unique [|x|] 1 [|x|] 0);auto with zarith. - assert (U2 := spec_double_digits n). + assert (U2 := spec_double_digits n). assert (U3 : 0 < Zpos w_digits). exact (refl_equal Lt). destruct x;unfold high;fold high. unfold double_to_Z,zn2z_to_Z;rewrite spec_0. @@ -337,31 +337,31 @@ Section GENDIVN1. simpl [!S n|WW w0 w1!]. unfold double_wB,base;rewrite Zdiv_shift_r;auto with zarith. replace (2 ^ (Zpos (double_digits w_digits (S n)) - Zpos w_digits)) with - (2^(Zpos (double_digits w_digits n) - Zpos w_digits) * + (2^(Zpos (double_digits w_digits n) - Zpos w_digits) * 2^Zpos (double_digits w_digits n)). rewrite Zdiv_mult_cancel_r;auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (double_digits w_digits n) - Zpos w_digits + + replace (Zpos (double_digits w_digits n) - Zpos w_digits + Zpos (double_digits w_digits n)) with (Zpos (double_digits w_digits (S n)) - Zpos w_digits);trivial. - change (Zpos (double_digits w_digits (S n))) with + change (Zpos (double_digits w_digits (S n))) with (2*Zpos (double_digits w_digits n));ring. - change (Zpos (double_digits w_digits (S n))) with + change (Zpos (double_digits w_digits (S n))) with (2*Zpos (double_digits w_digits n)); auto with zarith. Qed. - - Definition double_divn1 (n:nat) (a:word w n) (b:w) := + + Definition double_divn1 (n:nat) (a:word w n) (b:w) := let p := w_head0 b in match w_compare p w_0 with | Gt => let b2p := w_add_mul_div p b w_0 in let ha := high n a in let k := w_sub w_zdigits p in - let lsr_n := w_add_mul_div k w_0 in + let lsr_n := w_add_mul_div k w_0 in let r0 := w_add_mul_div p w_0 ha in let (q,r) := double_divn1_p b2p p n r0 a (double_0 w_0 n) in (q, lsr_n r) - | _ => double_divn1_0 b n w_0 a + | _ => double_divn1_0 b n w_0 a end. Lemma spec_double_divn1 : forall n a b, @@ -392,21 +392,21 @@ Section GENDIVN1. apply Zmult_le_compat;auto with zarith. assert (wB <= 2^[|w_head0 b|]). unfold base;apply Zpower_le_monotone;auto with zarith. omega. - assert ([|w_add_mul_div (w_head0 b) b w_0|] = + assert ([|w_add_mul_div (w_head0 b) b w_0|] = 2 ^ [|w_head0 b|] * [|b|]). rewrite (spec_add_mul_div b w_0); auto with zarith. rewrite spec_0;rewrite Zdiv_0_l; try omega. rewrite Zplus_0_r; rewrite Zmult_comm. rewrite Zmod_small; auto with zarith. assert (H5 := spec_to_Z (high n a)). - assert + assert ([|w_add_mul_div (w_head0 b) w_0 (high n a)|] <[|w_add_mul_div (w_head0 b) b w_0|]). rewrite H4. rewrite spec_add_mul_div;auto with zarith. rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l. assert (([|high n a|]/2^(Zpos w_digits - [|w_head0 b|])) < wB). - apply Zdiv_lt_upper_bound;auto with zarith. + apply Zdiv_lt_upper_bound;auto with zarith. apply Zlt_le_trans with wB;auto with zarith. pattern wB at 1;replace wB with (wB*1);try ring. apply Zmult_le_compat;auto with zarith. @@ -420,8 +420,8 @@ Section GENDIVN1. apply Zmult_le_compat;auto with zarith. pattern 2 at 1;rewrite <- Zpower_1_r. apply Zpower_le_monotone;split;auto with zarith. - rewrite <- H4 in H0. - assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith. + rewrite <- H4 in H0. + assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith. assert (H7:= spec_double_divn1_p H0 Hb3 n a (double_0 w_0 n) H6). destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n (w_add_mul_div (w_head0 b) w_0 (high n a)) a @@ -436,7 +436,7 @@ Section GENDIVN1. rewrite Zmod_small;auto with zarith. rewrite spec_high. rewrite Zdiv_Zdiv;auto with zarith. rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (double_digits w_digits n) - Zpos w_digits + + replace (Zpos (double_digits w_digits n) - Zpos w_digits + (Zpos w_digits - [|w_head0 b|])) with (Zpos (double_digits w_digits n) - [|w_head0 b|]);trivial;ring. assert (H8 := Zpower_gt_0 2 (Zpos w_digits - [|w_head0 b|]));auto with zarith. @@ -448,11 +448,11 @@ Section GENDIVN1. rewrite H8 in H7;unfold double_wB,base in H7. rewrite <- shift_unshift_mod in H7;auto with zarith. rewrite H4 in H7. - assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|] + assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|] = [|r|]/2^[|w_head0 b|]). rewrite spec_add_mul_div. rewrite spec_0;rewrite Zmult_0_l;rewrite Zplus_0_l. - replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|]) + replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|]) with ([|w_head0 b|]). rewrite Zmod_small;auto with zarith. assert (H9 := spec_to_Z r). @@ -474,11 +474,11 @@ Section GENDIVN1. split. rewrite <- (Z_div_mult [!n|a!] (2^[|w_head0 b|]));auto with zarith. rewrite H71;rewrite H9. - replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|])) + replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|])) with ([!n|q!] *[|b|] * 2^[|w_head0 b|]); try (ring;fail). rewrite Z_div_plus_l;auto with zarith. - assert (H10 := spec_to_Z + assert (H10 := spec_to_Z (w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r));split; auto with zarith. rewrite H9. @@ -487,19 +487,19 @@ Section GENDIVN1. exact (spec_double_to_Z w_digits w_to_Z spec_to_Z n a). Qed. - - Definition double_modn1 (n:nat) (a:word w n) (b:w) := + + Definition double_modn1 (n:nat) (a:word w n) (b:w) := let p := w_head0 b in match w_compare p w_0 with | Gt => let b2p := w_add_mul_div p b w_0 in let ha := high n a in let k := w_sub w_zdigits p in - let lsr_n := w_add_mul_div k w_0 in + let lsr_n := w_add_mul_div k w_0 in let r0 := w_add_mul_div p w_0 ha in let r := double_modn1_p b2p p n r0 a (double_0 w_0 n) in lsr_n r - | _ => double_modn1_0 b n w_0 a + | _ => double_modn1_0 b n w_0 a end. Lemma spec_double_modn1_aux : forall n a b, @@ -525,4 +525,4 @@ Section GENDIVN1. destruct H1 as (h1,h2);rewrite h1;ring. Qed. -End GENDIVN1. +End GENDIVN1. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v index d9c2340936..28dff1a29a 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v @@ -61,13 +61,13 @@ Section DoubleLift. (* 0 < p < ww_digits *) - Definition ww_add_mul_div p x y := + Definition ww_add_mul_div p x y := let zdigits := w_0W w_zdigits in match x, y with | W0, W0 => W0 | W0, WW yh yl => match ww_compare p zdigits with - | Eq => w_0W yh + | Eq => w_0W yh | Lt => w_0W (w_add_mul_div (low p) w_0 yh) | Gt => let n := low (ww_sub p zdigits) in @@ -75,15 +75,15 @@ Section DoubleLift. end | WW xh xl, W0 => match ww_compare p zdigits with - | Eq => w_W0 xl + | Eq => w_W0 xl | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl w_0) | Gt => let n := low (ww_sub p zdigits) in - w_W0 (w_add_mul_div n xl w_0) + w_W0 (w_add_mul_div n xl w_0) end | WW xh xl, WW yh yl => match ww_compare p zdigits with - | Eq => w_WW xl yh + | Eq => w_WW xl yh | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh) | Gt => let n := low (ww_sub p zdigits) in @@ -93,7 +93,7 @@ Section DoubleLift. Section DoubleProof. Variable w_to_Z : w -> Z. - + Notation wB := (base w_digits). Notation wwB := (base (ww_digits w_digits)). Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). @@ -122,21 +122,21 @@ Section DoubleLift. Variable spec_w_head0 : forall x, 0 < [|x|] -> wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB. Variable spec_w_tail00 : forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits. - Variable spec_w_tail0 : forall x, 0 < [|x|] -> + Variable spec_w_tail0 : forall x, 0 < [|x|] -> exists y, 0 <= y /\ [|x|] = (2* y + 1) * (2 ^ [|w_tail0 x|]). Variable spec_w_add_mul_div : forall x y p, [|p|] <= Zpos w_digits -> [| w_add_mul_div p x y |] = ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_w_add: forall x y, + Variable spec_w_add: forall x y, [[w_add x y]] = [|x|] + [|y|]. - Variable spec_ww_sub: forall x y, + Variable spec_ww_sub: forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. Variable spec_low: forall x, [| low x|] = [[x]] mod wB. - + Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos ww_Digits. Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift. @@ -168,7 +168,7 @@ Section DoubleLift. rewrite spec_w_0; auto with zarith. rewrite spec_w_0; auto with zarith. Qed. - + Lemma spec_ww_head0 : forall x, 0 < [[x]] -> wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB. Proof. @@ -179,7 +179,7 @@ Section DoubleLift. assert (H0 := spec_compare w_0 xh);rewrite spec_w_0 in H0. destruct (w_compare w_0 xh). rewrite <- H0. simpl Zplus. rewrite <- H0 in H;simpl in H. - case (spec_to_Z w_zdigits); + case (spec_to_Z w_zdigits); case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4. rewrite spec_w_add. rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith. @@ -209,7 +209,7 @@ Section DoubleLift. rewrite <- Zmult_assoc; apply Zmult_lt_compat_l; zarith. rewrite <- (Zplus_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith. apply Zmult_lt_reg_r with (2 ^ p); zarith. - rewrite <- Zpower_exp;zarith. + rewrite <- Zpower_exp;zarith. rewrite Zmult_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith. assert (H1 := spec_to_Z xh);zarith. Qed. @@ -293,8 +293,8 @@ Section DoubleLift. Qed. Hint Rewrite Zdiv_0_l Zmult_0_l Zplus_0_l Zmult_0_r Zplus_0_r - spec_w_W0 spec_w_0W spec_w_WW spec_w_0 - (wB_div w_digits w_to_Z spec_to_Z) + spec_w_W0 spec_w_0W spec_w_WW spec_w_0 + (wB_div w_digits w_to_Z spec_to_Z) (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite. Ltac w_rewrite := autorewrite with w_rewrite;trivial. @@ -303,12 +303,12 @@ Section DoubleLift. [[p]] <= Zpos (xO w_digits) -> [[match ww_compare p zdigits with | Eq => w_WW xl yh - | Lt => w_WW (w_add_mul_div (low p) xh xl) + | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh) | Gt => let n := low (ww_sub p zdigits) in w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) - end]] = + end]] = ([[WW xh xl]] * (2^[[p]]) + [[WW yh yl]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. Proof. @@ -317,7 +317,7 @@ Section DoubleLift. case (spec_to_w_Z p); intros Hv1 Hv2. replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits). 2 : rewrite Zpos_xO;ring. - replace (Zpos w_digits + Zpos w_digits - [[p]]) with + replace (Zpos w_digits + Zpos w_digits - [[p]]) with (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring. intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl); assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)); @@ -330,7 +330,7 @@ Section DoubleLift. fold wB. rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;rewrite <- Zplus_assoc. rewrite <- Zpower_2. - rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|]. + rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|]. exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring. simpl ww_to_Z; w_rewrite;zarith. assert (HH0: [|low p|] = [[p]]). @@ -353,7 +353,7 @@ Section DoubleLift. rewrite Zmult_plus_distr_l. pattern ([|xl|] * 2 ^ [[p]]) at 2; rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith. - replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring. + replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring. rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc. unfold base at 5;rewrite <- Zmod_shift_r;zarith. unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); @@ -387,8 +387,8 @@ Section DoubleLift. lazy zeta; simpl ww_to_Z; w_rewrite;zarith. repeat rewrite spec_w_add_mul_div;zarith. rewrite HH0. - pattern wB at 5;replace wB with - (2^(([[p]] - Zpos w_digits) + pattern wB at 5;replace wB with + (2^(([[p]] - Zpos w_digits) + (Zpos w_digits - ([[p]] - Zpos w_digits)))). rewrite Zpower_exp;zarith. rewrite Zmult_assoc. rewrite Z_div_plus_l;zarith. @@ -401,28 +401,28 @@ Section DoubleLift. repeat rewrite <- Zplus_assoc. unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); fold wB;fold wwB;zarith. - unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits) + unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits) (b:= Zpos w_digits);fold wB;fold wwB;zarith. rewrite wwB_wBwB; rewrite Zpower_2; rewrite Zmult_mod_distr_r;zarith. rewrite Zmult_plus_distr_l. - replace ([|xh|] * wB * 2 ^ u) with + replace ([|xh|] * wB * 2 ^ u) with ([|xh|]*2^u*wB). 2:ring. - repeat rewrite <- Zplus_assoc. + repeat rewrite <- Zplus_assoc. rewrite (Zplus_comm ([|xh|] * 2 ^ u * wB)). rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith. unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. - unfold u; split;zarith. + unfold u; split;zarith. split;zarith. unfold u; apply Zdiv_lt_upper_bound;zarith. rewrite <- Zpower_exp;zarith. - fold u. - ring_simplify (u + (Zpos w_digits - u)); fold + fold u. + ring_simplify (u + (Zpos w_digits - u)); fold wB;zarith. unfold ww_digits;rewrite Zpos_xO;zarith. unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. unfold u; split;zarith. unfold u; split;zarith. apply Zdiv_lt_upper_bound;zarith. rewrite <- Zpower_exp;zarith. - fold u. + fold u. ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith. unfold u;zarith. unfold u;zarith. @@ -446,7 +446,7 @@ Section DoubleLift. clear H1;w_rewrite);simpl ww_add_mul_div. replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. intros Heq;rewrite <- Heq;clear Heq; auto. - generalize (spec_ww_compare p (w_0W w_zdigits)); + generalize (spec_ww_compare p (w_0W w_zdigits)); case ww_compare; intros H1; w_rewrite. rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. generalize H1; w_rewrite; rewrite spec_zdigits; clear H1; intros H1. @@ -459,7 +459,7 @@ Section DoubleLift. rewrite HH0; auto with zarith. replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. intros Heq;rewrite <- Heq;clear Heq. - generalize (spec_ww_compare p (w_0W w_zdigits)); + generalize (spec_ww_compare p (w_0W w_zdigits)); case ww_compare; intros H1; w_rewrite. rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. rewrite Zpos_xO in H;zarith. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v index cc32214017..b215f6a868 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v @@ -45,7 +45,7 @@ Section DoubleMul. (* (xh*B+xl) (yh*B + yl) xh*yh = hh = |hhh|hhl|B2 xh*yl +xl*yh = cc = |cch|ccl|B - xl*yl = ll = |llh|lll + xl*yl = ll = |llh|lll *) Definition double_mul_c (cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w) x y := @@ -56,7 +56,7 @@ Section DoubleMul. let hh := w_mul_c xh yh in let ll := w_mul_c xl yl in let (wc,cc) := cross xh xl yh yl hh ll in - match cc with + match cc with | W0 => WW (ww_add hh (w_W0 wc)) ll | WW cch ccl => match ww_add_c (w_W0 ccl) ll with @@ -67,8 +67,8 @@ Section DoubleMul. end. Definition ww_mul_c := - double_mul_c - (fun xh xl yh yl hh ll=> + double_mul_c + (fun xh xl yh yl hh ll=> match ww_add_c (w_mul_c xh yl) (w_mul_c xl yh) with | C0 cc => (w_0, cc) | C1 cc => (w_1, cc) @@ -77,11 +77,11 @@ Section DoubleMul. Definition w_2 := w_add w_1 w_1. Definition kara_prod xh xl yh yl hh ll := - match ww_add_c hh ll with + match ww_add_c hh ll with C0 m => match w_compare xl xh with Eq => (w_0, m) - | Lt => + | Lt => match w_compare yl yh with Eq => (w_0, m) | Lt => (w_0, ww_sub m (w_mul_c (w_sub xh xl) (w_sub yh yl))) @@ -89,7 +89,7 @@ Section DoubleMul. C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) end end - | Gt => + | Gt => match w_compare yl yh with Eq => (w_0, m) | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with @@ -101,17 +101,17 @@ Section DoubleMul. | C1 m => match w_compare xl xh with Eq => (w_1, m) - | Lt => + | Lt => match w_compare yl yh with Eq => (w_1, m) | Lt => match ww_sub_c m (w_mul_c (w_sub xh xl) (w_sub yh yl)) with C0 m1 => (w_1, m1) | C1 m1 => (w_0, m1) - end + end | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) end end - | Gt => + | Gt => match w_compare yl yh with Eq => (w_1, m) | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with @@ -129,8 +129,8 @@ Section DoubleMul. Definition ww_mul x y := match x, y with | W0, _ => W0 - | _, W0 => W0 - | WW xh xl, WW yh yl => + | _, W0 => W0 + | WW xh xl, WW yh yl => let ccl := w_add (w_mul xh yl) (w_mul xl yh) in ww_add (w_W0 ccl) (w_mul_c xl yl) end. @@ -161,9 +161,9 @@ Section DoubleMul. Variable w_mul_add : w -> w -> w -> w * w. Fixpoint double_mul_add_n1 (n:nat) : word w n -> w -> w -> w * word w n := - match n return word w n -> w -> w -> w * word w n with - | O => w_mul_add - | S n1 => + match n return word w n -> w -> w -> w * word w n with + | O => w_mul_add + | S n1 => let mul_add := double_mul_add_n1 n1 in fun x y r => match x with @@ -183,11 +183,11 @@ Section DoubleMul. Variable wn_0W : wn -> zn2z wn. Variable wn_WW : wn -> wn -> zn2z wn. Variable w_mul_add_n1 : wn -> w -> w -> w*wn. - Fixpoint double_mul_add_mn1 (m:nat) : + Fixpoint double_mul_add_mn1 (m:nat) : word wn m -> w -> w -> w*word wn m := - match m return word wn m -> w -> w -> w*word wn m with - | O => w_mul_add_n1 - | S m1 => + match m return word wn m -> w -> w -> w*word wn m with + | O => w_mul_add_n1 + | S m1 => let mul_add := double_mul_add_mn1 m1 in fun x y r => match x with @@ -207,11 +207,11 @@ Section DoubleMul. | WW h l => match w_add_c l r with | C0 lr => (h,lr) - | C1 lr => (w_succ h, lr) + | C1 lr => (w_succ h, lr) end end. - + (*Section DoubleProof. *) Variable w_digits : positive. Variable w_to_Z : w -> Z. @@ -225,11 +225,11 @@ Section DoubleMul. (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). Notation "[|| x ||]" := @@ -269,8 +269,8 @@ Section DoubleMul. forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - - + + Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. Proof. intros x;apply spec_ww_to_Z;auto. Qed. @@ -281,21 +281,21 @@ Section DoubleMul. Ltac zarith := auto with zarith mult. Lemma wBwB_lex: forall a b c d, - a * wB^2 + [[b]] <= c * wB^2 + [[d]] -> + a * wB^2 + [[b]] <= c * wB^2 + [[d]] -> a <= c. - Proof. + Proof. intros a b c d H; apply beta_lex with [[b]] [[d]] (wB^2);zarith. Qed. - Lemma wBwB_lex_inv: forall a b c d, - a < c -> - a * wB^2 + [[b]] < c * wB^2 + [[d]]. + Lemma wBwB_lex_inv: forall a b c d, + a < c -> + a * wB^2 + [[b]] < c * wB^2 + [[d]]. Proof. intros a b c d H; apply beta_lex_inv; zarith. Qed. Lemma sum_mul_carry : forall xh xl yh yl wc cc, - [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> + [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> 0 <= [|wc|] <= 1. Proof. intros. @@ -303,14 +303,14 @@ Section DoubleMul. apply wB_pos. Qed. - Theorem mult_add_ineq: forall xH yH crossH, + Theorem mult_add_ineq: forall xH yH crossH, 0 <= [|xH|] * [|yH|] + [|crossH|] < wwB. Proof. intros;rewrite wwB_wBwB;apply mult_add_ineq;zarith. Qed. - + Hint Resolve mult_add_ineq : mult. - + Lemma spec_mul_aux : forall xh xl yh yl wc (cc:zn2z w) hh ll, [[hh]] = [|xh|] * [|yh|] -> [[ll]] = [|xl|] * [|yl|] -> @@ -325,9 +325,9 @@ Section DoubleMul. end||] = ([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|]). Proof. intros;assert (U1 := wB_pos w_digits). - replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with + replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with ([|xh|]*[|yh|]*wB^2 + ([|xh|]*[|yl|] + [|xl|]*[|yh|])*wB + [|xl|]*[|yl|]). - 2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0. + 2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0. assert (H2 := sum_mul_carry _ _ _ _ _ _ H1). destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z. rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_small; @@ -346,7 +346,7 @@ Section DoubleMul. rewrite <- Zmult_plus_distr_l. assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB). apply Zmult_le_compat;zarith. - rewrite Zmult_plus_distr_l in H3. + rewrite Zmult_plus_distr_l in H3. intros. assert (U2 := spec_to_Z ccl);omega. generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll) as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Zmult_1_l; @@ -363,8 +363,8 @@ Section DoubleMul. (forall xh xl yh yl hh ll, [[hh]] = [|xh|]*[|yh|] -> [[ll]] = [|xl|]*[|yl|] -> - let (wc,cc) := cross xh xl yh yl hh ll in - [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) -> + let (wc,cc) := cross xh xl yh yl hh ll in + [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) -> forall x y, [||double_mul_c cross x y||] = [[x]] * [[y]]. Proof. intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial. @@ -376,7 +376,7 @@ Section DoubleMul. rewrite <- wwB_wBwB;trivial. Qed. - Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]]. + Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]]. Proof. intros x y;unfold ww_mul_c;apply spec_double_mul_c. intros xh xl yh yl hh ll H1 H2. @@ -402,9 +402,9 @@ Section DoubleMul. let (wc,cc) := kara_prod xh xl yh yl hh ll in [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]. Proof. - intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux; + intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux; rewrite <- H; rewrite <- H0; unfold kara_prod. - assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl)); + assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl)); assert (Hyh := (spec_to_Z yh)); assert (Hyl := (spec_to_Z yl)). generalize (spec_ww_add_c hh ll); case (ww_add_c hh ll); intros z Hz; rewrite <- Hz; unfold interp_carry; assert (Hz1 := (spec_ww_to_Z z)). @@ -412,7 +412,7 @@ Section DoubleMul. try rewrite Hxlh; try rewrite spec_w_0; try (ring; fail). generalize (spec_w_compare yl yh); case (w_compare yl yh); intros Hylh. rewrite Hylh; rewrite spec_w_0; try (ring; fail). - rewrite spec_w_0; try (ring; fail). + rewrite spec_w_0; try (ring; fail). repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). repeat rewrite Zmod_small; auto with zarith; try (ring; fail). split; auto with zarith. @@ -508,8 +508,8 @@ Section DoubleMul. repeat rewrite Zmod_small; auto with zarith; try (ring; fail). Qed. - Lemma sub_carry : forall xh xl yh yl z, - 0 <= z -> + Lemma sub_carry : forall xh xl yh yl z, + 0 <= z -> [|xh|]*[|yl|] + [|xl|]*[|yh|] = wwB + z -> z < wwB. Proof. @@ -519,7 +519,7 @@ Section DoubleMul. generalize (Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). rewrite <- wwB_wBwB;intros H1 H2. assert (H3 := wB_pos w_digits). - assert (2*wB <= wwB). + assert (2*wB <= wwB). rewrite wwB_wBwB; rewrite Zpower_2; apply Zmult_le_compat;zarith. omega. Qed. @@ -528,7 +528,7 @@ Section DoubleMul. let H:= fresh "H" in assert (H:= spec_ww_to_Z x). - Ltac Zmult_lt_b x y := + Ltac Zmult_lt_b x y := let H := fresh "H" in assert (H := Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). @@ -582,7 +582,7 @@ Section DoubleMul. Variable w_mul_add : w -> w -> w -> w * w. Variable spec_w_mul_add : forall x y r, let (h,l):= w_mul_add x y r in - [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. + [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. Lemma spec_double_mul_add_n1 : forall n x y r, let (h,l) := double_mul_add_n1 w_mul_add n x y r in @@ -590,7 +590,7 @@ Section DoubleMul. Proof. induction n;intros x y r;trivial. exact (spec_w_mul_add x y r). - unfold double_mul_add_n1;destruct x as[ |xh xl]; + unfold double_mul_add_n1;destruct x as[ |xh xl]; fold(double_mul_add_n1 w_mul_add). rewrite spec_w_0;rewrite spec_extend;simpl;trivial. assert(H:=IHn xl y r);destruct (double_mul_add_n1 w_mul_add n xl y r)as(rl,l). @@ -599,13 +599,13 @@ Section DoubleMul. rewrite Zmult_plus_distr_l;rewrite <- Zplus_assoc;rewrite <- H. rewrite Zmult_assoc;rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite U;ring. - Qed. - + Qed. + End DoubleMulAddn1Proof. - Lemma spec_w_mul_add : forall x y r, + Lemma spec_w_mul_add : forall x y r, let (h,l):= w_mul_add x y r in - [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. + [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. Proof. intros x y r;unfold w_mul_add;assert (H:=spec_w_mul_c x y); destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v index c72abed619..ac2232cc0d 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v @@ -52,7 +52,7 @@ Section DoubleSqrt. Let wwBm1 := ww_Bm1 w_Bm1. - Definition ww_is_even x := + Definition ww_is_even x := match x with | W0 => true | WW xh xl => w_is_even xl @@ -62,7 +62,7 @@ Section DoubleSqrt. match w_compare x z with | Eq => match w_compare y z with - Eq => (C1 w_1, w_0) + Eq => (C1 w_1, w_0) | Gt => (C1 w_1, w_sub y z) | Lt => (C1 w_0, y) end @@ -120,7 +120,7 @@ Section DoubleSqrt. let ( q, r) := w_sqrt2 x1 x2 in let (q1, r1) := w_div2s r y1 q in match q1 with - C0 q1 => + C0 q1 => let q2 := w_square_c q1 in let a := WW q q1 in match r1 with @@ -132,9 +132,9 @@ Section DoubleSqrt. | C0 r2 => match ww_sub_c (WW r2 y2) q2 with C0 r3 => (a, C0 r3) - | C1 r3 => + | C1 r3 => let a2 := ww_add_mul_div (w_0W w_1) a W0 in - match ww_pred_c a2 with + match ww_pred_c a2 with C0 a3 => (ww_pred a, ww_add_c a3 r3) | C1 a3 => @@ -166,20 +166,20 @@ Section DoubleSqrt. | Gt => match ww_add_mul_div p x W0 with W0 => W0 - | WW x1 x2 => + | WW x1 x2 => let (r, _) := w_sqrt2 x1 x2 in - WW w_0 (w_add_mul_div - (w_sub w_zdigits + WW w_0 (w_add_mul_div + (w_sub w_zdigits (low (ww_add_mul_div (ww_pred ww_zdigits) W0 p))) w_0 r) end - | _ => + | _ => match x with W0 => W0 | WW x1 x2 => WW w_0 (fst (w_sqrt2 x1 x2)) end end. - + Variable w_to_Z : w -> Z. @@ -192,11 +192,11 @@ Section DoubleSqrt. (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). Notation "[|| x ||]" := @@ -274,7 +274,7 @@ Section DoubleSqrt. Lemma spec_ww_is_even : forall x, if ww_is_even x then [[x]] mod 2 = 0 else [[x]] mod 2 = 1. -clear spec_more_than_1_digit. +clear spec_more_than_1_digit. intros x; case x; simpl ww_is_even. simpl. rewrite Zmod_small; auto with zarith. @@ -377,8 +377,8 @@ intros x; case x; simpl ww_is_even. end. rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith. destruct (spec_to_Z w1) as [H1 H2];auto with zarith. - split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. + split; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. rewrite Hp; ring. Qed. @@ -400,7 +400,7 @@ intros x; case x; simpl ww_is_even. rewrite Zmax_right; auto with zarith. rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith. destruct (spec_to_Z w1) as [H1 H2];auto with zarith. - split; auto with zarith. + split; auto with zarith. unfold base. match goal with |- _ < _ ^ ?X => assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; @@ -432,7 +432,7 @@ intros x; case x; simpl ww_is_even. intros w1. rewrite spec_ww_add_mul_div; auto with zarith. autorewrite with w_rewrite rm10. - rewrite spec_w_0W; rewrite spec_w_1. + rewrite spec_w_0W; rewrite spec_w_1. rewrite Zpower_1_r; auto with zarith. rewrite Zmult_comm; auto. rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. @@ -456,7 +456,7 @@ intros x; case x; simpl ww_is_even. match goal with |- 0 <= ?X - 1 => assert (0 < X); auto with zarith end. - apply Zpower_gt_0; auto with zarith. + apply Zpower_gt_0; auto with zarith. match goal with |- 0 <= ?X - 1 => assert (0 < X); auto with zarith; red; reflexivity end. @@ -540,7 +540,7 @@ intros x; case x; simpl ww_is_even. rewrite add_mult_div_2_plus_1; unfold base. match goal with |- context[_ ^ ?X] => assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith end. rewrite Zpos_minus; auto with zarith. @@ -557,7 +557,7 @@ intros x; case x; simpl ww_is_even. unfold base. match goal with |- context[_ ^ ?X] => assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith end. rewrite Zpos_minus; auto with zarith. @@ -590,7 +590,7 @@ intros x; case x; simpl ww_is_even. rewrite H1; unfold base. match goal with |- context[_ ^ ?X] => assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith end. rewrite Zpos_minus; auto with zarith. @@ -609,7 +609,7 @@ intros x; case x; simpl ww_is_even. rewrite H1; unfold base. match goal with |- context[_ ^ ?X] => assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; + rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith end. rewrite Zpos_minus; auto with zarith. @@ -680,7 +680,7 @@ intros x; case x; simpl ww_is_even. rewrite Zsquare_mult; replace (p * p) with ((- p) * (- p)); try ring. apply Zmult_le_0_compat; auto with zarith. Qed. - + Lemma spec_split: forall x, [|fst (split x)|] * wB + [|snd (split x)|] = [[x]]. intros x; case x; simpl; autorewrite with w_rewrite; @@ -749,7 +749,7 @@ intros x; case x; simpl ww_is_even. match goal with |- ?X <= ?Y => replace Y with (2 * (wB/ 2 - 1)); auto with zarith end. - pattern wB at 2; rewrite <- wB_div_2; auto with zarith. + pattern wB at 2; rewrite <- wB_div_2; auto with zarith. match type of H1 with ?X = _ => assert (U5: X < wB / 4 * wB) end. @@ -762,9 +762,9 @@ intros x; case x; simpl ww_is_even. destruct (spec_to_Z w3);auto with zarith. generalize (@spec_w_div2s c w0 w4 U1 H2). case (w_div2s c w0 w4). - intros c0; case c0; intros w5; + intros c0; case c0; intros w5; repeat (rewrite C0_id || rewrite C1_plus_wB). - intros c1; case c1; intros w6; + intros c1; case c1; intros w6; repeat (rewrite C0_id || rewrite C1_plus_wB). intros (H3, H4). match goal with |- context [ww_sub_c ?y ?z] => @@ -1036,7 +1036,7 @@ intros x; case x; simpl ww_is_even. end. apply Zle_not_lt; rewrite <- H3; auto with zarith. rewrite Zmult_plus_distr_l. - apply Zlt_le_trans with ((2 * [|w4|]) * wB + 0); + apply Zlt_le_trans with ((2 * [|w4|]) * wB + 0); auto with zarith. apply beta_lex_inv; auto with zarith. destruct (spec_to_Z w0);auto with zarith. @@ -1117,9 +1117,9 @@ intros x; case x; simpl ww_is_even. auto with zarith. simpl ww_to_Z. assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z x);auto with zarith. - Qed. - - Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2. + Qed. + + Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2. pattern wwB at 1; rewrite wwB_wBwB; rewrite Zpower_2. rewrite <- wB_div_2. match goal with |- context[(2 * ?X) * (2 * ?Z)] => @@ -1132,7 +1132,7 @@ intros x; case x; simpl ww_is_even. Lemma spec_ww_head1 - : forall x : zn2z w, + : forall x : zn2z w, (ww_is_even (ww_head1 x) = true) /\ (0 < [[x]] -> wwB / 4 <= 2 ^ [[ww_head1 x]] * [[x]] < wwB). assert (U := wB_pos w_digits). @@ -1165,7 +1165,7 @@ intros x; case x; simpl ww_is_even. rewrite Hp. rewrite Zminus_mod; auto with zarith. rewrite H2; repeat rewrite Zmod_small; auto with zarith. - intros H3; rewrite Hp. + intros H3; rewrite Hp. case (spec_ww_head0 x); auto; intros Hv3 Hv4. assert (Hu: forall u, 0 < u -> 2 * 2 ^ (u - 1) = 2 ^u). intros u Hu. @@ -1187,7 +1187,7 @@ intros x; case x; simpl ww_is_even. apply sym_equal; apply Zdiv_unique with 0; auto with zarith. rewrite Zmult_assoc; rewrite wB_div_4; auto with zarith. - rewrite wwB_wBwB; ring. + rewrite wwB_wBwB; ring. Qed. Lemma spec_ww_sqrt : forall x, @@ -1196,14 +1196,14 @@ intros x; case x; simpl ww_is_even. intro x; unfold ww_sqrt. generalize (spec_ww_is_zero x); case (ww_is_zero x). simpl ww_to_Z; simpl Zpower; unfold Zpower_pos; simpl; - auto with zarith. + auto with zarith. intros H1. generalize (spec_ww_compare (ww_head1 x) W0); case ww_compare; simpl ww_to_Z; autorewrite with rm10. generalize H1; case x. intros HH; contradict HH; simpl ww_to_Z; auto with zarith. intros w0 w1; simpl ww_to_Z; autorewrite with w_rewrite rm10. - intros H2; case (spec_ww_head1 (WW w0 w1)); intros H3 H4 H5. + intros H2; case (spec_ww_head1 (WW w0 w1)); intros H3 H4 H5. generalize (H4 H2); clear H4; rewrite H5; clear H5; autorewrite with rm10. intros (H4, H5). assert (V: wB/4 <= [|w0|]). @@ -1239,7 +1239,7 @@ intros x; case x; simpl ww_is_even. apply Zle_not_lt; unfold base. apply Zle_trans with (2 ^ [[ww_head1 x]]). apply Zpower_le_monotone; auto with zarith. - pattern (2 ^ [[ww_head1 x]]) at 1; + pattern (2 ^ [[ww_head1 x]]) at 1; rewrite <- (Zmult_1_r (2 ^ [[ww_head1 x]])). apply Zmult_le_compat_l; auto with zarith. generalize (spec_ww_add_mul_div x W0 (ww_head1 x) Hv2); @@ -1281,13 +1281,13 @@ intros x; case x; simpl ww_is_even. rewrite Zmod_small; auto with zarith. split; auto with zarith. apply Zlt_le_trans with (Zpos (xO w_digits)); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. + unfold base; apply Zpower2_le_lin; auto with zarith. assert (Hv4: [[ww_head1 x]]/2 < wB). apply Zle_lt_trans with (Zpos w_digits). apply Zmult_le_reg_r with 2; auto with zarith. repeat rewrite (fun x => Zmult_comm x 2). rewrite <- Hv0; rewrite <- Zpos_xO; auto. - unfold base; apply Zpower2_lt_lin; auto with zarith. + unfold base; apply Zpower2_lt_lin; auto with zarith. assert (Hv5: [[(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))]] = [[ww_head1 x]]/2). rewrite spec_ww_add_mul_div. @@ -1328,14 +1328,14 @@ intros x; case x; simpl ww_is_even. rewrite tmp; clear tmp. apply Zpower_le_monotone3; auto with zarith. split; auto with zarith. - pattern [|w2|] at 2; + pattern [|w2|] at 2; rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]] / 2))); auto with zarith. match goal with |- ?X <= ?X + ?Y => assert (0 <= Y); auto with zarith end. case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]] / 2))); auto with zarith. - case c; unfold interp_carry; autorewrite with rm10; + case c; unfold interp_carry; autorewrite with rm10; intros w3; assert (V3 := spec_to_Z w3);auto with zarith. apply Zmult_lt_reg_r with (2 ^ [[ww_head1 x]]); auto with zarith. rewrite H4. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v index 638bf69160..d3a08c6e00 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v @@ -39,7 +39,7 @@ Section DoubleSub. Definition ww_opp_c x := match x with | W0 => C0 W0 - | WW xh xl => + | WW xh xl => match w_opp_c xl with | C0 _ => match w_opp_c xh with @@ -53,7 +53,7 @@ Section DoubleSub. Definition ww_opp x := match x with | W0 => W0 - | WW xh xl => + | WW xh xl => match w_opp_c xl with | C0 _ => WW (w_opp xh) w_0 | C1 l => WW (w_opp_carry xh) l @@ -72,14 +72,14 @@ Section DoubleSub. | WW xh xl => match w_pred_c xl with | C0 l => C0 (w_WW xh l) - | C1 _ => - match w_pred_c xh with + | C1 _ => + match w_pred_c xh with | C0 h => C0 (WW h w_Bm1) | C1 _ => C1 ww_Bm1 end end end. - + Definition ww_pred x := match x with | W0 => ww_Bm1 @@ -89,19 +89,19 @@ Section DoubleSub. | C1 l => WW (w_pred xh) w_Bm1 end end. - + Definition ww_sub_c x y := match y, x with | W0, _ => C0 x | WW yh yl, W0 => ww_opp_c (WW yh yl) | WW yh yl, WW xh xl => match w_sub_c xl yl with - | C0 l => + | C0 l => match w_sub_c xh yh with | C0 h => C0 (w_WW h l) | C1 h => C1 (WW h l) end - | C1 l => + | C1 l => match w_sub_carry_c xh yh with | C0 h => C0 (WW h l) | C1 h => C1 (WW h l) @@ -109,7 +109,7 @@ Section DoubleSub. end end. - Definition ww_sub x y := + Definition ww_sub x y := match y, x with | W0, _ => x | WW yh yl, W0 => ww_opp (WW yh yl) @@ -127,7 +127,7 @@ Section DoubleSub. | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl)) | WW yh yl, WW xh xl => match w_sub_carry_c xl yl with - | C0 l => + | C0 l => match w_sub_c xh yh with | C0 h => C0 (w_WW h l) | C1 h => C1 (WW h l) @@ -155,7 +155,7 @@ Section DoubleSub. (*Section DoubleProof.*) Variable w_digits : positive. Variable w_to_Z : w -> Z. - + Notation wB := (base w_digits). Notation wwB := (base (ww_digits w_digits)). @@ -166,13 +166,13 @@ Section DoubleSub. (interp_carry (-1) wB w_to_Z c) (at level 0, x at level 99). Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[+[ c ]]" := + (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) + Notation "[-[ c ]]" := + (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) (at level 0, x at level 99). - + Variable spec_w_0 : [|w_0|] = 0. Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. Variable spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. @@ -187,7 +187,7 @@ Section DoubleSub. Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. Variable spec_sub_carry_c : forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1. - + Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. Variable spec_sub_carry : @@ -197,12 +197,12 @@ Section DoubleSub. Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]]. Proof. destruct x as [ |xh xl];simpl. reflexivity. - rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl) + rewrite Zopp_plus_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl) as [l|l];intros H;unfold interp_carry in H;rewrite <- H; - rewrite Zopp_mult_distr_l. + rewrite Zopp_mult_distr_l. assert ([|l|] = 0). assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh) + rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh) as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1. assert ([|h|] = 0). assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. @@ -216,7 +216,7 @@ Section DoubleSub. Proof. destruct x as [ |xh xl];simpl. reflexivity. rewrite Zopp_plus_distr;rewrite Zopp_mult_distr_l. - generalize (spec_opp_c xl);destruct (w_opp_c xl) + generalize (spec_opp_c xl);destruct (w_opp_c xl) as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. rewrite spec_w_0;rewrite Zplus_0_r;rewrite wwB_wBwB. assert ([|l|] = 0). @@ -247,7 +247,7 @@ Section DoubleSub. assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1). generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h]; - intros H1;unfold interp_carry in H1;rewrite <- H1. + intros H1;unfold interp_carry in H1;rewrite <- H1. simpl;rewrite spec_w_Bm1;ring. assert ([|h|] = wB - 1). assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. @@ -258,14 +258,14 @@ Section DoubleSub. Proof. destruct y as [ |yh yl];simpl. ring. destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)). - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring. generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H; unfold interp_carry in H;rewrite <- H. generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z; @@ -275,37 +275,37 @@ Section DoubleSub. Lemma spec_ww_sub_carry_c : forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1. Proof. - destruct y as [ |yh yl];simpl. + destruct y as [ |yh yl];simpl. unfold Zminus;simpl;rewrite Zplus_0_r;exact (spec_ww_pred_c x). destruct x as [ |xh xl]. unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB; repeat rewrite spec_opp_carry;ring. simpl ww_to_Z. - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring. - generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl) + generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl) as [l|l];intros H;unfold interp_carry in H;rewrite <- H. generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW; simpl ww_to_Z; try rewrite wwB_wBwB;ring. - Qed. - + Qed. + Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. Proof. - destruct x as [ |xh xl];simpl. + destruct x as [ |xh xl];simpl. apply Zmod_unique with (-1). apply spec_ww_to_Z;trivial. rewrite spec_ww_Bm1;ring. replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H; unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. - rewrite Zmod_small. apply spec_w_WW. + rewrite Zmod_small. apply spec_w_WW. exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)). - rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. + rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. change ([|xh|] + -1) with ([|xh|] - 1). assert ([|l|] = wB - 1). assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega. @@ -318,7 +318,7 @@ Section DoubleSub. destruct y as [ |yh yl];simpl. ring_simplify ([[x]] - 0);rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)). - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring. generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H; unfold interp_carry in H;rewrite <- H. @@ -338,7 +338,7 @@ Section DoubleSub. apply spec_ww_to_Z;trivial. fold (ww_opp_carry (WW yh yl)). rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring. - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) + replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring. generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l]; intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW. @@ -354,4 +354,4 @@ End DoubleSub. - + diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v index 73fd266e42..3bd4b8127a 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v +++ b/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v @@ -37,10 +37,10 @@ Section Zn2Z. Variable znz : Type. - (** From a type [znz] representing a cyclic structure Z/nZ, + (** From a type [znz] representing a cyclic structure Z/nZ, we produce a representation of Z/2nZ by pairs of elements of [znz] - (plus a special case for zero). High half of the new number comes - first. + (plus a special case for zero). High half of the new number comes + first. *) Inductive zn2z := @@ -57,10 +57,10 @@ End Zn2Z. Implicit Arguments W0 [znz]. -(** From a cyclic representation [w], we iterate the [zn2z] construct - [n] times, gaining the type of binary trees of depth at most [n], - whose leafs are either W0 (if depth < n) or elements of w - (if depth = n). +(** From a cyclic representation [w], we iterate the [zn2z] construct + [n] times, gaining the type of binary trees of depth at most [n], + whose leafs are either W0 (if depth < n) or elements of w + (if depth = n). *) Fixpoint word (w:Type) (n:nat) : Type := diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 3835c6cde7..6e71bad82c 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -34,9 +34,9 @@ Section Basics. Lemma iszero_eq0 : forall x, iszero x = true -> x=0. Proof. destruct x; simpl; intros. - repeat - match goal with H:(if ?d then _ else _) = true |- _ => - destruct d; try discriminate + repeat + match goal with H:(if ?d then _ else _) = true |- _ => + destruct d; try discriminate end. reflexivity. Qed. @@ -46,26 +46,26 @@ Section Basics. intros x H Eq; rewrite Eq in H; simpl in *; discriminate. Qed. - Lemma sneakl_shiftr : forall x, + Lemma sneakl_shiftr : forall x, x = sneakl (firstr x) (shiftr x). Proof. destruct x; simpl; auto. Qed. - Lemma sneakr_shiftl : forall x, + Lemma sneakr_shiftl : forall x, x = sneakr (firstl x) (shiftl x). Proof. destruct x; simpl; auto. Qed. - Lemma twice_zero : forall x, + Lemma twice_zero : forall x, twice x = 0 <-> twice_plus_one x = 1. Proof. - destruct x; simpl in *; split; + destruct x; simpl in *; split; intro H; injection H; intros; subst; auto. Qed. - Lemma twice_or_twice_plus_one : forall x, + Lemma twice_or_twice_plus_one : forall x, x = twice (shiftr x) \/ x = twice_plus_one (shiftr x). Proof. intros; case_eq (firstr x); intros. @@ -79,13 +79,13 @@ Section Basics. Definition nshiftr n x := iter_nat n _ shiftr x. - Lemma nshiftr_S : + Lemma nshiftr_S : forall n x, nshiftr (S n) x = shiftr (nshiftr n x). Proof. reflexivity. Qed. - Lemma nshiftr_S_tail : + Lemma nshiftr_S_tail : forall n x, nshiftr (S n) x = nshiftr n (shiftr x). Proof. induction n; simpl; auto. @@ -103,7 +103,7 @@ Section Basics. destruct x; simpl; auto. Qed. - Lemma nshiftr_above_size : forall k x, size<=k -> + Lemma nshiftr_above_size : forall k x, size<=k -> nshiftr k x = 0. Proof. intros. @@ -117,13 +117,13 @@ Section Basics. Definition nshiftl n x := iter_nat n _ shiftl x. - Lemma nshiftl_S : + Lemma nshiftl_S : forall n x, nshiftl (S n) x = shiftl (nshiftl n x). Proof. reflexivity. Qed. - Lemma nshiftl_S_tail : + Lemma nshiftl_S_tail : forall n x, nshiftl (S n) x = nshiftl n (shiftl x). Proof. induction n; simpl; auto. @@ -141,7 +141,7 @@ Section Basics. destruct x; simpl; auto. Qed. - Lemma nshiftl_above_size : forall k x, size<=k -> + Lemma nshiftl_above_size : forall k x, size<=k -> nshiftl k x = 0. Proof. intros. @@ -151,27 +151,27 @@ Section Basics. simpl; rewrite nshiftl_S, IHn; auto. Qed. - Lemma firstr_firstl : + Lemma firstr_firstl : forall x, firstr x = firstl (nshiftl (pred size) x). Proof. destruct x; simpl; auto. Qed. - Lemma firstl_firstr : + Lemma firstl_firstr : forall x, firstl x = firstr (nshiftr (pred size) x). Proof. destruct x; simpl; auto. Qed. - + (** More advanced results about [nshiftr] *) - Lemma nshiftr_predsize_0_firstl : forall x, + Lemma nshiftr_predsize_0_firstl : forall x, nshiftr (pred size) x = 0 -> firstl x = D0. Proof. destruct x; compute; intros H; injection H; intros; subst; auto. Qed. - Lemma nshiftr_0_propagates : forall n p x, n <= p -> + Lemma nshiftr_0_propagates : forall n p x, n <= p -> nshiftr n x = 0 -> nshiftr p x = 0. Proof. intros. @@ -181,7 +181,7 @@ Section Basics. simpl; rewrite nshiftr_S; rewrite IHn0; auto. Qed. - Lemma nshiftr_0_firstl : forall n x, n < size -> + Lemma nshiftr_0_firstl : forall n x, n < size -> nshiftr n x = 0 -> firstl x = D0. Proof. intros. @@ -194,8 +194,8 @@ Section Basics. (** Not used for the moment. Are they really useful ? *) Lemma int31_ind_sneakl : forall P : int31->Prop, - P 0 -> - (forall x d, P x -> P (sneakl d x)) -> + P 0 -> + (forall x d, P x -> P (sneakl d x)) -> forall x, P x. Proof. intros. @@ -210,10 +210,10 @@ Section Basics. change x with (nshiftr (size-size) x); auto. Qed. - Lemma int31_ind_twice : forall P : int31->Prop, - P 0 -> - (forall x, P x -> P (twice x)) -> - (forall x, P x -> P (twice_plus_one x)) -> + Lemma int31_ind_twice : forall P : int31->Prop, + P 0 -> + (forall x, P x -> P (twice x)) -> + (forall x, P x -> P (twice_plus_one x)) -> forall x, P x. Proof. induction x using int31_ind_sneakl; auto. @@ -224,21 +224,21 @@ Section Basics. (** * Some generic results about [recr] *) Section Recr. - + (** [recr] satisfies the fixpoint equation used for its definition. *) Variable (A:Type)(case0:A)(caserec:digits->int31->A->A). - - Lemma recr_aux_eqn : forall n x, iszero x = false -> - recr_aux (S n) A case0 caserec x = + + Lemma recr_aux_eqn : forall n x, iszero x = false -> + recr_aux (S n) A case0 caserec x = caserec (firstr x) (shiftr x) (recr_aux n A case0 caserec (shiftr x)). Proof. intros; simpl; rewrite H; auto. Qed. - Lemma recr_aux_converges : + Lemma recr_aux_converges : forall n p x, n <= size -> n <= p -> - recr_aux n A case0 caserec (nshiftr (size - n) x) = + recr_aux n A case0 caserec (nshiftr (size - n) x) = recr_aux p A case0 caserec (nshiftr (size - n) x). Proof. induction n. @@ -255,8 +255,8 @@ Section Basics. apply IHn; auto with arith. Qed. - Lemma recr_eqn : forall x, iszero x = false -> - recr A case0 caserec x = + Lemma recr_eqn : forall x, iszero x = false -> + recr A case0 caserec x = caserec (firstr x) (shiftr x) (recr A case0 caserec (shiftr x)). Proof. intros. @@ -265,11 +265,11 @@ Section Basics. rewrite (recr_aux_converges size (S size)); auto with arith. rewrite recr_aux_eqn; auto. Qed. - - (** [recr] is usually equivalent to a variant [recrbis] + + (** [recr] is usually equivalent to a variant [recrbis] written without [iszero] check. *) - Fixpoint recrbis_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) + Fixpoint recrbis_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) (i:int31) : A := match n with | O => case0 @@ -277,7 +277,7 @@ Section Basics. let si := shiftr i in caserec (firstr i) si (recrbis_aux next A case0 caserec si) end. - + Definition recrbis := recrbis_aux size. Hypothesis case0_caserec : caserec D0 0 case0 = case0. @@ -291,8 +291,8 @@ Section Basics. replace (recrbis_aux n A case0 caserec 0) with case0; auto. clear H IHn; induction n; simpl; congruence. Qed. - - Lemma recrbis_equiv : forall x, + + Lemma recrbis_equiv : forall x, recrbis A case0 caserec x = recr A case0 caserec x. Proof. intros; apply recrbis_aux_equiv; auto. @@ -348,7 +348,7 @@ Section Basics. rewrite incr_eqn1; destruct x; simpl; auto. Qed. - Lemma incr_twice_plus_one_firstl : + Lemma incr_twice_plus_one_firstl : forall x, firstl x = D0 -> incr (twice_plus_one x) = twice (incr x). Proof. intros. @@ -356,9 +356,9 @@ Section Basics. f_equal; f_equal. destruct x; simpl in *; rewrite H; auto. Qed. - - (** The previous result is actually true even without the - constraint on [firstl], but this is harder to prove + + (** The previous result is actually true even without the + constraint on [firstl], but this is harder to prove (see later). *) End Incr. @@ -369,9 +369,9 @@ Section Basics. (** Variant of [phi] via [recrbis] *) - Let Phi := fun b (_:int31) => + Let Phi := fun b (_:int31) => match b with D0 => Zdouble | D1 => Zdouble_plus_one end. - + Definition phibis_aux n x := recrbis_aux n _ Z0 Phi x. Lemma phibis_aux_equiv : forall x, phibis_aux size x = phi x. @@ -382,7 +382,7 @@ Section Basics. (** Recursive equations satisfied by [phi] *) - Lemma phi_eqn1 : forall x, firstr x = D0 -> + Lemma phi_eqn1 : forall x, firstr x = D0 -> phi x = Zdouble (phi (shiftr x)). Proof. intros. @@ -392,7 +392,7 @@ Section Basics. rewrite H; auto. Qed. - Lemma phi_eqn2 : forall x, firstr x = D1 -> + Lemma phi_eqn2 : forall x, firstr x = D1 -> phi x = Zdouble_plus_one (phi (shiftr x)). Proof. intros. @@ -402,7 +402,7 @@ Section Basics. rewrite H; auto. Qed. - Lemma phi_twice_firstl : forall x, firstl x = D0 -> + Lemma phi_twice_firstl : forall x, firstl x = D0 -> phi (twice x) = Zdouble (phi x). Proof. intros. @@ -411,7 +411,7 @@ Section Basics. destruct x; simpl in *; rewrite H; auto. Qed. - Lemma phi_twice_plus_one_firstl : forall x, firstl x = D0 -> + Lemma phi_twice_plus_one_firstl : forall x, firstl x = D0 -> phi (twice_plus_one x) = Zdouble_plus_one (phi x). Proof. intros. @@ -427,23 +427,23 @@ Section Basics. Lemma phibis_aux_pos : forall n x, (0 <= phibis_aux n x)%Z. Proof. induction n. - simpl; unfold phibis_aux; simpl; auto with zarith. + simpl; unfold phibis_aux; simpl; auto with zarith. intros. - unfold phibis_aux, recrbis_aux; fold recrbis_aux; + unfold phibis_aux, recrbis_aux; fold recrbis_aux; fold (phibis_aux n (shiftr x)). destruct (firstr x). specialize IHn with (shiftr x); rewrite Zdouble_mult; omega. specialize IHn with (shiftr x); rewrite Zdouble_plus_one_mult; omega. Qed. - Lemma phibis_aux_bounded : - forall n x, n <= size -> + Lemma phibis_aux_bounded : + forall n x, n <= size -> (phibis_aux n (nshiftr (size-n) x) < 2 ^ (Z_of_nat n))%Z. Proof. induction n. simpl; unfold phibis_aux; simpl; auto with zarith. intros. - unfold phibis_aux, recrbis_aux; fold recrbis_aux; + unfold phibis_aux, recrbis_aux; fold recrbis_aux; fold (phibis_aux n (shiftr (nshiftr (size - S n) x))). assert (shiftr (nshiftr (size - S n) x) = nshiftr (size-n) x). replace (size - n)%nat with (S (size - (S n))) by omega. @@ -468,8 +468,8 @@ Section Basics. apply phibis_aux_bounded; auto. Qed. - Lemma phibis_aux_lowerbound : - forall n x, firstr (nshiftr n x) = D1 -> + Lemma phibis_aux_lowerbound : + forall n x, firstr (nshiftr n x) = D1 -> (2 ^ Z_of_nat n <= phibis_aux (S n) x)%Z. Proof. induction n. @@ -480,7 +480,7 @@ Section Basics. intros. remember (S n) as m. - unfold phibis_aux, recrbis_aux; fold recrbis_aux; + unfold phibis_aux, recrbis_aux; fold recrbis_aux; fold (phibis_aux m (shiftr x)). subst m. rewrite inj_S, Zpower_Zsucc; auto with zarith. @@ -488,13 +488,13 @@ Section Basics. apply IHn. rewrite <- nshiftr_S_tail; auto. destruct (firstr x). - change (Zdouble (phibis_aux (S n) (shiftr x))) with + change (Zdouble (phibis_aux (S n) (shiftr x))) with (2*(phibis_aux (S n) (shiftr x)))%Z. omega. rewrite Zdouble_plus_one_mult; omega. Qed. - Lemma phi_lowerbound : + Lemma phi_lowerbound : forall x, firstl x = D1 -> (2^(Z_of_nat (pred size)) <= phi x)%Z. Proof. intros. @@ -508,9 +508,9 @@ Section Basics. Section EqShiftL. - (** After killing [n] bits at the left, are the numbers equal ?*) + (** After killing [n] bits at the left, are the numbers equal ?*) - Definition EqShiftL n x y := + Definition EqShiftL n x y := nshiftl n x = nshiftl n y. Lemma EqShiftL_zero : forall x y, EqShiftL O x y <-> x = y. @@ -523,7 +523,7 @@ Section Basics. red; intros; rewrite 2 nshiftl_above_size; auto. Qed. - Lemma EqShiftL_le : forall k k' x y, k <= k' -> + Lemma EqShiftL_le : forall k k' x y, k <= k' -> EqShiftL k x y -> EqShiftL k' x y. Proof. unfold EqShiftL; intros. @@ -534,18 +534,18 @@ Section Basics. rewrite 2 nshiftl_S; f_equal; auto. Qed. - Lemma EqShiftL_firstr : forall k x y, k < size -> + Lemma EqShiftL_firstr : forall k x y, k < size -> EqShiftL k x y -> firstr x = firstr y. Proof. intros. rewrite 2 firstr_firstl. f_equal. - apply EqShiftL_le with k; auto. + apply EqShiftL_le with k; auto. unfold size. auto with arith. Qed. - Lemma EqShiftL_twice : forall k x y, + Lemma EqShiftL_twice : forall k x y, EqShiftL k (twice x) (twice y) <-> EqShiftL (S k) x y. Proof. intros; unfold EqShiftL. @@ -553,7 +553,7 @@ Section Basics. Qed. (** * From int31 to list of digits. *) - + (** Lower (=rightmost) bits comes first. *) Definition i2l := recrbis _ nil (fun d _ rec => d::rec). @@ -561,10 +561,10 @@ Section Basics. Lemma i2l_length : forall x, length (i2l x) = size. Proof. intros; reflexivity. - Qed. + Qed. - Fixpoint lshiftl l x := - match l with + Fixpoint lshiftl l x := + match l with | nil => x | d::l => sneakl d (lshiftl l x) end. @@ -576,19 +576,19 @@ Section Basics. destruct x; compute; auto. Qed. - Lemma i2l_sneakr : forall x d, + Lemma i2l_sneakr : forall x d, i2l (sneakr d x) = tail (i2l x) ++ d::nil. Proof. destruct x; compute; auto. Qed. - Lemma i2l_sneakl : forall x d, + Lemma i2l_sneakl : forall x d, i2l (sneakl d x) = d :: removelast (i2l x). Proof. destruct x; compute; auto. Qed. - Lemma i2l_l2i : forall l, length l = size -> + Lemma i2l_l2i : forall l, length l = size -> i2l (l2i l) = l. Proof. repeat (destruct l as [ |? l]; [intros; discriminate | ]). @@ -596,9 +596,9 @@ Section Basics. intros _; compute; auto. Qed. - Fixpoint cstlist (A:Type)(a:A) n := - match n with - | O => nil + Fixpoint cstlist (A:Type)(a:A) n := + match n with + | O => nil | S n => a::cstlist _ a n end. @@ -612,7 +612,7 @@ Section Basics. induction (i2l x); simpl; f_equal; auto. rewrite H0; clear H0. reflexivity. - + intros. rewrite nshiftl_S. unfold shiftl; rewrite i2l_sneakl. @@ -657,10 +657,10 @@ Section Basics. f_equal; auto. Qed. - (** This equivalence allows to prove easily the following delicate + (** This equivalence allows to prove easily the following delicate result *) - Lemma EqShiftL_twice_plus_one : forall k x y, + Lemma EqShiftL_twice_plus_one : forall k x y, EqShiftL k (twice_plus_one x) (twice_plus_one y) <-> EqShiftL (S k) x y. Proof. intros. @@ -683,7 +683,7 @@ Section Basics. subst lx n; rewrite i2l_length; omega. Qed. - Lemma EqShiftL_shiftr : forall k x y, EqShiftL k x y -> + Lemma EqShiftL_shiftr : forall k x y, EqShiftL k x y -> EqShiftL (S k) (shiftr x) (shiftr y). Proof. intros. @@ -704,41 +704,41 @@ Section Basics. omega. Qed. - Lemma EqShiftL_incrbis : forall n k x y, n<=size -> + Lemma EqShiftL_incrbis : forall n k x y, n<=size -> (n+k=S size)%nat -> - EqShiftL k x y -> + EqShiftL k x y -> EqShiftL k (incrbis_aux n x) (incrbis_aux n y). Proof. induction n; simpl; intros. red; auto. - destruct (eq_nat_dec k size). + destruct (eq_nat_dec k size). subst k; apply EqShiftL_size; auto. - unfold incrbis_aux; simpl; + unfold incrbis_aux; simpl; fold (incrbis_aux n (shiftr x)); fold (incrbis_aux n (shiftr y)). rewrite (EqShiftL_firstr k x y); auto; try omega. case_eq (firstr y); intros. rewrite EqShiftL_twice_plus_one. apply EqShiftL_shiftr; auto. - + rewrite EqShiftL_twice. apply IHn; try omega. apply EqShiftL_shiftr; auto. Qed. - Lemma EqShiftL_incr : forall x y, + Lemma EqShiftL_incr : forall x y, EqShiftL 1 x y -> EqShiftL 1 (incr x) (incr y). Proof. intros. rewrite <- 2 incrbis_aux_equiv. apply EqShiftL_incrbis; auto. Qed. - + End EqShiftL. (** * More equations about [incr] *) - Lemma incr_twice_plus_one : + Lemma incr_twice_plus_one : forall x, incr (twice_plus_one x) = twice (incr x). Proof. intros. @@ -757,7 +757,7 @@ Section Basics. destruct (incr (shiftr x)); simpl; discriminate. Qed. - Lemma incr_inv : forall x y, + Lemma incr_inv : forall x y, incr x = twice_plus_one y -> x = twice y. Proof. intros. @@ -777,7 +777,7 @@ Section Basics. (** First, recursive equations *) - Lemma phi_inv_double_plus_one : forall z, + Lemma phi_inv_double_plus_one : forall z, phi_inv (Zdouble_plus_one z) = twice_plus_one (phi_inv z). Proof. destruct z; simpl; auto. @@ -789,14 +789,14 @@ Section Basics. auto. Qed. - Lemma phi_inv_double : forall z, + Lemma phi_inv_double : forall z, phi_inv (Zdouble z) = twice (phi_inv z). Proof. destruct z; simpl; auto. rewrite incr_twice_plus_one; auto. Qed. - Lemma phi_inv_incr : forall z, + Lemma phi_inv_incr : forall z, phi_inv (Zsucc z) = incr (phi_inv z). Proof. destruct z. @@ -816,19 +816,19 @@ Section Basics. rewrite incr_twice_plus_one; auto. Qed. - (** [phi_inv o inv], the always-exact and easy-to-prove trip : + (** [phi_inv o inv], the always-exact and easy-to-prove trip : from int31 to Z and then back to int31. *) - Lemma phi_inv_phi_aux : - forall n x, n <= size -> - phi_inv (phibis_aux n (nshiftr (size-n) x)) = + Lemma phi_inv_phi_aux : + forall n x, n <= size -> + phi_inv (phibis_aux n (nshiftr (size-n) x)) = nshiftr (size-n) x. Proof. induction n. intros; simpl. rewrite nshiftr_size; auto. intros. - unfold phibis_aux, recrbis_aux; fold recrbis_aux; + unfold phibis_aux, recrbis_aux; fold recrbis_aux; fold (phibis_aux n (shiftr (nshiftr (size-S n) x))). assert (shiftr (nshiftr (size - S n) x) = nshiftr (size-n) x). replace (size - n)%nat with (S (size - (S n))); auto; omega. @@ -863,10 +863,10 @@ Section Basics. (** * [positive_to_int31] *) - (** A variant of [p2i] with [twice] and [twice_plus_one] instead of + (** A variant of [p2i] with [twice] and [twice_plus_one] instead of [2*i] and [2*i+1] *) - Fixpoint p2ibis n p : (N*int31)%type := + Fixpoint p2ibis n p : (N*int31)%type := match n with | O => (Npos p, On) | S n => match p with @@ -876,7 +876,7 @@ Section Basics. end end. - Lemma p2ibis_bounded : forall n p, + Lemma p2ibis_bounded : forall n p, nshiftr n (snd (p2ibis n p)) = 0. Proof. induction n. @@ -906,20 +906,20 @@ Section Basics. replace (shiftr In) with 0; auto. apply nshiftr_n_0. Qed. - + Lemma p2ibis_spec : forall n p, n<=size -> - Zpos p = ((Z_of_N (fst (p2ibis n p)))*2^(Z_of_nat n) + + Zpos p = ((Z_of_N (fst (p2ibis n p)))*2^(Z_of_nat n) + phi (snd (p2ibis n p)))%Z. Proof. induction n; intros. simpl; rewrite Pmult_1_r; auto. - replace (2^(Z_of_nat (S n)))%Z with (2*2^(Z_of_nat n))%Z by - (rewrite <- Zpower_Zsucc, <- Zpos_P_of_succ_nat; + replace (2^(Z_of_nat (S n)))%Z with (2*2^(Z_of_nat n))%Z by + (rewrite <- Zpower_Zsucc, <- Zpos_P_of_succ_nat; auto with zarith). rewrite (Zmult_comm 2). assert (n<=size) by omega. - destruct p; simpl; [ | | auto]; - specialize (IHn p H0); + destruct p; simpl; [ | | auto]; + specialize (IHn p H0); generalize (p2ibis_bounded n p); destruct (p2ibis n p) as (r,i); simpl in *; intros. @@ -937,25 +937,25 @@ Section Basics. (** We now prove that this [p2ibis] is related to [phi_inv_positive] *) - Lemma phi_inv_positive_p2ibis : forall n p, (n<=size)%nat -> + Lemma phi_inv_positive_p2ibis : forall n p, (n<=size)%nat -> EqShiftL (size-n) (phi_inv_positive p) (snd (p2ibis n p)). Proof. induction n. intros. apply EqShiftL_size; auto. intros. - simpl p2ibis; destruct p; [ | | red; auto]; - specialize IHn with p; - destruct (p2ibis n p); simpl snd in *; simpl phi_inv_positive; - rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice; - replace (S (size - S n))%nat with (size - n)%nat by omega; + simpl p2ibis; destruct p; [ | | red; auto]; + specialize IHn with p; + destruct (p2ibis n p); simpl snd in *; simpl phi_inv_positive; + rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice; + replace (S (size - S n))%nat with (size - n)%nat by omega; apply IHn; omega. Qed. (** This gives the expected result about [phi o phi_inv], at least for the positive case. *) - Lemma phi_phi_inv_positive : forall p, + Lemma phi_phi_inv_positive : forall p, phi (phi_inv_positive p) = (Zpos p) mod (2^(Z_of_nat size)). Proof. intros. @@ -975,12 +975,12 @@ Section Basics. Lemma double_twice_firstl : forall x, firstl x = D0 -> Twon*x = twice x. Proof. - intros. + intros. unfold mul31. rewrite <- Zdouble_mult, <- phi_twice_firstl, phi_inv_phi; auto. Qed. - Lemma double_twice_plus_one_firstl : forall x, firstl x = D0 -> + Lemma double_twice_plus_one_firstl : forall x, firstl x = D0 -> Twon*x+In = twice_plus_one x. Proof. intros. @@ -989,14 +989,14 @@ Section Basics. rewrite phi_twice_firstl, <- Zdouble_plus_one_mult, <- phi_twice_plus_one_firstl, phi_inv_phi; auto. Qed. - - Lemma p2i_p2ibis : forall n p, (n<=size)%nat -> + + Lemma p2i_p2ibis : forall n p, (n<=size)%nat -> p2i n p = p2ibis n p. Proof. induction n; simpl; auto; intros. - destruct p; auto; specialize IHn with p; - generalize (p2ibis_bounded n p); - rewrite IHn; try omega; destruct (p2ibis n p); simpl; intros; + destruct p; auto; specialize IHn with p; + generalize (p2ibis_bounded n p); + rewrite IHn; try omega; destruct (p2ibis n p); simpl; intros; f_equal; auto. apply double_twice_plus_one_firstl. apply (nshiftr_0_firstl n); auto; omega. @@ -1004,7 +1004,7 @@ Section Basics. apply (nshiftr_0_firstl n); auto; omega. Qed. - Lemma positive_to_int31_phi_inv_positive : forall p, + Lemma positive_to_int31_phi_inv_positive : forall p, snd (positive_to_int31 p) = phi_inv_positive p. Proof. intros; unfold positive_to_int31. @@ -1014,8 +1014,8 @@ Section Basics. apply (phi_inv_positive_p2ibis size); auto. Qed. - Lemma positive_to_int31_spec : forall p, - Zpos p = ((Z_of_N (fst (positive_to_int31 p)))*2^(Z_of_nat size) + + Lemma positive_to_int31_spec : forall p, + Zpos p = ((Z_of_N (fst (positive_to_int31 p)))*2^(Z_of_nat size) + phi (snd (positive_to_int31 p)))%Z. Proof. unfold positive_to_int31. @@ -1023,11 +1023,11 @@ Section Basics. apply p2ibis_spec; auto. Qed. - (** Thanks to the result about [phi o phi_inv_positive], we can - now establish easily the most general results about + (** Thanks to the result about [phi o phi_inv_positive], we can + now establish easily the most general results about [phi o twice] and so one. *) - - Lemma phi_twice : forall x, + + Lemma phi_twice : forall x, phi (twice x) = (Zdouble (phi x)) mod 2^(Z_of_nat size). Proof. intros. @@ -1041,7 +1041,7 @@ Section Basics. compute in H; elim H; auto. Qed. - Lemma phi_twice_plus_one : forall x, + Lemma phi_twice_plus_one : forall x, phi (twice_plus_one x) = (Zdouble_plus_one (phi x)) mod 2^(Z_of_nat size). Proof. intros. @@ -1055,14 +1055,14 @@ Section Basics. compute in H; elim H; auto. Qed. - Lemma phi_incr : forall x, + Lemma phi_incr : forall x, phi (incr x) = (Zsucc (phi x)) mod 2^(Z_of_nat size). Proof. intros. pattern x at 1; rewrite <- (phi_inv_phi x). rewrite <- phi_inv_incr. assert (0 <= Zsucc (phi x))%Z. - change (Zsucc (phi x)) with ((phi x)+1)%Z; + change (Zsucc (phi x)) with ((phi x)+1)%Z; generalize (phi_bounded x); omega. destruct (Zsucc (phi x)). simpl; auto. @@ -1070,10 +1070,10 @@ Section Basics. compute in H; elim H; auto. Qed. - (** With the previous results, we can deal with [phi o phi_inv] even + (** With the previous results, we can deal with [phi o phi_inv] even in the negative case *) - Lemma phi_phi_inv_negative : + Lemma phi_phi_inv_negative : forall p, phi (incr (complement_negative p)) = (Zneg p) mod 2^(Z_of_nat size). Proof. induction p. @@ -1091,11 +1091,11 @@ Section Basics. rewrite incr_twice_plus_one, phi_twice. remember (phi (incr (complement_negative p))) as q. rewrite Zdouble_mult, IHp, Zmult_mod_idemp_r; auto with zarith. - + simpl; auto. Qed. - Lemma phi_phi_inv : + Lemma phi_phi_inv : forall z, phi (phi_inv z) = z mod 2 ^ (Z_of_nat size). Proof. destruct z. @@ -1120,7 +1120,7 @@ Let w_pos_mod p i := end. (** Parity test *) -Let w_iseven i := +Let w_iseven i := let (_,r) := i/2 in match r ?= 0 with Eq => true | _ => false end. @@ -1181,14 +1181,14 @@ Definition int31_op := (mk_znz_op End Int31_Op. Section Int31_Spec. - + Open Local Scope Z_scope. Notation "[| x |]" := (phi x) (at level 0, x at level 99). Notation Local wB := (2 ^ (Z_of_nat size)). - - Lemma wB_pos : wB > 0. + + Lemma wB_pos : wB > 0. Proof. auto with zarith. Qed. @@ -1216,12 +1216,12 @@ Section Int31_Spec. Proof. reflexivity. Qed. - + Lemma spec_1 : [| 1 |] = 1. Proof. reflexivity. Qed. - + Lemma spec_Bm1 : [| Tn |] = wB - 1. Proof. reflexivity. @@ -1252,16 +1252,16 @@ Section Int31_Spec. destruct (Z_lt_le_dec (X+Y) wB). contradict H1; auto using Zmod_small with zarith. rewrite <- (Z_mod_plus_full (X+Y) (-1) wB). - rewrite Zmod_small; romega. + rewrite Zmod_small; romega. generalize (Zcompare_Eq_eq ((X+Y) mod wB) (X+Y)); intros Heq. - destruct Zcompare; intros; + destruct Zcompare; intros; [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. Qed. Lemma spec_succ_c : forall x, [+|add31c x 1|] = [|x|] + 1. Proof. - intros; apply spec_add_c. + intros; apply spec_add_c. Qed. Lemma spec_add_carry_c : forall x y, [+|add31carryc x y|] = [|x|] + [|y|] + 1. @@ -1279,7 +1279,7 @@ Section Int31_Spec. rewrite Zmod_small; romega. generalize (Zcompare_Eq_eq ((X+Y+1) mod wB) (X+Y+1)); intros Heq. - destruct Zcompare; intros; + destruct Zcompare; intros; [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. Qed. @@ -1304,7 +1304,7 @@ Section Int31_Spec. (** Substraction *) Lemma spec_sub_c : forall x y, [-|sub31c x y|] = [|x|] - [|y|]. - Proof. + Proof. unfold sub31c, sub31, interp_carry; intros. rewrite phi_phi_inv. generalize (phi_bounded x)(phi_bounded y); intros. @@ -1337,7 +1337,7 @@ Section Int31_Spec. contradict H1; apply Zmod_small; romega. generalize (Zcompare_Eq_eq ((X-Y-1) mod wB) (X-Y-1)); intros Heq. - destruct Zcompare; intros; + destruct Zcompare; intros; [ rewrite phi_phi_inv; auto | now apply H1 | now apply H1]. Qed. @@ -1355,7 +1355,7 @@ Section Int31_Spec. Qed. Lemma spec_opp_c : forall x, [-|sub31c 0 x|] = -[|x|]. - Proof. + Proof. intros; apply spec_sub_c. Qed. @@ -1402,7 +1402,7 @@ Section Int31_Spec. change (wB*wB) with (wB^2); ring. unfold phi_inv2. - destruct x; unfold zn2z_to_Z; rewrite ?phi_phi_inv; + destruct x; unfold zn2z_to_Z; rewrite ?phi_phi_inv; change base with wB; auto. Qed. @@ -1426,7 +1426,7 @@ Section Int31_Spec. intros; apply spec_mul_c. Qed. - (** Division *) + (** Division *) Lemma spec_div21 : forall a1 a2 b, wB/2 <= [|b|] -> @@ -1537,7 +1537,7 @@ Section Int31_Spec. intros (H,_); compute in H; elim H; auto. Qed. - Lemma iter_int31_iter_nat : forall A f i a, + Lemma iter_int31_iter_nat : forall A f i a, iter_int31 i A f a = iter_nat (Zabs_nat [|i|]) A f a. Proof. intros. @@ -1548,17 +1548,17 @@ Section Int31_Spec. revert i a; induction size. simpl; auto. simpl; intros. - case_eq (firstr i); intros H; rewrite 2 IHn; + case_eq (firstr i); intros H; rewrite 2 IHn; unfold phibis_aux; simpl; rewrite H; fold (phibis_aux n (shiftr i)); - generalize (phibis_aux_pos n (shiftr i)); intros; - set (z := phibis_aux n (shiftr i)) in *; clearbody z; + generalize (phibis_aux_pos n (shiftr i)); intros; + set (z := phibis_aux n (shiftr i)) in *; clearbody z; rewrite <- iter_nat_plus. f_equal. rewrite Zdouble_mult, Zmult_comm, <- Zplus_diag_eq_mult_2. symmetry; apply Zabs_nat_Zplus; auto with zarith. - change (iter_nat (S (Zabs_nat z + Zabs_nat z)) A f a = + change (iter_nat (S (Zabs_nat z + Zabs_nat z)) A f a = iter_nat (Zabs_nat (Zdouble_plus_one z)) A f a); f_equal. rewrite Zdouble_plus_one_mult, Zmult_comm, <- Zplus_diag_eq_mult_2. rewrite Zabs_nat_Zplus; auto with zarith. @@ -1566,13 +1566,13 @@ Section Int31_Spec. change (Zabs_nat 1) with 1%nat; omega. Qed. - Fixpoint addmuldiv31_alt n i j := - match n with - | O => i + Fixpoint addmuldiv31_alt n i j := + match n with + | O => i | S n => addmuldiv31_alt n (sneakl (firstl j) i) (shiftl j) end. - Lemma addmuldiv31_equiv : forall p x y, + Lemma addmuldiv31_equiv : forall p x y, addmuldiv31 p x y = addmuldiv31_alt (Zabs_nat [|p|]) x y. Proof. intros. @@ -1588,7 +1588,7 @@ Section Int31_Spec. Qed. Lemma spec_add_mul_div : forall x y p, [|p|] <= Zpos 31 -> - [| addmuldiv31 p x y |] = + [| addmuldiv31 p x y |] = ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos 31) - [|p|]))) mod wB. Proof. intros. @@ -1626,7 +1626,7 @@ Section Int31_Spec. replace (31-Z_of_nat n) with (Zsucc(31-Zsucc(Z_of_nat n))) by ring. rewrite Zpower_Zsucc, <- Zdiv_Zdiv; auto with zarith. rewrite Zmult_comm, Z_div_mult; auto with zarith. - + rewrite phi_twice_plus_one, Zdouble_plus_one_mult. rewrite phi_twice; auto. change (Zdouble [|y|]) with (2*[|y|]). @@ -1644,7 +1644,7 @@ Section Int31_Spec. unfold wB'. rewrite <- Zpower_Zsucc, <- inj_S by (auto with zarith). f_equal. rewrite H1. - replace wB with (2^(Z_of_nat n)*2^(31-Z_of_nat n)) by + replace wB with (2^(Z_of_nat n)*2^(31-Z_of_nat n)) by (rewrite <- Zpower_exp; auto with zarith; f_equal; unfold size; ring). unfold Zminus; rewrite Zopp_mult_distr_l. rewrite Z_div_plus; auto with zarith. @@ -1669,8 +1669,8 @@ Section Int31_Spec. apply Zlt_le_trans with wB; auto with zarith. apply Zpower_le_monotone; auto with zarith. intros. - case_eq ([|p|] ?= 31); intros; - [ apply H; rewrite (Zcompare_Eq_eq _ _ H0); auto with zarith | | + case_eq ([|p|] ?= 31); intros; + [ apply H; rewrite (Zcompare_Eq_eq _ _ H0); auto with zarith | | apply H; change ([|p|]>31)%Z in H0; auto with zarith ]. change ([|p|]<31) in H0. rewrite spec_add_mul_div by auto with zarith. @@ -1701,16 +1701,16 @@ Section Int31_Spec. simpl; auto. Qed. - Fixpoint head031_alt n x := - match n with + Fixpoint head031_alt n x := + match n with | O => 0%nat - | S n => match firstl x with + | S n => match firstl x with | D0 => S (head031_alt n (shiftl x)) | D1 => 0%nat end end. - Lemma head031_equiv : + Lemma head031_equiv : forall x, [|head031 x|] = Z_of_nat (head031_alt size x). Proof. intros. @@ -1720,10 +1720,10 @@ Section Int31_Spec. unfold head031, recl. change On with (phi_inv (Z_of_nat (31-size))). - replace (head031_alt size x) with + replace (head031_alt size x) with (head031_alt size x + (31 - size))%nat by (apply plus_0_r; auto). assert (size <= 31)%nat by auto with arith. - + revert x H; induction size; intros. simpl; auto. unfold recl_aux; fold recl_aux. @@ -1748,7 +1748,7 @@ Section Int31_Spec. change [|In|] with 1. replace (31-n)%nat with (S (31 - S n))%nat by omega. rewrite inj_S; ring. - + clear - H H2. rewrite (sneakr_shiftl x) in H. rewrite H2 in H. @@ -1793,7 +1793,7 @@ Section Int31_Spec. rewrite (sneakr_shiftl x), H1, H; auto. rewrite <- nshiftl_S_tail; auto. - + change (2^(Z_of_nat 0)) with 1; rewrite Zmult_1_l. generalize (phi_bounded x); unfold size; split; auto with zarith. change (2^(Z_of_nat 31)/2) with (2^(Z_of_nat (pred size))). @@ -1809,16 +1809,16 @@ Section Int31_Spec. simpl; auto. Qed. - Fixpoint tail031_alt n x := - match n with + Fixpoint tail031_alt n x := + match n with | O => 0%nat - | S n => match firstr x with + | S n => match firstr x with | D0 => S (tail031_alt n (shiftr x)) | D1 => 0%nat end end. - Lemma tail031_equiv : + Lemma tail031_equiv : forall x, [|tail031 x|] = Z_of_nat (tail031_alt size x). Proof. intros. @@ -1828,10 +1828,10 @@ Section Int31_Spec. unfold tail031, recr. change On with (phi_inv (Z_of_nat (31-size))). - replace (tail031_alt size x) with + replace (tail031_alt size x) with (tail031_alt size x + (31 - size))%nat by (apply plus_0_r; auto). assert (size <= 31)%nat by auto with arith. - + revert x H; induction size; intros. simpl; auto. unfold recr_aux; fold recr_aux. @@ -1856,7 +1856,7 @@ Section Int31_Spec. change [|In|] with 1. replace (31-n)%nat with (S (31 - S n))%nat by omega. rewrite inj_S; ring. - + clear - H H2. rewrite (sneakl_shiftr x) in H. rewrite H2 in H. @@ -1864,7 +1864,7 @@ Section Int31_Spec. rewrite (iszero_eq0 _ H0) in H; discriminate. Qed. - Lemma spec_tail0 : forall x, 0 < [|x|] -> + Lemma spec_tail0 : forall x, 0 < [|x|] -> exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail031 x|]). Proof. intros. @@ -1882,23 +1882,23 @@ Section Int31_Spec. case_eq (firstr x); intros. rewrite (inj_S (tail031_alt n (shiftr x))), Zpower_Zsucc; auto with zarith. destruct (IHn (shiftr x)) as (y & Hy1 & Hy2). - + rewrite phi_nz; rewrite phi_nz in H; contradict H. rewrite (sneakl_shiftr x), H1, H; auto. rewrite <- nshiftr_S_tail; auto. - + exists y; split; auto. rewrite phi_eqn1; auto. rewrite Zdouble_mult, Hy2; ring. - + exists [|shiftr x|]. split. generalize (phi_bounded (shiftr x)); auto with zarith. rewrite phi_eqn2; auto. rewrite Zdouble_plus_one_mult; simpl; ring. Qed. - + (* Sqrt *) (* Direct transcription of an old proof @@ -1910,23 +1910,23 @@ Section Int31_Spec. intros H1; rewrite Zmod_eq_full; auto with zarith. Qed. - Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> + Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> (j * k) + j <= ((j + k)/2 + 1) ^ 2. Proof. - intros j k Hj; generalize Hj k; pattern j; apply natlike_ind; + intros j k Hj; generalize Hj k; pattern j; apply natlike_ind; auto; clear k j Hj. intros _ k Hk; repeat rewrite Zplus_0_l. apply Zmult_le_0_compat; generalize (Z_div_pos k 2); auto with zarith. intros j Hj Hrec _ k Hk; pattern k; apply natlike_ind; auto; clear k Hk. rewrite Zmult_0_r, Zplus_0_r, Zplus_0_l. - generalize (sqr_pos (Zsucc j / 2)) (quotient_by_2 (Zsucc j)); + generalize (sqr_pos (Zsucc j / 2)) (quotient_by_2 (Zsucc j)); unfold Zsucc. rewrite Zpower_2, Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. auto with zarith. intros k Hk _. replace ((Zsucc j + Zsucc k) / 2) with ((j + k)/2 + 1). generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). - unfold Zsucc; repeat rewrite Zpower_2; + unfold Zsucc; repeat rewrite Zpower_2; repeat rewrite Zmult_plus_distr_l; repeat rewrite Zmult_plus_distr_r. repeat rewrite Zmult_1_l; repeat rewrite Zmult_1_r. auto with zarith. @@ -1991,7 +1991,7 @@ Section Int31_Spec. Qed. Lemma sqrt31_step_def rec i j: - sqrt31_step rec i j = + sqrt31_step rec i j = match (fst (i/j) ?= j)%int31 with Lt => rec i (fst ((j + fst(i/j))/2))%int31 | _ => j @@ -2008,8 +2008,8 @@ Section Int31_Spec. rewrite H1; ring. Qed. - Lemma sqrt31_step_correct rec i j: - 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> + Lemma sqrt31_step_correct rec i j: + 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < wB -> (forall j1 : int31, 0 < [|j1|] < [|j|] -> [|i|] < ([|j1|] + 1) ^ 2 -> @@ -2018,14 +2018,14 @@ Section Int31_Spec. Proof. assert (Hp2: 0 < [|2|]) by exact (refl_equal Lt). intros rec i j Hi Hj Hij H31 Hrec; rewrite sqrt31_step_def. - generalize (spec_compare (fst (i/j)%int31) j); case compare31; + generalize (spec_compare (fst (i/j)%int31) j); case compare31; rewrite div31_phi; auto; intros Hc; try (split; auto; apply sqrt_test_true; auto with zarith; fail). apply Hrec; repeat rewrite div31_phi; auto with zarith. replace [|(j + fst (i / j)%int31)|] with ([|j|] + [|i|] / [|j|]). split. case (Zle_lt_or_eq 1 [|j|]); auto with zarith; intros Hj1. - replace ([|j|] + [|i|]/[|j|]) with + replace ([|j|] + [|i|]/[|j|]) with (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])); try ring. rewrite Z_div_plus_full_l; auto with zarith. assert (0 <= [|i|]/ [|j|]) by (apply Z_div_pos; auto with zarith). @@ -2048,7 +2048,7 @@ Section Int31_Spec. Lemma iter31_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] -> [|i|] < ([|j|] + 1) ^ 2 -> 2 * [|j|] < 2 ^ (Z_of_nat size) -> - (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> + (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> [|i|] < ([|j1|] + 1) ^ 2 -> 2 * [|j1|] < 2 ^ (Z_of_nat size) -> [|rec i j1|] ^ 2 <= [|i|] < ([|rec i j1|] + 1) ^ 2) -> [|iter31_sqrt n rec i j|] ^ 2 <= [|i|] < ([|iter31_sqrt n rec i j|] + 1) ^ 2. @@ -2098,7 +2098,7 @@ Section Int31_Spec. Qed. Lemma sqrt312_step_def rec ih il j: - sqrt312_step rec ih il j = + sqrt312_step rec ih il j = match (ih ?= j)%int31 with Eq => j | Gt => j @@ -2116,7 +2116,7 @@ Section Int31_Spec. simpl; case compare31; auto. Qed. - Lemma sqrt312_lower_bound ih il j: + Lemma sqrt312_lower_bound ih il j: phi2 ih il < ([|j|] + 1) ^ 2 -> [|ih|] <= [|j|]. Proof. intros ih il j H1. @@ -2140,11 +2140,11 @@ Section Int31_Spec. simpl fst; apply trans_equal with (1 := Hq); ring. Qed. - Lemma sqrt312_step_correct rec ih il j: - 2 ^ 29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> + Lemma sqrt312_step_correct rec ih il j: + 2 ^ 29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> (forall j1, 0 < [|j1|] < [|j|] -> phi2 ih il < ([|j1|] + 1) ^ 2 -> [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2) -> - [|sqrt312_step rec ih il j|] ^ 2 <= phi2 ih il + [|sqrt312_step rec ih il j|] ^ 2 <= phi2 ih il < ([|sqrt312_step rec ih il j|] + 1) ^ 2. Proof. assert (Hp2: (0 < [|2|])%Z) by exact (refl_equal Lt). @@ -2174,7 +2174,7 @@ Section Int31_Spec. case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2. 2: contradict Hc; apply Zle_not_lt; rewrite <- Hf2, Zdiv_1_r; auto with zarith. assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2). - replace ([|j|] + phi2 ih il/ [|j|])%Z with + replace ([|j|] + phi2 ih il/ [|j|])%Z with (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring. rewrite Z_div_plus_full_l; auto with zarith. assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2) ; auto with zarith. @@ -2213,7 +2213,7 @@ Section Int31_Spec. rewrite div31_phi; change (phi 2) with 2%Z; auto. change (2 ^Z_of_nat size) with (base/2 + phi v30). assert (phi r / 2 < base/2); auto with zarith. - apply Zmult_gt_0_lt_reg_r with 2; auto with zarith. + apply Zmult_gt_0_lt_reg_r with 2; auto with zarith. change (base/2 * 2) with base. apply Zle_lt_trans with (phi r). rewrite Zmult_comm; apply Z_mult_div_ge; auto with zarith. @@ -2234,12 +2234,12 @@ Section Int31_Spec. apply Zge_le; apply Z_div_ge; auto with zarith. Qed. - Lemma iter312_sqrt_correct n rec ih il j: - 2^29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> - (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> - phi2 ih il < ([|j1|] + 1) ^ 2 -> + Lemma iter312_sqrt_correct n rec ih il j: + 2^29 <= [|ih|] -> 0 < [|j|] -> phi2 ih il < ([|j|] + 1) ^ 2 -> + (forall j1, 0 < [|j1|] -> 2^(Z_of_nat n) + [|j1|] <= [|j|] -> + phi2 ih il < ([|j1|] + 1) ^ 2 -> [|rec ih il j1|] ^ 2 <= phi2 ih il < ([|rec ih il j1|] + 1) ^ 2) -> - [|iter312_sqrt n rec ih il j|] ^ 2 <= phi2 ih il + [|iter312_sqrt n rec ih il j|] ^ 2 <= phi2 ih il < ([|iter312_sqrt n rec ih il j|] + 1) ^ 2. Proof. intros n; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n. @@ -2265,7 +2265,7 @@ Section Int31_Spec. Proof. intros ih il Hih; unfold sqrt312. change [||WW ih il||] with (phi2 ih il). - assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by + assert (Hbin: forall s, s * s + 2* s + 1 = (s + 1) ^ 2) by (intros s; ring). assert (Hb: 0 <= base) by (red; intros HH; discriminate). assert (Hi2: phi2 ih il < (phi Tn + 1) ^ 2). @@ -2428,9 +2428,9 @@ Section Int31_Spec. apply Zcompare_Eq_eq. now destruct ([|x|] ?= 0). Qed. - + (* Even *) - + Let w_is_even := int31_op.(znz_is_even). Lemma spec_is_even : forall x, @@ -2460,13 +2460,13 @@ Section Int31_Spec. exact spec_more_than_1_digit. exact spec_0. - exact spec_1. + exact spec_1. exact spec_Bm1. exact spec_compare. exact spec_eq0. - exact spec_opp_c. + exact spec_opp_c. exact spec_opp. exact spec_opp_carry. @@ -2500,7 +2500,7 @@ Section Int31_Spec. exact spec_head00. exact spec_head0. - exact spec_tail00. + exact spec_tail00. exact spec_tail0. exact spec_add_mul_div. diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index 12c0cc2642..1168e7fd6d 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -17,7 +17,7 @@ Require Export DoubleType. Unset Boxed Definitions. -(** * 31-bit integers *) +(** * 31-bit integers *) (** This file contains basic definitions of a 31-bit integer arithmetic. In fact it is more general than that. The only reason @@ -36,8 +36,8 @@ Definition size := 31%nat. Inductive digits : Type := D0 | D1. (** The type of 31-bit integers *) - -(** The type [int31] has a unique constructor [I31] that expects + +(** The type [int31] has a unique constructor [I31] that expects 31 arguments of type [digits]. *) Inductive int31 : Type := I31 : nfun digits size int31. @@ -69,26 +69,26 @@ Definition Twon : int31 := Eval compute in (napply_cst _ _ D0 (size-2) I31) D1 D (** * Bits manipulation *) -(** [sneakr b x] shifts [x] to the right by one bit. +(** [sneakr b x] shifts [x] to the right by one bit. Rightmost digit is lost while leftmost digit becomes [b]. - Pseudo-code is + Pseudo-code is [ match x with (I31 d0 ... dN) => I31 b d0 ... d(N-1) end ] *) Definition sneakr : digits -> int31 -> int31 := Eval compute in fun b => int31_rect _ (napply_except_last _ _ (size-1) (I31 b)). -(** [sneakl b x] shifts [x] to the left by one bit. +(** [sneakl b x] shifts [x] to the left by one bit. Leftmost digit is lost while rightmost digit becomes [b]. - Pseudo-code is + Pseudo-code is [ match x with (I31 d0 ... dN) => I31 d1 ... dN b end ] *) -Definition sneakl : digits -> int31 -> int31 := Eval compute in +Definition sneakl : digits -> int31 -> int31 := Eval compute in fun b => int31_rect _ (fun _ => napply_then_last _ _ b (size-1) I31). -(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct +(** [shiftl], [shiftr], [twice] and [twice_plus_one] are direct consequences of [sneakl] and [sneakr]. *) Definition shiftl := sneakl D0. @@ -96,31 +96,31 @@ Definition shiftr := sneakr D0. Definition twice := sneakl D0. Definition twice_plus_one := sneakl D1. -(** [firstl x] returns the leftmost digit of number [x]. +(** [firstl x] returns the leftmost digit of number [x]. Pseudo-code is [ match x with (I31 d0 ... dN) => d0 end ] *) -Definition firstl : int31 -> digits := Eval compute in +Definition firstl : int31 -> digits := Eval compute in int31_rect _ (fun d => napply_discard _ _ d (size-1)). -(** [firstr x] returns the rightmost digit of number [x]. +(** [firstr x] returns the rightmost digit of number [x]. Pseudo-code is [ match x with (I31 d0 ... dN) => dN end ] *) -Definition firstr : int31 -> digits := Eval compute in +Definition firstr : int31 -> digits := Eval compute in int31_rect _ (napply_discard _ _ (fun d=>d) (size-1)). -(** [iszero x] is true iff [x = I31 D0 ... D0]. Pseudo-code is +(** [iszero x] is true iff [x = I31 D0 ... D0]. Pseudo-code is [ match x with (I31 D0 ... D0) => true | _ => false end ] *) -Definition iszero : int31 -> bool := Eval compute in - let f d b := match d with D0 => b | D1 => false end +Definition iszero : int31 -> bool := Eval compute in + let f d b := match d with D0 => b | D1 => false end in int31_rect _ (nfold_bis _ _ f true size). -(* NB: DO NOT transform the above match in a nicer (if then else). +(* NB: DO NOT transform the above match in a nicer (if then else). It seems to work, but later "unfold iszero" takes forever. *) -(** [base] is [2^31], obtained via iterations of [Zdouble]. - It can also be seen as the smallest b > 0 s.t. phi_inv b = 0 +(** [base] is [2^31], obtained via iterations of [Zdouble]. + It can also be seen as the smallest b > 0 s.t. phi_inv b = 0 (see below) *) Definition base := Eval compute in @@ -140,7 +140,7 @@ Fixpoint recl_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) caserec (firstl i) si (recl_aux next A case0 caserec si) end. -Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) +Fixpoint recr_aux (n:nat)(A:Type)(case0:A)(caserec:digits->int31->A->A) (i:int31) : A := match n with | O => case0 @@ -159,22 +159,22 @@ Definition recr := recr_aux size. (** From int31 to Z, we simply iterates [Zdouble] or [Zdouble_plus_one]. *) -Definition phi : int31 -> Z := +Definition phi : int31 -> Z := recr Z (0%Z) (fun b _ => match b with D0 => Zdouble | D1 => Zdouble_plus_one end). -(** From positive to int31. An abstract definition could be : - [ phi_inv (2n) = 2*(phi_inv n) /\ +(** From positive to int31. An abstract definition could be : + [ phi_inv (2n) = 2*(phi_inv n) /\ phi_inv 2n+1 = 2*(phi_inv n) + 1 ] *) -Fixpoint phi_inv_positive p := +Fixpoint phi_inv_positive p := match p with | xI q => twice_plus_one (phi_inv_positive q) | xO q => twice (phi_inv_positive q) | xH => In end. -(** The negative part : 2-complement *) +(** The negative part : 2-complement *) Fixpoint complement_negative p := match p with @@ -186,9 +186,9 @@ Fixpoint complement_negative p := (** A simple incrementation function *) Definition incr : int31 -> int31 := - recr int31 In - (fun b si rec => match b with - | D0 => sneakl D1 si + recr int31 In + (fun b si rec => match b with + | D0 => sneakl D1 si | D1 => sneakl D0 rec end). (** We can now define the conversion from Z to int31. *) @@ -196,11 +196,11 @@ Definition incr : int31 -> int31 := Definition phi_inv : Z -> int31 := fun n => match n with | Z0 => On - | Zpos p => phi_inv_positive p + | Zpos p => phi_inv_positive p | Zneg p => incr (complement_negative p) end. -(** [phi_inv2] is similar to [phi_inv] but returns a double word +(** [phi_inv2] is similar to [phi_inv] but returns a double word [zn2z int31] *) Definition phi_inv2 n := @@ -211,7 +211,7 @@ Definition phi_inv2 n := (** [phi2] is similar to [phi] but takes a double word (two args) *) -Definition phi2 nh nl := +Definition phi2 nh nl := ((phi nh)*base+(phi nl))%Z. (** * Addition *) @@ -227,11 +227,11 @@ Notation "n + m" := (add31 n m) : int31_scope. (* mode, (phi n)+(phi m) is computed twice*) (* it may be considered to optimize it *) -Definition add31c (n m : int31) := +Definition add31c (n m : int31) := let npm := n+m in - match (phi npm ?= (phi n)+(phi m))%Z with - | Eq => C0 npm - | _ => C1 npm + match (phi npm ?= (phi n)+(phi m))%Z with + | Eq => C0 npm + | _ => C1 npm end. Notation "n '+c' m" := (add31c n m) (at level 50, no associativity) : int31_scope. @@ -254,7 +254,7 @@ Notation "n - m" := (sub31 n m) : int31_scope. (** Subtraction with carry (thus exact) *) -Definition sub31c (n m : int31) := +Definition sub31c (n m : int31) := let nmm := n-m in match (phi nmm ?= (phi n)-(phi m))%Z with | Eq => C0 nmm @@ -290,13 +290,13 @@ Notation "n '*c' m" := (mul31c n m) (at level 40, no associativity) : int31_scop (** Division of a double size word modulo [2^31] *) -Definition div3121 (nh nl m : int31) := +Definition div3121 (nh nl m : int31) := let (q,r) := Zdiv_eucl (phi2 nh nl) (phi m) in (phi_inv q, phi_inv r). (** Division modulo [2^31] *) -Definition div31 (n m : int31) := +Definition div31 (n m : int31) := let (q,r) := Zdiv_eucl (phi n) (phi m) in (phi_inv q, phi_inv r). Notation "n / m" := (div31 n m) : int31_scope. @@ -308,12 +308,12 @@ Definition compare31 (n m : int31) := ((phi n)?=(phi m))%Z. Notation "n ?= m" := (compare31 n m) (at level 70, no associativity) : int31_scope. -(** Computing the [i]-th iterate of a function: +(** Computing the [i]-th iterate of a function: [iter_int31 i A f = f^i] *) Definition iter_int31 i A f := - recr (A->A) (fun x => x) - (fun b si rec => match b with + recr (A->A) (fun x => x) + (fun b si rec => match b with | D0 => fun x => rec (rec x) | D1 => fun x => f (rec (rec x)) end) @@ -322,9 +322,9 @@ Definition iter_int31 i A f := (** Combining the [(31-p)] low bits of [i] above the [p] high bits of [j]: [addmuldiv31 p i j = i*2^p+j/2^(31-p)] (modulo [2^31]) *) -Definition addmuldiv31 p i j := - let (res, _ ) := - iter_int31 p (int31*int31) +Definition addmuldiv31 p i j := + let (res, _ ) := + iter_int31 p (int31*int31) (fun ij => let (i,j) := ij in (sneakl (firstl j) i, shiftl j)) (i,j) in @@ -346,7 +346,7 @@ Register addmuldiv31 as int31 addmuldiv in "coq_int31" by True. Definition gcd31 (i j:int31) := (fix euler (guard:nat) (i j:int31) {struct guard} := - match guard with + match guard with | O => In | S p => match j ?= On with | Eq => i @@ -370,17 +370,17 @@ Eval lazy delta [Twon] in | _ => j end. -Fixpoint iter31_sqrt (n: nat) (rec: int31 -> int31 -> int31) +Fixpoint iter31_sqrt (n: nat) (rec: int31 -> int31 -> int31) (i j: int31) {struct n} : int31 := - sqrt31_step + sqrt31_step (match n with O => rec | S n => (iter31_sqrt n (iter31_sqrt n rec)) end) i j. -Definition sqrt31 i := +Definition sqrt31 i := Eval lazy delta [On In Twon] in - match compare31 In i with + match compare31 In i with Gt => On | Eq => In | Lt => iter31_sqrt 31 (fun i j => j) i (fst (i/Twon)) @@ -388,7 +388,7 @@ Eval lazy delta [On In Twon] in Definition v30 := Eval compute in (addmuldiv31 (phi_inv (Z_of_nat size - 1)) In On). -Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31) +Definition sqrt312_step (rec: int31 -> int31 -> int31 -> int31) (ih il j: int31) := Eval lazy delta [Twon v30] in match ih ?= j with Eq => j | Gt => j | _ => @@ -401,28 +401,28 @@ Eval lazy delta [Twon v30] in | _ => j end end. -Fixpoint iter312_sqrt (n: nat) - (rec: int31 -> int31 -> int31 -> int31) +Fixpoint iter312_sqrt (n: nat) + (rec: int31 -> int31 -> int31 -> int31) (ih il j: int31) {struct n} : int31 := - sqrt312_step + sqrt312_step (match n with O => rec | S n => (iter312_sqrt n (iter312_sqrt n rec)) end) ih il j. -Definition sqrt312 ih il := +Definition sqrt312 ih il := Eval lazy delta [On In] in let s := iter312_sqrt 31 (fun ih il j => j) ih il Tn in match s *c s with W0 => (On, C0 On) (* impossible *) | WW ih1 il1 => match il -c il1 with - C0 il2 => + C0 il2 => match ih ?= ih1 with Gt => (s, C1 il2) | _ => (s, C0 il2) end - | C1 il2 => + | C1 il2 => match (ih - In) ?= ih1 with (* we could parametrize ih - 1 *) Gt => (s, C1 il2) | _ => (s, C0 il2) @@ -431,7 +431,7 @@ Eval lazy delta [On In] in end. -Fixpoint p2i n p : (N*int31)%type := +Fixpoint p2i n p : (N*int31)%type := match n with | O => (Npos p, On) | S n => match p with @@ -444,26 +444,26 @@ Fixpoint p2i n p : (N*int31)%type := Definition positive_to_int31 (p:positive) := p2i size p. (** Constant 31 converted into type int31. - It is used as default answer for numbers of zeros + It is used as default answer for numbers of zeros in [head0] and [tail0] *) Definition T31 : int31 := Eval compute in phi_inv (Z_of_nat size). Definition head031 (i:int31) := - recl _ (fun _ => T31) - (fun b si rec n => match b with + recl _ (fun _ => T31) + (fun b si rec n => match b with | D0 => rec (add31 n In) | D1 => n end) i On. Definition tail031 (i:int31) := - recr _ (fun _ => T31) - (fun b si rec n => match b with + recr _ (fun _ => T31) + (fun b si rec n => match b with | D0 => rec (add31 n In) | D1 => n end) i On. Register head031 as int31 head0 in "coq_int31" by True. -Register tail031 as int31 tail0 in "coq_int31" by True. +Register tail031 as int31 tail0 in "coq_int31" by True. diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 7373acc9ad..1b1283400b 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -8,11 +8,11 @@ (* $Id$ *) -(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ] +(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ] as defined abstractly in CyclicAxioms. *) -(** Even if the construction provided here is not reused for building - the efficient arbitrary precision numbers, it provides a simple +(** Even if the construction provided here is not reused for building + the efficient arbitrary precision numbers, it provides a simple implementation of CyclicAxioms, hence ensuring its coherence. *) Set Implicit Arguments. @@ -56,9 +56,9 @@ Section ZModulo. destruct 1; auto. Qed. Let digits_gt_1 := spec_more_than_1_digit. - + Lemma wB_pos : wB > 0. - Proof. + Proof. unfold wB, base; auto with zarith. Qed. Hint Resolve wB_pos. @@ -79,7 +79,7 @@ Section ZModulo. auto. Qed. - Definition znz_of_pos x := + Definition znz_of_pos x := let (q,r) := Zdiv_eucl_POS x wB in (N_of_Z q, r). Lemma spec_of_pos : forall p, @@ -90,10 +90,10 @@ Section ZModulo. destruct (Zdiv_eucl_POS p wB); simpl; destruct 1. unfold znz_to_Z; rewrite Zmod_small; auto. assert (0 <= z). - replace z with (Zpos p / wB) by + replace z with (Zpos p / wB) by (symmetry; apply Zdiv_unique with z0; auto). apply Z_div_pos; auto with zarith. - replace (Z_of_N (N_of_Z z)) with z by + replace (Z_of_N (N_of_Z z)) with z by (destruct z; simpl; auto; elim H1; auto). rewrite Zmult_comm; auto. Qed. @@ -110,7 +110,7 @@ Section ZModulo. Definition znz_0 := 0. Definition znz_1 := 1. Definition znz_Bm1 := wB - 1. - + Lemma spec_0 : [|znz_0|] = 0. Proof. unfold znz_to_Z, znz_0. @@ -121,7 +121,7 @@ Section ZModulo. Proof. unfold znz_to_Z, znz_1. apply Zmod_small; split; auto with zarith. - unfold wB, base. + unfold wB, base. apply Zlt_trans with (Zpos digits); auto. apply Zpower2_lt_lin; auto with zarith. Qed. @@ -138,7 +138,7 @@ Section ZModulo. Definition znz_compare x y := Zcompare [|x|] [|y|]. - Lemma spec_compare : forall x y, + Lemma spec_compare : forall x y, match znz_compare x y with | Eq => [|x|] = [|y|] | Lt => [|x|] < [|y|] @@ -150,19 +150,19 @@ Section ZModulo. intros; apply Zcompare_Eq_eq; auto. Qed. - Definition znz_eq0 x := + Definition znz_eq0 x := match [|x|] with Z0 => true | _ => false end. - + Lemma spec_eq0 : forall x, znz_eq0 x = true -> [|x|] = 0. Proof. unfold znz_eq0; intros; now destruct [|x|]. Qed. - Definition znz_opp_c x := + Definition znz_opp_c x := if znz_eq0 x then C0 0 else C1 (- x). Definition znz_opp x := - x. Definition znz_opp_carry x := - x - 1. - + Lemma spec_opp_c : forall x, [-|znz_opp_c x|] = -[|x|]. Proof. intros; unfold znz_opp_c, znz_to_Z; auto. @@ -180,7 +180,7 @@ Section ZModulo. change ((- x) mod wB = (0 - (x mod wB)) mod wB). rewrite Zminus_mod_idemp_r; simpl; auto. Qed. - + Lemma spec_opp_carry : forall x, [|znz_opp_carry x|] = wB - [|x|] - 1. Proof. intros; unfold znz_opp_carry, znz_to_Z; auto. @@ -194,15 +194,15 @@ Section ZModulo. generalize (Z_mod_lt x wB wB_pos); omega. Qed. - Definition znz_succ_c x := - let y := Zsucc x in + Definition znz_succ_c x := + let y := Zsucc x in if znz_eq0 y then C1 0 else C0 y. - Definition znz_add_c x y := - let z := [|x|] + [|y|] in + Definition znz_add_c x y := + let z := [|x|] + [|y|] in if Z_lt_le_dec z wB then C0 z else C1 (z-wB). - Definition znz_add_carry_c x y := + Definition znz_add_carry_c x y := let z := [|x|]+[|y|]+1 in if Z_lt_le_dec z wB then C0 z else C1 (z-wB). @@ -210,7 +210,7 @@ Section ZModulo. Definition znz_add := Zplus. Definition znz_add_carry x y := x + y + 1. - Lemma Zmod_equal : + Lemma Zmod_equal : forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z. Proof. intros. @@ -225,12 +225,12 @@ Section ZModulo. Proof. intros; unfold znz_succ_c, znz_to_Z, Zsucc. case_eq (znz_eq0 (x+1)); intros; unfold interp_carry. - + rewrite Zmult_1_l. replace (wB + 0 mod wB) with wB by auto with zarith. symmetry; rewrite Zeq_plus_swap. assert ((x+1) mod wB = 0) by (apply spec_eq0; auto). - replace (wB-1) with ((wB-1) mod wB) by + replace (wB-1) with ((wB-1) mod wB) by (apply Zmod_small; generalize wB_pos; omega). rewrite <- Zminus_mod_idemp_l; rewrite Z_mod_same; simpl; auto. apply Zmod_equal; auto. @@ -289,15 +289,15 @@ Section ZModulo. rewrite Zplus_mod_idemp_l; auto. Qed. - Definition znz_pred_c x := + Definition znz_pred_c x := if znz_eq0 x then C1 (wB-1) else C0 (x-1). - Definition znz_sub_c x y := - let z := [|x|]-[|y|] in + Definition znz_sub_c x y := + let z := [|x|]-[|y|] in if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z. - Definition znz_sub_carry_c x y := - let z := [|x|]-[|y|]-1 in + Definition znz_sub_carry_c x y := + let z := [|x|]-[|y|]-1 in if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z. Definition znz_pred := Zpred. @@ -323,7 +323,7 @@ Section ZModulo. Proof. intros; unfold znz_sub_c, znz_to_Z, interp_carry. destruct Z_lt_le_dec. - replace ((wB + (x mod wB - y mod wB)) mod wB) with + replace ((wB + (x mod wB - y mod wB)) mod wB) with (wB + (x mod wB - y mod wB)). omega. symmetry; apply Zmod_small. @@ -337,7 +337,7 @@ Section ZModulo. Proof. intros; unfold znz_sub_carry_c, znz_to_Z, interp_carry. destruct Z_lt_le_dec. - replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with + replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with (wB + (x mod wB - y mod wB -1)). omega. symmetry; apply Zmod_small. @@ -358,7 +358,7 @@ Section ZModulo. intros; unfold znz_sub, znz_to_Z; apply Zminus_mod. Qed. - Lemma spec_sub_carry : + Lemma spec_sub_carry : forall x y, [|znz_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. Proof. intros; unfold znz_sub_carry, znz_to_Z. @@ -367,15 +367,15 @@ Section ZModulo. rewrite Zminus_mod_idemp_l. auto. Qed. - - Definition znz_mul_c x y := + + Definition znz_mul_c x y := let (h,l) := Zdiv_eucl ([|x|]*[|y|]) wB in if znz_eq0 h then if znz_eq0 l then W0 else WW h l else WW h l. Definition znz_mul := Zmult. Definition znz_square_c x := znz_mul_c x x. - + Lemma spec_mul_c : forall x y, [|| znz_mul_c x y ||] = [|x|] * [|y|]. Proof. intros; unfold znz_mul_c, zn2z_to_Z. @@ -426,7 +426,7 @@ Section ZModulo. destruct Zdiv_eucl as (q,r); destruct 1; intros. injection H1; clear H1; intros. assert ([|r|]=r). - apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; + apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; auto with zarith. assert ([|q|]=q). apply Zmod_small. @@ -453,7 +453,7 @@ Section ZModulo. Definition znz_mod x y := [|x|] mod [|y|]. Definition znz_mod_gt x y := [|x|] mod [|y|]. - + Lemma spec_mod : forall a b, 0 < [|b|] -> [|znz_mod a b|] = [|a|] mod [|b|]. Proof. @@ -469,7 +469,7 @@ Section ZModulo. Proof. intros; apply spec_mod; auto. Qed. - + Definition znz_gcd x y := Zgcd [|x|] [|y|]. Definition znz_gcd_gt x y := Zgcd [|x|] [|y|]. @@ -516,7 +516,7 @@ Section ZModulo. intros. apply spec_gcd; auto. Qed. - Definition znz_div21 a1 a2 b := + Definition znz_div21 a1 a2 b := Zdiv_eucl ([|a1|]*wB+[|a2|]) [|b|]. Lemma spec_div21 : forall a1 a2 b, @@ -537,7 +537,7 @@ Section ZModulo. destruct Zdiv_eucl as (q,r); destruct 1; intros. injection H4; clear H4; intros. assert ([|r|]=r). - apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; + apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; auto with zarith. assert ([|q|]=q). apply Zmod_small. @@ -576,7 +576,7 @@ Section ZModulo. apply Zmod_le; auto with zarith. Qed. - Definition znz_is_even x := + Definition znz_is_even x := if Z_eq_dec ([|x|] mod 2) 0 then true else false. Lemma spec_is_even : forall x, @@ -586,7 +586,7 @@ Section ZModulo. generalize (Z_mod_lt [|x|] 2); omega. Qed. - Definition znz_sqrt x := Zsqrt_plain [|x|]. + Definition znz_sqrt x := Zsqrt_plain [|x|]. Lemma spec_sqrt : forall x, [|znz_sqrt x|] ^ 2 <= [|x|] < ([|znz_sqrt x|] + 1) ^ 2. Proof. @@ -609,12 +609,12 @@ Section ZModulo. generalize wB_pos; auto with zarith. Qed. - Definition znz_sqrt2 x y := - let z := [|x|]*wB+[|y|] in - match z with + Definition znz_sqrt2 x y := + let z := [|x|]*wB+[|y|] in + match z with | Z0 => (0, C0 0) - | Zpos p => - let (s,r,_,_) := sqrtrempos p in + | Zpos p => + let (s,r,_,_) := sqrtrempos p in (s, if Z_lt_le_dec r wB then C0 r else C1 (r-wB)) | Zneg _ => (0, C0 0) end. @@ -651,7 +651,7 @@ Section ZModulo. rewrite Zpower_2; auto with zarith. replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; auto with zarith). rewrite Zpower_2; omega. - + assert (0<=Zneg p). rewrite Heqz; generalize wB_pos; auto with zarith. compute in H0; elim H0; auto. @@ -665,8 +665,8 @@ Section ZModulo. apply two_power_pos_correct. Qed. - Definition znz_head0 x := match [|x|] with - | Z0 => znz_zdigits + Definition znz_head0 x := match [|x|] with + | Z0 => znz_zdigits | Zpos p => znz_zdigits - log_inf p - 1 | _ => 0 end. @@ -695,7 +695,7 @@ Section ZModulo. change (Zpos x~0) with (2*(Zpos x)) in H. replace p with (Zsucc (p-1)) in H; auto with zarith. rewrite Zpower_Zsucc in H; auto with zarith. - + simpl; intros; destruct p; compute; auto with zarith. Qed. @@ -730,8 +730,8 @@ Section ZModulo. by ring. unfold wB, base, znz_zdigits; auto with zarith. apply Zmult_le_compat; auto with zarith. - - apply Zlt_le_trans + + apply Zlt_le_trans with (2^(znz_zdigits - log_inf p - 1)*(2^(Zsucc (log_inf p)))). apply Zmult_lt_compat_l; auto with zarith. rewrite <- Zpower_exp; auto with zarith. @@ -740,17 +740,17 @@ Section ZModulo. unfold wB, base, znz_zdigits; auto with zarith. Qed. - Fixpoint Ptail p := match p with + Fixpoint Ptail p := match p with | xO p => (Ptail p)+1 | _ => 0 - end. + end. Lemma Ptail_pos : forall p, 0 <= Ptail p. Proof. induction p; simpl; auto with zarith. Qed. Hint Resolve Ptail_pos. - + Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d. Proof. induction p; try (compute; auto; fail). @@ -775,7 +775,7 @@ Section ZModulo. Qed. Definition znz_tail0 x := - match [|x|] with + match [|x|] with | Z0 => znz_zdigits | Zpos p => Ptail p | Zneg _ => 0 @@ -788,7 +788,7 @@ Section ZModulo. apply spec_zdigits. Qed. - Lemma spec_tail0 : forall x, 0 < [|x|] -> + Lemma spec_tail0 : forall x, 0 < [|x|] -> exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|znz_tail0 x|]). Proof. intros; unfold znz_tail0. @@ -818,7 +818,7 @@ Section ZModulo. (** Let's now group everything in two records *) - Definition zmod_op := mk_znz_op + Definition zmod_op := mk_znz_op (znz_digits : positive) (znz_zdigits: znz) (znz_to_Z : znz -> Z) @@ -859,11 +859,11 @@ Section ZModulo. (znz_div_gt : znz -> znz -> znz * znz) (znz_div : znz -> znz -> znz * znz) - (znz_mod_gt : znz -> znz -> znz) - (znz_mod : znz -> znz -> znz) + (znz_mod_gt : znz -> znz -> znz) + (znz_mod : znz -> znz -> znz) (znz_gcd_gt : znz -> znz -> znz) - (znz_gcd : znz -> znz -> znz) + (znz_gcd : znz -> znz -> znz) (znz_add_mul_div : znz -> znz -> znz -> znz) (znz_pos_mod : znz -> znz -> znz) @@ -878,54 +878,54 @@ Section ZModulo. spec_more_than_1_digit spec_0 - spec_1 - spec_Bm1 - - spec_compare - spec_eq0 - - spec_opp_c - spec_opp - spec_opp_carry - - spec_succ_c - spec_add_c - spec_add_carry_c - spec_succ - spec_add - spec_add_carry - - spec_pred_c - spec_sub_c - spec_sub_carry_c - spec_pred - spec_sub - spec_sub_carry - - spec_mul_c - spec_mul - spec_square_c - - spec_div21 - spec_div_gt - spec_div - - spec_mod_gt - spec_mod - - spec_gcd_gt - spec_gcd - - spec_head00 - spec_head0 - spec_tail00 - spec_tail0 - - spec_add_mul_div - spec_pos_mod - - spec_is_even - spec_sqrt2 + spec_1 + spec_Bm1 + + spec_compare + spec_eq0 + + spec_opp_c + spec_opp + spec_opp_carry + + spec_succ_c + spec_add_c + spec_add_carry_c + spec_succ + spec_add + spec_add_carry + + spec_pred_c + spec_sub_c + spec_sub_carry_c + spec_pred + spec_sub + spec_sub_carry + + spec_mul_c + spec_mul + spec_square_c + + spec_div21 + spec_div_gt + spec_div + + spec_mod_gt + spec_mod + + spec_gcd_gt + spec_gcd + + spec_head00 + spec_head0 + spec_tail00 + spec_tail0 + + spec_add_mul_div + spec_pos_mod + + spec_is_even + spec_sqrt2 spec_sqrt. End ZModulo. @@ -934,7 +934,7 @@ End ZModulo. Module Type PositiveNotOne. Parameter p : positive. - Axiom not_one : p<> 1%positive. + Axiom not_one : p<> 1%positive. End PositiveNotOne. Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType. diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v index cbf6f701f2..dc22256348 100644 --- a/theories/Numbers/Integer/BigZ/ZMake.v +++ b/theories/Numbers/Integer/BigZ/ZMake.v @@ -17,31 +17,31 @@ Require Import ZSig. Open Scope Z_scope. -(** * ZMake - - A generic transformation from a structure of natural numbers +(** * ZMake + + A generic transformation from a structure of natural numbers [NSig.NType] to a structure of integers [ZSig.ZType]. *) Module Make (N:NType) <: ZType. - - Inductive t_ := + + Inductive t_ := | Pos : N.t -> t_ | Neg : N.t -> t_. - + Definition t := t_. Definition zero := Pos N.zero. Definition one := Pos N.one. Definition minus_one := Neg N.one. - Definition of_Z x := + Definition of_Z x := match x with | Zpos x => Pos (N.of_N (Npos x)) | Z0 => zero | Zneg x => Neg (N.of_N (Npos x)) end. - + Definition to_Z x := match x with | Pos nx => N.to_Z nx @@ -99,13 +99,13 @@ Module Make (N:NType) <: ZType. unfold compare, to_Z; intros x y; case x; case y; clear x y; intros x y; auto; generalize (N.spec_pos x) (N.spec_pos y). generalize (N.spec_compare y x); case N.compare; auto with zarith. - generalize (N.spec_compare y N.zero); case N.compare; + generalize (N.spec_compare y N.zero); case N.compare; try rewrite N.spec_0; auto with zarith. generalize (N.spec_compare x N.zero); case N.compare; rewrite N.spec_0; auto with zarith. generalize (N.spec_compare x N.zero); case N.compare; rewrite N.spec_0; auto with zarith. - generalize (N.spec_compare N.zero y); case N.compare; + generalize (N.spec_compare N.zero y); case N.compare; try rewrite N.spec_0; auto with zarith. generalize (N.spec_compare N.zero x); case N.compare; rewrite N.spec_0; auto with zarith. @@ -114,7 +114,7 @@ Module Make (N:NType) <: ZType. generalize (N.spec_compare x y); case N.compare; auto with zarith. Qed. - Definition eq_bool x y := + Definition eq_bool x y := match compare x y with | Eq => true | _ => false @@ -128,9 +128,9 @@ Module Make (N:NType) <: ZType. Definition cmp_sign x y := match x, y with - | Pos nx, Neg ny => - if N.eq_bool ny N.zero then Eq else Gt - | Neg nx, Pos ny => + | Pos nx, Neg ny => + if N.eq_bool ny N.zero then Eq else Gt + | Neg nx, Pos ny => if N.eq_bool nx N.zero then Eq else Lt | _, _ => Eq end. @@ -150,7 +150,7 @@ Module Make (N:NType) <: ZType. rewrite N.spec_0; unfold to_Z. generalize (N.spec_pos x) (N.spec_pos y); auto with zarith. Qed. - + Definition to_N x := match x with | Pos nx => nx @@ -164,9 +164,9 @@ Module Make (N:NType) <: ZType. simpl; rewrite Zabs_eq; auto. simpl; rewrite Zabs_non_eq; simpl; auto with zarith. Qed. - - Definition opp x := - match x with + + Definition opp x := + match x with | Pos nx => Neg nx | Neg nx => Pos nx end. @@ -174,7 +174,7 @@ Module Make (N:NType) <: ZType. Theorem spec_opp: forall x, to_Z (opp x) = - to_Z x. intros x; case x; simpl; auto with zarith. Qed. - + Definition succ x := match x with | Pos n => Pos (N.succ n) @@ -188,7 +188,7 @@ Module Make (N:NType) <: ZType. Theorem spec_succ: forall n, to_Z (succ n) = to_Z n + 1. intros x; case x; clear x; intros x. exact (N.spec_succ x). - simpl; generalize (N.spec_compare N.zero x); case N.compare; + simpl; generalize (N.spec_compare N.zero x); case N.compare; rewrite N.spec_0; simpl. intros HH; rewrite <- HH; rewrite N.spec_1; ring. intros HH; rewrite N.spec_pred; auto with zarith. @@ -212,7 +212,7 @@ Module Make (N:NType) <: ZType. end | Neg nx, Neg ny => Neg (N.add nx ny) end. - + Theorem spec_add: forall x y, to_Z (add x y) = to_Z x + to_Z y. unfold add, to_Z; intros [x | x] [y | y]. exact (N.spec_add x y). @@ -239,7 +239,7 @@ Module Make (N:NType) <: ZType. Theorem spec_pred: forall x, to_Z (pred x) = to_Z x - 1. unfold pred, to_Z, minus_one; intros [x | x]. - generalize (N.spec_compare N.zero x); case N.compare; + generalize (N.spec_compare N.zero x); case N.compare; rewrite N.spec_0; try rewrite N.spec_1; auto with zarith. intros H; exact (N.spec_pred _ H). generalize (N.spec_pos x); auto with zarith. @@ -248,7 +248,7 @@ Module Make (N:NType) <: ZType. Definition sub x y := match x, y with - | Pos nx, Pos ny => + | Pos nx, Pos ny => match N.compare nx ny with | Gt => Pos (N.sub nx ny) | Eq => zero @@ -256,7 +256,7 @@ Module Make (N:NType) <: ZType. end | Pos nx, Neg ny => Pos (N.add nx ny) | Neg nx, Pos ny => Neg (N.add nx ny) - | Neg nx, Neg ny => + | Neg nx, Neg ny => match N.compare nx ny with | Gt => Neg (N.sub nx ny) | Eq => zero @@ -278,7 +278,7 @@ Module Make (N:NType) <: ZType. intros; rewrite N.spec_sub; try ring; auto with zarith. Qed. - Definition mul x y := + Definition mul x y := match x, y with | Pos nx, Pos ny => Pos (N.mul nx ny) | Pos nx, Neg ny => Neg (N.mul nx ny) @@ -291,7 +291,7 @@ Module Make (N:NType) <: ZType. unfold mul, to_Z; intros [x | x] [y | y]; rewrite N.spec_mul; ring. Qed. - Definition square x := + Definition square x := match x with | Pos nx => Pos (N.square nx) | Neg nx => Pos (N.square nx) @@ -304,7 +304,7 @@ Module Make (N:NType) <: ZType. Definition power_pos x p := match x with | Pos nx => Pos (N.power_pos nx p) - | Neg nx => + | Neg nx => match p with | xH => x | xO _ => Pos (N.power_pos nx p) @@ -315,7 +315,7 @@ Module Make (N:NType) <: ZType. Theorem spec_power_pos: forall x n, to_Z (power_pos x n) = to_Z x ^ Zpos n. assert (F0: forall x, (-x)^2 = x^2). intros x; rewrite Zpower_2; ring. - unfold power_pos, to_Z; intros [x | x] [p | p |]; + unfold power_pos, to_Z; intros [x | x] [p | p |]; try rewrite N.spec_power_pos; try ring. assert (F: 0 <= 2 * Zpos p). assert (0 <= Zpos p); auto with zarith. @@ -336,7 +336,7 @@ Module Make (N:NType) <: ZType. end. - Theorem spec_sqrt: forall x, 0 <= to_Z x -> + Theorem spec_sqrt: forall x, 0 <= to_Z x -> to_Z (sqrt x) ^ 2 <= to_Z x < (to_Z (sqrt x) + 1) ^ 2. unfold to_Z, sqrt; intros [x | x] H. exact (N.spec_sqrt x). @@ -381,7 +381,7 @@ Module Make (N:NType) <: ZType. generalize (N.spec_pos y); auto with zarith. generalize (N.spec_div_eucl x y HH); case N.div_eucl; auto. intros q r; generalize (N.spec_pos x) HH; unfold Zdiv_eucl; - case_eq (N.to_Z x); case_eq (N.to_Z y); + case_eq (N.to_Z x); case_eq (N.to_Z y); try (intros; apply False_ind; auto with zarith; fail). intros p He1 He2 _ _ H1; injection H1; intros H2 H3. generalize (N.spec_compare N.zero r); case N.compare; @@ -407,13 +407,13 @@ Module Make (N:NType) <: ZType. assert (N.to_Z r = (Zpos p1 mod (Zpos p))). unfold Zmod, Zdiv_eucl; rewrite <- H3; auto. case (Z_mod_lt (Zpos p1) (Zpos p)); auto with zarith. - rewrite N.spec_0; intros H2; generalize (N.spec_pos r); + rewrite N.spec_0; intros H2; generalize (N.spec_pos r); intros; apply False_ind; auto with zarith. assert (HH: 0 < N.to_Z y). generalize (N.spec_pos y); auto with zarith. generalize (N.spec_div_eucl x y HH); case N.div_eucl; auto. intros q r; generalize (N.spec_pos x) HH; unfold Zdiv_eucl; - case_eq (N.to_Z x); case_eq (N.to_Z y); + case_eq (N.to_Z x); case_eq (N.to_Z y); try (intros; apply False_ind; auto with zarith; fail). intros p He1 He2 _ _ H1; injection H1; intros H2 H3. generalize (N.spec_compare N.zero r); case N.compare; @@ -443,7 +443,7 @@ Module Make (N:NType) <: ZType. generalize (N.spec_pos y); auto with zarith. generalize (N.spec_div_eucl x y H1); case N.div_eucl; auto. intros q r; generalize (N.spec_pos x) H1; unfold Zdiv_eucl; - case_eq (N.to_Z x); case_eq (N.to_Z y); + case_eq (N.to_Z x); case_eq (N.to_Z y); try (intros; apply False_ind; auto with zarith; fail). change (-0) with 0; lazy iota beta; auto. intros p _ _ _ _ H2; injection H2. @@ -478,7 +478,7 @@ Module Make (N:NType) <: ZType. | Pos nx, Pos ny => Pos (N.gcd nx ny) | Pos nx, Neg ny => Pos (N.gcd nx ny) | Neg nx, Pos ny => Pos (N.gcd nx ny) - | Neg nx, Neg ny => Pos (N.gcd nx ny) + | Neg nx, Neg ny => Pos (N.gcd nx ny) end. Theorem spec_gcd: forall a b, to_Z (gcd a b) = Zgcd (to_Z a) (to_Z b). diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v index 4e45939831..00e292db0f 100644 --- a/theories/Numbers/Integer/SpecViaZ/ZSig.v +++ b/theories/Numbers/Integer/SpecViaZ/ZSig.v @@ -58,7 +58,7 @@ Module Type ZType. Parameter spec_eq_bool: forall x y, if eq_bool x y then [x] = [y] else [x] <> [y]. - + Parameter succ : t -> t. Parameter spec_succ: forall n, [succ n] = [n] + 1. @@ -93,21 +93,21 @@ Module Type ZType. Parameter sqrt : t -> t. - Parameter spec_sqrt: forall x, 0 <= [x] -> + Parameter spec_sqrt: forall x, 0 <= [x] -> [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. Parameter div_eucl : t -> t -> t * t. Parameter spec_div_eucl: forall x y, [y] <> 0 -> let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. - + Parameter div : t -> t -> t. Parameter spec_div: forall x y, [y] <> 0 -> [div x y] = [x] / [y]. Parameter modulo : t -> t -> t. - Parameter spec_modulo: forall x y, [y] <> 0 -> + Parameter spec_modulo: forall x y, [y] <> 0 -> [modulo x y] = [x] mod [y]. Parameter gcd : t -> t -> t. diff --git a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v index 4d1054553f..030c589ff9 100644 --- a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v +++ b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v @@ -27,7 +27,7 @@ Infix "-" := Z.sub : IntScope. Infix "*" := Z.mul : IntScope. Notation "- x" := (Z.opp x) : IntScope. -Hint Rewrite +Hint Rewrite Z.spec_0 Z.spec_1 Z.spec_add Z.spec_sub Z.spec_pred Z.spec_succ Z.spec_mul Z.spec_opp Z.spec_of_Z : Zspec. @@ -91,7 +91,7 @@ Section Induction. Variable A : Z.t -> Prop. Hypothesis A_wd : predicate_wd Z.eq A. Hypothesis A0 : A 0. -Hypothesis AS : forall n, A n <-> A (Z.succ n). +Hypothesis AS : forall n, A n <-> A (Z.succ n). Add Morphism A with signature Z.eq ==> iff as A_morph. Proof. apply A_wd. Qed. @@ -214,7 +214,7 @@ Proof. Qed. Add Morphism Z.compare with signature Z.eq ==> Z.eq ==> (@eq comparison) as compare_wd. -Proof. +Proof. intros x x' Hx y y' Hy. rewrite 2 spec_compare_alt; unfold Z.eq in *; rewrite Hx, Hy; intuition. Qed. diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v index feb7a49166..a8adf49af6 100644 --- a/theories/Numbers/NaryFunctions.v +++ b/theories/Numbers/NaryFunctions.v @@ -16,19 +16,19 @@ Require Import List. (** * Generic dependently-typed operators about [n]-ary functions *) -(** The type of [n]-ary function: [nfun A n B] is +(** The type of [n]-ary function: [nfun A n B] is [A -> ... -> A -> B] with [n] occurences of [A] in this type. *) -Fixpoint nfun A n B := +Fixpoint nfun A n B := match n with - | O => B + | O => B | S n => A -> (nfun A n B) - end. + end. Notation " A ^^ n --> B " := (nfun A n B) (at level 50, n at next level) : type_scope. -(** [napply_cst _ _ a n f] iterates [n] times the application of a +(** [napply_cst _ _ a n f] iterates [n] times the application of a particular constant [a] to the [n]-ary function [f]. *) Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B := @@ -40,47 +40,47 @@ Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B := (** A generic transformation from an n-ary function to another one.*) -Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n : +Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n : (A^^n-->B) -> (A^^n-->C) := - match n return (A^^n-->B) -> (A^^n-->C) with + match n return (A^^n-->B) -> (A^^n-->C) with | O => f | S n => fun g a => nfun_to_nfun _ _ _ f n (g a) end. -(** [napply_except_last _ _ n f] expects [n] arguments of type [A], - applies [n-1] of them to [f] and discard the last one. *) +(** [napply_except_last _ _ n f] expects [n] arguments of type [A], + applies [n-1] of them to [f] and discard the last one. *) -Definition napply_except_last (A B:Type) := +Definition napply_except_last (A B:Type) := nfun_to_nfun A B (A->B) (fun b a => b). -(** [napply_then_last _ _ a n f] expects [n] arguments of type [A], - applies them to [f] and then apply [a] to the result. *) +(** [napply_then_last _ _ a n f] expects [n] arguments of type [A], + applies them to [f] and then apply [a] to the result. *) -Definition napply_then_last (A B:Type)(a:A) := +Definition napply_then_last (A B:Type)(a:A) := nfun_to_nfun A (A->B) B (fun fab => fab a). -(** [napply_discard _ b n] expects [n] arguments, discards then, +(** [napply_discard _ b n] expects [n] arguments, discards then, and returns [b]. *) Fixpoint napply_discard (A B:Type)(b:B) n : A^^n-->B := - match n return A^^n-->B with + match n return A^^n-->B with | O => b | S n => fun _ => napply_discard _ _ b n end. (** A fold function *) -Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) := - match n return (A^^n-->B) with +Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) := + match n return (A^^n-->B) with | O => b | S n => fun a => (nfold _ _ f (f a b) n) end. -(** [n]-ary products : [nprod A n] is [A*...*A*unit], +(** [n]-ary products : [nprod A n] is [A*...*A*unit], with [n] occurrences of [A] in this type. *) -Fixpoint nprod A n : Type := match n with +Fixpoint nprod A n : Type := match n with | O => unit | S n => (A * nprod A n)%type end. @@ -89,54 +89,54 @@ Notation "A ^ n" := (nprod A n) : type_scope. (** [n]-ary curryfication / uncurryfication *) -Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) := - match n return (A^n -> B) -> (A^^n-->B) with +Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) := + match n return (A^n -> B) -> (A^^n-->B) with | O => fun x => x tt | S n => fun f a => ncurry _ _ n (fun p => f (a,p)) end. -Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) := +Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) := match n return (A^^n-->B) -> (A^n -> B) with | O => fun x _ => x | S n => fun f p => let (x,p) := p in nuncurry _ _ n (f x) p end. -(** Earlier functions can also be defined via [ncurry/nuncurry]. +(** Earlier functions can also be defined via [ncurry/nuncurry]. For instance : *) Definition nfun_to_nfun_bis A B C (f:B->C) n : - (A^^n-->B) -> (A^^n-->C) := + (A^^n-->B) -> (A^^n-->C) := fun anb => ncurry _ _ n (fun an => f ((nuncurry _ _ n anb) an)). -(** We can also us it to obtain another [fold] function, +(** We can also us it to obtain another [fold] function, equivalent to the previous one, but with a nicer expansion (see for instance Int31.iszero). *) -Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) := - match n return (A^^n-->B) with +Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) := + match n return (A^^n-->B) with | O => b - | S n => fun a => + | S n => fun a => nfun_to_nfun_bis _ _ _ (f a) n (nfold_bis _ _ f b n) end. (** From [nprod] to [list] *) -Fixpoint nprod_to_list (A:Type) n : A^n -> list A := - match n with +Fixpoint nprod_to_list (A:Type) n : A^n -> list A := + match n with | O => fun _ => nil | S n => fun p => let (x,p) := p in x::(nprod_to_list _ n p) end. (** From [list] to [nprod] *) -Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) := - match l return A^(length l) with +Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) := + match l return A^(length l) with | nil => tt | x::l => (x, nprod_of_list _ l) end. (** This gives an additional way to write the fold *) -Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) := +Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) := ncurry _ _ n (fun p => fold_right f b (nprod_to_list _ _ p)). diff --git a/theories/Numbers/NatInt/NZAxioms.v b/theories/Numbers/NatInt/NZAxioms.v index 1ef7809866..a9c023856f 100644 --- a/theories/Numbers/NatInt/NZAxioms.v +++ b/theories/Numbers/NatInt/NZAxioms.v @@ -23,7 +23,7 @@ Parameter Inline NZadd : NZ -> NZ -> NZ. Parameter Inline NZsub : NZ -> NZ -> NZ. Parameter Inline NZmul : NZ -> NZ -> NZ. -(* Unary subtraction (opp) is not defined on natural numbers, so we have +(* Unary subtraction (opp) is not defined on natural numbers, so we have it for integers only *) Axiom NZeq_equiv : equiv NZ NZeq. diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v index 5212e63814..f02baca2cf 100644 --- a/theories/Numbers/Natural/Abstract/NOrder.v +++ b/theories/Numbers/Natural/Abstract/NOrder.v @@ -309,7 +309,7 @@ Proof NZgt_wf. Theorem lt_wf_0 : well_founded lt. Proof. -setoid_replace lt with (fun n m : N => 0 <= n /\ n < m) +setoid_replace lt with (fun n m : N => 0 <= n /\ n < m) using relation (@relations_eq N N). apply lt_wf. intros x y; split. diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml index 7424d877bb..c22680be3a 100644 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ b/theories/Numbers/Natural/BigN/NMake_gen.ml @@ -15,7 +15,7 @@ (*s The two parameters that control the generation: *) -let size = 6 (* how many times should we repeat the Z/nZ --> Z/2nZ +let size = 6 (* how many times should we repeat the Z/nZ --> Z/2nZ process before relying on a generic construct *) let gen_proof = true (* should we generate proofs ? *) @@ -27,18 +27,18 @@ let c = "N" let pz n = if n == 0 then "w_0" else "W0" let rec gen2 n = if n == 0 then "1" else if n == 1 then "2" else "2 * " ^ (gen2 (n - 1)) -let rec genxO n s = +let rec genxO n s = if n == 0 then s else " (xO" ^ (genxO (n - 1) s) ^ ")" -(* NB: in ocaml >= 3.10, we could use Printf.ifprintf for printing to - /dev/null, but for being compatible with earlier ocaml and not - relying on system-dependent stuff like open_out "/dev/null", +(* NB: in ocaml >= 3.10, we could use Printf.ifprintf for printing to + /dev/null, but for being compatible with earlier ocaml and not + relying on system-dependent stuff like open_out "/dev/null", let's use instead a magical hack *) (* Standard printer, with a final newline *) let pr s = Printf.printf (s^^"\n") (* Printing to /dev/null *) -let pn = (fun s -> Obj.magic (fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> ()) +let pn = (fun s -> Obj.magic (fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> ()) : ('a, out_channel, unit) format -> 'a) (* Proof printer : prints iff gen_proof is true *) let pp = if gen_proof then pr else pn @@ -51,7 +51,7 @@ let pp0 = if gen_proof then pr0 else pn (*s The actual printing *) -let _ = +let _ = pr "(************************************************************************)"; pr "(* v * The Coq Proof Assistant / The Coq Development Team *)"; @@ -67,7 +67,7 @@ let _ = pr ""; pr "(** From a cyclic Z/nZ representation to arbitrary precision natural numbers.*)"; pr ""; - pr "(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *)"; + pr "(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *)"; pr ""; pr "Require Import BigNumPrelude."; pr "Require Import ZArith."; @@ -132,7 +132,7 @@ let _ = pr ""; pr " Inductive %s_ :=" t; - for i = 0 to size do + for i = 0 to size do pr " | %s%i : w%i -> %s_" c i i t done; pr " | %sn : forall n, word w%i (S n) -> %s_." c size t; @@ -167,7 +167,7 @@ let _ = pr " Definition to_N x := Zabs_N (to_Z x)."; pr ""; - + pr " Definition eq x y := (to_Z x = to_Z y)."; pr ""; @@ -191,7 +191,7 @@ let _ = for i = 0 to size do pp " Let nmake_op%i := nmake_op _ w%i_op." i i; pp " Let eval%in n := znz_to_Z (nmake_op%i n)." i i; - if i == 0 then + if i == 0 then pr " Let extend%i := DoubleBase.extend (WW w_0)." i else pr " Let extend%i := DoubleBase.extend (WW (W0: w%i))." i i; @@ -280,7 +280,7 @@ let _ = pp " Let w0_spec: znz_spec w0_op := W0.w_spec."; for i = 1 to 3 do - pp " Let w%i_spec: znz_spec w%i_op := mk_znz2_spec w%i_spec." i i (i-1) + pp " Let w%i_spec: znz_spec w%i_op := mk_znz2_spec w%i_spec." i i (i-1) done; for i = 4 to size + 3 do pp " Let w%i_spec : znz_spec w%i_op := mk_znz2_karatsuba_spec w%i_spec." i i (i-1) @@ -309,14 +309,14 @@ let _ = for i = 0 to size do - pp " Theorem digits_w%i: znz_digits w%i_op = znz_digits (nmake_op _ w0_op %i)." i i i; + pp " Theorem digits_w%i: znz_digits w%i_op = znz_digits (nmake_op _ w0_op %i)." i i i; if i == 0 then pp " auto." else pp " rewrite digits_nmake; rewrite <- digits_w%i; auto." (i - 1); pp " Qed."; pp ""; - pp " Let spec_double_eval%in: forall n, eval%in n = DoubleBase.double_to_Z (znz_digits w%i_op) (znz_to_Z w%i_op) n." i i i i; + pp " Let spec_double_eval%in: forall n, eval%in n = DoubleBase.double_to_Z (znz_digits w%i_op) (znz_to_Z w%i_op) n." i i i i; pp " Proof."; pp " intros n; exact (nmake_double n w%i w%i_op)." i i; pp " Qed."; @@ -325,7 +325,7 @@ let _ = for i = 0 to size do for j = 0 to (size - i) do - pp " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i)." i j (i + j) i j; + pp " Theorem digits_w%in%i: znz_digits w%i_op = znz_digits (nmake_op _ w%i_op %i)." i j (i + j) i j; pp " Proof."; if j == 0 then if i == 0 then @@ -346,7 +346,7 @@ let _ = end; pp " Qed."; pp ""; - pp " Let spec_eval%in%i: forall x, [%s%i x] = eval%in %i x." i j c (i + j) i j; + pp " Let spec_eval%in%i: forall x, [%s%i x] = eval%in %i x." i j c (i + j) i j; pp " Proof."; if j == 0 then pp " intros x; rewrite spec_double_eval%in; unfold DoubleBase.double_to_Z, to_Z; auto." i @@ -363,7 +363,7 @@ let _ = pp " Qed."; if i + j <> size then begin - pp " Let spec_extend%in%i: forall x, [%s%i x] = [%s%i (extend%i %i x)]." i (i + j + 1) c i c (i + j + 1) i j; + pp " Let spec_extend%in%i: forall x, [%s%i x] = [%s%i (extend%i %i x)]." i (i + j + 1) c i c (i + j + 1) i j; if j == 0 then begin pp " intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x)." i (i + j); @@ -393,7 +393,7 @@ let _ = pp " Qed."; pp ""; - pp " Let spec_eval%in%i: forall x, [%sn 0 x] = eval%in %i x." i (size - i + 1) c i (size - i + 1); + pp " Let spec_eval%in%i: forall x, [%sn 0 x] = eval%in %i x." i (size - i + 1) c i (size - i + 1); pp " Proof."; pp " intros x; case x."; pp " auto."; @@ -405,7 +405,7 @@ let _ = pp " Qed."; pp ""; - pp " Let spec_eval%in%i: forall x, [%sn 1 x] = eval%in %i x." i (size - i + 2) c i (size - i + 2); + pp " Let spec_eval%in%i: forall x, [%sn 1 x] = eval%in %i x." i (size - i + 2) c i (size - i + 2); pp " intros x; case x."; pp " auto."; pp " intros xh xl; unfold to_Z; rewrite znz_to_Z_%i." (size + 2); @@ -430,7 +430,7 @@ let _ = pp " Qed."; pp ""; - pp " Let spec_eval%in: forall n x, [%sn n x] = eval%in (S n) x." size c size; + pp " Let spec_eval%in: forall n x, [%sn n x] = eval%in (S n) x." size c size; pp " intros n; elim n; clear n."; pp " exact spec_eval%in1." size; pp " intros n Hrec x; case x; clear x."; @@ -446,7 +446,7 @@ let _ = pp " Qed."; pp ""; - pp " Let spec_extend%in: forall n x, [%s%i x] = [%sn n (extend%i n x)]." size c size c size ; + pp " Let spec_extend%in: forall n x, [%s%i x] = [%sn n (extend%i n x)]." size c size c size ; pp " intros n; elim n; clear n."; pp " intros x; change (extend%i 0 x) with (WW (znz_0 w%i_op) x)." size size; pp " unfold to_Z."; @@ -578,14 +578,14 @@ let _ = pr " | %s%i wx, %s%i wy => f%i (extend%i %i wx) wy" c i c j j i (j - i - 1); done; if i == size then - pr " | %s%i wx, %sn m wy => fnn m (extend%i m wx) wy" c size c size - else + pr " | %s%i wx, %sn m wy => fnn m (extend%i m wx) wy" c size c size + else pr " | %s%i wx, %sn m wy => fnn m (extend%i m (extend%i %i wx)) wy" c i c size i (size - i - 1); done; for i = 0 to size do if i == size then - pr " | %sn n wx, %s%i wy => fnn n wx (extend%i n wy)" c c size size - else + pr " | %sn n wx, %s%i wy => fnn n wx (extend%i n wy)" c c size size + else pr " | %sn n wx, %s%i wy => fnn n wx (extend%i n (extend%i %i wy))" c c i size i (size - i - 1); done; pr " | %sn n wx, Nn m wy =>" c; @@ -611,14 +611,14 @@ let _ = done; if i == size then pp " intros m y; rewrite (spec_extend%in m); apply Pfnn." size - else + else pp " intros m y; rewrite spec_extend%in%i; rewrite (spec_extend%in m); apply Pfnn." i size size; done; pp " intros n x y; case y; clear y."; for i = 0 to size do if i == size then pp " intros y; rewrite (spec_extend%in n); apply Pfnn." size - else + else pp " intros y; rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn." i size size; done; pp " intros m y; rewrite <- (spec_cast_l n m x); "; @@ -644,7 +644,7 @@ let _ = pr " match y with"; for j = 0 to i - 1 do pr " | %s%i wy =>" c j; - if j == 0 then + if j == 0 then pr " if w0_eq0 wy then ft0 x else"; pr " f%i wx (extend%i %i wy)" i j (i - j -1); done; @@ -653,8 +653,8 @@ let _ = pr " | %s%i wy => f%i (extend%i %i wx) wy" c j j i (j - i - 1); done; if i == size then - pr " | %sn m wy => fnn m (extend%i m wx) wy" c size - else + pr " | %sn m wy => fnn m (extend%i m wx) wy" c size + else pr " | %sn m wy => fnn m (extend%i m (extend%i %i wx)) wy" c size i (size - i - 1); pr" end"; done; @@ -665,8 +665,8 @@ let _ = if i == 0 then pr " if w0_eq0 wy then ft0 x else"; if i == size then - pr " fnn n wx (extend%i n wy)" size - else + pr " fnn n wx (extend%i n wy)" size + else pr " fnn n wx (extend%i n (extend%i %i wy))" size i (size - i - 1); done; pr " | %sn m wy =>" c; @@ -707,7 +707,7 @@ let _ = done; if i == size then pp " intros m y; rewrite (spec_extend%in m); apply Pfnn." size - else + else pp " intros m y; rewrite spec_extend%in%i; rewrite (spec_extend%in m); apply Pfnn." i size size; done; pp " intros n x y; case y; clear y."; @@ -721,7 +721,7 @@ let _ = end; if i == size then pp " rewrite (spec_extend%in n); apply Pfnn." size - else + else pp " rewrite spec_extend%in%i; rewrite (spec_extend%in n); apply Pfnn." i size size; done; pp " intros m y; rewrite <- (spec_cast_l n m x); "; @@ -748,14 +748,14 @@ let _ = pr " | %s%i wx, %s%i wy => f%in %i wx wy" c i c j i (j - i - 1); done; if i == size then - pr " | %s%i wx, %sn m wy => f%in m wx wy" c size c size - else + pr " | %s%i wx, %sn m wy => f%in m wx wy" c size c size + else pr " | %s%i wx, %sn m wy => f%in m (extend%i %i wx) wy" c i c size i (size - i - 1); done; for i = 0 to size do if i == size then - pr " | %sn n wx, %s%i wy => fn%i n wx wy" c c size size - else + pr " | %sn n wx, %s%i wy => fn%i n wx wy" c c size size + else pr " | %sn n wx, %s%i wy => fn%i n wx (extend%i %i wy)" c c i size i (size - i - 1); done; pr " | %sn n wx, %sn m wy => fnm n m wx wy" c c; @@ -779,14 +779,14 @@ let _ = done; if i == size then pp " intros m y; rewrite spec_eval%in; apply Pf%in." size size - else + else pp " intros m y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pf%in." i size size size; done; pp " intros n x y; case y; clear y."; for i = 0 to size do if i == size then pp " intros y; rewrite spec_eval%in; apply Pfn%i." size size - else + else pp " intros y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pfn%i." i size size size; done; pp " intros m y; apply Pfnm."; @@ -820,8 +820,8 @@ let _ = pr " | %s%i wy => f%in %i wx wy" c j i (j - i - 1); done; if i == size then - pr " | %sn m wy => f%in m wx wy" c size - else + pr " | %sn m wy => f%in m wx wy" c size + else pr " | %sn m wy => f%in m (extend%i %i wx) wy" c size i (size - i - 1); pr " end"; done; @@ -832,8 +832,8 @@ let _ = if i == 0 then pr " if w0_eq0 wy then ft0 x else"; if i == size then - pr " fn%i n wx wy" size - else + pr " fn%i n wx wy" size + else pr " fn%i n wx (extend%i %i wy)" size i (size - i - 1); done; pr " | %sn m wy => fnm n m wx wy" c; @@ -869,7 +869,7 @@ let _ = done; if i == size then pp " intros m y; rewrite spec_eval%in; apply Pf%in." size size - else + else pp " intros m y; rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pf%in." i size size size; done; pp " intros n x y; case y; clear y."; @@ -883,7 +883,7 @@ let _ = end; if i == size then pp " rewrite spec_eval%in; apply Pfn%i." size size - else + else pp " rewrite spec_extend%in%i; rewrite spec_eval%in; apply Pfn%i." i size size size; done; pp " intros m y; apply Pfnm."; @@ -902,20 +902,20 @@ let _ = pr " (***************************************************************)"; pr ""; - pr " Definition reduce_0 (x:w) := %s0 x." c; + pr " Definition reduce_0 (x:w) := %s0 x." c; pr " Definition reduce_1 :="; pr " Eval lazy beta iota delta[reduce_n1] in"; pr " reduce_n1 _ _ zero w0_eq0 %s0 %s1." c c; for i = 2 to size do pr " Definition reduce_%i :=" i; pr " Eval lazy beta iota delta[reduce_n1] in"; - pr " reduce_n1 _ _ zero w%i_eq0 reduce_%i %s%i." + pr " reduce_n1 _ _ zero w%i_eq0 reduce_%i %s%i." (i-1) (i-1) c i done; pr " Definition reduce_%i :=" (size+1); pr " Eval lazy beta iota delta[reduce_n1] in"; - pr " reduce_n1 _ _ zero w%i_eq0 reduce_%i (%sn 0)." - size size c; + pr " reduce_n1 _ _ zero w%i_eq0 reduce_%i (%sn 0)." + size size c; pr " Definition reduce_n n := "; pr " Eval lazy beta iota delta[reduce_n] in"; @@ -940,7 +940,7 @@ let _ = pp " intros x1 y1."; pp " generalize (spec_w%i_eq0 x1); " (i - 1); pp " case w%i_eq0; intros H1; auto." (i - 1); - if i <> 1 then + if i <> 1 then pp " rewrite spec_reduce_%i." (i - 1); pp " unfold to_Z; rewrite znz_to_Z_%i." i; pp " unfold to_Z in H1; rewrite H1; auto."; @@ -983,19 +983,19 @@ let _ = for i = 0 to size-1 do pr " | %s%i wx =>" c i; pr " match w%i_succ_c wx with" i; - pr " | C0 r => %s%i r" c i; + pr " | C0 r => %s%i r" c i; pr " | C1 r => %s%i (WW one%i r)" c (i+1) i; pr " end"; done; pr " | %s%i wx =>" c size; pr " match w%i_succ_c wx with" size; - pr " | C0 r => %s%i r" c size; + pr " | C0 r => %s%i r" c size; pr " | C1 r => %sn 0 (WW one%i r)" c size ; pr " end"; pr " | %sn n wx =>" c; pr " let op := make_op n in"; pr " match op.(znz_succ_c) wx with"; - pr " | C0 r => %sn n r" c; + pr " | C0 r => %sn n r" c; pr " | C1 r => %sn (S n) (WW op.(znz_1) r)" c; pr " end"; pr " end."; @@ -1033,7 +1033,7 @@ let _ = pr ""; for i = 0 to size do - pr " Definition w%i_add_c := znz_add_c w%i_op." i i; + pr " Definition w%i_add_c := znz_add_c w%i_op." i i; pr " Definition w%i_add x y :=" i; pr " match w%i_add_c x y with" i; pr " | C0 r => %s%i r" c i; @@ -1057,7 +1057,7 @@ let _ = pp " Proof."; pp " intros n m; unfold to_Z, w%i_add, w%i_add_c." i i; pp " generalize (spec_add_c w%i_spec n m); case znz_add_c; auto." i; - pp " intros ww H; rewrite <- H."; + pp " intros ww H; rewrite <- H."; pp " rewrite znz_to_Z_%i; unfold interp_carry;" (i + 1); pp " apply f_equal2 with (f := Zplus); auto;"; pp " apply f_equal2 with (f := Zmult); auto;"; @@ -1070,7 +1070,7 @@ let _ = pp " Proof."; pp " intros k n m; unfold to_Z, addn."; pp " generalize (spec_add_c (wn_spec k) n m); case znz_add_c; auto."; - pp " intros ww H; rewrite <- H."; + pp " intros ww H; rewrite <- H."; pp " rewrite (znz_to_Z_n k); unfold interp_carry;"; pp " apply f_equal2 with (f := Zplus); auto;"; pp " apply f_equal2 with (f := Zmult); auto;"; @@ -1116,14 +1116,14 @@ let _ = for i = 0 to size do pr " | %s%i wx =>" c i; pr " match w%i_pred_c wx with" i; - pr " | C0 r => reduce_%i r" i; + pr " | C0 r => reduce_%i r" i; pr " | C1 r => zero"; pr " end"; done; pr " | %sn n wx =>" c; pr " let op := make_op n in"; pr " match op.(znz_pred_c) wx with"; - pr " | C0 r => reduce_n n r"; + pr " | C0 r => reduce_n n r"; pr " | C1 r => zero"; pr " end"; pr " end."; @@ -1153,7 +1153,7 @@ let _ = pp " unfold to_Z in H1; auto with zarith."; pp " Qed."; pp " "; - + pp " Let spec_pred0: forall x, [x] = 0 -> [pred x] = 0."; pp " Proof."; pp " intros x; case x; unfold pred."; @@ -1187,7 +1187,7 @@ let _ = done; pr ""; - for i = 0 to size do + for i = 0 to size do pr " Definition w%i_sub x y :=" i; pr " match w%i_sub_c x y with" i; pr " | C0 r => reduce_%i r" i; @@ -1209,7 +1209,7 @@ let _ = pp " Proof."; pp " intros n m; unfold w%i_sub, w%i_sub_c." i i; pp " generalize (spec_sub_c w%i_spec n m); case znz_sub_c; " i; - if i == 0 then + if i == 0 then pp " intros x; auto." else pp " intros x; try rewrite spec_reduce_%i; auto." i; @@ -1219,7 +1219,7 @@ let _ = pp " Qed."; pp ""; done; - + pp " Let spec_wn_sub: forall n x y, [%sn n y] <= [%sn n x] -> [subn n x y] = [%sn n x] - [%sn n y]." c c c c; pp " Proof."; pp " intros k n m; unfold subn."; @@ -1299,7 +1299,7 @@ let _ = pr " Definition comparen_%i :=" i; pr " compare_mn_1 w%i w%i %s compare_%i (compare_%i %s) compare_%i." i i (pz i) i i (pz i) i done; - pr ""; + pr ""; pr " Definition comparenm n m wx wy :="; pr " let mn := Max.max n m in"; @@ -1337,7 +1337,7 @@ let _ = pp " unfold compare_%i, to_Z; exact (spec_compare w%i_spec)." i i; pp " Qed."; pp ""; - + pp " Let spec_comparen_%i:" i; pp " forall (n : nat) (x : word w%i n) (y : w%i)," i i; pp " match comparen_%i n x y with" i; @@ -1387,12 +1387,12 @@ let _ = pp " (fun n => comparen_%i (S n)) _ _ _" i; done; pp " comparenm _)."; - + for i = 0 to size - 1 do pp " exact spec_compare_%i." i; pp " intros n x y H;apply spec_opp_compare; apply spec_comparen_%i." i; pp " intros n x y H; exact (spec_comparen_%i (S n) x y)." i; - done; + done; pp " exact spec_compare_%i." size; pp " intros n x y;apply spec_opp_compare; apply spec_comparen_%i." size; pp " intros n; exact (spec_comparen_%i (S n))." size; @@ -1461,7 +1461,7 @@ let _ = pr " match n return word w%i (S n) -> t_ with" i; for j = 0 to size - i do if (i + j) == size then - begin + begin pr " | %i%s => fun x => %sn 0 x" j "%nat" c; pr " | %i%s => fun x => %sn 1 x" (j + 1) "%nat" c end @@ -1471,7 +1471,7 @@ let _ = pr " | _ => fun _ => N0 w_0"; pr " end."; pr ""; - done; + done; for i = 0 to size - 1 do @@ -1486,7 +1486,7 @@ let _ = pp " repeat rewrite inj_S; unfold Zsucc; auto with zarith."; pp " Qed."; pp ""; - done; + done; for i = 0 to size do @@ -1497,8 +1497,8 @@ let _ = pr " if w%i_eq0 w then %sn n r" i c; pr " else %sn (S n) (WW (extend%i n w) r)." c i; end - else - begin + else + begin pr " if w%i_eq0 w then to_Z%i n r" i i; pr " else to_Z%i (S n) (WW (extend%i n w) r)." i i; end; @@ -1556,7 +1556,7 @@ let _ = pp " Qed."; pp ""; done; - + pp " Lemma nmake_op_WW: forall ww ww1 n x y,"; pp " znz_to_Z (nmake_op ww ww1 (S n)) (WW x y) ="; pp " znz_to_Z (nmake_op ww ww1 n) x * base (znz_digits (nmake_op ww ww1 n)) +"; @@ -1564,7 +1564,7 @@ let _ = pp " auto."; pp " Qed."; pp ""; - + for i = 0 to size do pp " Lemma extend%in_spec: forall n x1," i; pp " znz_to_Z (nmake_op _ w%i_op (S n)) (extend%i n x1) = " i i; @@ -1573,12 +1573,12 @@ let _ = pp " intros n1 x2; rewrite nmake_double."; pp " unfold extend%i." i; pp " rewrite DoubleBase.spec_extend; auto."; - if i == 0 then + if i == 0 then pp " intros l; simpl; unfold w_0; rewrite (spec_0 w0_spec); ring."; pp " Qed."; pp ""; done; - + pp " Lemma spec_muln:"; pp " forall n (x: word _ (S n)) y,"; pp " [%sn (S n) (znz_mul_c (make_op n) x y)] = [%sn n x] * [%sn n y]." c c c; @@ -1614,7 +1614,7 @@ let _ = pp " generalize (spec_w%i_eq0 x1); case w%i_eq0; intros HH." i i; pp " unfold to_Z in HH; rewrite HH."; if i == size then - begin + begin pp " rewrite spec_eval%in; unfold eval%in, nmake_op%i; auto." i i i; pp " rewrite spec_eval%in; unfold eval%in, nmake_op%i." i i i end @@ -1708,7 +1708,7 @@ let _ = pr " (* Power *)"; pr " (* *)"; pr " (***************************************************************)"; - pr ""; + pr ""; pr " Fixpoint power_pos (x:%s) (p:positive) {struct p} : %s :=" t t; pr " match p with"; @@ -1719,7 +1719,7 @@ let _ = pr ""; pr " Theorem spec_power_pos: forall x n, [power_pos x n] = [x] ^ Zpos n."; - pa " Admitted."; + pa " Admitted."; pp " Proof."; pp " intros x n; generalize x; elim n; clear n x; simpl power_pos."; pp " intros; rewrite spec_mul; rewrite spec_square; rewrite H."; @@ -1775,7 +1775,7 @@ let _ = pr " (* Division *)"; pr " (* *)"; pr " (***************************************************************)"; - pr ""; + pr ""; for i = 0 to size do pr " Definition w%i_div_gt := w%i_op.(znz_div_gt)." i i @@ -1844,7 +1844,7 @@ let _ = pr " Definition div_gt := Eval lazy beta delta [iter] in"; pr " (iter _ "; - for i = 0 to size do + for i = 0 to size do pr " div_gt%i" i; pr " (fun n x y => div_gt%i x (DoubleBase.get_low %s (S n) y))" i (pz i); pr " w%i_divn1" i; @@ -1862,10 +1862,10 @@ let _ = pp " forall x y, [x] > [y] -> 0 < [y] ->"; pp " let (q,r) := div_gt x y in"; pp " [x] = [q] * [y] + [r] /\\ 0 <= [r] < [y])."; - pp " refine (spec_iter (t_*t_) (fun x y res => x > y -> 0 < y ->"; + pp " refine (spec_iter (t_*t_) (fun x y res => x > y -> 0 < y ->"; pp " let (q,r) := res in"; pp " x = [q] * y + [r] /\\ 0 <= [r] < y)"; - for i = 0 to size do + for i = 0 to size do pp " div_gt%i" i; pp " (fun n x y => div_gt%i x (DoubleBase.get_low %s (S n) y))" i (pz i); pp " w%i_divn1 _ _ _" i; @@ -1883,7 +1883,7 @@ let _ = pp " (DoubleBase.get_low %s (S n) y))." (pz i); pp0 " "; for j = 0 to i do - pp0 "unfold w%i; " (i-j); + pp0 "unfold w%i; " (i-j); done; pp "case znz_div_gt."; pp " intros xx yy H4; repeat rewrite spec_reduce_%i." i; @@ -1897,7 +1897,7 @@ let _ = pp " (spec_divn1 w%i w%i_op w%i_spec (S n) x y H3)." i i i; pp0 " unfold w%i_divn1; " i; for j = 0 to i do - pp0 "unfold w%i; " (i-j); + pp0 "unfold w%i; " (i-j); done; pp "case double_divn1."; pp " intros xx yy H4."; @@ -1990,7 +1990,7 @@ let _ = pr " (* Modulo *)"; pr " (* *)"; pr " (***************************************************************)"; - pr ""; + pr ""; for i = 0 to size do pr " Definition w%i_mod_gt := w%i_op.(znz_mod_gt)." i i @@ -2063,7 +2063,7 @@ let _ = pp " rewrite <- (spec_get_end%i (S n) y x) in H3; auto with zarith." i; if i == size then pp " intros n x y H2 H3; rewrite spec_reduce_%i." i - else + else pp " intros n x y H1 H2 H3; rewrite spec_reduce_%i." i; pp " unfold w%i_modn1, to_Z; rewrite spec_double_eval%in." i i; pp " apply (spec_modn1 _ _ w%i_spec); auto." i; @@ -2110,7 +2110,7 @@ let _ = pr " (* Gcd *)"; pr " (* *)"; pr " (***************************************************************)"; - pr ""; + pr ""; pr " Definition digits x :="; pr " match x with"; @@ -2423,7 +2423,7 @@ let _ = pr " (* Shift *)"; pr " (* *)"; pr " (***************************************************************)"; - pr ""; + pr ""; (* Head0 *) pr " Definition head0 w := match w with"; @@ -2513,7 +2513,7 @@ let _ = pr " Definition %sdigits x :=" c; pr " match x with"; pr " | %s0 _ => %s0 w0_op.(znz_zdigits)" c c; - for i = 1 to size do + for i = 1 to size do pr " | %s%i _ => reduce_%i w%i_op.(znz_zdigits)" c i i i; done; pr " | %sn n _ => reduce_n n (make_op n).(znz_zdigits)" c; @@ -2644,7 +2644,7 @@ let _ = pp " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." size; pp " try (apply sym_equal; exact (spec_extend%in m x))." size; end - else + else begin pp " intros m y; unfold shiftrn, Ndigits."; pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; @@ -2857,7 +2857,7 @@ let _ = pp " apply F4 with (3:=(wn_spec m))(4:=wn_spec m)(5:=w%i_spec); auto with zarith." size; pp " try (apply sym_equal; exact (spec_extend%in m x))." size; end - else + else begin pp " intros m y; unfold shiftln, head0."; pp " repeat rewrite spec_reduce_n; unfold to_Z; intros H1."; @@ -3030,7 +3030,7 @@ let _ = pr " (forall x, 2 ^ (Zpos p + 1) <= [head0 x]->"; pr " [cont n x] = [x] * 2 ^ [n]) ->"; pr " [safe_shiftl_aux_body cont n x] = [x] * 2 ^ [n]."; - pa " Admitted."; + pa " Admitted."; pp " Proof."; pp " intros n p x cont H1 H2; unfold safe_shiftl_aux_body."; pp " generalize (spec_compare n (head0 x)); case compare; intros H."; diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v index c3fdd1bf4a..d42db97d57 100644 --- a/theories/Numbers/Natural/BigN/Nbasic.v +++ b/theories/Numbers/Natural/BigN/Nbasic.v @@ -21,7 +21,7 @@ Require Import DoubleCyclic. (* To compute the necessary height *) Fixpoint plength (p: positive) : positive := - match p with + match p with xH => xH | xO p1 => Psucc (plength p1) | xI p1 => Psucc (plength p1) @@ -34,10 +34,10 @@ rewrite Zpower_exp; auto with zarith. rewrite Zpos_succ_morphism; unfold Zsucc; auto with zarith. intros p; elim p; simpl plength; auto. intros p1 Hp1; rewrite F; repeat rewrite Zpos_xI. -assert (tmp: (forall p, 2 * p = p + p)%Z); +assert (tmp: (forall p, 2 * p = p + p)%Z); try repeat rewrite tmp; auto with zarith. intros p1 Hp1; rewrite F; rewrite (Zpos_xO p1). -assert (tmp: (forall p, 2 * p = p + p)%Z); +assert (tmp: (forall p, 2 * p = p + p)%Z); try repeat rewrite tmp; auto with zarith. rewrite Zpower_1_r; auto with zarith. Qed. @@ -73,7 +73,7 @@ case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith. intros q1 H2. replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q). 2: pattern (Zpos p) at 2; rewrite H2; auto with zarith. -generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2; +generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2; case Zmod. intros HH _; rewrite HH; auto with zarith. intros r1 HH (_,HH1); rewrite HH; rewrite Zpos_succ_morphism. @@ -121,9 +121,9 @@ Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n. Defined. Fixpoint extend (n:nat) {struct n} : forall w:Type, zn2z w -> word w (S n) := - match n return forall w:Type, zn2z w -> word w (S n) with + match n return forall w:Type, zn2z w -> word w (S n) with | O => fun w x => x - | S m => + | S m => let aux := extend m in fun w x => WW W0 (aux w x) end. @@ -169,7 +169,7 @@ Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n := | S n1 => let v := fst (diff m1 n1) + n1 in let v1 := fst (diff m1 n1) + S n1 in - eq_ind v (fun n => v1 = S n) + eq_ind v (fun n => v1 = S n) (eq_ind v1 (fun n => v1 = n) (refl_equal v1) (S v) (plusnS _ _)) _ (diff_l _ _) end @@ -182,7 +182,7 @@ Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n := | 0 => refl_equal _ | S _ => plusn0 _ end - | S m => + | S m => match n return (snd (diff (S m) n) + S m = max (S m) n) with | 0 => refl_equal (snd (diff (S m) 0) + S m) | S n1 => @@ -253,9 +253,9 @@ Section ReduceRec. | WW xh xl => match xh with | W0 => @reduce_n m xl - | _ => @c (S m) x + | _ => @c (S m) x end - end + end end. End ReduceRec. @@ -276,14 +276,14 @@ Section CompareRec. Variable compare_m : wm -> w -> comparison. Fixpoint compare0_mn (n:nat) : word wm n -> comparison := - match n return word wm n -> comparison with - | O => compare0_m + match n return word wm n -> comparison with + | O => compare0_m | S m => fun x => match x with | W0 => Eq - | WW xh xl => + | WW xh xl => match compare0_mn m xh with - | Eq => compare0_mn m xl + | Eq => compare0_mn m xl | r => Lt end end @@ -296,7 +296,7 @@ Section CompareRec. Variable spec_compare0_m: forall x, match compare0_m x with Eq => w_to_Z w_0 = wm_to_Z x - | Lt => w_to_Z w_0 < wm_to_Z x + | Lt => w_to_Z w_0 < wm_to_Z x | Gt => w_to_Z w_0 > wm_to_Z x end. Variable wm_to_Z_pos: forall x, 0 <= wm_to_Z x < base wm_base. @@ -341,14 +341,14 @@ Section CompareRec. Qed. Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison := - match n return word wm n -> w -> comparison with - | O => compare_m - | S m => fun x y => + match n return word wm n -> w -> comparison with + | O => compare_m + | S m => fun x y => match x with | W0 => compare w_0 y - | WW xh xl => + | WW xh xl => match compare0_mn m xh with - | Eq => compare_mn_1 m xl y + | Eq => compare_mn_1 m xl y | r => Gt end end @@ -366,7 +366,7 @@ Section CompareRec. | Lt => wm_to_Z x < w_to_Z y | Gt => wm_to_Z x > w_to_Z y end. - Variable wm_base_lt: forall x, + Variable wm_base_lt: forall x, 0 <= w_to_Z x < base (wm_base). Let double_wB_lt: forall n x, @@ -385,7 +385,7 @@ Section CompareRec. unfold Zpower_pos; simpl; ring. Qed. - + Lemma spec_compare_mn_1: forall n x y, match compare_mn_1 n x y with Eq => double_to_Z n x = w_to_Z y @@ -434,7 +434,7 @@ Section AddS. | C1 z => match incr hy with C0 z1 => C0 (WW z1 z) | C1 z1 => C1 (WW z1 z) - end + end end end. @@ -458,12 +458,12 @@ End AddS. Fixpoint length_pos x := match x with xH => O | xO x1 => S (length_pos x1) | xI x1 => S (length_pos x1) end. - + Theorem length_pos_lt: forall x y, (length_pos x < length_pos y)%nat -> Zpos x < Zpos y. Proof. intros x; elim x; clear x; [intros x1 Hrec | intros x1 Hrec | idtac]; - intros y; case y; clear y; intros y1 H || intros H; simpl length_pos; + intros y; case y; clear y; intros y1 H || intros H; simpl length_pos; try (rewrite (Zpos_xI x1) || rewrite (Zpos_xO x1)); try (rewrite (Zpos_xI y1) || rewrite (Zpos_xO y1)); try (inversion H; fail); @@ -492,20 +492,20 @@ End AddS. Qed. Theorem make_zop: forall w (x: znz_op w), - znz_to_Z (mk_zn2z_op x) = - fun z => match z with + znz_to_Z (mk_zn2z_op x) = + fun z => match z with W0 => 0 - | WW xh xl => znz_to_Z x xh * base (znz_digits x) + | WW xh xl => znz_to_Z x xh * base (znz_digits x) + znz_to_Z x xl end. intros ww x; auto. Qed. Theorem make_kzop: forall w (x: znz_op w), - znz_to_Z (mk_zn2z_op_karatsuba x) = - fun z => match z with + znz_to_Z (mk_zn2z_op_karatsuba x) = + fun z => match z with W0 => 0 - | WW xh xl => znz_to_Z x xh * base (znz_digits x) + | WW xh xl => znz_to_Z x xh * base (znz_digits x) + znz_to_Z x xl end. intros ww x; auto. diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v index e53e627eca..5295aaec2a 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSig.v +++ b/theories/Numbers/Natural/SpecViaZ/NSig.v @@ -58,7 +58,7 @@ Module Type NType. Parameter spec_eq_bool: forall x y, if eq_bool x y then [x] = [y] else [x] <> [y]. - + Parameter succ : t -> t. Parameter spec_succ: forall n, [succ n] = [n] + 1. @@ -98,7 +98,7 @@ Module Type NType. Parameter spec_div_eucl: forall x y, 0 < [y] -> let (q,r) := div_eucl x y in ([q], [r]) = Zdiv_eucl [x] [y]. - + Parameter div : t -> t -> t. Parameter spec_div: forall x y, 0 < [y] -> [div x y] = [x] / [y]. diff --git a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v index 773807120b..578cb62561 100644 --- a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v +++ b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v @@ -97,7 +97,7 @@ Section Induction. Variable A : N.t -> Prop. Hypothesis A_wd : predicate_wd N.eq A. Hypothesis A0 : A 0. -Hypothesis AS : forall n, A n <-> A (N.succ n). +Hypothesis AS : forall n, A n <-> A (N.succ n). Add Morphism A with signature N.eq ==> iff as A_morph. Proof. apply A_wd. Qed. @@ -221,7 +221,7 @@ Proof. Qed. Add Morphism N.compare with signature N.eq ==> N.eq ==> (@eq comparison) as compare_wd. -Proof. +Proof. intros x x' Hx y y' Hy. rewrite 2 spec_compare_alt. unfold N.eq in *. rewrite Hx, Hy; intuition. Qed. diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v index 67411eac81..0973b7d8d9 100644 --- a/theories/Numbers/Rational/BigQ/QMake.v +++ b/theories/Numbers/Rational/BigQ/QMake.v @@ -28,27 +28,27 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. number y interpreted as x/y. The pairs (x,0) and (0,y) are all interpreted as 0. *) - Inductive t_ := + Inductive t_ := | Qz : Z.t -> t_ | Qq : Z.t -> N.t -> t_. Definition t := t_. - (** Specification with respect to [QArith] *) + (** Specification with respect to [QArith] *) Open Local Scope Q_scope. Definition of_Z x: t := Qz (Z.of_Z x). - Definition of_Q (q:Q) : t := - let (x,y) := q in - match y with + Definition of_Q (q:Q) : t := + let (x,y) := q in + match y with | 1%positive => Qz (Z.of_Z x) | _ => Qq (Z.of_Z x) (N.of_N (Npos y)) end. - Definition to_Q (q: t) := - match q with + Definition to_Q (q: t) := + match q with | Qz x => Z.to_Z x # 1 | Qq x y => if N.eq_bool y N.zero then 0 else Z.to_Z x # Z2P (N.to_Z y) @@ -59,11 +59,11 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem strong_spec_of_Q: forall q: Q, [of_Q q] = q. Proof. intros(x,y); destruct y; simpl; rewrite Z.spec_of_Z; auto. - generalize (N.spec_eq_bool (N.of_N (Npos y~1)) N.zero); + generalize (N.spec_eq_bool (N.of_N (Npos y~1)) N.zero); case N.eq_bool; auto; rewrite N.spec_0. rewrite N.spec_of_N; discriminate. rewrite N.spec_of_N; auto. - generalize (N.spec_eq_bool (N.of_N (Npos y~0)) N.zero); + generalize (N.spec_eq_bool (N.of_N (Npos y~0)) N.zero); case N.eq_bool; auto; rewrite N.spec_0. rewrite N.spec_of_N; discriminate. rewrite N.spec_of_N; auto. @@ -98,77 +98,77 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Definition compare (x y: t) := match x, y with | Qz zx, Qz zy => Z.compare zx zy - | Qz zx, Qq ny dy => + | Qz zx, Qq ny dy => if N.eq_bool dy N.zero then Z.compare zx Z.zero else Z.compare (Z.mul zx (Z_of_N dy)) ny - | Qq nx dx, Qz zy => - if N.eq_bool dx N.zero then Z.compare Z.zero zy + | Qq nx dx, Qz zy => + if N.eq_bool dx N.zero then Z.compare Z.zero zy else Z.compare nx (Z.mul zy (Z_of_N dx)) | Qq nx dx, Qq ny dy => match N.eq_bool dx N.zero, N.eq_bool dy N.zero with | true, true => Eq | true, false => Z.compare Z.zero ny | false, true => Z.compare nx Z.zero - | false, false => Z.compare (Z.mul nx (Z_of_N dy)) + | false, false => Z.compare (Z.mul nx (Z_of_N dy)) (Z.mul ny (Z_of_N dx)) end end. - Lemma Zcompare_spec_alt : + Lemma Zcompare_spec_alt : forall z z', Z.compare z z' = (Z.to_Z z ?= Z.to_Z z')%Z. Proof. intros; generalize (Z.spec_compare z z'); destruct Z.compare; auto. intro H; rewrite H; symmetry; apply Zcompare_refl. Qed. - - Lemma Ncompare_spec_alt : + + Lemma Ncompare_spec_alt : forall n n', N.compare n n' = (N.to_Z n ?= N.to_Z n')%Z. Proof. intros; generalize (N.spec_compare n n'); destruct N.compare; auto. intro H; rewrite H; symmetry; apply Zcompare_refl. Qed. - Lemma N_to_Z2P : forall n, N.to_Z n <> 0%Z -> + Lemma N_to_Z2P : forall n, N.to_Z n <> 0%Z -> Zpos (Z2P (N.to_Z n)) = N.to_Z n. Proof. intros; apply Z2P_correct. generalize (N.spec_pos n); romega. Qed. - Hint Rewrite - Zplus_0_r Zplus_0_l Zmult_0_r Zmult_0_l Zmult_1_r Zmult_1_l + Hint Rewrite + Zplus_0_r Zplus_0_l Zmult_0_r Zmult_0_l Zmult_1_r Zmult_1_l Z.spec_0 N.spec_0 Z.spec_1 N.spec_1 Z.spec_m1 Z.spec_opp Zcompare_spec_alt Ncompare_spec_alt - Z.spec_add N.spec_add Z.spec_mul N.spec_mul + Z.spec_add N.spec_add Z.spec_mul N.spec_mul Z.spec_gcd N.spec_gcd Zgcd_Zabs Zgcd_1 spec_Z_of_N spec_Zabs_N : nz. Ltac nzsimpl := autorewrite with nz in *. Ltac destr_neq_bool := repeat - (match goal with |- context [N.eq_bool ?x ?y] => + (match goal with |- context [N.eq_bool ?x ?y] => generalize (N.spec_eq_bool x y); case N.eq_bool end). - + Ltac destr_zeq_bool := repeat - (match goal with |- context [Z.eq_bool ?x ?y] => + (match goal with |- context [Z.eq_bool ?x ?y] => generalize (Z.spec_eq_bool x y); case Z.eq_bool end). Ltac simpl_ndiv := rewrite N.spec_div by (nzsimpl; romega). - Tactic Notation "simpl_ndiv" "in" "*" := + Tactic Notation "simpl_ndiv" "in" "*" := rewrite N.spec_div in * by (nzsimpl; romega). Ltac simpl_zdiv := rewrite Z.spec_div by (nzsimpl; romega). - Tactic Notation "simpl_zdiv" "in" "*" := + Tactic Notation "simpl_zdiv" "in" "*" := rewrite Z.spec_div in * by (nzsimpl; romega). - Ltac qsimpl := try red; unfold to_Q; simpl; intros; + Ltac qsimpl := try red; unfold to_Q; simpl; intros; destr_neq_bool; destr_zeq_bool; simpl; nzsimpl; auto; intros. Theorem spec_compare: forall q1 q2, (compare q1 q2) = ([q1] ?= [q2]). Proof. - intros [z1 | x1 y1] [z2 | x2 y2]; + intros [z1 | x1 y1] [z2 | x2 y2]; unfold Qcompare, compare; qsimpl; rewrite ! N_to_Z2P; auto. Qed. @@ -177,7 +177,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Definition min n m := match compare n m with Gt => m | _ => n end. Definition max n m := match compare n m with Lt => m | _ => n end. - Definition eq_bool n m := + Definition eq_bool n m := match compare n m with Eq => true | _ => false end. Theorem spec_eq_bool: forall x y, @@ -196,9 +196,9 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. (** Normalisation function *) Definition norm n d : t := - let gcd := N.gcd (Zabs_N n) d in + let gcd := N.gcd (Zabs_N n) d in match N.compare N.one gcd with - | Lt => + | Lt => let n := Z.div n (Z_of_N gcd) in let d := N.div d gcd in match N.compare d N.one with @@ -249,7 +249,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem strong_spec_norm : forall p q, [norm p q] = Qred [Qq p q]. Proof. intros. - replace (Qred [Qq p q]) with (Qred [norm p q]) by + replace (Qred [Qq p q]) with (Qred [norm p q]) by (apply Qred_complete; apply spec_norm). symmetry; apply Qred_identity. unfold norm. @@ -282,10 +282,10 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. simpl; auto with zarith. Qed. - (** Reduction function : producing irreducible fractions *) + (** Reduction function : producing irreducible fractions *) - Definition red (x : t) : t := - match x with + Definition red (x : t) : t := + match x with | Qz z => x | Qq n d => norm n d end. @@ -307,18 +307,18 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. symmetry; apply Qred_identity; simpl; auto with zarith. unfold red; apply strong_spec_norm. Qed. - + Definition add (x y: t): t := match x with | Qz zx => match y with | Qz zy => Qz (Z.add zx zy) - | Qq ny dy => - if N.eq_bool dy N.zero then x + | Qq ny dy => + if N.eq_bool dy N.zero then x else Qq (Z.add (Z.mul zx (Z_of_N dy)) ny) dy end | Qq nx dx => - if N.eq_bool dx N.zero then y + if N.eq_bool dx N.zero then y else match y with | Qz zy => Qq (Z.add nx (Z.mul zy (Z_of_N dx))) dx | Qq ny dy => @@ -352,12 +352,12 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. | Qz zx => match y with | Qz zy => Qz (Z.add zx zy) - | Qq ny dy => - if N.eq_bool dy N.zero then x + | Qq ny dy => + if N.eq_bool dy N.zero then x else norm (Z.add (Z.mul zx (Z_of_N dy)) ny) dy end | Qq nx dx => - if N.eq_bool dx N.zero then y + if N.eq_bool dx N.zero then y else match y with | Qz zy => norm (Z.add nx (Z.mul zy (Z_of_N dx))) dx | Qq ny dy => @@ -372,16 +372,16 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem spec_add_norm : forall x y, [add_norm x y] == [x] + [y]. Proof. intros x y; rewrite <- spec_add. - destruct x; destruct y; unfold add_norm, add; + destruct x; destruct y; unfold add_norm, add; destr_neq_bool; auto using Qeq_refl, spec_norm. Qed. - Theorem strong_spec_add_norm : forall x y : t, + Theorem strong_spec_add_norm : forall x y : t, Reduced x -> Reduced y -> Reduced (add_norm x y). Proof. unfold Reduced; intros. rewrite strong_spec_red. - rewrite <- (Qred_complete [add x y]); + rewrite <- (Qred_complete [add x y]); [ | rewrite spec_add, spec_add_norm; apply Qeq_refl ]. rewrite <- strong_spec_red. destruct x as [zx|nx dx]; destruct y as [zy|ny dy]. @@ -404,7 +404,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Proof. intros [z | x y]; simpl. rewrite Z.spec_opp; auto. - match goal with |- context[N.eq_bool ?X ?Y] => + match goal with |- context[N.eq_bool ?X ?Y] => generalize (N.spec_eq_bool X Y); case N.eq_bool end; auto; rewrite N.spec_0. rewrite Z.spec_opp; auto. @@ -438,7 +438,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite spec_opp; ring. Qed. - Theorem strong_spec_sub_norm : forall x y, + Theorem strong_spec_sub_norm : forall x y, Reduced x -> Reduced y -> Reduced (sub_norm x y). Proof. intros. @@ -470,7 +470,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. generalize (N.spec_pos dy); omega. Qed. - Lemma norm_denum : forall n d, + Lemma norm_denum : forall n d, [if N.eq_bool d N.one then Qz n else Qq n d] == [Qq n d]. Proof. intros; simpl; qsimpl. @@ -478,15 +478,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite N_to_Z2P, H0; auto with zarith. Qed. - Definition irred n d := + Definition irred n d := let gcd := N.gcd (Zabs_N n) d in - match N.compare gcd N.one with + match N.compare gcd N.one with | Gt => (Z.div n (Z_of_N gcd), N.div d gcd) | _ => (n, d) end. - Lemma spec_irred : forall n d, exists g, - let (n',d') := irred n d in + Lemma spec_irred : forall n d, exists g, + let (n',d') := irred n d in (Z.to_Z n' * g = Z.to_Z n)%Z /\ (N.to_Z d' * g = N.to_Z d)%Z. Proof. intros. @@ -511,7 +511,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite Zmult_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith. Qed. - Lemma spec_irred_zero : forall n d, + Lemma spec_irred_zero : forall n d, (N.to_Z d = 0)%Z <-> (N.to_Z (snd (irred n d)) = 0)%Z. Proof. intros. @@ -535,8 +535,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. compute in H1; elim H1; auto. Qed. - Lemma strong_spec_irred : forall n d, - (N.to_Z d <> 0%Z) -> + Lemma strong_spec_irred : forall n d, + (N.to_Z d <> 0%Z) -> let (n',d') := irred n d in Zgcd (Z.to_Z n') (N.to_Z d') = 1%Z. Proof. unfold irred; intros. @@ -554,31 +554,31 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Zgcd_is_gcd; auto. Qed. - Definition mul_norm_Qz_Qq z n d := - if Z.eq_bool z Z.zero then zero + Definition mul_norm_Qz_Qq z n d := + if Z.eq_bool z Z.zero then zero else let gcd := N.gcd (Zabs_N z) d in match N.compare gcd N.one with - | Gt => + | Gt => let z := Z.div z (Z_of_N gcd) in let d := N.div d gcd in if N.eq_bool d N.one then Qz (Z.mul z n) else Qq (Z.mul z n) d | _ => Qq (Z.mul z n) d end. - Definition mul_norm (x y: t): t := + Definition mul_norm (x y: t): t := match x, y with | Qz zx, Qz zy => Qz (Z.mul zx zy) | Qz zx, Qq ny dy => mul_norm_Qz_Qq zx ny dy | Qq nx dx, Qz zy => mul_norm_Qz_Qq zy nx dx - | Qq nx dx, Qq ny dy => - let (nx, dy) := irred nx dy in - let (ny, dx) := irred ny dx in + | Qq nx dx, Qq ny dy => + let (nx, dy) := irred nx dy in + let (ny, dx) := irred ny dx in let d := N.mul dx dy in if N.eq_bool d N.one then Qz (Z.mul ny nx) else Qq (Z.mul ny nx) d end. - Lemma spec_mul_norm_Qz_Qq : forall z n d, + Lemma spec_mul_norm_Qz_Qq : forall z n d, [mul_norm_Qz_Qq z n d] == [Qq (Z.mul z n) d]. Proof. intros z n d; unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. @@ -599,14 +599,14 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite <- Zgcd_div_swap0; auto with zarith; ring. Qed. - Lemma strong_spec_mul_norm_Qz_Qq : forall z n d, + Lemma strong_spec_mul_norm_Qz_Qq : forall z n d, Reduced (Qq n d) -> Reduced (mul_norm_Qz_Qq z n d). Proof. unfold Reduced; intros z n d. rewrite 2 strong_spec_red, 2 Qred_iff. simpl; nzsimpl. destr_neq_bool; intros Hd H; simpl in *; nzsimpl. - + unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. destr_zeq_bool; intros Hz; simpl; nzsimpl; simpl; auto. destruct Z_le_gt_dec. @@ -670,7 +670,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. destruct (spec_irred ny dx) as (g' & Hg'). assert (Hz := spec_irred_zero nx dy). assert (Hz':= spec_irred_zero ny dx). - destruct irred as (n1,d1); destruct irred as (n2,d2). + destruct irred as (n1,d1); destruct irred as (n2,d2). simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. rewrite norm_denum. qsimpl. @@ -686,10 +686,10 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite 2 Z2P_correct. rewrite <- Hg1, <- Hg2, <- Hg1', <- Hg2'; ring. - assert (0 <= N.to_Z d2 * N.to_Z d1)%Z + assert (0 <= N.to_Z d2 * N.to_Z d1)%Z by (apply Zmult_le_0_compat; apply N.spec_pos). romega. - assert (0 <= N.to_Z dx * N.to_Z dy)%Z + assert (0 <= N.to_Z dx * N.to_Z dy)%Z by (apply Zmult_le_0_compat; apply N.spec_pos). romega. Qed. @@ -712,7 +712,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. assert (Hz':= spec_irred_zero ny dx). assert (Hgc := strong_spec_irred nx dy). assert (Hgc' := strong_spec_irred ny dx). - destruct irred as (n1,d1); destruct irred as (n2,d2). + destruct irred as (n1,d1); destruct irred as (n2,d2). simpl snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. destr_neq_bool; simpl; nzsimpl; intros; auto. destr_neq_bool; simpl; nzsimpl; intros; auto. @@ -729,7 +729,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Zgcd_mult_rel_prime; rewrite Zgcd_comm; apply Zgcd_mult_rel_prime; rewrite Zgcd_comm; auto. - + rewrite Zgcd_1_rel_prime in *. apply bezout_rel_prime. destruct (rel_prime_bezout _ _ H4) as [u v Huv]. @@ -747,15 +747,15 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. romega. Qed. - Definition inv (x: t): t := + Definition inv (x: t): t := match x with - | Qz z => - match Z.compare Z.zero z with + | Qz z => + match Z.compare Z.zero z with | Eq => zero | Lt => Qq Z.one (Zabs_N z) | Gt => Qq Z.minus_one (Zabs_N z) end - | Qq n d => + | Qq n d => match Z.compare Z.zero n with | Eq => zero | Lt => Qq (Z_of_N d) (Zabs_N n) @@ -827,25 +827,25 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite T, Zpos_mult_morphism, N_to_Z2P; auto; ring. Qed. - Definition inv_norm (x: t): t := + Definition inv_norm (x: t): t := match x with - | Qz z => - match Z.compare Z.zero z with + | Qz z => + match Z.compare Z.zero z with | Eq => zero | Lt => Qq Z.one (Zabs_N z) | Gt => Qq Z.minus_one (Zabs_N z) end - | Qq n d => - if N.eq_bool d N.zero then zero else - match Z.compare Z.zero n with + | Qq n d => + if N.eq_bool d N.zero then zero else + match Z.compare Z.zero n with | Eq => zero - | Lt => - match Z.compare n Z.one with + | Lt => + match Z.compare n Z.one with | Gt => Qq (Z_of_N d) (Zabs_N n) | _ => Qz (Z_of_N d) end - | Gt => - match Z.compare n Z.minus_one with + | Gt => + match Z.compare n Z.minus_one with | Lt => Qq (Z.opp (Z_of_N d)) (Zabs_N n) | _ => Qz (Z.opp (Z_of_N d)) end @@ -882,7 +882,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Theorem strong_spec_inv_norm : forall x, Reduced x -> Reduced (inv_norm x). Proof. - unfold Reduced. + unfold Reduced. intros. destruct x as [ z | n d ]. (* Qz *) @@ -952,8 +952,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Qeq_refl. apply spec_inv_norm; auto. Qed. - - Theorem strong_spec_div_norm : forall x y, + + Theorem strong_spec_div_norm : forall x y, Reduced x -> Reduced y -> Reduced (div_norm x y). Proof. intros; unfold div_norm. @@ -980,7 +980,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite H in H0; simpl in H0; elim H0; auto. assert (0 < N.to_Z d)%Z by (generalize (N.spec_pos d); romega). clear H H0. - rewrite Z.spec_square, N.spec_square. + rewrite Z.spec_square, N.spec_square. red; simpl. rewrite Zpos_mult_morphism; rewrite !Z2P_correct; auto. apply Zmult_lt_0_compat; auto. @@ -991,7 +991,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. | Qz zx => Qz (Z.power_pos zx p) | Qq nx dx => Qq (Z.power_pos nx p) (N.power_pos dx p) end. - + Theorem spec_power_pos : forall x p, [power_pos x p] == [x] ^ Zpos p. Proof. intros [ z | n d ] p; unfold power_pos. @@ -1019,7 +1019,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite N.spec_power_pos. auto. Qed. - Theorem strong_spec_power_pos : forall x p, + Theorem strong_spec_power_pos : forall x p, Reduced x -> Reduced (power_pos x p). Proof. destruct x as [z | n d]; simpl; intros. @@ -1040,8 +1040,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply rel_prime_Zpower; auto with zarith. Qed. - Definition power (x : t) (z : Z) : t := - match z with + Definition power (x : t) (z : Z) : t := + match z with | Z0 => one | Zpos p => power_pos x p | Zneg p => inv (power_pos x p) @@ -1056,8 +1056,8 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite spec_inv, spec_power_pos; apply Qeq_refl. Qed. - Definition power_norm (x : t) (z : Z) : t := - match z with + Definition power_norm (x : t) (z : Z) : t := + match z with | Z0 => one | Zpos p => power_pos x p | Zneg p => inv_norm (power_pos x p) @@ -1072,7 +1072,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite spec_inv_norm, spec_power_pos; apply Qeq_refl. Qed. - Theorem strong_spec_power_norm : forall x z, + Theorem strong_spec_power_norm : forall x z, Reduced x -> Reduced (power_norm x z). Proof. destruct z; simpl. @@ -1085,7 +1085,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. (** Interaction with [Qcanon.Qc] *) - + Open Scope Qc_scope. Definition of_Qc q := of_Q (this q). @@ -1166,7 +1166,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Qplus_comp; apply Qeq_sym; apply Qred_correct. Qed. - Theorem spec_add_normc_bis : forall x y : Qc, + Theorem spec_add_normc_bis : forall x y : Qc, [add_norm (of_Qc x) (of_Qc y)] = x+y. Proof. intros. @@ -1189,7 +1189,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. rewrite spec_oppc; ring. Qed. - Theorem spec_sub_normc_bis : forall x y : Qc, + Theorem spec_sub_normc_bis : forall x y : Qc, [sub_norm (of_Qc x) (of_Qc y)] = x-y. Proof. intros. @@ -1228,7 +1228,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Qmult_comp; apply Qeq_sym; apply Qred_correct. Qed. - Theorem spec_mul_normc_bis : forall x y : Qc, + Theorem spec_mul_normc_bis : forall x y : Qc, [mul_norm (of_Qc x) (of_Qc y)] = x*y. Proof. intros. @@ -1266,7 +1266,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply Qinv_comp; apply Qeq_sym; apply Qred_correct. Qed. - Theorem spec_inv_normc_bis : forall x : Qc, + Theorem spec_inv_normc_bis : forall x : Qc, [inv_norm (of_Qc x)] = /x. Proof. intros. @@ -1280,7 +1280,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. Proof. intros x y; unfold div; rewrite spec_mulc; auto. unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. + apply spec_invc; auto. Qed. Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. @@ -1290,7 +1290,7 @@ Module Make (N:NType)(Z:ZType)(Import NZ:NType_ZType N Z) <: QType. apply spec_inv_normc; auto. Qed. - Theorem spec_div_normc_bis : forall x y : Qc, + Theorem spec_div_normc_bis : forall x y : Qc, [div_norm (of_Qc x) (of_Qc y)] = x/y. Proof. intros. diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v index 7c88d25aae..8be66493e5 100644 --- a/theories/Numbers/Rational/SpecViaQ/QSig.v +++ b/theories/Numbers/Rational/SpecViaQ/QSig.v @@ -48,12 +48,12 @@ Module Type QType. Definition max n m := match compare n m with Lt => m | _ => n end. Parameter eq_bool : t -> t -> bool. - - Parameter spec_eq_bool : forall x y, + + Parameter spec_eq_bool : forall x y, if eq_bool x y then [x]==[y] else ~([x]==[y]). Parameter red : t -> t. - + Parameter spec_red : forall x, [red x] == [x]. Parameter strong_spec_red : forall x, [red x] = Qred [x]. diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index 9335f48348..c547568816 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -8,7 +8,7 @@ (* $Id$ *) (** Standard functions and combinators. - + Proofs about them require functional extensionality and can be found in [Combinators]. Author: Matthieu Sozeau @@ -21,12 +21,12 @@ Implicit Arguments id [[A]]. (** Function composition. *) -Definition compose {A B C} (g : B -> C) (f : A -> B) := +Definition compose {A B C} (g : B -> C) (f : A -> B) := fun x : A => g (f x). Hint Unfold compose. -Notation " g ∘ f " := (compose g f) +Notation " g ∘ f " := (compose g f) (at level 40, left associativity) : program_scope. Open Local Scope program_scope. diff --git a/theories/Program/Combinators.v b/theories/Program/Combinators.v index 33ad3b556c..e12f57668c 100644 --- a/theories/Program/Combinators.v +++ b/theories/Program/Combinators.v @@ -34,7 +34,7 @@ Proof. symmetry ; apply eta_expansion. Qed. -Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D), +Lemma compose_assoc : forall A B C D (f : A -> B) (g : B -> C) (h : C -> D), h ∘ g ∘ f = h ∘ (g ∘ f). Proof. intros. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index f35dc7adc9..381a0bae4c 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -26,7 +26,7 @@ Notation "'refl'" := (@refl_equal _ _). (** Do something on an heterogeneous equality appearing in the context. *) -Ltac on_JMeq tac := +Ltac on_JMeq tac := match goal with | [ H : @JMeq ?x ?X ?y ?Y |- _ ] => tac H end. @@ -44,17 +44,17 @@ Ltac simpl_JMeq := repeat simpl_one_JMeq. Ltac simpl_one_dep_JMeq := on_JMeq - ltac:(fun H => let H' := fresh "H" in + ltac:(fun H => let H' := fresh "H" in assert (H' := JMeq_eq H)). Require Import Eqdep. -(** Simplify dependent equality using sigmas to equality of the second projections if possible. +(** Simplify dependent equality using sigmas to equality of the second projections if possible. Uses UIP. *) Ltac simpl_existT := match goal with - [ H : existT _ ?x _ = existT _ ?x _ |- _ ] => + [ H : existT _ ?x _ = existT _ ?x _ |- _ ] => let Hi := fresh H in assert(Hi:=inj_pairT2 _ _ _ _ _ H) ; clear H end. @@ -64,15 +64,15 @@ Ltac simpl_existTs := repeat simpl_existT. Ltac elim_eq_rect := match goal with - | [ |- ?t ] => + | [ |- ?t ] => match t with - | context [ @eq_rect _ _ _ _ _ ?p ] => - let P := fresh "P" in - set (P := p); simpl in P ; + | context [ @eq_rect _ _ _ _ _ ?p ] => + let P := fresh "P" in + set (P := p); simpl in P ; ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) - | context [ @eq_rect _ _ _ _ _ ?p _ ] => - let P := fresh "P" in - set (P := p); simpl in P ; + | context [ @eq_rect _ _ _ _ _ ?p _ ] => + let P := fresh "P" in + set (P := p); simpl in P ; ((case P ; clear P) || (clearbody P; rewrite (UIP_refl _ _ P); clear P)) end end. @@ -90,18 +90,18 @@ Ltac simpl_eq := simpl ; unfold eq_rec_r, eq_rec ; repeat (elim_eq_rect ; simpl) (** Try to abstract a proof of equality, if no proof of the same equality is present in the context. *) -Ltac abstract_eq_hyp H' p := +Ltac abstract_eq_hyp H' p := let ty := type of p in let tyred := eval simpl in ty in - match tyred with - ?X = ?Y => - match goal with + match tyred with + ?X = ?Y => + match goal with | [ H : X = Y |- _ ] => fail 1 | _ => set (H':=p) ; try (change p with H') ; clearbody H' ; simpl in H' end end. -(** Apply the tactic tac to proofs of equality appearing as coercion arguments. +(** Apply the tactic tac to proofs of equality appearing as coercion arguments. Just redefine this tactic (using [Ltac on_coerce_proof tac ::=]) to handle custom coercion operators. *) @@ -109,7 +109,7 @@ Ltac on_coerce_proof tac T := match T with | context [ eq_rect _ _ _ _ ?p ] => tac p end. - + Ltac on_coerce_proof_gl tac := match goal with [ |- ?T ] => on_coerce_proof tac T @@ -120,17 +120,17 @@ Ltac on_coerce_proof_gl tac := Ltac abstract_eq_proof := on_coerce_proof_gl ltac:(fun p => let H := fresh "eqH" in abstract_eq_hyp H p). Ltac abstract_eq_proofs := repeat abstract_eq_proof. - -(** Factorize proofs, by using proof irrelevance so that two proofs of the same equality + +(** Factorize proofs, by using proof irrelevance so that two proofs of the same equality in the goal become convertible. *) Ltac pi_eq_proof_hyp p := let ty := type of p in let tyred := eval simpl in ty in match tyred with - ?X = ?Y => - match goal with - | [ H : X = Y |- _ ] => + ?X = ?Y => + match goal with + | [ H : X = Y |- _ ] => match p with | H => fail 2 | _ => rewrite (proof_irrelevance (X = Y) p H) @@ -162,28 +162,28 @@ Ltac rewrite_refl_id := autorewrite with refl_id. Ltac clear_eq_ctx := rewrite_refl_id ; clear_eq_proofs. -(** Reapeated elimination of [eq_rect] applications. +(** Reapeated elimination of [eq_rect] applications. Abstracting equalities makes it run much faster than an naive implementation. *) -Ltac simpl_eqs := +Ltac simpl_eqs := repeat (elim_eq_rect ; simpl ; clear_eq_ctx). (** Clear unused reflexivity proofs. *) -Ltac clear_refl_eq := +Ltac clear_refl_eq := match goal with [ H : ?X = ?X |- _ ] => clear H end. Ltac clear_refl_eqs := repeat clear_refl_eq. (** Clear unused equality proofs. *) -Ltac clear_eq := +Ltac clear_eq := match goal with [ H : _ = _ |- _ ] => clear H end. Ltac clear_eqs := repeat clear_eq. (** Combine all the tactics to simplify goals containing coercions. *) -Ltac simplify_eqs := - simpl ; simpl_eqs ; clear_eq_ctx ; clear_refl_eqs ; +Ltac simplify_eqs := + simpl ; simpl_eqs ; clear_eq_ctx ; clear_refl_eqs ; try subst ; simpl ; repeat simpl_uip ; rewrite_refl_id. (** A tactic that tries to remove trivial equality guards in induction hypotheses coming @@ -219,7 +219,7 @@ Ltac simpl_IH_eq H := Ltac simpl_IH_eqs H := repeat simpl_IH_eq H. -Ltac do_simpl_IHs_eqs := +Ltac do_simpl_IHs_eqs := match goal with | [ H : context [ @JMeq _ _ _ _ -> _ ] |- _ ] => progress (simpl_IH_eqs H) | [ H : context [ _ = _ -> _ ] |- _ ] => progress (simpl_IH_eqs H) @@ -227,17 +227,17 @@ Ltac do_simpl_IHs_eqs := Ltac simpl_IHs_eqs := repeat do_simpl_IHs_eqs. -(** We split substitution tactics in the two directions depending on which +(** We split substitution tactics in the two directions depending on which names we want to keep corresponding to the generalization performed by the [generalize_eqs] tactic. *) Ltac subst_left_no_fail := - repeat (match goal with + repeat (match goal with [ H : ?X = ?Y |- _ ] => subst X end). Ltac subst_right_no_fail := - repeat (match goal with + repeat (match goal with [ H : ?X = ?Y |- _ ] => subst Y end). @@ -250,32 +250,32 @@ Ltac inject_right H := Ltac autoinjections_left := repeat autoinjection ltac:inject_left. Ltac autoinjections_right := repeat autoinjection ltac:inject_right. -Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ; +Ltac simpl_depind := subst_no_fail ; autoinjections ; try discriminates ; simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. -Ltac simpl_depind_l := subst_left_no_fail ; autoinjections_left ; try discriminates ; +Ltac simpl_depind_l := subst_left_no_fail ; autoinjections_left ; try discriminates ; simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. -Ltac simpl_depind_r := subst_right_no_fail ; autoinjections_right ; try discriminates ; +Ltac simpl_depind_r := subst_right_no_fail ; autoinjections_right ; try discriminates ; simpl_JMeq ; simpl_existTs ; simpl_IHs_eqs. (** Support for the [Equations] command. - These tactics implement the necessary machinery to solve goals produced by the - [Equations] command relative to dependent pattern-matching. + These tactics implement the necessary machinery to solve goals produced by the + [Equations] command relative to dependent pattern-matching. It is completely inspired from the "Eliminating Dependent Pattern-Matching" paper by Goguen, McBride and McKinna. *) (** The NoConfusionPackage class provides a method for making progress on proving a property [P] implied by an equality on an inductive type [I]. The type of [noConfusion] for a given - [P] should be of the form [ Π Δ, (x y : I Δ) (x = y) -> NoConfusion P x y ], where + [P] should be of the form [ Π Δ, (x y : I Δ) (x = y) -> NoConfusion P x y ], where [NoConfusion P x y] for constructor-headed [x] and [y] will give a formula ending in [P]. This gives a general method for simplifying by discrimination or injectivity of constructors. - + Some actual instances are defined later in the file using the more primitive [discriminate] and [injection] tactics on which we can always fall back. *) - + Class NoConfusionPackage (I : Type) := { NoConfusion : Π P : Prop, Type ; noConfusion : Π P, NoConfusion P }. (** The [DependentEliminationPackage] provides the default dependent elimination principle to @@ -287,13 +287,13 @@ Class DependentEliminationPackage (A : Type) := (** A higher-order tactic to apply a registered eliminator. *) -Ltac elim_tac tac p := +Ltac elim_tac tac p := let ty := type of p in let eliminator := eval simpl in (elim (A:=ty)) in tac p eliminator. -(** Specialization to do case analysis or induction. - Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register +(** Specialization to do case analysis or induction. + Note: the [equations] tactic tries [case] before [elim_case]: there is no need to register generated induction principles. *) Ltac elim_case p := elim_tac ltac:(fun p el => destruct p using el) p. @@ -308,7 +308,7 @@ Class BelowPackage (A : Type) := { (** The [Recursor] class defines a recursor on a type, based on some definition of [Below]. *) -Class Recursor (A : Type) (BP : BelowPackage A) := +Class Recursor (A : Type) (BP : BelowPackage A) := { rec_type : A -> Type ; rec : Π (a : A), rec_type a }. (** Lemmas used by the simplifier, mainly rephrasings of [eq_rect], [eq_ind]. *) @@ -332,7 +332,7 @@ Proof. intros. apply X. apply inj_pair2. exact H. Defined. Lemma simplification_existT1 : Π A (P : A -> Type) B (p q : A) (x : P p) (y : P q), (p = q -> existT P p x = existT P q y -> B) -> (existT P p x = existT P q y -> B). Proof. intros. injection H. intros ; auto. Defined. - + Lemma simplification_K : Π A (x : A) (B : x = x -> Type), B (refl_equal x) -> (Π p : x = x, B p). Proof. intros. rewrite (UIP_refl A). assumption. Defined. @@ -342,26 +342,26 @@ Ltac unfold_equations := unfold solution_left, solution_right, deletion, simplification_heq, simplification_existT1, simplification_existT2, eq_rect_r, eq_rec, eq_ind. -(** The tactic [simplify_equations] is to be used when a program generated using [Equations] - is in the goal. It simplifies it as much as possible, possibly using [K] if needed. *) +(** The tactic [simplify_equations] is to be used when a program generated using [Equations] + is in the goal. It simplifies it as much as possible, possibly using [K] if needed. *) -Ltac simplify_equations := repeat (unfold_equations ; simplify_eqs). +Ltac simplify_equations := repeat (unfold_equations ; simplify_eqs). -(** We will use the [block_induction] definition to separate the goal from the +(** We will use the [block_induction] definition to separate the goal from the equalities generated by the tactic. *) Definition block_dep_elim {A : Type} (a : A) := a. -(** Using these we can make a simplifier that will perform the unification +(** Using these we can make a simplifier that will perform the unification steps needed to put the goal in normalised form (provided there are only constructor forms). Compare with the lemma 16 of the paper. - We don't have a [noCycle] procedure yet. *) + We don't have a [noCycle] procedure yet. *) Ltac simplify_one_dep_elim_term c := match c with | @JMeq _ _ _ _ -> _ => refine (simplification_heq _ _ _ _ _) | ?t = ?t -> _ => intros _ || refine (simplification_K _ t _ _) - | eq (existT _ _ _) (existT _ _ _) -> _ => + | eq (existT _ _ _) (existT _ _ _) -> _ => refine (simplification_existT2 _ _ _ _ _ _ _) || refine (simplification_existT1 _ _ _ _ _ _ _ _) | ?x = ?y -> _ => (* variables case *) @@ -413,12 +413,12 @@ Definition inaccessible_pattern {A : Type} (t : A) := t. Notation "?( t )" := (inaccessible_pattern t). (** To handle sections, we need to separate the context in two parts: - variables introduced by the section and the rest. We introduce a dummy variable + variables introduced by the section and the rest. We introduce a dummy variable between them to indicate that. *) CoInductive end_of_section := the_end_of_the_section. -Ltac set_eos := let eos := fresh "eos" in +Ltac set_eos := let eos := fresh "eos" in assert (eos:=the_end_of_the_section). (** We have a specialized [reverse_local] tactic to reverse the goal until the begining of the @@ -426,14 +426,14 @@ Ltac set_eos := let eos := fresh "eos" in Ltac reverse_local := match goal with - | [ H : ?T |- _ ] => + | [ H : ?T |- _ ] => match T with | end_of_section => idtac | _ => revert H ; reverse_local end | _ => idtac end. (** Do as much as possible to apply a method, trying to get the arguments right. - !!Unsafe!! We use [auto] for the [_nocomp] variant of [Equations], in which case some + !!Unsafe!! We use [auto] for the [_nocomp] variant of [Equations], in which case some non-dependent arguments of the method can remain after [apply]. *) Ltac simpl_intros m := ((apply m || refine m) ; auto) || (intro ; simpl_intros m). @@ -453,7 +453,7 @@ Ltac simplify_method tac := repeat (tac || simplify_one_dep_elim) ; reverse_loca (** Solving a method call: we can solve it by splitting on an empty family member or we must refine the goal until the body can be applied. *) - + Ltac solve_method rec := match goal with | [ H := ?body : nat |- _ ] => subst H ; clear ; abstract (simplify_method idtac ; solve_empty body) @@ -463,21 +463,21 @@ Ltac solve_method rec := (** Impossible cases, by splitting on a given target. *) Ltac solve_split := - match goal with + match goal with | [ |- let split := ?x : nat in _ ] => clear ; abstract (intros _ ; solve_empty x) end. (** If defining recursive functions, the prototypes come first. *) Ltac intro_prototypes := - match goal with + match goal with | [ |- Π x : _, _ ] => intro ; intro_prototypes | _ => idtac end. -Ltac introduce p := first [ - match p with _ => (* Already there, generalize dependent hyps *) - generalize dependent p ; intros p +Ltac introduce p := first [ + match p with _ => (* Already there, generalize dependent hyps *) + generalize dependent p ; intros p end | intros until p | intros ]. @@ -489,7 +489,7 @@ Ltac dep_elimify := match goal with [ |- ?T ] => change (block_dep_elim T) end. Ltac un_dep_elimify := unfold block_dep_elim in *. Ltac case_last := dep_elimify ; - on_last_hyp ltac:(fun p => + on_last_hyp ltac:(fun p => let ty := type of p in match ty with | ?x = ?x => revert p ; refine (simplification_K _ x _ _) @@ -497,28 +497,28 @@ Ltac case_last := dep_elimify ; | _ => simpl in p ; generalize_eqs p ; do_case p end). -Ltac nonrec_equations := +Ltac nonrec_equations := solve [solve_equations (case_last) (solve_method idtac)] || solve [ solve_split ] || fail "Unnexpected equations goal". Ltac recursive_equations := - solve [solve_equations (case_last) (solve_method ltac:intro)] || solve [ solve_split ] + solve [solve_equations (case_last) (solve_method ltac:intro)] || solve [ solve_split ] || fail "Unnexpected recursive equations goal". (** The [equations] tactic is the toplevel tactic for solving goals generated by [Equations]. *) Ltac equations := set_eos ; - match goal with + match goal with | [ |- Π x : _, _ ] => intro ; recursive_equations | _ => nonrec_equations end. (** The following tactics allow to do induction on an already instantiated inductive predicate - by first generalizing it and adding the proper equalities to the context, in a maner similar to + by first generalizing it and adding the proper equalities to the context, in a maner similar to the BasicElim tactic of "Elimination with a motive" by Conor McBride. *) -(** The [do_depind] higher-order tactic takes an induction tactic as argument and an hypothesis +(** The [do_depind] higher-order tactic takes an induction tactic as argument and an hypothesis and starts a dependent induction using this tactic. *) Ltac do_depind tac H := @@ -532,36 +532,36 @@ Ltac do_depind' tac H := (** Calls [destruct] on the generalized hypothesis, results should be similar to inversion. By default, we don't try to generalize the hyp by its variable indices. *) -Tactic Notation "dependent" "destruction" ident(H) := +Tactic Notation "dependent" "destruction" ident(H) := do_depind' ltac:(fun hyp => do_case hyp) H. -Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := +Tactic Notation "dependent" "destruction" ident(H) "using" constr(c) := do_depind' ltac:(fun hyp => destruct hyp using c) H. (** This tactic also generalizes the goal by the given variables before the induction. *) -Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) := +Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) := do_depind' ltac:(fun hyp => revert l ; do_case hyp) H. -Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := +Tactic Notation "dependent" "destruction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := do_depind' ltac:(fun hyp => revert l ; destruct hyp using c) H. -(** Then we have wrappers for usual calls to induction. One can customize the induction tactic by +(** Then we have wrappers for usual calls to induction. One can customize the induction tactic by writting another wrapper calling do_depind. We suppose the hyp has to be generalized before calling [induction]. *) -Tactic Notation "dependent" "induction" ident(H) := +Tactic Notation "dependent" "induction" ident(H) := do_depind ltac:(fun hyp => do_ind hyp) H. -Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := +Tactic Notation "dependent" "induction" ident(H) "using" constr(c) := do_depind ltac:(fun hyp => induction hyp using c) H. (** This tactic also generalizes the goal by the given variables before the induction. *) -Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) := +Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) := do_depind' ltac:(fun hyp => generalize l ; clear l ; do_ind hyp) H. -Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := +Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) := do_depind' ltac:(fun hyp => generalize l ; clear l ; induction hyp using c) H. Ltac simplify_IH_hyps := repeat diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index 14dc473584..a6aa4d5243 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -14,7 +14,7 @@ Require Import Coq.Program.Equality. Open Local Scope program_scope. -(** The following tactics implement a poor-man's solution for proof-irrelevance: it tries to +(** The following tactics implement a poor-man's solution for proof-irrelevance: it tries to factorize every proof of the same proposition in a goal so that equality of such proofs becomes trivial. *) Ltac on_subset_proof_aux tac T := @@ -27,25 +27,25 @@ Ltac on_subset_proof tac := [ |- ?T ] => on_subset_proof_aux tac T end. -Ltac abstract_any_hyp H' p := +Ltac abstract_any_hyp H' p := match type of p with - ?X => - match goal with + ?X => + match goal with | [ H : X |- _ ] => fail 1 | _ => set (H':=p) ; try (change p with H') ; clearbody H' end end. -Ltac abstract_subset_proof := +Ltac abstract_subset_proof := on_subset_proof ltac:(fun p => let H := fresh "eqH" in abstract_any_hyp H p ; simpl in H). Ltac abstract_subset_proofs := repeat abstract_subset_proof. Ltac pi_subset_proof_hyp p := match type of p with - ?X => - match goal with - | [ H : X |- _ ] => + ?X => + match goal with + | [ H : X |- _ ] => match p with | H => fail 2 | _ => rewrite (proof_irrelevance X p H) @@ -78,16 +78,16 @@ Proof. pi. Qed. -(* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f] +(* Somewhat trivial definition, but not unfolded automatically hence we can match on [match_eq ?A ?B ?x ?f] in tactics. *) Definition match_eq (A B : Type) (x : A) (fn : forall (y : A | y = x), B) : B := fn (exist _ x (refl_equal x)). -(* This is what we want to be able to do: replace the originaly matched object by a new, +(* This is what we want to be able to do: replace the originaly matched object by a new, propositionally equal one. If [fn] works on [x] it should work on any [y | y = x]. *) -Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : forall (y : A | y = x), B) +Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : forall (y : A | y = x), B) (y : A | y = x), match_eq A B x fn = fn y. Proof. @@ -103,9 +103,9 @@ Qed. (** Now we make a tactic to be able to rewrite a term [t] which is applied to a [match_eq] using an arbitrary equality [t = u], and [u] is now the subject of the [match]. *) -Ltac rewrite_match_eq H := +Ltac rewrite_match_eq H := match goal with - [ |- ?T ] => + [ |- ?T ] => match T with context [ match_eq ?A ?B ?t ?f ] => rewrite (match_eq_rewrite A B t f (exist _ _ (sym_eq H))) diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index 7e8fedceb7..8812979559 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -15,13 +15,13 @@ Ltac show_goal := match goal with [ |- ?T ] => idtac T end. -Ltac show_hyp id := - match goal with - | [ H := ?b : ?T |- _ ] => +Ltac show_hyp id := + match goal with + | [ H := ?b : ?T |- _ ] => match H with | id => idtac id ":=" b ":" T end - | [ H : ?T |- _ ] => + | [ H : ?T |- _ ] => match H with | id => idtac id ":" T end @@ -77,7 +77,7 @@ Ltac destruct_exists := repeat (destruct_one_ex). Ltac destruct_conjs := repeat (destruct_one_pair || destruct_one_ex). -(** Destruct an existential hypothesis [t] keeping its name for the first component +(** Destruct an existential hypothesis [t] keeping its name for the first component and using [Ht] for the second *) Tactic Notation "destruct" "exist" ident(t) ident(Ht) := destruct t as [t Ht]. @@ -96,7 +96,7 @@ Ltac discriminates := (** Revert the last hypothesis. *) -Ltac revert_last := +Ltac revert_last := match goal with [ H : _ |- _ ] => revert H end. @@ -108,8 +108,8 @@ Ltac reverse := repeat revert_last. (** Clear duplicated hypotheses *) Ltac clear_dup := - match goal with - | [ H : ?X |- _ ] => + match goal with + | [ H : ?X |- _ ] => match goal with | [ H' : ?Y |- _ ] => match H with @@ -124,7 +124,7 @@ Ltac clear_dups := repeat clear_dup. (** A non-failing subst that substitutes as much as possible. *) Ltac subst_no_fail := - repeat (match goal with + repeat (match goal with [ H : ?X = ?Y |- _ ] => subst X || subst Y end). @@ -139,13 +139,13 @@ Ltac on_application f tac T := | context [f ?x ?y ?z ?w ?v] => tac (f x y z w v) | context [f ?x ?y ?z ?w] => tac (f x y z w) | context [f ?x ?y ?z] => tac (f x y z) - | context [f ?x ?y] => tac (f x y) + | context [f ?x ?y] => tac (f x y) | context [f ?x] => tac (f x) end. (** A variant of [apply] using [refine], doing as much conversion as necessary. *) -Ltac rapply p := +Ltac rapply p := refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _ _ _ _ _ _ _) || refine (p _ _ _ _ _ _ _ _ _ _ _ _ _) || @@ -162,7 +162,7 @@ Ltac rapply p := refine (p _ _) || refine (p _) || refine p. - + (** Tactical [on_call f tac] applies [tac] on any application of [f] in the hypothesis or goal. *) Ltac on_call f tac := @@ -195,15 +195,15 @@ Tactic Notation "destruct_call" constr(f) := destruct_call f. (** Permit to name the results of destructing the call to [f]. *) -Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := +Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) := destruct_call_as f l. (** Specify the hypothesis in which the call occurs as well. *) -Tactic Notation "destruct_call" constr(f) "in" hyp(id) := +Tactic Notation "destruct_call" constr(f) "in" hyp(id) := destruct_call_in f id. -Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(id) := +Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(id) := destruct_call_as_in f l id. (** A marker for prototypes to destruct. *) @@ -215,7 +215,7 @@ Ltac destruct_rec_calls := | [ H : fix_proto _ |- _ ] => destruct_calls H ; clear H end. -Ltac destruct_all_rec_calls := +Ltac destruct_all_rec_calls := repeat destruct_rec_calls ; unfold fix_proto in *. (** Try to inject any potential constructor equality hypothesis. *) @@ -237,23 +237,23 @@ Ltac destruct_nondep H := let H0 := fresh "H" in assert(H0 := H); destruct H0. Ltac bang := match goal with - | |- ?x => + | |- ?x => match x with | context [False_rect _ ?p] => elim p end end. - + (** A tactic to show contradiction by first asserting an automatically provable hypothesis. *) -Tactic Notation "contradiction" "by" constr(t) := +Tactic Notation "contradiction" "by" constr(t) := let H := fresh in assert t as H by auto with * ; contradiction. (** A tactic that adds [H:=p:typeof(p)] to the context if no hypothesis of the same type appears in the goal. Useful to do saturation using tactics. *) -Ltac add_hypothesis H' p := +Ltac add_hypothesis H' p := match type of p with - ?X => - match goal with + ?X => + match goal with | [ H : X |- _ ] => fail 1 | _ => set (H':=p) ; try (change p with H') ; clearbody H' end @@ -281,11 +281,11 @@ Ltac refine_hyp c := end. (** The default simplification tactic used by Program is defined by [program_simpl], sometimes [auto] - is not enough, better rebind using [Obligation Tactic := tac] in this case, + is not enough, better rebind using [Obligation Tactic := tac] in this case, possibly using [program_simplify] to use standard goal-cleaning tactics. *) Ltac program_simplify := - simpl in |- *; intros ; destruct_all_rec_calls ; repeat (destruct_conjs; simpl proj1_sig in *); + simpl in |- *; intros ; destruct_all_rec_calls ; repeat (destruct_conjs; simpl proj1_sig in *); subst*; autoinjections ; try discriminates ; try (solve [ red ; intros ; destruct_conjs ; autoinjections ; discriminates ]). diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index 041b318e85..9b7ea04748 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -22,20 +22,20 @@ Section Well_founded. Variable A : Type. Variable R : A -> A -> Prop. Hypothesis Rwf : well_founded R. - + Variable P : A -> Type. - + Variable F_sub : forall x:A, (forall y: { y : A | R y x }, P (proj1_sig y)) -> P x. - + Fixpoint Fix_F_sub (x : A) (r : Acc R x) {struct r} : P x := - F_sub x (fun y: { y : A | R y x} => Fix_F_sub (proj1_sig y) + F_sub x (fun y: { y : A | R y x} => Fix_F_sub (proj1_sig y) (Acc_inv r (proj2_sig y))). - + Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x). - - (* Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) *) + + (* Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) *) (* Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). *) - + Hypothesis F_ext : forall (x:A) (f g:forall y:{y:A | R y x}, P (`y)), @@ -44,10 +44,10 @@ Section Well_founded. Lemma Fix_F_eq : forall (x:A) (r:Acc R x), F_sub x (fun (y:A|R y x) => Fix_F_sub (`y) (Acc_inv r (proj2_sig y))) = Fix_F_sub x r. - Proof. + Proof. destruct r using Acc_inv_dep; auto. Qed. - + Lemma Fix_F_inv : forall (x:A) (r s:Acc R x), Fix_F_sub x r = Fix_F_sub x s. Proof. intro x; induction (Rwf x); intros. @@ -115,7 +115,7 @@ Section Fix_rects. Variable R : A -> A -> Prop. Variable Rwf : well_founded R. Variable f: forall (x : A), (forall y: { y: A | R y x }, P (proj1_sig y)) -> P x. - + Lemma F_unfold x r: Fix_F_sub A R P f x r = f (fun y => Fix_F_sub A R P f (proj1_sig y) (Acc_inv r (proj2_sig y))). @@ -200,8 +200,8 @@ Section Fix_rects. intros. assert (forall y: A, R y x0 -> Q y (Fix_F_sub A R P f y (Rwf y)))... set (inv x0 X0 a). clearbody q. - rewrite <- (equiv_lowers (fun y: {y: A | R y x0} => - Fix_F_sub A R P f (proj1_sig y) (Rwf (proj1_sig y))) + rewrite <- (equiv_lowers (fun y: {y: A | R y x0} => + Fix_F_sub A R P f (proj1_sig y) (Rwf (proj1_sig y))) (fun y: {y: A | R y x0} => Fix_F_sub A R P f (proj1_sig y) (Acc_inv a (proj2_sig y))))... intros. apply eq_Fix_F_sub. @@ -213,9 +213,9 @@ End Fix_rects. Ltac fold_sub f := match goal with - | [ |- ?T ] => + | [ |- ?T ] => match T with - appcontext C [ @Fix_sub _ _ _ _ ?arg ] => + appcontext C [ @Fix_sub _ _ _ _ ?arg ] => let app := context C [ f arg ] in change app end @@ -230,7 +230,7 @@ Module WfExtensionality. (** The two following lemmas allow to unfold a well-founded fixpoint definition without restriction using the functional extensionality axiom. *) - + (** For a function defined with Program using a well-founded order. *) Program Lemma fix_sub_eq_ext : @@ -247,11 +247,11 @@ Module WfExtensionality. extensionality y ; apply H. rewrite H0 ; auto. Qed. - + (** Tactic to unfold once a definition based on [Fix_sub]. *) - - Ltac unfold_sub f fargs := - set (call:=fargs) ; unfold f in call ; unfold call ; clear call ; + + Ltac unfold_sub f fargs := + set (call:=fargs) ; unfold f in call ; unfold call ; clear call ; rewrite fix_sub_eq_ext ; repeat fold_sub fargs ; simpl proj1_sig. End WfExtensionality. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 16733c3b8c..dff556b98f 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -120,12 +120,12 @@ Defined. Definition Qeq_bool x y := (Zeq_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z. -Definition Qle_bool x y := +Definition Qle_bool x y := (Zle_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z. Lemma Qeq_bool_iff : forall x y, Qeq_bool x y = true <-> x == y. Proof. - unfold Qeq_bool, Qeq; intros. + unfold Qeq_bool, Qeq; intros. symmetry; apply Zeq_is_eq_bool. Qed. diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index c34423b4d8..266d81e013 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -13,7 +13,7 @@ Require Import QArith. Require Import Znumtheory. Require Import Eqdep_dec. -(** [Qc] : A canonical representation of rational numbers. +(** [Qc] : A canonical representation of rational numbers. based on the setoid representation [Q]. *) Record Qc : Set := Qcmake { this :> Q ; canon : Qred this = this }. @@ -23,7 +23,7 @@ Bind Scope Qc_scope with Qc. Arguments Scope Qcmake [Q_scope]. Open Scope Qc_scope. -Lemma Qred_identity : +Lemma Qred_identity : forall q:Q, Zgcd (Qnum q) (QDen q) = 1%Z -> Qred q = q. Proof. unfold Qred; intros (a,b); simpl. @@ -36,7 +36,7 @@ Proof. subst; simpl; auto. Qed. -Lemma Qred_identity2 : +Lemma Qred_identity2 : forall q:Q, Qred q = q -> Zgcd (Qnum q) (QDen q) = 1%Z. Proof. unfold Qred; intros (a,b); simpl. @@ -50,7 +50,7 @@ Proof. destruct g as [|g|g]; destruct bb as [|bb|bb]; simpl in *; try discriminate. f_equal. apply Pmult_reg_r with bb. - injection H2; intros. + injection H2; intros. rewrite <- H0. rewrite H; simpl; auto. elim H1; auto. @@ -70,7 +70,7 @@ Proof. apply Qred_correct. Qed. -Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). +Definition Q2Qc (q:Q) : Qc := Qcmake (Qred q) (Qred_involutive q). Arguments Scope Q2Qc [Q_scope]. Notation " !! " := Q2Qc : Qc_scope. @@ -82,7 +82,7 @@ Proof. assert (H0:=Qred_complete _ _ H). assert (q = q') by congruence. subst q'. - assert (proof_q = proof_q'). + assert (proof_q = proof_q'). apply eq_proofs_unicity; auto; intros. repeat decide equality. congruence. @@ -98,8 +98,8 @@ Notation Qcgt := (fun x y : Qc => Qlt y x). Notation Qcge := (fun x y : Qc => Qle y x). Infix "<" := Qclt : Qc_scope. Infix "<=" := Qcle : Qc_scope. -Infix ">" := Qcgt : Qc_scope. -Infix ">=" := Qcge : Qc_scope. +Infix ">" := Qcgt : Qc_scope. +Infix ">=" := Qcge : Qc_scope. Notation "x <= y <= z" := (x<=y/\y<=z) : Qc_scope. Notation "x < y < z" := (x destruct q; qc +Ltac qc := match goal with + | q:Qc |- _ => destruct q; qc | _ => apply Qc_is_canon; simpl; repeat rewrite Qred_correct end. @@ -191,7 +191,7 @@ Qed. Lemma Qcplus_0_r : forall x, x+0 = x. Proof. intros; qc; apply Qplus_0_r. -Qed. +Qed. (** Commutativity of addition: *) @@ -265,13 +265,13 @@ Qed. Theorem Qcmult_integral_l : forall x y, ~ x = 0 -> x*y = 0 -> y = 0. Proof. intros; destruct (Qcmult_integral _ _ H0); tauto. -Qed. +Qed. -(** Inverse and division. *) +(** Inverse and division. *) Theorem Qcmult_inv_r : forall x, x<>0 -> x*(/x) = 1. Proof. - intros; qc; apply Qmult_inv_r; auto. + intros; qc; apply Qmult_inv_r; auto. Qed. Theorem Qcmult_inv_l : forall x, x<>0 -> (/x)*x = 1. @@ -436,24 +436,24 @@ Qed. Lemma Qcmult_lt_0_le_reg_r : forall x y z, 0 < z -> x*z <= y*z -> x <= y. Proof. unfold Qcmult, Qcle, Qclt; intros; simpl in *. - repeat progress rewrite Qred_correct in * |-. + repeat progress rewrite Qred_correct in * |-. eapply Qmult_lt_0_le_reg_r; eauto. Qed. Lemma Qcmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z. Proof. unfold Qcmult, Qclt; intros; simpl in *. - repeat progress rewrite Qred_correct in *. + repeat progress rewrite Qred_correct in *. eapply Qmult_lt_compat_r; eauto. Qed. (** Rational to the n-th power *) -Fixpoint Qcpower (q:Qc)(n:nat) { struct n } : Qc := - match n with +Fixpoint Qcpower (q:Qc)(n:nat) { struct n } : Qc := + match n with | O => 1 | S n => q * (Qcpower q n) - end. + end. Notation " q ^ n " := (Qcpower q n) : Qc_scope. @@ -467,7 +467,7 @@ Lemma Qcpower_0 : forall n, n<>O -> 0^n = 0. Proof. destruct n; simpl. destruct 1; auto. - intros. + intros. apply Qc_is_canon. simpl. compute; auto. @@ -537,7 +537,7 @@ Proof. intros (q, Hq) (q', Hq'); simpl; intros H. assert (H1 := H Hq Hq'). subst q'. - assert (Hq = Hq'). + assert (Hq = Hq'). apply Eqdep_dec.eq_proofs_unicity; auto; intros. repeat decide equality. congruence. diff --git a/theories/QArith/Qfield.v b/theories/QArith/Qfield.v index 5373c1db3b..fbfae55c3f 100644 --- a/theories/QArith/Qfield.v +++ b/theories/QArith/Qfield.v @@ -73,15 +73,15 @@ Ltac Qpow_tac t := | _ => NotConstant end. -Add Field Qfield : Qsft - (decidable Qeq_bool_eq, +Add Field Qfield : Qsft + (decidable Qeq_bool_eq, completeness Qeq_eq_bool, - constants [Qcst], + constants [Qcst], power_tac Qpower_theory [Qpow_tac]). (** Exemple of use: *) -Section Examples. +Section Examples. Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). intros. @@ -89,7 +89,7 @@ Let ex1 : forall x y z : Q, (x+y)*z == (x*z)+(y*z). Qed. Let ex2 : forall x y : Q, x+y == y+x. - intros. + intros. ring. Qed. diff --git a/theories/QArith/Qpower.v b/theories/QArith/Qpower.v index efaefbb7c2..fa341dd9c0 100644 --- a/theories/QArith/Qpower.v +++ b/theories/QArith/Qpower.v @@ -59,7 +59,7 @@ Qed. Lemma Qmult_power : forall a b n, (a*b)^n == a^n*b^n. Proof. - intros a b [|n|n]; simpl; + intros a b [|n|n]; simpl; try rewrite Qmult_power_positive; try rewrite Qinv_mult_distr; reflexivity. @@ -73,7 +73,7 @@ Qed. Lemma Qinv_power : forall a n, (/a)^n == /a^n. Proof. - intros a [|n|n]; simpl; + intros a [|n|n]; simpl; try rewrite Qinv_power_positive; reflexivity. Qed. @@ -173,8 +173,8 @@ Qed. Lemma Qpower_mult : forall a n m, a^(n*m) == (a^n)^m. Proof. -intros a [|n|n] [|m|m]; simpl; - try rewrite Qpower_positive_1; +intros a [|n|n] [|m|m]; simpl; + try rewrite Qpower_positive_1; try rewrite Qpower_mult_positive; try rewrite Qinv_power_positive; try rewrite Qinv_involutive; diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index d57a8c8242..12e371ee9e 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -173,7 +173,7 @@ unfold Qinv, Q2R, Qeq in |- *; intros (x1, x2); unfold Qden, Qnum in |- *. case x1. simpl in |- *; intros; elim H; trivial. intros; field; auto. -intros; +intros; change (IZR (Zneg x2)) with (- IZR (' x2))%R in |- *; change (IZR (Zneg p)) with (- IZR (' p))%R in |- *; field; (*auto 8 with real.*) @@ -193,8 +193,8 @@ Hint Rewrite Q2R_plus Q2R_mult Q2R_opp Q2R_minus Q2R_inv Q2R_div : q2r_simpl. Section LegacyQField. (** In the past, the field tactic was not able to deal with setoid datatypes, - so translating from Q to R and applying field on reals was a workaround. - See now Qfield for a direct field tactic on Q. *) + so translating from Q to R and applying field on reals was a workaround. + See now Qfield for a direct field tactic on Q. *) Ltac QField := apply eqR_Qeq; autorewrite with q2r_simpl; try field; auto. diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 6b16cfff4c..27e3c4e02a 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -35,15 +35,15 @@ Qed. (** Simplification of fractions using [Zgcd]. This version can compute within Coq. *) -Definition Qred (q:Q) := - let (q1,q2) := q in - let (r1,r2) := snd (Zggcd q1 ('q2)) +Definition Qred (q:Q) := + let (q1,q2) := q in + let (r1,r2) := snd (Zggcd q1 ('q2)) in r1#(Z2P r2). Lemma Qred_correct : forall q, (Qred q) == q. Proof. unfold Qred, Qeq; intros (n,d); simpl. - generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d)) + generalize (Zggcd_gcd n ('d)) (Zgcd_is_pos n ('d)) (Zgcd_is_gcd n ('d)) (Zggcd_correct_divisors n ('d)). destruct (Zggcd n (Zpos d)) as (g,(nn,dd)); simpl. Open Scope Z_scope. @@ -52,7 +52,7 @@ Proof. rewrite H3; rewrite H4. assert (0 <> g). intro; subst g; discriminate. - + assert (0 < dd). apply Zmult_gt_0_lt_0_reg_r with g. omega. @@ -68,10 +68,10 @@ Proof. intros (a,b) (c,d). unfold Qred, Qeq in *; simpl in *. Open Scope Z_scope. - generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b)) + generalize (Zggcd_gcd a ('b)) (Zgcd_is_gcd a ('b)) (Zgcd_is_pos a ('b)) (Zggcd_correct_divisors a ('b)). destruct (Zggcd a (Zpos b)) as (g,(aa,bb)). - generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d)) + generalize (Zggcd_gcd c ('d)) (Zgcd_is_gcd c ('d)) (Zgcd_is_pos c ('d)) (Zggcd_correct_divisors c ('d)). destruct (Zggcd c (Zpos d)) as (g',(cc,dd)). simpl. @@ -136,7 +136,7 @@ Proof. Close Scope Z_scope. Qed. -Add Morphism Qred : Qred_comp. +Add Morphism Qred : Qred_comp. Proof. intros q q' H. rewrite (Qred_correct q); auto. @@ -144,7 +144,7 @@ Proof. Qed. Definition Qplus' (p q : Q) := Qred (Qplus p q). -Definition Qmult' (p q : Q) := Qred (Qmult p q). +Definition Qmult' (p q : Q) := Qred (Qmult p q). Definition Qminus' x y := Qred (Qminus x y). Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q). diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index 4511657a0b..6e2488f5d1 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - + (*i $Id$ i*) Require Import Rbase. @@ -198,7 +198,7 @@ Proof. replace (Wn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Wn (S n)); [ idtac | ring ]; replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with - (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); + (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); [ idtac | ring ]; apply Rmult_le_compat_l. left; apply Rmult_lt_0_compat. prove_sup0. @@ -273,7 +273,7 @@ Proof. replace (Vn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Vn (S n)); [ idtac | ring ]; replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with - (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); + (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n)))); [ idtac | ring ]; apply Rmult_le_compat_l. left; apply Rmult_lt_0_compat. prove_sup0. @@ -304,8 +304,8 @@ Proof. pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double; rewrite Rplus_assoc; apply Rplus_le_compat_l. apply Rplus_le_reg_l with (- An n); rewrite Rplus_0_r; - rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc; - rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp; + rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc; + rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp; apply RRle_abs. unfold Vn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2)); repeat rewrite Rmult_assoc; apply Rmult_le_compat_l. @@ -318,7 +318,7 @@ Proof. rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l. apply Rinv_0_lt_compat; prove_sup0. apply Rplus_lt_reg_r with (An n); rewrite Rplus_0_r; unfold Rminus in |- *; - rewrite (Rplus_comm (An n)); rewrite Rplus_assoc; + rewrite (Rplus_comm (An n)); rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rle_lt_trans with (Rabs (An n)). apply RRle_abs. @@ -328,7 +328,7 @@ Proof. rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l. apply Rinv_0_lt_compat; prove_sup0. apply Rplus_lt_reg_r with (- An n); rewrite Rplus_0_r; unfold Rminus in |- *; - rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc; + rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_r; apply Rle_lt_trans with (Rabs (An n)). rewrite <- Rabs_Ropp; apply RRle_abs. @@ -352,7 +352,7 @@ Proof. unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x). intro; elim (H1 (eps / Rabs x) H4); intros. exists x0; intros; unfold R_dist in |- *; unfold Rminus in |- *; - rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; + rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Bn in |- *; replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x). rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs x). @@ -363,13 +363,13 @@ Proof. replace (Rabs (An (S n) / An n)) with (R_dist (Rabs (An (S n) * / An n)) 0). apply H5; assumption. unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *; + rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *; reflexivity. apply Rabs_no_R0; assumption. replace (S n) with (n + 1)%nat; [ idtac | ring ]; rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr. replace (An (n + 1)%nat * (x ^ n * x ^ 1) * (/ An n * / x ^ n)) with - (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n)); + (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n)); [ idtac | ring ]; rewrite <- Rinv_r_sym. simpl in |- *; ring. apply pow_nonzero; assumption. @@ -638,7 +638,7 @@ Lemma Alembert_C6 : rewrite Rmult_1_r. rewrite Rinv_mult_distr. replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with - (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); + (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); [ idtac | ring ]. rewrite <- Rinv_r_sym. rewrite Rmult_1_r; reflexivity. @@ -713,7 +713,7 @@ Lemma Alembert_C6 : rewrite Rmult_1_r. rewrite Rinv_mult_distr. replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with - (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); + (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n)); [ idtac | ring ]. rewrite <- Rinv_r_sym. rewrite Rmult_1_r; reflexivity. diff --git a/theories/Reals/AltSeries.v b/theories/Reals/AltSeries.v index 952853a86d..cccc8ceec1 100644 --- a/theories/Reals/AltSeries.v +++ b/theories/Reals/AltSeries.v @@ -69,7 +69,7 @@ Lemma CV_ALT_step2 : forall (Un:nat -> R) (N:nat), Un_decreasing Un -> positivity_seq Un -> - sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0. + sum_f_R0 (fun i:nat => tg_alt Un (S i)) (S (2 * N)) <= 0. Proof. intros; induction N as [| N HrecN]. simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r. @@ -101,7 +101,7 @@ Qed. Lemma CV_ALT_step3 : forall (Un:nat -> R) (N:nat), Un_decreasing Un -> - positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0. + positivity_seq Un -> sum_f_R0 (fun i:nat => tg_alt Un (S i)) N <= 0. Proof. intros; induction N as [| N HrecN]. simpl in |- *; unfold tg_alt in |- *; simpl in |- *; rewrite Rmult_1_r. @@ -184,7 +184,7 @@ Proof. rewrite H12; apply H7; assumption. rewrite Rabs_Ropp; unfold tg_alt in |- *; rewrite Rabs_mult; rewrite pow_1_abs; rewrite Rmult_1_l; unfold Rminus in H6; - rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n))); + rewrite Ropp_0 in H6; rewrite <- (Rplus_0_r (Un (S n))); apply H6. unfold ge in |- *; apply le_trans with n. apply le_trans with N; [ unfold N in |- *; apply le_max_r | assumption ]. @@ -246,7 +246,7 @@ Proof. apply CV_ALT_step1; assumption. assumption. unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1; - unfold R_dist in H1; intros. + unfold R_dist in H1; intros. elim (H1 eps H2); intros. exists x; intros. apply H3. @@ -254,20 +254,20 @@ Proof. apply le_trans with n. assumption. assert (H5 := mult_O_le n 2). - elim H5; intro. + elim H5; intro. cut (0%nat <> 2%nat); [ intro; elim H7; symmetry in |- *; assumption | discriminate ]. assumption. apply le_n_Sn. unfold Un_cv in |- *; unfold R_dist in |- *; unfold Un_cv in H1; - unfold R_dist in H1; intros. + unfold R_dist in H1; intros. elim (H1 eps H2); intros. exists x; intros. apply H3. unfold ge in |- *; apply le_trans with n. assumption. assert (H5 := mult_O_le n 2). - elim H5; intro. + elim H5; intro. cut (0%nat <> 2%nat); [ intro; elim H7; symmetry in |- *; assumption | discriminate ]. assumption. diff --git a/theories/Reals/ArithProp.v b/theories/Reals/ArithProp.v index a5c5ddaf82..f22ff5cb25 100644 --- a/theories/Reals/ArithProp.v +++ b/theories/Reals/ArithProp.v @@ -124,7 +124,7 @@ Proof. rewrite <- Ropp_inv_permute; [ idtac | assumption ]. replace (IZR (up (x * / - y)) - x * - / y + - (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1; + (- (x * / y) + - (IZR (up (x * / - y)) - 1))) with 1; [ idtac | ring ]. elim H0; intros _ H1; unfold Rdiv in H1; exact H1. rewrite (Rabs_left _ r); apply Rmult_lt_reg_l with (/ - y). @@ -153,11 +153,11 @@ Proof. rewrite Rmult_0_r; rewrite (Rmult_comm (/ y)); rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ]; - apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y); + apply Rplus_le_reg_l with (IZR (up (x / y)) - x / y); rewrite Rplus_0_r; unfold Rdiv in |- *; replace (IZR (up (x * / y)) - x * / y + (x * / y + (1 - IZR (up (x * / y))))) with - 1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2; + 1; [ idtac | ring ]; elim H0; intros _ H2; unfold Rdiv in H2; exact H2. rewrite (Rabs_right _ r); apply Rmult_lt_reg_l with (/ y). apply Rinv_0_lt_compat; assumption. @@ -165,10 +165,10 @@ Proof. rewrite Rmult_plus_distr_r; rewrite Rmult_assoc; rewrite <- Rinv_r_sym; [ rewrite Rmult_1_r | assumption ]; apply Rplus_lt_reg_r with (IZR (up (x / y)) - 1); - replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y))); + replace (IZR (up (x / y)) - 1 + 1) with (IZR (up (x / y))); [ idtac | ring ]; replace (IZR (up (x / y)) - 1 + (x * / y + (1 - IZR (up (x / y))))) with - (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *; + (x * / y); [ idtac | ring ]; elim H0; unfold Rdiv in |- *; intros H2 _; exact H2. case (total_order_T 0 y); intro. elim s; intro. diff --git a/theories/Reals/Binomial.v b/theories/Reals/Binomial.v index 3a8e816bcc..0d34d22c55 100644 --- a/theories/Reals/Binomial.v +++ b/theories/Reals/Binomial.v @@ -194,7 +194,7 @@ Proof. apply minus_Sn_m; assumption. rewrite <- (Rmult_comm x); rewrite scal_sum; apply sum_eq. intros; replace (S i) with (i + 1)%nat; [ idtac | ring ]; rewrite pow_add; - replace (x ^ 1) with x; [ idtac | simpl in |- *; ring ]; + replace (x ^ 1) with x; [ idtac | simpl in |- *; ring ]; ring. intro; unfold C in |- *. replace (INR (fact 0)) with 1; [ idtac | reflexivity ]. diff --git a/theories/Reals/Cauchy_prod.v b/theories/Reals/Cauchy_prod.v index c1c61586ad..6ea0767d09 100644 --- a/theories/Reals/Cauchy_prod.v +++ b/theories/Reals/Cauchy_prod.v @@ -47,7 +47,7 @@ Theorem cauchy_finite : sum_f_R0 (fun k:nat => sum_f_R0 (fun l:nat => An (S (l + k)) * Bn (N - l)%nat) - (pred (N - k))) (pred N). + (pred (N - k))) (pred N). Proof. intros; induction N as [| N HrecN]. elim (lt_irrefl _ H). @@ -124,7 +124,7 @@ Proof. (fun k:nat => sum_f_R0 (fun l:nat => An (S (S (l + k))) * Bn (N - l)%nat) (pred (pred (N - k)))) (pred (pred N))); - set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N)); + set (Z2 := sum_f_R0 (fun i:nat => Bn (S i)) (pred N)); ring. rewrite (sum_N_predN diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v index a0675827bb..6c08356a75 100644 --- a/theories/Reals/Cos_plus.v +++ b/theories/Reals/Cos_plus.v @@ -111,7 +111,7 @@ Proof. (Rsum_abs (fun l:nat => (-1) ^ S (l + n) / INR (fact (2 * S (l + n))) * x ^ (2 * S (l + n)) * - ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * + ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) * y ^ (2 * (N - l))) (pred (N - n))). apply Rle_trans with (sum_f_R0 @@ -745,42 +745,42 @@ Proof. exact H. Qed. -Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y. +Theorem cos_plus : forall x y:R, cos (x + y) = cos x * cos y - sin x * sin y. Proof. - intros. - cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)). - cut (Un_cv (C1 x y) (cos (x + y))). - intros. - apply UL_sequence with (C1 x y); assumption. - apply C1_cvg. - unfold Un_cv in |- *; unfold R_dist in |- *. - intros. - assert (H0 := A1_cvg x). - assert (H1 := A1_cvg y). - assert (H2 := B1_cvg x). - assert (H3 := B1_cvg y). - assert (H4 := CV_mult _ _ _ _ H0 H1). - assert (H5 := CV_mult _ _ _ _ H2 H3). + intros. + cut (Un_cv (C1 x y) (cos x * cos y - sin x * sin y)). + cut (Un_cv (C1 x y) (cos (x + y))). + intros. + apply UL_sequence with (C1 x y); assumption. + apply C1_cvg. + unfold Un_cv in |- *; unfold R_dist in |- *. + intros. + assert (H0 := A1_cvg x). + assert (H1 := A1_cvg y). + assert (H2 := B1_cvg x). + assert (H3 := B1_cvg y). + assert (H4 := CV_mult _ _ _ _ H0 H1). + assert (H5 := CV_mult _ _ _ _ H2 H3). assert (H6 := reste_cv_R0 x y). unfold Un_cv in H4; unfold Un_cv in H5; unfold Un_cv in H6. - unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6. + unfold R_dist in H4; unfold R_dist in H5; unfold R_dist in H6. cut (0 < eps / 3); [ intro | unfold Rdiv in |- *; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. - elim (H4 (eps / 3) H7); intros N1 H8. - elim (H5 (eps / 3) H7); intros N2 H9. + [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ]. + elim (H4 (eps / 3) H7); intros N1 H8. + elim (H5 (eps / 3) H7); intros N2 H9. elim (H6 (eps / 3) H7); intros N3 H10. - set (N := S (S (max (max N1 N2) N3))). - exists N. - intros. - cut (n = S (pred n)). - intro; rewrite H12. - rewrite <- cos_plus_form. - rewrite <- H12. + set (N := S (S (max (max N1 N2) N3))). + exists N. + intros. + cut (n = S (pred n)). + intro; rewrite H12. + rewrite <- cos_plus_form. + rewrite <- H12. apply Rle_lt_trans with (Rabs (A1 x n * A1 y n - cos x * cos y) + - Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))). + Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))). replace (A1 x n * A1 y n - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n) - (cos x * cos y - sin x * sin y)) with @@ -788,28 +788,28 @@ Proof. (sin x * sin y - B1 x (pred n) * B1 y (pred n) + Reste x y (pred n))); [ apply Rabs_triang | ring ]. replace eps with (eps / 3 + (eps / 3 + eps / 3)). - apply Rplus_lt_compat. - apply H8. - unfold ge in |- *; apply le_trans with N. - unfold N in |- *. - apply le_trans with (max N1 N2). - apply le_max_l. + apply Rplus_lt_compat. + apply H8. + unfold ge in |- *; apply le_trans with N. + unfold N in |- *. + apply le_trans with (max N1 N2). + apply le_max_l. apply le_trans with (max (max N1 N2) N3). apply le_max_l. apply le_trans with (S (max (max N1 N2) N3)); apply le_n_Sn. - assumption. + assumption. apply Rle_lt_trans with (Rabs (sin x * sin y - B1 x (pred n) * B1 y (pred n)) + Rabs (Reste x y (pred n))). apply Rabs_triang. apply Rplus_lt_compat. - rewrite <- Rabs_Ropp. - rewrite Ropp_minus_distr. - apply H9. - unfold ge in |- *; apply le_trans with (max N1 N2). - apply le_max_r. - apply le_S_n. - rewrite <- H12. + rewrite <- Rabs_Ropp. + rewrite Ropp_minus_distr. + apply H9. + unfold ge in |- *; apply le_trans with (max N1 N2). + apply le_max_r. + apply le_S_n. + rewrite <- H12. apply le_trans with N. unfold N in |- *. apply le_n_S. @@ -843,11 +843,11 @@ Proof. replace (S (pred N)) with N. assumption. unfold N in |- *; simpl in |- *; reflexivity. - cut (0 < N)%nat. - intro. - cut (0 < n)%nat. - intro. + cut (0 < N)%nat. + intro. + cut (0 < n)%nat. + intro. apply S_pred with 0%nat; assumption. - apply lt_le_trans with N; assumption. + apply lt_le_trans with N; assumption. unfold N in |- *; apply lt_O_Sn. Qed. diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index 56423f3376..7a893c53c3 100644 --- a/theories/Reals/Cos_rel.v +++ b/theories/Reals/Cos_rel.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - + (*i $Id$ i*) Require Import Rbase. @@ -15,15 +15,15 @@ Require Import Rtrigo_def. Open Local Scope R_scope. Definition A1 (x:R) (N:nat) : R := - sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N. - + sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N. + Definition B1 (x:R) (N:nat) : R := sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) - N. - + N. + Definition C1 (x y:R) (N:nat) : R := - sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N. - + sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N. + Definition Reste1 (x y:R) (N:nat) : R := sum_f_R0 (fun k:nat => @@ -50,7 +50,7 @@ Definition Reste (x y:R) (N:nat) : R := Reste2 x y N - Reste1 x y (S N). Theorem cos_plus_form : forall (x y:R) (n:nat), (0 < n)%nat -> - A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n). + A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n). intros. unfold A1, B1 in |- *. rewrite @@ -244,152 +244,152 @@ apply INR_fact_neq_0. apply INR_fact_neq_0. unfold Reste2 in |- *; apply sum_eq; intros. apply sum_eq; intros. -unfold Rdiv in |- *; ring. +unfold Rdiv in |- *; ring. unfold Reste1 in |- *; apply sum_eq; intros. apply sum_eq; intros. unfold Rdiv in |- *; ring. apply lt_O_Sn. Qed. -Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i. -intros. +Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i. +intros. assert (H := pow_Rsqr x i). unfold Rsqr in H; exact H. -Qed. - -Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x). -intro. -assert (H := exist_cos (x * x)). -elim H; intros. -assert (p_i := p). -unfold cos_in in p. -unfold cos_n, infinite_sum in p. -unfold R_dist in p. -cut (cos x = x0). -intro. -rewrite H0. -unfold Un_cv in |- *; unfold R_dist in |- *; intros. -elim (p eps H1); intros. -exists x1; intros. -unfold A1 in |- *. +Qed. + +Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x). +intro. +assert (H := exist_cos (x * x)). +elim H; intros. +assert (p_i := p). +unfold cos_in in p. +unfold cos_n, infinite_sum in p. +unfold R_dist in p. +cut (cos x = x0). +intro. +rewrite H0. +unfold Un_cv in |- *; unfold R_dist in |- *; intros. +elim (p eps H1); intros. +exists x1; intros. +unfold A1 in |- *. replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with - (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n). -apply H2; assumption. -apply sum_eq. -intros. -replace ((x * x) ^ i) with (x ^ (2 * i)). -reflexivity. -apply pow_sqr. -unfold cos in |- *. -case (exist_cos (Rsqr x)). -unfold Rsqr in |- *; intros. -unfold cos_in in p_i. -unfold cos_in in c. -apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption. -Qed. - -Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)). -intros. -assert (H := exist_cos ((x + y) * (x + y))). -elim H; intros. -assert (p_i := p). -unfold cos_in in p. -unfold cos_n, infinite_sum in p. -unfold R_dist in p. -cut (cos (x + y) = x0). -intro. -rewrite H0. -unfold Un_cv in |- *; unfold R_dist in |- *; intros. -elim (p eps H1); intros. -exists x1; intros. -unfold C1 in |- *. + (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n). +apply H2; assumption. +apply sum_eq. +intros. +replace ((x * x) ^ i) with (x ^ (2 * i)). +reflexivity. +apply pow_sqr. +unfold cos in |- *. +case (exist_cos (Rsqr x)). +unfold Rsqr in |- *; intros. +unfold cos_in in p_i. +unfold cos_in in c. +apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption. +Qed. + +Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)). +intros. +assert (H := exist_cos ((x + y) * (x + y))). +elim H; intros. +assert (p_i := p). +unfold cos_in in p. +unfold cos_n, infinite_sum in p. +unfold R_dist in p. +cut (cos (x + y) = x0). +intro. +rewrite H0. +unfold Un_cv in |- *; unfold R_dist in |- *; intros. +elim (p eps H1); intros. +exists x1; intros. +unfold C1 in |- *. replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n) with (sum_f_R0 - (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). -apply H2; assumption. -apply sum_eq. -intros. -replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). -reflexivity. -apply pow_sqr. -unfold cos in |- *. -case (exist_cos (Rsqr (x + y))). -unfold Rsqr in |- *; intros. -unfold cos_in in p_i. -unfold cos_in in c. + (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n). +apply H2; assumption. +apply sum_eq. +intros. +replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)). +reflexivity. +apply pow_sqr. +unfold cos in |- *. +case (exist_cos (Rsqr (x + y))). +unfold Rsqr in |- *; intros. +unfold cos_in in p_i. +unfold cos_in in c. apply uniqueness_sum with (fun i:nat => cos_n i * ((x + y) * (x + y)) ^ i); - assumption. -Qed. - -Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x). -intro. -case (Req_dec x 0); intro. -rewrite H. -rewrite sin_0. -unfold B1 in |- *. -unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros. + assumption. +Qed. + +Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x). +intro. +case (Req_dec x 0); intro. +rewrite H. +rewrite sin_0. +unfold B1 in |- *. +unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros. replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1)) - n) with 0. -unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. -induction n as [| n Hrecn]. -simpl in |- *; ring. -rewrite tech5; rewrite <- Hrecn. -simpl in |- *; ring. -unfold ge in |- *; apply le_O_n. -assert (H0 := exist_sin (x * x)). -elim H0; intros. -assert (p_i := p). -unfold sin_in in p. -unfold sin_n, infinite_sum in p. -unfold R_dist in p. -cut (sin x = x * x0). -intro. -rewrite H1. -unfold Un_cv in |- *; unfold R_dist in |- *; intros. + n) with 0. +unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. +induction n as [| n Hrecn]. +simpl in |- *; ring. +rewrite tech5; rewrite <- Hrecn. +simpl in |- *; ring. +unfold ge in |- *; apply le_O_n. +assert (H0 := exist_sin (x * x)). +elim H0; intros. +assert (p_i := p). +unfold sin_in in p. +unfold sin_n, infinite_sum in p. +unfold R_dist in p. +cut (sin x = x * x0). +intro. +rewrite H1. +unfold Un_cv in |- *; unfold R_dist in |- *; intros. cut (0 < eps / Rabs x); [ intro | unfold Rdiv in |- *; apply Rmult_lt_0_compat; - [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ]. -elim (p (eps / Rabs x) H3); intros. -exists x1; intros. -unfold B1 in |- *. + [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ]. +elim (p (eps / Rabs x) H3); intros. +exists x1; intros. +unfold B1 in |- *. replace (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1)) n) with (x * - sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n). + sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n). replace (x * sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n - x * x0) with (x * (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n - - x0)); [ idtac | ring ]. -rewrite Rabs_mult. -apply Rmult_lt_reg_l with (/ Rabs x). -apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. -rewrite <- Rmult_assoc. -rewrite <- Rinv_l_sym. + x0)); [ idtac | ring ]. +rewrite Rabs_mult. +apply Rmult_lt_reg_l with (/ Rabs x). +apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. +rewrite <- Rmult_assoc. +rewrite <- Rinv_l_sym. rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H4; apply H4; - assumption. -apply Rabs_no_R0; assumption. -rewrite scal_sum. -apply sum_eq. -intros. -rewrite pow_add. -rewrite pow_sqr. -simpl in |- *. -ring. -unfold sin in |- *. -case (exist_sin (Rsqr x)). -unfold Rsqr in |- *; intros. -unfold sin_in in p_i. -unfold sin_in in s. + assumption. +apply Rabs_no_R0; assumption. +rewrite scal_sum. +apply sum_eq. +intros. +rewrite pow_add. +rewrite pow_sqr. +simpl in |- *. +ring. +unfold sin in |- *. +case (exist_sin (Rsqr x)). +unfold Rsqr in |- *; intros. +unfold sin_in in p_i. +unfold sin_in in s. assert - (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s). -rewrite H1; reflexivity. -Qed. + (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s). +rewrite H1; reflexivity. +Qed. diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index 603010c912..45e91577ea 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -19,7 +19,7 @@ Qed. Lemma Rplus_lt_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x + y. intros. apply Rlt_trans with x. -assumption. +assumption. pattern x at 1 in |- *; rewrite <- Rplus_0_r. apply Rplus_lt_compat_l. assumption. @@ -63,9 +63,9 @@ Ltac omega_sup := change 0 with (IZR 0); repeat rewrite <- plus_IZR || - rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; + rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; apply IZR_lt; omega. - + Ltac prove_sup := match goal with | |- (?X1 > ?X2) => change (X2 < X1) in |- *; prove_sup @@ -83,5 +83,5 @@ Ltac Rcompute := change 0 with (IZR 0); repeat rewrite <- plus_IZR || - rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; + rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; apply IZR_eq; try reflexivity. diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index 177035c4ec..1c74f55a0d 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -46,7 +46,7 @@ Proof. intros; unfold E1 in |- *. rewrite cauchy_finite. unfold Reste_E in |- *; unfold Rminus in |- *; rewrite Rplus_assoc; - rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq; + rewrite Rplus_opp_r; rewrite Rplus_0_r; apply sum_eq; intros. rewrite binomial. rewrite scal_sum; apply sum_eq; intros. @@ -125,7 +125,7 @@ Proof. sum_f_R0 (fun k:nat => sum_f_R0 (fun l:nat => / Rsqr (INR (fact (div2 (S N))))) - (pred (N - k))) (pred N)). + (pred (N - k))) (pred N)). unfold Reste_E in |- *. apply Rle_trans with (sum_f_R0 @@ -473,7 +473,7 @@ Proof. apply lt_n_S; apply H. cut (1 < S N)%nat. intro; unfold Rsqr in |- *; apply prod_neq_R0; apply not_O_INR; intro; - assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; + assert (H4 := div2_not_R0 _ H2); rewrite H3 in H4; elim (lt_n_O _ H4). apply lt_n_S; apply H. assert (H1 := even_odd_cor N). diff --git a/theories/Reals/Integration.v b/theories/Reals/Integration.v index 95237d1169..774a0bd5cd 100644 --- a/theories/Reals/Integration.v +++ b/theories/Reals/Integration.v @@ -5,7 +5,7 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - + (*i $Id$ i*) Require Export NewtonInt. diff --git a/theories/Reals/MVT.v b/theories/Reals/MVT.v index ca4c38954f..4037e3dece 100644 --- a/theories/Reals/MVT.v +++ b/theories/Reals/MVT.v @@ -115,7 +115,7 @@ Proof. (derivable_pt_mult _ _ _ (derivable_pt_const (f b - f a) c) (pr2 c P)))); [ idtac | apply pr_nu ]. rewrite derive_pt_minus; do 2 rewrite derive_pt_mult; - do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l; + do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l; do 2 rewrite Rplus_0_l; reflexivity. unfold h in |- *; ring. intros; unfold h in |- *; @@ -180,7 +180,7 @@ Proof. cut (derive_pt id x (X2 x x0) = 1). cut (derive_pt f x (X0 x x0) = f' x). intros; rewrite H4 in H3; rewrite H5 in H3; unfold id in H3; - rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry in |- *; + rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry in |- *; assumption. apply derive_pt_eq_0; apply H0; elim x0; intros; split; left; assumption. apply derive_pt_eq_0; apply derivable_pt_lim_id. @@ -258,7 +258,7 @@ Lemma nonpos_derivative_0 : decreasing f -> forall x:R, derive_pt f x (pr x) <= 0. Proof. intros f pr H x; assert (H0 := H); unfold decreasing in H0; - generalize (derivable_derive f x (pr x)); intro; elim H1; + generalize (derivable_derive f x (pr x)); intro; elim H1; intros l H2. rewrite H2; case (Rtotal_order l 0); intro. left; assumption. @@ -282,7 +282,7 @@ Proof. intro. generalize (Ropp_lt_gt_contravar (- ((f (x + delta / 2) + - f x) / (delta / 2))) - (- (l / 2)) H15). + (- (l / 2)) H15). repeat rewrite Ropp_involutive. intro. generalize @@ -432,7 +432,7 @@ Lemma strictincreasing_strictdecreasing_opp : forall f:R -> R, strict_increasing f -> strict_decreasing (- f)%F. Proof. unfold strict_increasing, strict_decreasing, opp_fct in |- *; intros; - generalize (H x y H0); intro; apply Ropp_lt_gt_contravar; + generalize (H x y H0); intro; apply Ropp_lt_gt_contravar; assumption. Qed. @@ -467,14 +467,14 @@ Qed. (**********) Lemma null_derivative_0 : forall (f:R -> R) (pr:derivable f), - constant f -> forall x:R, derive_pt f x (pr x) = 0. + constant f -> forall x:R, derive_pt f x (pr x) = 0. Proof. intros. unfold constant in H. apply derive_pt_eq_0. intros; exists (mkposreal 1 Rlt_0_1); simpl in |- *; intros. rewrite (H x (x + h)); unfold Rminus in |- *; unfold Rdiv in |- *; - rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r; + rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption. Qed. @@ -576,7 +576,7 @@ Lemma derive_increasing_interv_var : forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y. Proof. intros a b f pr H H0 x y H1 H2 H3; - generalize (derive_increasing_interv_ax a b f pr H); + generalize (derive_increasing_interv_ax a b f pr H); intro; elim H4; intros _ H5; apply (H5 H0 x y H1 H2 H3). Qed. @@ -618,7 +618,7 @@ Proof. cut (derivable (g - f)). intro X. cut (forall c:R, a <= c <= b -> derive_pt (g - f) c (X c) <= 0). - intro. + intro. assert (H2 := IAF (g - f)%F a b 0 X H H1). rewrite Rmult_0_l in H2; unfold minus_fct in H2. apply Rplus_le_reg_l with (- f b + f a). @@ -697,11 +697,11 @@ Proof. clear H0; intros H0 _; exists (g1 a - g2 a); intros; assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x). intros; unfold derivable_pt in |- *; exists (f x0); elim (H x0 H3); - intros; eapply derive_pt_eq_1; symmetry in |- *; + intros; eapply derive_pt_eq_1; symmetry in |- *; apply H4. assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x). intros; unfold derivable_pt in |- *; exists (f x0); - elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry in |- *; + elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry in |- *; apply H5. assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x). intros; elim H5; intros; apply derivable_pt_minus; @@ -717,6 +717,6 @@ Proof. apply derivable_pt_lim_minus; [ elim (H _ H9) | elim (H0 _ H9) ]; intros; eapply derive_pt_eq_1; symmetry in |- *; apply H10. assert (H8 := null_derivative_loc (g1 - g2)%F a b H5 H6 H7); - unfold constant_D_eq in H8; assert (H9 := H8 _ H2); + unfold constant_D_eq in H8; assert (H9 := H8 _ H2); unfold minus_fct in H9; rewrite <- H9; ring. Qed. diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 43ddfaf4a6..74bcf7dcd1 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -31,7 +31,7 @@ Lemma FTCN_step1 : Newton_integrable (fun x:R => derive_pt f x (cond_diff f x)) a b. Proof. intros f a b; unfold Newton_integrable in |- *; exists (d1 f); - unfold antiderivative in |- *; intros; case (Rle_dec a b); + unfold antiderivative in |- *; intros; case (Rle_dec a b); intro; [ left; split; [ intros; exists (cond_diff f x); reflexivity | assumption ] | right; split; @@ -229,15 +229,15 @@ Lemma NewtonInt_P6 : l * NewtonInt f a b pr1 + NewtonInt g a b pr2. Proof. intros f g l a b pr1 pr2; unfold NewtonInt in |- *; - case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1; - intros; case pr2; intros; case (total_order_T a b); + case (NewtonInt_P5 f g l a b pr1 pr2); intros; case pr1; + intros; case pr2; intros; case (total_order_T a b); intro. elim s; intro. elim o; intro. elim o0; intro. elim o1; intro. assert (H2 := antiderivative_P1 f g x0 x1 l a b H0 H1); - assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); + assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); elim H3; intros; assert (H5 : a <= a <= b). split; [ right; reflexivity | left; assumption ]. assert (H6 : a <= b <= b). @@ -260,7 +260,7 @@ Proof. unfold antiderivative in H1; elim H1; intros; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H3 r)). assert (H2 := antiderivative_P1 f g x0 x1 l b a H0 H1); - assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); + assert (H3 := antiderivative_Ucte _ _ _ _ _ H H2); elim H3; intros; assert (H5 : b <= a <= a). split; [ left; assumption | right; reflexivity ]. assert (H6 : b <= b <= a). @@ -313,7 +313,7 @@ Proof. apply RRle_abs. apply H13. apply Rplus_le_reg_l with (- x); rewrite <- Rplus_assoc; rewrite Rplus_opp_l; - rewrite Rplus_0_l; rewrite Rplus_comm; unfold D in |- *; + rewrite Rplus_0_l; rewrite Rplus_comm; unfold D in |- *; apply Rmin_r. elim n; left; assumption. assert @@ -396,7 +396,7 @@ Proof. cut (b < x + h). intro; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r0 H14)). apply Rplus_lt_reg_r with (- h - b); replace (- h - b + b) with (- h); - [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); + [ idtac | ring ]; replace (- h - b + (x + h)) with (x - b); [ idtac | ring ]; apply Rle_lt_trans with (Rabs h). rewrite <- Rabs_Ropp; apply RRle_abs. apply Rlt_le_trans with D. diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v index 623ae6311a..97793386de 100644 --- a/theories/Reals/PSeries_reg.v +++ b/theories/Reals/PSeries_reg.v @@ -19,13 +19,13 @@ Open Local Scope R_scope. Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r. (** Uniform convergence *) -Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R) +Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R) (r:posreal) : Prop := forall eps:R, 0 < eps -> exists N : nat, (forall (n:nat) (y:R), - (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps). + (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps). (** Normal convergence *) Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type := @@ -37,7 +37,7 @@ Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type := Definition CVN_R (fn:nat -> R -> R) : Type := forall r:posreal, CVN_r fn r. Definition SFL (fn:nat -> R -> R) - (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) + (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }) (y:R) : R := let (a,_) := cv y in a. (** In a complete space, normal convergence implies uniform convergence *) @@ -94,7 +94,7 @@ Lemma CVU_continuity : forall y:R, Boule x r y -> continuity_pt f y. Proof. intros; unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros. unfold CVU in H. cut (0 < eps / 3); @@ -219,11 +219,11 @@ Proof. intros; apply (H n y). apply H1. unfold Boule in |- *; simpl in |- *; rewrite Rminus_0_r; - pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; + pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1. Qed. -(** As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) +(** As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *) Lemma CVN_R_CVS : forall fn:nat -> R -> R, CVN_R fn -> forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }. @@ -256,7 +256,7 @@ Proof. intro; apply Rle_trans with (Rabs (An n)). apply Rabs_pos. unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *; - rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *; + rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1. apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ]. Qed. diff --git a/theories/Reals/PartSum.v b/theories/Reals/PartSum.v index 40972fbcf3..6a33b80928 100644 --- a/theories/Reals/PartSum.v +++ b/theories/Reals/PartSum.v @@ -31,7 +31,7 @@ Lemma tech2 : forall (An:nat -> R) (m n:nat), (m < n)%nat -> sum_f_R0 An n = - sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m). + sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m). Proof. intros; induction n as [| n Hrecn]. elim (lt_n_O _ H). @@ -155,7 +155,7 @@ Lemma tech12 : Proof. intros; unfold Pser in |- *; unfold infinite_sum in |- *; unfold Un_cv in H; assumption. -Qed. +Qed. Lemma scal_sum : forall (An:nat -> R) (N:nat) (x:R), @@ -256,12 +256,12 @@ Qed. Lemma minus_sum : forall (An Bn:nat -> R) (N:nat), - sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N. + sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N. Proof. - intros; induction N as [| N HrecN]. - simpl in |- *; ring. - do 3 rewrite tech5; rewrite HrecN; ring. -Qed. + intros; induction N as [| N HrecN]. + simpl in |- *; ring. + do 3 rewrite tech5; rewrite HrecN; ring. +Qed. Lemma sum_decomposition : forall (An:nat -> R) (N:nat), @@ -346,7 +346,7 @@ Qed. (**********) Lemma Rabs_triang_gen : forall (An:nat -> R) (N:nat), - Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N. + Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N. Proof. intros. induction N as [| N HrecN]. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index b2e5619222..93b723af30 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -75,7 +75,7 @@ Hint Resolve Rlt_dichotomy_converse: real. Lemma Req_dec : forall r1 r2, r1 = r2 \/ r1 <> r2. Proof. intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse; - intuition eauto 3. + intuition eauto 3. Qed. Hint Resolve Req_dec: real. @@ -129,7 +129,7 @@ Hint Immediate Rge_le: rorders. (**********) Lemma Rlt_gt : forall r1 r2, r1 < r2 -> r2 > r1. -Proof. +Proof. trivial. Qed. Hint Resolve Rlt_gt: rorders. @@ -291,7 +291,7 @@ Proof. eauto using Rlt_trans with rorders. Qed. (**********) Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3. Proof. - generalize Rlt_trans Rlt_eq_compat. + generalize Rlt_trans Rlt_eq_compat. unfold Rle in |- *. intuition eauto 2. Qed. @@ -456,7 +456,7 @@ Proof. rewrite Rplus_comm; auto with real. Qed. -(*********************************************************) +(*********************************************************) (** ** Multiplication *) (*********************************************************) @@ -568,13 +568,13 @@ Proof. auto with real. Qed. -(**********) +(**********) Lemma Rmult_neq_0_reg : forall r1 r2, r1 * r2 <> 0 -> r1 <> 0 /\ r2 <> 0. Proof. intros r1 r2 H; split; red in |- *; intro; apply H; auto with real. Qed. -(**********) +(**********) Lemma Rmult_integral_contrapositive : forall r1 r2, r1 <> 0 /\ r2 <> 0 -> r1 * r2 <> 0. Proof. @@ -583,11 +583,11 @@ Proof. Qed. Hint Resolve Rmult_integral_contrapositive: real. -Lemma Rmult_integral_contrapositive_currified : +Lemma Rmult_integral_contrapositive_currified : forall r1 r2, r1 <> 0 -> r2 <> 0 -> r1 * r2 <> 0. Proof. auto using Rmult_integral_contrapositive. Qed. -(**********) +(**********) Lemma Rmult_plus_distr_r : forall r1 r2 r3, (r1 + r2) * r3 = r1 * r3 + r2 * r3. Proof. @@ -757,7 +757,7 @@ Lemma Rminus_not_eq_right : forall r1 r2, r2 - r1 <> 0 -> r1 <> r2. Proof. red in |- *; intros; elim H; rewrite H0; ring. Qed. -Hint Resolve Rminus_not_eq_right: real. +Hint Resolve Rminus_not_eq_right: real. (**********) Lemma Rmult_minus_distr_l : @@ -1284,7 +1284,7 @@ Proof. case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0. rewrite Eq0 in H0; elimtype False; apply (Rlt_irrefl (z * y)); auto. generalize (Rmult_lt_compat_l z y x H Eq0); intro; elimtype False; - generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); + generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); intro; apply (Rlt_irrefl (z * x)); auto. Qed. @@ -1333,7 +1333,7 @@ Qed. Hint Resolve Rlt_minus: real. Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0. -Proof. +Proof. intros; apply (Rplus_lt_reg_r r2). replace (r2 + (r1 - r2)) with r1. replace (r2 + 0) with r2; auto with real. @@ -1347,7 +1347,7 @@ Proof. Qed. Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0. -Proof. +Proof. destruct 1. auto using Rgt_minus, Rgt_ge. right; auto using Rminus_diag_eq with rorders. @@ -1500,7 +1500,7 @@ Proof. Qed. Hint Resolve Rinv_1_lt_contravar: real. -(*********************************************************) +(*********************************************************) (** ** Miscellaneous *) (*********************************************************) @@ -1528,7 +1528,7 @@ Proof. pattern r1 at 2 in |- *; replace r1 with (r1 + 0); auto with real. Qed. -(*********************************************************) +(*********************************************************) (** ** Injection from [N] to [R] *) (*********************************************************) @@ -1545,7 +1545,7 @@ Proof. Qed. (**********) -Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m. +Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m. Proof. intros n m; induction n as [| n Hrecn]. simpl in |- *; auto with real. @@ -1621,7 +1621,7 @@ Proof. simpl in |- *; elimtype False; apply (Rlt_irrefl 0); auto. auto with arith. generalize (pos_INR (S n0)); intro; cut (INR 0 = 0); - [ intro H2; rewrite H2 in H0; idtac | simpl in |- *; trivial ]. + [ intro H2; rewrite H2 in H0; idtac | simpl in |- *; trivial ]. generalize (Rle_lt_trans 0 (INR (S n0)) 0 H1 H0); intro; elimtype False; apply (Rlt_irrefl 0); auto. do 2 rewrite S_INR in H1; cut (INR n1 < INR n0). @@ -1696,7 +1696,7 @@ Proof. Qed. Hint Resolve not_1_INR: real. -(*********************************************************) +(*********************************************************) (** ** Injection from [Z] to [R] *) (*********************************************************) @@ -1797,7 +1797,7 @@ Lemma Z_R_minus : forall n m:Z, IZR n - IZR m = IZR (n - m). Proof. intros z1 z2; unfold Rminus in |- *; unfold Zminus in |- *. rewrite <- (Ropp_Ropp_IZR z2); symmetry in |- *; apply plus_IZR. -Qed. +Qed. (**********) Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. @@ -1812,7 +1812,7 @@ Qed. (**********) Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z. Proof. - intros z1 z2 H; apply Zlt_0_minus_lt. + intros z1 z2 H; apply Zlt_0_minus_lt. apply lt_0_IZR. rewrite <- Z_R_minus. exact (Rgt_minus (IZR z2) (IZR z1) H). @@ -1831,7 +1831,7 @@ Qed. Lemma eq_IZR : forall n m:Z, IZR n = IZR m -> n = m. Proof. intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H); - rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); + rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); intro; omega. Qed. @@ -1981,7 +1981,7 @@ Proof. rewrite <- Rinv_l_sym. rewrite Rmult_1_r; replace (2 * x) with (x + x). rewrite (Rplus_comm y); intro H5; apply Rplus_le_reg_l with x; assumption. - ring. + ring. replace 2 with (INR 2); [ apply not_0_INR; discriminate | reflexivity ]. pattern y at 2 in |- *; replace y with (y / 2 + y / 2). unfold Rminus, Rdiv in |- *. diff --git a/theories/Reals/RList.v b/theories/Reals/RList.v index 35a92793ce..a95985d3b1 100644 --- a/theories/Reals/RList.v +++ b/theories/Reals/RList.v @@ -144,7 +144,7 @@ Proof. induction l as [| r0 l Hrecl0]. simpl in |- *; left; reflexivity. change (In (Rmax r (MaxRlist (cons r0 l))) (cons r (cons r0 l))) in |- *; - unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); + unfold Rmax in |- *; case (Rle_dec r (MaxRlist (cons r0 l))); intro. right; apply Hrecl; exists r0; left; reflexivity. left; reflexivity. @@ -395,8 +395,8 @@ Lemma RList_P7 : ordered_Rlist l -> In x l -> x <= pos_Rl l (pred (Rlength l)). Proof. intros; assert (H1 := RList_P6 l); elim H1; intros H2 _; assert (H3 := H2 H); - clear H1 H2; assert (H1 := RList_P3 l x); elim H1; - clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4; + clear H1 H2; assert (H1 := RList_P3 l x); elim H1; + clear H1; intros; assert (H4 := H1 H0); elim H4; clear H4; intros; elim H4; clear H4; intros; rewrite H4; assert (H6 : Rlength l = S (pred (Rlength l))). apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro; @@ -468,7 +468,7 @@ Proof. simple induction l1; [ intro; reflexivity | intros; simpl in |- *; rewrite (H (insert l2 r)); rewrite RList_P10; - apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; + apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; rewrite S_INR; ring ]. Qed. @@ -495,7 +495,7 @@ Proof. reflexivity. change (pos_Rl (mid_Rlist (cons r1 r2) r) (S i) = - (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2) + (pos_Rl (cons r1 r2) i + pos_Rl (cons r1 r2) (S i)) / 2) in |- *; apply H0; simpl in |- *; apply lt_S_n; assumption. Qed. @@ -528,7 +528,7 @@ Proof. In (pos_Rl (cons_ORlist (cons r l1) l2) 0) (cons_ORlist (cons r l1) l2)); [ elim (RList_P3 (cons_ORlist (cons r l1) l2) - (pos_Rl (cons_ORlist (cons r l1) l2) 0)); + (pos_Rl (cons_ORlist (cons r l1) l2) 0)); intros; apply H3; exists 0%nat; split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ] | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) 0)); @@ -547,7 +547,7 @@ Lemma RList_P16 : Proof. intros; apply Rle_antisym. induction l1 as [| r l1 Hrecl1]. - simpl in |- *; simpl in H1; right; symmetry in |- *; assumption. + simpl in |- *; simpl in H1; right; symmetry in |- *; assumption. assert (H2 : In @@ -557,13 +557,13 @@ Proof. [ elim (RList_P3 (cons_ORlist (cons r l1) l2) (pos_Rl (cons_ORlist (cons r l1) l2) - (pred (Rlength (cons_ORlist (cons r l1) l2))))); + (pred (Rlength (cons_ORlist (cons r l1) l2))))); intros; apply H3; exists (pred (Rlength (cons_ORlist (cons r l1) l2))); split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ] | elim (RList_P9 (cons r l1) l2 (pos_Rl (cons_ORlist (cons r l1) l2) - (pred (Rlength (cons_ORlist (cons r l1) l2))))); + (pred (Rlength (cons_ORlist (cons r l1) l2))))); intros; assert (H5 := H3 H2); elim H5; intro; [ apply RList_P7; assumption | rewrite H1; apply RList_P7; assumption ] ]. induction l1 as [| r l1 Hrecl1]. @@ -576,19 +576,19 @@ Proof. In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) (cons r l1) \/ In (pos_Rl (cons r l1) (pred (Rlength (cons r l1)))) l2); [ left; change (In (pos_Rl (cons r l1) (Rlength l1)) (cons r l1)) in |- *; - elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1))); + elim (RList_P3 (cons r l1) (pos_Rl (cons r l1) (Rlength l1))); intros; apply H5; exists (Rlength l1); split; [ reflexivity | simpl in |- *; apply lt_n_Sn ] | assert (H5 := H3 H4); apply RList_P7; [ apply RList_P2; assumption | elim (RList_P9 (cons r l1) l2 - (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); + (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); intros; apply H7; left; elim (RList_P3 (cons r l1) - (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); - intros; apply H9; exists (pred (Rlength (cons r l1))); + (pos_Rl (cons r l1) (pred (Rlength (cons r l1))))); + intros; apply H9; exists (pred (Rlength (cons r l1))); split; [ reflexivity | simpl in |- *; apply lt_n_Sn ] ] ]. Qed. @@ -643,7 +643,7 @@ Lemma RList_P20 : forall l:Rlist, (2 <= Rlength l)%nat -> exists r : R, - (exists r1 : R, (exists l' : Rlist, l = cons r (cons r1 l'))). + (exists r1 : R, (exists l' : Rlist, l = cons r (cons r1 l'))). Proof. intros; induction l as [| r l Hrecl]; [ simpl in H; elim (le_Sn_O _ H) @@ -720,7 +720,7 @@ Proof. simpl in |- *; apply (H1 0%nat); simpl in |- *; apply lt_O_Sn. change (pos_Rl (cons_Rlist (cons r1 r2) l2) i <= - pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)) in |- *; + pos_Rl (cons_Rlist (cons r1 r2) l2) (S i)) in |- *; apply (H i); simpl in |- *; apply lt_S_n; assumption. Qed. diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index dd589646da..57b2c76756 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -32,10 +32,10 @@ Lemma tech_up : forall (r:R) (z:Z), r < IZR z -> IZR z <= r + 1 -> z = up r. Proof. intros; generalize (archimed r); intro; elim H1; intros; clear H1; unfold Rgt in H2; unfold Rminus in H3; - generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3); + generalize (Rplus_le_compat_l r (IZR (up r) + - r) 1 H3); intro; clear H3; rewrite (Rplus_comm (IZR (up r)) (- r)) in H1; rewrite <- (Rplus_assoc r (- r) (IZR (up r))) in H1; - rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r))); + rewrite (Rplus_opp_r r) in H1; elim (Rplus_ne (IZR (up r))); intros a b; rewrite b in H1; clear a b; apply (single_z_r_R1 r z (up r)); auto with zarith real. Qed. @@ -56,15 +56,15 @@ Qed. Lemma fp_R0 : frac_part 0 = 0. Proof. unfold frac_part in |- *; unfold Int_part in |- *; elim (archimed 0); intros; - unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1))); - intros a b; rewrite b; clear a b; rewrite <- Z_R_minus; + unfold Rminus in |- *; elim (Rplus_ne (- IZR (up 0 - 1))); + intros a b; rewrite b; clear a b; rewrite <- Z_R_minus; cut (up 0 = 1%Z). intro; rewrite H1; - rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1))); - apply Ropp_0. + rewrite (Rminus_diag_eq (IZR 1) (IZR 1) (refl_equal (IZR 1))); + apply Ropp_0. elim (archimed 0); intros; clear H2; unfold Rgt in H1; rewrite (Rminus_0_r (IZR (up 0))) in H0; generalize (lt_O_IZR (up 0) H1); - intro; clear H1; generalize (le_IZR_R1 (up 0) H0); + intro; clear H1; generalize (le_IZR_R1 (up 0) H0); intro; clear H H0; omega. Qed. @@ -92,12 +92,12 @@ Proof. apply Rge_minus; auto with zarith real. rewrite <- Ropp_minus_distr; apply Ropp_le_ge_contravar; elim (for_base_fp r); auto with zarith real. - (*inf a 1*) + (*inf a 1*) cut (r - IZR (up r) < 0). rewrite <- Z_R_minus; simpl in |- *; intro; unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; - fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive; - elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *; + fold (r - IZR (up r)) in |- *; rewrite Ropp_involutive; + elim (Rplus_ne 1); intros a b; pattern 1 at 2 in |- *; rewrite <- a; clear a b; rewrite (Rplus_comm (r - IZR (up r)) 1); apply Rplus_lt_compat_l; auto with zarith real. elim (for_base_fp r); intros; rewrite <- Ropp_0; rewrite <- Ropp_minus_distr; @@ -110,7 +110,7 @@ Qed. (**********) Lemma base_Int_part : - forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1. + forall r:R, IZR (Int_part r) <= r /\ IZR (Int_part r) - r > -1. Proof. intro; unfold Int_part in |- *; elim (archimed r); intros. split; rewrite <- (Z_R_minus (up r) 1); simpl in |- *. @@ -122,13 +122,13 @@ Proof. apply Rminus_le; auto with zarith real. generalize (Rplus_gt_compat_l (-1) (IZR (up r)) r H); intro; rewrite (Rplus_comm (-1) (IZR (up r))) in H1; - generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); + generalize (Rplus_gt_compat_l (- r) (IZR (up r) + -1) (-1 + r) H1); intro; clear H H0 H1; rewrite (Rplus_comm (- r) (IZR (up r) + -1)) in H2; fold (IZR (up r) - 1) in H2; fold (IZR (up r) - 1 - r) in H2; rewrite (Rplus_comm (- r) (-1 + r)) in H2; rewrite (Rplus_assoc (-1) r (- r)) in H2; rewrite (Rplus_opp_r r) in H2; - elim (Rplus_ne (-1)); intros a b; rewrite a in H2; - clear a b; auto with zarith real. + elim (Rplus_ne (-1)); intros a b; rewrite a in H2; + clear a b; auto with zarith real. Qed. (**********) @@ -168,19 +168,19 @@ Lemma Rminus_Int_part1 : Proof. intros; elim (base_fp r1); elim (base_fp r2); intros; generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0; - generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); + generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); intro; clear H4; rewrite Ropp_0 in H0; - generalize (Rge_le 0 (- frac_part r2) H0); intro; - clear H0; generalize (Rge_le (frac_part r1) 0 H2); + generalize (Rge_le 0 (- frac_part r2) H0); intro; + clear H0; generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1); intro; clear H1; unfold Rgt in H2; generalize (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4); - intro; elim H1; intros; clear H1; elim (Rplus_ne 1); + intro; elim H1; intros; clear H1; elim (Rplus_ne 1); intros a b; rewrite a in H6; clear a b H5; - generalize (Rge_minus (frac_part r1) (frac_part r2) H); + generalize (Rge_minus (frac_part r1) (frac_part r2) H); intro; clear H; fold (frac_part r1 - frac_part r2) in H6; - generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1); + generalize (Rge_le (frac_part r1 - frac_part r2) 0 H1); intro; clear H1 H3 H4 H0 H2; unfold frac_part in H6, H; unfold Rminus in H6, H; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H; @@ -195,7 +195,7 @@ Proof. fold (r1 - r2) in H; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H; generalize (Rplus_le_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) 0 - (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H); + (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H); intro; clear H; rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0; rewrite <- @@ -209,9 +209,9 @@ Proof. (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2)) (- IZR (Int_part r1))) in H0; rewrite (Rplus_opp_l (IZR (Int_part r2))) in H0; - elim (Rplus_ne (- IZR (Int_part r1))); intros a b; + elim (Rplus_ne (- IZR (Int_part r1))); intros a b; rewrite b in H0; clear a b; - elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2))); + elim (Rplus_ne (IZR (Int_part r1) + - IZR (Int_part r2))); intros a b; rewrite a in H0; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H0; elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; clear a b; @@ -229,7 +229,7 @@ Proof. fold (r1 - r2) in H6; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H6; generalize (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) - (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6); + (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 1 H6); intro; clear H6; rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H; rewrite <- @@ -238,14 +238,14 @@ Proof. in H; rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H; rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H; - elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; + elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; clear a b; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; - rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; + rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; cut (1 = IZR 1); auto with zarith real. intro; rewrite H1 in H; clear H1; rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H; - generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); - intros; clear H H0; unfold Int_part at 1 in |- *; + generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); + intros; clear H H0; unfold Int_part at 1 in |- *; omega. Qed. @@ -257,18 +257,18 @@ Lemma Rminus_Int_part2 : Proof. intros; elim (base_fp r1); elim (base_fp r2); intros; generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0; - generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); + generalize (Ropp_le_ge_contravar 0 (frac_part r2) H4); intro; clear H4; rewrite Ropp_0 in H0; - generalize (Rge_le 0 (- frac_part r2) H0); intro; - clear H0; generalize (Rge_le (frac_part r1) 0 H2); + generalize (Rge_le 0 (- frac_part r2) H0); intro; + clear H0; generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2; generalize (Ropp_lt_gt_contravar (frac_part r2) 1 H1); intro; clear H1; unfold Rgt in H2; generalize (sum_inequa_Rle_lt 0 (frac_part r1) 1 (-1) (- frac_part r2) 0 H0 H3 H2 H4); - intro; elim H1; intros; clear H1; elim (Rplus_ne (-1)); + intro; elim H1; intros; clear H1; elim (Rplus_ne (-1)); intros a b; rewrite b in H5; clear a b H6; - generalize (Rlt_minus (frac_part r1) (frac_part r2) H); - intro; clear H; fold (frac_part r1 - frac_part r2) in H5; + generalize (Rlt_minus (frac_part r1) (frac_part r2) H); + intro; clear H; fold (frac_part r1 - frac_part r2) in H5; clear H3 H4 H0 H2; unfold frac_part in H5, H1; unfold Rminus in H5, H1; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H5; rewrite (Ropp_involutive (IZR (Int_part r2))) in H5; @@ -283,7 +283,7 @@ Proof. fold (r1 - r2) in H5; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H5; generalize (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) (-1) - (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5); + (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) H5); intro; clear H5; rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H; rewrite <- @@ -297,9 +297,9 @@ Proof. (Rplus_assoc (- IZR (Int_part r2)) (IZR (Int_part r2)) (- IZR (Int_part r1))) in H; rewrite (Rplus_opp_l (IZR (Int_part r2))) in H; - elim (Rplus_ne (- IZR (Int_part r1))); intros a b; + elim (Rplus_ne (- IZR (Int_part r1))); intros a b; rewrite b in H; clear a b; rewrite (Rplus_opp_r (IZR (Int_part r1))) in H; - elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; + elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H; clear a b; fold (IZR (Int_part r1) - IZR (Int_part r2)) in H; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H; rewrite (Ropp_plus_distr r2 (- IZR (Int_part r2))) in H1; @@ -315,7 +315,7 @@ Proof. fold (r1 - r2) in H1; fold (IZR (Int_part r2) - IZR (Int_part r1)) in H1; generalize (Rplus_lt_compat_l (IZR (Int_part r1) - IZR (Int_part r2)) - (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1); + (r1 - r2 + (IZR (Int_part r2) - IZR (Int_part r1))) 0 H1); intro; clear H1; rewrite (Rplus_comm (r1 - r2) (IZR (Int_part r2) - IZR (Int_part r1))) in H0; rewrite <- @@ -324,21 +324,21 @@ Proof. in H0; rewrite <- (Ropp_minus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) - IZR (Int_part r2))) in H0; - elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; + elim (Rplus_ne (r1 - r2)); intros a b; rewrite b in H0; clear a b; rewrite <- (Rplus_opp_l 1) in H0; rewrite <- (Rplus_assoc (IZR (Int_part r1) - IZR (Int_part r2)) (-1) 1) in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; - rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; + rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; cut (1 = IZR 1); auto with zarith real. intro; rewrite H1 in H; rewrite H1 in H0; clear H1; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0; rewrite <- (plus_IZR (Int_part r1 - Int_part r2 - 1) 1) in H0; - generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H); + generalize (Rlt_le (IZR (Int_part r1 - Int_part r2 - 1)) (r1 - r2) H); intro; clear H; - generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0); - intros; clear H0 H1; unfold Int_part at 1 in |- *; + generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0); + intros; clear H0 H1; unfold Int_part at 1 in |- *; omega. Qed. @@ -358,7 +358,7 @@ Proof. rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2))); rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))); rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2))); - rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); + rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); auto with zarith real. Qed. @@ -370,7 +370,7 @@ Lemma Rminus_fp2 : Proof. intros; unfold frac_part in |- *; generalize (Rminus_Int_part2 r1 r2 H); intro; rewrite H0; rewrite <- (Z_R_minus (Int_part r1 - Int_part r2) 1); - rewrite <- (Z_R_minus (Int_part r1) (Int_part r2)); + rewrite <- (Z_R_minus (Int_part r1) (Int_part r2)); unfold Rminus in |- *; rewrite (Ropp_plus_distr (IZR (Int_part r1) + - IZR (Int_part r2)) (- IZR 1)) @@ -385,7 +385,7 @@ Proof. rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (- r2 + IZR (Int_part r2))); rewrite <- (Rplus_assoc (- r2) (- IZR (Int_part r1)) (IZR (Int_part r2))); rewrite <- (Rplus_assoc (- IZR (Int_part r1)) (- r2) (IZR (Int_part r2))); - rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); + rewrite (Rplus_comm (- r2) (- IZR (Int_part r1))); auto with zarith real. Qed. @@ -397,11 +397,11 @@ Lemma plus_Int_part1 : Proof. intros; generalize (Rge_le (frac_part r1 + frac_part r2) 1 H); intro; clear H; elim (base_fp r1); elim (base_fp r2); intros; clear H H2; - generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3); - intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1); + generalize (Rplus_lt_compat_l (frac_part r2) (frac_part r1) 1 H3); + intro; clear H3; generalize (Rplus_lt_compat_l 1 (frac_part r2) 1 H1); intro; clear H1; rewrite (Rplus_comm 1 (frac_part r2)) in H2; generalize - (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2); + (Rlt_trans (frac_part r2 + frac_part r1) (frac_part r2 + 1) 2 H H2); intro; clear H H2; rewrite (Rplus_comm (frac_part r2) (frac_part r1)) in H1; unfold frac_part in H0, H1; unfold Rminus in H0, H1; rewrite (Rplus_assoc r1 (- IZR (Int_part r1)) (r2 + - IZR (Int_part r2))) @@ -422,11 +422,11 @@ Proof. rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H0; generalize (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 1 - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0); + (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H0); intro; clear H0; generalize (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1); + (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 2 H1); intro; clear H1; rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) in H; @@ -434,7 +434,7 @@ Proof. (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) in H; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H; - elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H; + elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H; clear a b; rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) in H0; @@ -442,7 +442,7 @@ Proof. (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; - elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; + elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0; cut (1 = IZR 1); auto with zarith real. @@ -452,7 +452,7 @@ Proof. rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0; rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0; - generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); + generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); intro; clear H H0; unfold Int_part at 1 in |- *; omega. Qed. @@ -465,8 +465,8 @@ Proof. intros; elim (base_fp r1); elim (base_fp r2); intros; clear H1 H3; generalize (Rge_le (frac_part r2) 0 H0); intro; clear H0; generalize (Rge_le (frac_part r1) 0 H2); intro; clear H2; - generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1); - intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b; + generalize (Rplus_le_compat_l (frac_part r1) 0 (frac_part r2) H1); + intro; clear H1; elim (Rplus_ne (frac_part r1)); intros a b; rewrite a in H2; clear a b; generalize (Rle_trans 0 (frac_part r1) (frac_part r1 + frac_part r2) H0 H2); intro; clear H0 H2; unfold frac_part in H, H1; unfold Rminus in H, H1; @@ -487,11 +487,11 @@ Proof. rewrite <- (Ropp_plus_distr (IZR (Int_part r1)) (IZR (Int_part r2))) in H; generalize (Rplus_le_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) 0 - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1); + (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) H1); intro; clear H1; generalize (Rplus_lt_compat_l (IZR (Int_part r1) + IZR (Int_part r2)) - (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H); + (r1 + r2 + - (IZR (Int_part r1) + IZR (Int_part r2))) 1 H); intro; clear H; rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) in H1; @@ -499,7 +499,7 @@ Proof. (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) in H1; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H1; - elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1; + elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H1; clear a b; rewrite (Rplus_comm (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2)))) in H0; @@ -507,7 +507,7 @@ Proof. (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) (- (IZR (Int_part r1) + IZR (Int_part r2))) (r1 + r2)) in H0; rewrite (Rplus_opp_r (IZR (Int_part r1) + IZR (Int_part r2))) in H0; - elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2))); + elim (Rplus_ne (IZR (Int_part r1) + IZR (Int_part r2))); intros a b; rewrite a in H0; clear a b; elim (Rplus_ne (r1 + r2)); intros a b; rewrite b in H0; clear a b; cut (1 = IZR 1); auto with zarith real. @@ -515,8 +515,8 @@ Proof. rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H1; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1; - generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); - intro; clear H0 H1; unfold Int_part at 1 in |- *; + generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); + intro; clear H0 H1; unfold Int_part at 1 in |- *; omega. Qed. diff --git a/theories/Reals/R_sqr.v b/theories/Reals/R_sqr.v index 31a9b0b590..6460a92719 100644 --- a/theories/Reals/R_sqr.v +++ b/theories/Reals/R_sqr.v @@ -61,7 +61,7 @@ Proof. | elim H0; intro; [ elim H; symmetry in |- *; exact H1 | rewrite Rsqr_neg; generalize (Ropp_lt_gt_contravar x 0 H1); - rewrite Ropp_0; intro; unfold Rsqr in |- *; + rewrite Ropp_0; intro; unfold Rsqr in |- *; apply Rmult_lt_0_compat; assumption ] ]. Qed. @@ -103,8 +103,8 @@ Proof. [ assumption | cut (y < x); [ intro; unfold Rsqr in H; - generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2); - intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3); + generalize (Rmult_le_0_lt_compat y x y x H1 H1 H2 H2); + intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H3); intro; elim (Rlt_irrefl (x * x) H4) | auto with real ] ]. Qed. @@ -115,8 +115,8 @@ Proof. [ assumption | cut (y < x); [ intro; unfold Rsqr in H; - generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1); - intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2); + generalize (Rmult_le_0_lt_compat y x y x H0 H0 H1 H1); + intro; generalize (Rle_lt_trans (x * x) (y * y) (x * x) H H2); intro; elim (Rlt_irrefl (x * x) H3) | auto with real ] ]. Qed. @@ -152,7 +152,7 @@ Proof. generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro; generalize (Rlt_le 0 (- x) H1); intro; rewrite (Rsqr_neg x) in H; generalize (Rsqr_incr_0 (- x) y H H2 H0); intro; - rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar; + rewrite <- (Ropp_involutive x); apply Ropp_ge_le_contravar; apply Rle_ge; assumption. apply Rle_trans with 0; [ rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; assumption @@ -165,7 +165,7 @@ Proof. intros; case (Rcase_abs x); intro. generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro; generalize (Rlt_le 0 (- x) H2); intro; - generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; + generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; intro; generalize (Rge_le y (- x) H4); intro; rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption. generalize (Rge_le x 0 r); intro; apply Rsqr_incr_1; assumption. @@ -175,9 +175,9 @@ Lemma neg_pos_Rsqr_le : forall x y:R, - y <= x -> x <= y -> Rsqr x <= Rsqr y. Proof. intros; case (Rcase_abs x); intro. generalize (Ropp_lt_gt_contravar x 0 r); rewrite Ropp_0; intro; - generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; + generalize (Ropp_le_ge_contravar (- y) x H); rewrite Ropp_involutive; intro; generalize (Rge_le y (- x) H2); intro; generalize (Rlt_le 0 (- x) H1); - intro; generalize (Rle_trans 0 (- x) y H4 H3); intro; + intro; generalize (Rle_trans 0 (- x) y H4 H3); intro; rewrite (Rsqr_neg x); apply Rsqr_incr_1; assumption. generalize (Rge_le x 0 r); intro; generalize (Rle_trans 0 x y H1 H0); intro; apply Rsqr_incr_1; assumption. @@ -225,16 +225,16 @@ Proof. intros; unfold Rabs in |- *; case (Rcase_abs x); case (Rcase_abs y); intros. rewrite (Rsqr_neg x) in H; rewrite (Rsqr_neg y) in H; generalize (Ropp_lt_gt_contravar y 0 r); - generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; + generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; intros; generalize (Rlt_le 0 (- x) H0); generalize (Rlt_le 0 (- y) H1); intros; apply Rsqr_inj; assumption. rewrite (Rsqr_neg x) in H; generalize (Rge_le y 0 r); intro; - generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; - intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj; + generalize (Ropp_lt_gt_contravar x 0 r0); rewrite Ropp_0; + intro; generalize (Rlt_le 0 (- x) H1); intro; apply Rsqr_inj; assumption. rewrite (Rsqr_neg y) in H; generalize (Rge_le x 0 r0); intro; - generalize (Ropp_lt_gt_contravar y 0 r); rewrite Ropp_0; - intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj; + generalize (Ropp_lt_gt_contravar y 0 r); rewrite Ropp_0; + intro; generalize (Rlt_le 0 (- y) H1); intro; apply Rsqr_inj; assumption. generalize (Rge_le x 0 r0); generalize (Rge_le y 0 r); intros; apply Rsqr_inj; assumption. diff --git a/theories/Reals/R_sqrt.v b/theories/Reals/R_sqrt.v index 627f041021..ef9caa4024 100644 --- a/theories/Reals/R_sqrt.v +++ b/theories/Reals/R_sqrt.v @@ -40,7 +40,7 @@ Qed. Lemma sqrt_0 : sqrt 0 = 0. Proof. - apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity. + apply Rsqr_eq_0; unfold Rsqr in |- *; apply sqrt_sqrt; right; reflexivity. Qed. Lemma sqrt_1 : sqrt 1 = 1. @@ -48,7 +48,7 @@ Proof. apply (Rsqr_inj (sqrt 1) 1); [ apply sqrt_positivity; left | left - | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ]; + | unfold Rsqr in |- *; rewrite sqrt_sqrt; [ ring | left ] ]; apply Rlt_0_1. Qed. @@ -108,7 +108,7 @@ Proof. (Rsqr_inj (sqrt (x * y)) (sqrt x * sqrt y) (sqrt_positivity (x * y) (Rmult_le_pos x y H1 H2)) (Rmult_le_pos (sqrt x) (sqrt y) (sqrt_positivity x H1) - (sqrt_positivity y H2))); rewrite Rsqr_mult; + (sqrt_positivity y H2))); rewrite Rsqr_mult; repeat rewrite Rsqr_sqrt; [ ring | assumption | assumption | apply (Rmult_le_pos x y H1 H2) ]. Qed. @@ -132,7 +132,7 @@ Proof. | apply (Rmult_le_pos (sqrt x) (/ sqrt y)); [ apply (sqrt_positivity x H1) | generalize (sqrt_lt_R0 y H2); clear H2; intro H2; - generalize (Rinv_0_lt_compat (sqrt y) H2); clear H2; + generalize (Rinv_0_lt_compat (sqrt y) H2); clear H2; intro H2; left; assumption ] | rewrite Rsqr_div; repeat rewrite Rsqr_sqrt; [ reflexivity @@ -193,7 +193,7 @@ Qed. Lemma sqrt_less : forall x:R, 0 <= x -> 1 < x -> sqrt x < x. Proof. intros x H1 H2; generalize (sqrt_lt_1 1 x (Rlt_le 0 1 Rlt_0_1) H1 H2); - intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); + intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 2 in |- *; rewrite <- (sqrt_def x H1); apply @@ -204,8 +204,8 @@ Qed. Lemma sqrt_more : forall x:R, 0 < x -> x < 1 -> x < sqrt x. Proof. intros x H1 H2; - generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2); - intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); + generalize (sqrt_lt_1 x 1 (Rlt_le 0 x H1) (Rlt_le 0 1 Rlt_0_1) H2); + intro H3; rewrite sqrt_1 in H3; generalize (Rmult_ne (sqrt x)); intro H4; elim H4; intros H5 H6; rewrite <- H5; pattern x at 1 in |- *; rewrite <- (sqrt_def x (Rlt_le 0 x H1)); apply (Rmult_lt_compat_l (sqrt x) (sqrt x) 1 (sqrt_lt_R0 x H1) H3). @@ -338,7 +338,7 @@ Proof. (b * (- b * (/ 2 * / a)) + c). repeat rewrite <- Rplus_assoc; replace (b * b + b * b) with (2 * (b * b)). rewrite Rmult_plus_distr_r; repeat rewrite Rmult_assoc; - rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; + rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. rewrite Ropp_mult_distr_l_reverse; repeat rewrite Rmult_assoc. rewrite (Rmult_comm 2); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym. diff --git a/theories/Reals/Ranalysis.v b/theories/Reals/Ranalysis.v index 371c1af749..500dd5295d 100644 --- a/theories/Reals/Ranalysis.v +++ b/theories/Reals/Ranalysis.v @@ -85,7 +85,7 @@ Ltac intro_hyp_glob trm := match goal with | _:(forall x0:R, aux x0 <> 0) |- (derivable _) => intro_hyp_glob X1 - | _:(forall x0:R, aux x0 <> 0) |- (continuity _) => + | _:(forall x0:R, aux x0 <> 0) |- (continuity _) => intro_hyp_glob X1 | |- (derivable _) => cut (forall x0:R, aux x0 <> 0); @@ -277,7 +277,7 @@ Ltac intro_hyp_pt trm pt := Ltac is_diff_pt := match goal with | |- (derivable_pt Rsqr _) => - + (* fonctions de base *) apply derivable_pt_Rsqr | |- (derivable_pt id ?X1) => apply (derivable_pt_id X1) @@ -326,7 +326,7 @@ Ltac is_diff_pt := unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, comp, pow_fct, id, fct_cte in |- * ] | |- (derivable_pt (/ ?X1) ?X2) => - + (* INVERSION *) apply (derivable_pt_inv X1 X2); [ assumption || @@ -334,7 +334,7 @@ Ltac is_diff_pt := comp, pow_fct, id, fct_cte in |- * | is_diff_pt ] | |- (derivable_pt (comp ?X1 ?X2) ?X3) => - + (* COMPOSITION *) apply (derivable_pt_comp X2 X1 X3); is_diff_pt | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) => @@ -352,7 +352,7 @@ Ltac is_diff_pt := (**********) Ltac is_diff_glob := match goal with - | |- (derivable Rsqr) => + | |- (derivable Rsqr) => (* fonctions de base *) apply derivable_Rsqr | |- (derivable id) => apply derivable_id @@ -392,7 +392,7 @@ Ltac is_diff_glob := unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id, fct_cte, comp, pow_fct in |- * ] | |- (derivable (/ ?X1)) => - + (* INVERSION *) apply (derivable_inv X1); [ try @@ -401,7 +401,7 @@ Ltac is_diff_glob := id, fct_cte, comp, pow_fct in |- * | is_diff_glob ] | |- (derivable (comp sqrt _)) => - + (* COMPOSITION *) unfold derivable in |- *; intro; try is_diff_pt | |- (derivable (comp Rabs _)) => @@ -421,7 +421,7 @@ Ltac is_diff_glob := Ltac is_cont_pt := match goal with | |- (continuity_pt Rsqr _) => - + (* fonctions de base *) apply derivable_continuous_pt; apply derivable_pt_Rsqr | |- (continuity_pt id ?X1) => @@ -475,7 +475,7 @@ Ltac is_cont_pt := unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, comp, id, fct_cte, pow_fct in |- * ] | |- (continuity_pt (/ ?X1) ?X2) => - + (* INVERSION *) apply (continuity_pt_inv X1 X2); [ is_cont_pt @@ -483,7 +483,7 @@ Ltac is_cont_pt := unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, comp, id, fct_cte, pow_fct in |- * ] | |- (continuity_pt (comp ?X1 ?X2) ?X3) => - + (* COMPOSITION *) apply (continuity_pt_comp X2 X1 X3); is_cont_pt | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) => @@ -508,7 +508,7 @@ Ltac is_cont_pt := Ltac is_cont_glob := match goal with | |- (continuity Rsqr) => - + (* fonctions de base *) apply derivable_continuous; apply derivable_Rsqr | |- (continuity id) => apply derivable_continuous; apply derivable_id @@ -559,7 +559,7 @@ Ltac is_cont_glob := unfold plus_fct, mult_fct, div_fct, minus_fct, opp_fct, inv_fct, id, fct_cte, pow_fct in |- * ] | |- (continuity (comp sqrt _)) => - + (* COMPOSITION *) unfold continuity_pt in |- *; intro; try is_cont_pt | |- (continuity (comp ?X1 ?X2)) => diff --git a/theories/Reals/Ranalysis1.v b/theories/Reals/Ranalysis1.v index de43711c3a..1516b3384e 100644 --- a/theories/Reals/Ranalysis1.v +++ b/theories/Reals/Ranalysis1.v @@ -61,7 +61,7 @@ Definition strict_increasing f : Prop := forall x y:R, x < y -> f x < f y. Definition strict_decreasing f : Prop := forall x y:R, x < y -> f y < f x. Definition constant f : Prop := forall x y:R, f x = f y. -(**********) +(**********) Definition no_cond (x:R) : Prop := True. (**********) @@ -114,7 +114,7 @@ Qed. Lemma continuity_pt_const : forall f (x0:R), constant f -> continuity_pt f x0. Proof. unfold constant, continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; intros; exists 1; split; [ apply Rlt_0_1 | intros; generalize (H x x0); intro; rewrite H2; simpl in |- *; @@ -196,7 +196,7 @@ Proof. elim H5; intros; assumption. Qed. -(**********) +(**********) Lemma continuity_plus : forall f1 f2, continuity f1 -> continuity f2 -> continuity (f1 + f2). Proof. @@ -322,18 +322,18 @@ Proof. prove_sup0. rewrite (Rmult_comm 2); rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ]; rewrite Rmult_1_r; rewrite double; - pattern alp at 1 in |- *; replace alp with (alp + 0); + pattern alp at 1 in |- *; replace alp with (alp + 0); [ idtac | ring ]; apply Rplus_lt_compat_l; assumption. symmetry in |- *; apply Rabs_right; left; assumption. symmetry in |- *; apply Rabs_right; left; change (0 < / 2) in |- *; - apply Rinv_0_lt_compat; prove_sup0. + apply Rinv_0_lt_compat; prove_sup0. Qed. Lemma uniqueness_step2 : forall f (x l:R), derivable_pt_lim f x l -> limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) l 0. -Proof. +Proof. unfold derivable_pt_lim in |- *; intros; unfold limit1_in in |- *; unfold limit_in in |- *; intros. assert (H1 := H eps H0). @@ -418,10 +418,10 @@ Proof. intros; split. unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros. - apply derive_pt_eq_0. + apply derive_pt_eq_0. unfold derivable_pt_lim in |- *. intros; elim (H eps H0); intros alpha H1; elim H1; intros; - exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); + exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); intro; cut (x + h - x = h); [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha); [ intro; generalize (H6 H8); rewrite H7; intro; assumption @@ -434,7 +434,7 @@ Proof. intro. assert (H0 := derive_pt_eq_1 f x (df x) pr H). unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *; - unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; + unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; intros. elim (H0 eps H1); intros alpha H2; exists (pos alpha); split. apply (cond_pos alpha). @@ -454,7 +454,7 @@ Proof. simpl in |- *; unfold R_dist in |- *; intros. unfold derivable_pt_lim in |- *. intros; elim (H eps H0); intros alpha H1; elim H1; intros; - exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); + exists (mkposreal alpha H2); intros; generalize (H3 (x + h)); intro; cut (x + h - x = h); [ intro; cut (D_x no_cond x (x + h) /\ Rabs (x + h - x) < alpha); [ intro; generalize (H6 H8); rewrite H7; intro; assumption @@ -467,7 +467,7 @@ Proof. intro. unfold derivable_pt_lim in H. unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *; - unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; + unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; intros. elim (H eps H0); intros alpha H2; exists (pos alpha); split. apply (cond_pos alpha). @@ -548,7 +548,7 @@ Qed. Lemma derivable_pt_lim_opp : forall f (x l:R), derivable_pt_lim f x l -> derivable_pt_lim (- f) x (- l). -Proof. +Proof. intros. apply uniqueness_step3. assert (H1 := uniqueness_step2 _ _ _ H). @@ -1066,7 +1066,7 @@ Qed. Lemma pr_nu : forall f (x:R) (pr1 pr2:derivable_pt f x), - derive_pt f x pr1 = derive_pt f x pr2. + derive_pt f x pr1 = derive_pt f x pr2. Proof. intros. unfold derivable_pt in pr1. @@ -1141,7 +1141,7 @@ Proof. - ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) / Rmin (delta / 2) ((b + - c) / 2))) (l / 2) H19); - repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; + repeat rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; replace (- l + l / 2) with (- (l / 2)). intro; generalize @@ -1168,7 +1168,7 @@ Proof. Rge_le ((f (c + Rmin (delta / 2) ((b + - c) / 2)) + - f c) / Rmin (delta / 2) ((b + - c) / 2) + - l) 0 r). - elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)). + elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H20 H18)). assumption. rewrite <- Ropp_0; replace @@ -1260,7 +1260,7 @@ Proof. prove_sup0. rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym. rewrite Rmult_1_l. - replace (2 * delta) with (delta + delta). + replace (2 * delta) with (delta + delta). pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta); apply Rplus_lt_compat_l. rewrite Rplus_0_r; apply (cond_pos delta). @@ -1270,7 +1270,7 @@ Proof. intro; generalize (Rmin_stable_in_posreal (mkposreal (delta / 2) H9) - (mkposreal ((b - c) / 2) H8)); simpl in |- *; + (mkposreal ((b - c) / 2) H8)); simpl in |- *; intro; red in |- *; intro; rewrite H11 in H10; elim (Rlt_irrefl 0 H10). unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ]. @@ -1307,7 +1307,7 @@ Proof. cut (Rabs ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) / - Rmax (- (delta / 2)) ((a + - c) / 2) + - l) < + Rmax (- (delta / 2)) ((a + - c) / 2) + - l) < - (l / 2)). unfold Rabs in |- *; case @@ -1332,7 +1332,7 @@ Proof. generalize (Rlt_trans ((f (c + Rmax (- (delta / 2)) ((a + - c) / 2)) + - f c) / - Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21); + Rmax (- (delta / 2)) ((a + - c) / 2)) (l / 2) 0 H22 H21); intro; elim (Rlt_irrefl 0 @@ -1369,7 +1369,7 @@ Proof. reflexivity. unfold Rdiv in H11; assumption. generalize (Rplus_lt_compat_l c (Rmax (- (delta / 2)) ((a - c) / 2)) 0 H10); - rewrite Rplus_0_r; intro; apply Rlt_trans with c; + rewrite Rplus_0_r; intro; apply Rlt_trans with c; assumption. generalize (RmaxLess2 (- (delta / 2)) ((a - c) / 2)); intro; generalize @@ -1390,21 +1390,21 @@ Proof. generalize (Rge_le (delta / 2) (- Rmax (- (delta / 2)) ((a - c) / 2)) H13); intro; apply Rle_lt_trans with (delta / 2). assumption. - apply Rmult_lt_reg_l with 2. + apply Rmult_lt_reg_l with 2. prove_sup0. unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym. rewrite Rmult_1_l; rewrite double. pattern delta at 2 in |- *; rewrite <- (Rplus_0_r delta); apply Rplus_lt_compat_l; rewrite Rplus_0_r; apply (cond_pos delta). - discrR. + discrR. cut (- (delta / 2) < 0). cut ((a - c) / 2 < 0). intros; generalize (Rmax_stable_in_negreal (mknegreal (- (delta / 2)) H13) - (mknegreal ((a - c) / 2) H12)); simpl in |- *; - intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r); + (mknegreal ((a - c) / 2) H12)); simpl in |- *; + intro; generalize (Rge_le (Rmax (- (delta / 2)) ((a - c) / 2)) 0 r); intro; elim (Rlt_irrefl 0 @@ -1413,7 +1413,7 @@ Proof. apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2). assumption. unfold Rdiv in |- *. - rewrite <- Ropp_mult_distr_l_reverse. + rewrite <- Ropp_mult_distr_l_reverse. rewrite (Ropp_minus_distr a c). reflexivity. rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; unfold Rdiv in |- *; @@ -1435,7 +1435,7 @@ Proof. apply Ropp_lt_gt_contravar; replace (- ((a - c) / 2)) with ((c - a) / 2). assumption. unfold Rdiv in |- *. - rewrite <- Ropp_mult_distr_l_reverse. + rewrite <- Ropp_mult_distr_l_reverse. rewrite (Ropp_minus_distr a c). reflexivity. unfold Rdiv in |- *; apply Rmult_lt_0_compat; @@ -1532,7 +1532,7 @@ Proof. generalize (Rplus_le_compat_l (- f x) (f x) (f (x + delta * / 2)) H12); rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption. pattern x at 1 in |- *; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l; - left; assumption. + left; assumption. left; apply Rinv_0_lt_compat; assumption. split. unfold Rdiv in |- *; apply prod_neq_R0. diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index d9937e225e..66bac9de77 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -36,16 +36,16 @@ Proof. replace (l1 * (/ f2 x * / f2 (x + h)) * - f2 (x + h)) with (- (l1 * / f2 x * (f2 (x + h) * / f2 (x + h)))); [ idtac | ring ]. replace (f1 x * (/ f2 x * / f2 (x + h)) * (f2 (x + h) * / h)) with - (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h))); + (f1 x * / f2 x * / h * (f2 (x + h) * / f2 (x + h))); [ idtac | ring ]. replace (f1 x * (/ f2 x * / f2 (x + h)) * (- f2 x * / h)) with - (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x))); + (- (f1 x * / f2 (x + h) * / h * (f2 x * / f2 x))); [ idtac | ring ]. replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * f2 (x + h)) with (l2 * f1 x * / f2 x * / f2 x * (f2 (x + h) * / f2 (x + h))); [ idtac | ring ]. replace (l2 * f1 x * (/ f2 x * / f2 x * / f2 (x + h)) * - f2 x) with - (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x))); + (- (l2 * f1 x * / f2 x * / f2 (x + h) * (f2 x * / f2 x))); [ idtac | ring ]. repeat rewrite <- Rinv_r_sym; try assumption || ring. apply prod_neq_R0; assumption. @@ -58,7 +58,7 @@ Proof. Qed. Lemma maj_term1 : - forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal) + forall (x h eps l1 alp_f2:R) (eps_f2 alp_f1d:posreal) (f1 f2:R -> R), 0 < eps -> f2 x <> 0 -> @@ -105,7 +105,7 @@ Proof. Qed. Lemma maj_term2 : - forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal) + forall (x h eps l1 alp_f2 alp_f2t2:R) (eps_f2:posreal) (f2:R -> R), 0 < eps -> f2 x <> 0 -> @@ -143,7 +143,7 @@ Proof. replace (Rabs 2) with 2. rewrite (Rmult_comm 2). replace (Rabs l1 * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with - (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); + (Rabs l1 * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); [ idtac | ring ]. repeat apply Rmult_lt_compat_l. apply Rabs_pos_lt; assumption. @@ -176,7 +176,7 @@ Proof. Qed. Lemma maj_term3 : - forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal) + forall (x h eps l2 alp_f2:R) (eps_f2 alp_f2d:posreal) (f1 f2:R -> R), 0 < eps -> f2 x <> 0 -> @@ -218,7 +218,7 @@ Proof. replace (Rabs 2) with 2. rewrite (Rmult_comm 2). replace (Rabs (f1 x) * (Rabs (/ f2 x) * Rabs (/ f2 x)) * 2) with - (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); + (Rabs (f1 x) * (Rabs (/ f2 x) * (Rabs (/ f2 x) * 2))); [ idtac | ring ]. repeat apply Rmult_lt_compat_l. apply Rabs_pos_lt; assumption. @@ -251,7 +251,7 @@ Proof. Qed. Lemma maj_term4 : - forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal) + forall (x h eps l2 alp_f2 alp_f2c:R) (eps_f2:posreal) (f1 f2:R -> R), 0 < eps -> f2 x <> 0 -> @@ -431,7 +431,7 @@ Proof. assert (Hyp : 0 < 2). prove_sup0. intro; rewrite H11 in H10; assert (H12 := Rmult_lt_compat_l 2 _ _ Hyp H10); - rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12; + rewrite Rmult_1_r in H12; rewrite <- Rinv_r_sym in H12; [ idtac | discrR ]. cut (IZR 1 < IZR 2). unfold IZR in |- *; unfold INR, nat_of_P in |- *; simpl in |- *; intro; diff --git a/theories/Reals/Ranalysis3.v b/theories/Reals/Ranalysis3.v index cb48a26b82..3de97ba903 100644 --- a/theories/Reals/Ranalysis3.v +++ b/theories/Reals/Ranalysis3.v @@ -213,7 +213,7 @@ Proof. apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc; repeat apply prod_neq_R0. red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6). - assumption. + assumption. assumption. apply Rinv_neq_0_compat; repeat apply prod_neq_R0; [ discrR | discrR | discrR | assumption ]. @@ -380,7 +380,7 @@ Proof. unfold Rdiv, Rsqr in |- *. repeat rewrite Rinv_mult_distr; try assumption. repeat apply prod_neq_R0; try assumption. - red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). + red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. @@ -408,14 +408,14 @@ Proof. unfold Rsqr, Rdiv in |- *. repeat rewrite Rinv_mult_distr; try assumption || discrR. repeat apply prod_neq_R0; try assumption. - red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). + red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; assumption. apply Rinv_neq_0_compat; assumption. apply prod_neq_R0; [ discrR | assumption ]. - red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). + red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6). apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. apply Rinv_neq_0_compat; discrR. @@ -519,7 +519,7 @@ Proof. repeat apply Rmin_pos. apply (cond_pos eps_f2). elim H3; intros; assumption. - apply (cond_pos alp_f1d). + apply (cond_pos alp_f1d). apply (cond_pos alp_f2d). elim H11; intros; assumption. apply Rabs_pos_lt. @@ -776,7 +776,7 @@ Proof. Qed. Lemma derive_pt_div : - forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x) + forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x) (pr2:derivable_pt f2 x) (na:f2 x <> 0), derive_pt (f1 / f2) x (derivable_pt_div _ _ _ pr1 pr2 na) = (derive_pt f1 x pr1 * f2 x - derive_pt f2 x pr2 * f1 x) / Rsqr (f2 x). diff --git a/theories/Reals/Ranalysis4.v b/theories/Reals/Ranalysis4.v index adda4e5a5e..1ed3fb7135 100644 --- a/theories/Reals/Ranalysis4.v +++ b/theories/Reals/Ranalysis4.v @@ -31,8 +31,8 @@ Proof. unfold div_fct, inv_fct, fct_cte in |- *; intro X0; elim X0; intros; unfold derivable_pt in |- *; exists x0; unfold derivable_pt_abs in |- *; unfold derivable_pt_lim in |- *; - unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; - intros; elim (p eps H0); intros; exists x1; intros; + unfold derivable_pt_abs in p; unfold derivable_pt_lim in p; + intros; elim (p eps H0); intros; exists x1; intros; unfold Rdiv in H1; unfold Rdiv in |- *; rewrite <- (Rmult_1_l (/ f x)); rewrite <- (Rmult_1_l (/ f (x + h))). apply H1; assumption. @@ -60,14 +60,14 @@ Proof. elim pr1; intros. elim pr2; intros. simpl in |- *. - assert (H0 := uniqueness_step2 _ _ _ p). - assert (H1 := uniqueness_step2 _ _ _ p0). + assert (H0 := uniqueness_step2 _ _ _ p). + assert (H1 := uniqueness_step2 _ _ _ p0). cut (limit1_in (fun h:R => (f (x + h) - f x) / h) (fun h:R => h <> 0) x1 0). - intro; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2). + intro; assert (H3 := uniqueness_step1 _ _ _ _ H0 H2). assumption. unfold limit1_in in |- *; unfold limit_in in |- *; unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; unfold limit1_in in H1; - unfold limit_in in H1; unfold dist in H1; simpl in H1; + unfold limit_in in H1; unfold dist in H1; simpl in H1; unfold R_dist in H1. intros; elim (H1 eps H2); intros. elim H3; intros. @@ -122,7 +122,7 @@ Proof. case (Rcase_abs h); intro. rewrite (Rabs_left h r) in H2. left; rewrite Rplus_comm; apply Rplus_lt_reg_r with (- h); rewrite Rplus_0_r; - rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; + rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; apply H2. apply Rplus_le_le_0_compat. left; apply H. @@ -178,12 +178,12 @@ Proof. unfold continuity in |- *; intro. case (Req_dec x 0); intro. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; unfold R_dist in |- *; intros; exists eps; + unfold limit1_in in |- *; unfold limit_in in |- *; + simpl in |- *; unfold R_dist in |- *; intros; exists eps; split. apply H0. intros; rewrite H; rewrite Rabs_R0; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1; + rewrite Rplus_0_r; rewrite Rabs_Rabsolu; elim H1; intros; rewrite H in H3; unfold Rminus in H3; rewrite Ropp_0 in H3; rewrite Rplus_0_r in H3; apply H3. apply derivable_continuous_pt; apply (Rderivable_pt_abs x H). @@ -297,7 +297,7 @@ Proof. induction N as [| N HrecN]. exists 0; apply H. exists - (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))); + (sum_f_R0 (fun k:nat => INR (S k) * An (S k) * x ^ k) (pred (S N))); apply H. Qed. @@ -317,7 +317,7 @@ Proof. ((exp + comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ]. replace ((exp x - exp (- x)) * / 2) with ((exp x + exp (- x) * -1) * fct_cte (/ 2) x + - (exp + comp exp (- id))%F x * 0). + (exp + comp exp (- id))%F x * 0). apply derivable_pt_lim_mult. apply derivable_pt_lim_plus. apply derivable_pt_lim_exp. @@ -337,7 +337,7 @@ Proof. ((exp - comp exp (- id)) * fct_cte (/ 2))%F; [ idtac | reflexivity ]. replace ((exp x + exp (- x)) * / 2) with ((exp x - exp (- x) * -1) * fct_cte (/ 2) x + - (exp - comp exp (- id))%F x * 0). + (exp - comp exp (- id))%F x * 0). apply derivable_pt_lim_mult. apply derivable_pt_lim_minus. apply derivable_pt_lim_exp. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index eddcb561a1..9715414f5e 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -40,13 +40,13 @@ Hint Resolve Rplus_opp_r: real v62. Axiom Rplus_0_l : forall r:R, 0 + r = r. Hint Resolve Rplus_0_l: real. -(***********************************************************) +(***********************************************************) (** ** Multiplication *) (***********************************************************) (**********) Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. -Hint Resolve Rmult_comm: real v62. +Hint Resolve Rmult_comm: real v62. (**********) Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3). @@ -102,7 +102,7 @@ Axiom Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. -(**********************************************************) +(**********************************************************) (** * Injection from N to R *) (**********************************************************) @@ -112,11 +112,11 @@ Boxed Fixpoint INR (n:nat) : R := | O => 0 | S O => 1 | S n => INR n + 1 - end. + end. Arguments Scope INR [nat_scope]. -(**********************************************************) +(**********************************************************) (** * Injection from [Z] to [R] *) (**********************************************************) @@ -126,7 +126,7 @@ Definition IZR (z:Z) : R := | Z0 => 0 | Zpos n => INR (nat_of_P n) | Zneg n => - INR (nat_of_P n) - end. + end. Arguments Scope IZR [Z_scope]. (**********************************************************) diff --git a/theories/Reals/Rbasic_fun.v b/theories/Reals/Rbasic_fun.v index 1fcf6f61e4..5c3a929afa 100644 --- a/theories/Reals/Rbasic_fun.v +++ b/theories/Reals/Rbasic_fun.v @@ -151,7 +151,7 @@ Qed. (*******************************) (*********) -Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}. +Lemma Rcase_abs : forall r, {r < 0} + {r >= 0}. Proof. intro; generalize (Rle_dec 0 r); intro X; elim X; intro; clear X. right; apply (Rle_ge 0 r a). @@ -248,7 +248,7 @@ Proof. elimtype False; clear H0; elim H; clear H; generalize H1; unfold Rabs in |- *; case (Rcase_abs x); intros; auto. clear r H1; generalize (Rplus_eq_compat_l x 0 (- x) H0); - rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x); + rewrite (let (H1, H2) := Rplus_ne x in H1); rewrite (Rplus_opp_r x); trivial. Qed. @@ -258,13 +258,13 @@ Proof. intros; unfold Rabs in |- *; case (Rcase_abs (x - y)); case (Rcase_abs (y - x)); intros. generalize (Rminus_lt y x r); generalize (Rminus_lt x y r0); intros; - generalize (Rlt_asym x y H); intro; elimtype False; + generalize (Rlt_asym x y H); intro; elimtype False; auto. rewrite (Ropp_minus_distr x y); trivial. rewrite (Ropp_minus_distr y x); trivial. unfold Rge in r, r0; elim r; elim r0; intros; clear r r0. generalize (Ropp_lt_gt_0_contravar (x - y) H); rewrite (Ropp_minus_distr x y); - intro; unfold Rgt in H0; generalize (Rlt_asym 0 (y - x) H0); + intro; unfold Rgt in H0; generalize (Rlt_asym 0 (y - x) H0); intro; elimtype False; auto. rewrite (Rminus_diag_uniq x y H); trivial. rewrite (Rminus_diag_uniq y x H0); trivial. @@ -277,15 +277,15 @@ Proof. intros; unfold Rabs in |- *; case (Rcase_abs (x * y)); case (Rcase_abs x); case (Rcase_abs y); intros; auto. generalize (Rmult_lt_gt_compat_neg_l y x 0 r r0); intro; - rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1); - intro; unfold Rgt in H; elimtype False; rewrite (Rmult_comm y x) in H; + rewrite (Rmult_0_r y) in H; generalize (Rlt_asym (x * y) 0 r1); + intro; unfold Rgt in H; elimtype False; rewrite (Rmult_comm y x) in H; auto. - rewrite (Ropp_mult_distr_l_reverse x y); trivial. + rewrite (Ropp_mult_distr_l_reverse x y); trivial. rewrite (Rmult_comm x (- y)); rewrite (Ropp_mult_distr_l_reverse y x); rewrite (Rmult_comm x y); trivial. unfold Rge in r, r0; elim r; elim r0; clear r r0; intros; unfold Rgt in H, H0. generalize (Rmult_lt_compat_l x 0 y H H0); intro; rewrite (Rmult_0_r x) in H1; - generalize (Rlt_asym (x * y) 0 r1); intro; elimtype False; + generalize (Rlt_asym (x * y) 0 r1); intro; elimtype False; auto. rewrite H in r1; rewrite (Rmult_0_l y) in r1; generalize (Rlt_irrefl 0); intro; elimtype False; auto. @@ -297,27 +297,27 @@ Proof. unfold Rge in r, r1; elim r; elim r1; clear r r1; intros; unfold Rgt in H0, H. generalize (Rmult_lt_compat_l y x 0 H0 r0); intro; rewrite (Rmult_0_r y) in H1; rewrite (Rmult_comm y x) in H1; - generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; + generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; auto. generalize (Rlt_dichotomy_converse x 0 (or_introl (x > 0) r0)); - generalize (Rlt_dichotomy_converse y 0 (or_intror (y < 0) H0)); - intros; generalize (Rmult_integral x y H); intro; - elim H3; intro; elimtype False; auto. + generalize (Rlt_dichotomy_converse y 0 (or_intror (y < 0) H0)); + intros; generalize (Rmult_integral x y H); intro; + elim H3; intro; elimtype False; auto. rewrite H0 in H; rewrite (Rmult_0_r x) in H; unfold Rgt in H; - generalize (Rlt_irrefl 0); intro; elimtype False; + generalize (Rlt_irrefl 0); intro; elimtype False; auto. rewrite H0; rewrite (Rmult_0_r x); rewrite (Rmult_0_r (- x)); trivial. unfold Rge in r0, r1; elim r0; elim r1; clear r0 r1; intros; unfold Rgt in H0, H. generalize (Rmult_lt_compat_l x y 0 H0 r); intro; rewrite (Rmult_0_r x) in H1; - generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; + generalize (Rlt_asym (x * y) 0 H1); intro; elimtype False; auto. generalize (Rlt_dichotomy_converse y 0 (or_introl (y > 0) r)); - generalize (Rlt_dichotomy_converse 0 x (or_introl (0 > x) H0)); - intros; generalize (Rmult_integral x y H); intro; - elim H3; intro; elimtype False; auto. + generalize (Rlt_dichotomy_converse 0 x (or_introl (0 > x) H0)); + intros; generalize (Rmult_integral x y H); intro; + elim H3; intro; elimtype False; auto. rewrite H0 in H; rewrite (Rmult_0_l y) in H; unfold Rgt in H; - generalize (Rlt_irrefl 0); intro; elimtype False; + generalize (Rlt_irrefl 0); intro; elimtype False; auto. rewrite H0; rewrite (Rmult_0_l y); rewrite (Rmult_0_l (- y)); trivial. Qed. @@ -337,7 +337,7 @@ Proof. unfold Rgt in H0; generalize (Rlt_asym 0 (/ r) (Rinv_0_lt_compat r H0)); intro; elimtype False; auto. elimtype False; auto. -Qed. +Qed. Lemma Rabs_Ropp : forall x:R, Rabs (- x) = Rabs x. Proof. @@ -353,7 +353,7 @@ Proof. generalize (Ropp_le_ge_contravar 0 (-1) H1). rewrite Ropp_involutive; rewrite Ropp_0. intro; generalize (Rgt_not_le 1 0 Rlt_0_1); intro; generalize (Rge_le 0 1 H2); - intro; elimtype False; auto. + intro; elimtype False; auto. ring. Qed. @@ -368,7 +368,7 @@ Proof. rewrite (Ropp_plus_distr a b); apply (Rplus_le_compat_l (- a) (- b) b); unfold Rle in |- *; unfold Rge in r; elim r; intro. left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- b) 0 b H); intro; - elim (Rplus_ne (- b)); intros v w; rewrite v in H0; + elim (Rplus_ne (- b)); intros v w; rewrite v in H0; clear v w; rewrite (Rplus_opp_l b) in H0; apply (Rlt_trans (- b) 0 b H0 H). right; rewrite H; apply Ropp_0. (**) @@ -376,13 +376,13 @@ Proof. rewrite (Rplus_comm a (- b)); apply (Rplus_le_compat_l (- b) (- a) a); unfold Rle in |- *; unfold Rge in r0; elim r0; intro. left; unfold Rgt in H; generalize (Rplus_lt_compat_l (- a) 0 a H); intro; - elim (Rplus_ne (- a)); intros v w; rewrite v in H0; + elim (Rplus_ne (- a)); intros v w; rewrite v in H0; clear v w; rewrite (Rplus_opp_l a) in H0; apply (Rlt_trans (- a) 0 a H0 H). right; rewrite H; apply Ropp_0. (**) elimtype False; generalize (Rplus_ge_compat_l a b 0 r); intro; elim (Rplus_ne a); intros v w; rewrite v in H; clear v w; - generalize (Rge_trans (a + b) a 0 H r0); intro; clear H; + generalize (Rge_trans (a + b) a 0 H r0); intro; clear H; unfold Rge in H0; elim H0; intro; clear H0. unfold Rgt in H; generalize (Rlt_asym (a + b) 0 r1); intro; auto. absurd (a + b = 0); auto. @@ -390,7 +390,7 @@ Proof. (**) elimtype False; generalize (Rplus_lt_compat_l a b 0 r); intro; elim (Rplus_ne a); intros v w; rewrite v in H; clear v w; - generalize (Rlt_trans (a + b) a 0 H r0); intro; clear H; + generalize (Rlt_trans (a + b) a 0 H r0); intro; clear H; unfold Rge in r1; elim r1; clear r1; intro. unfold Rgt in H; generalize (Rlt_trans (a + b) 0 (a + b) H0 H); intro; apply (Rlt_irrefl (a + b)); assumption. @@ -399,16 +399,16 @@ Proof. rewrite (Rplus_comm a b); rewrite (Rplus_comm (- a) b); apply (Rplus_le_compat_l b a (- a)); apply (Rminus_le a (- a)); unfold Rminus in |- *; rewrite (Ropp_involutive a); - generalize (Rplus_lt_compat_l a a 0 r0); clear r r1; - intro; elim (Rplus_ne a); intros v w; rewrite v in H; - clear v w; generalize (Rlt_trans (a + a) a 0 H r0); + generalize (Rplus_lt_compat_l a a 0 r0); clear r r1; + intro; elim (Rplus_ne a); intros v w; rewrite v in H; + clear v w; generalize (Rlt_trans (a + a) a 0 H r0); intro; apply (Rlt_le (a + a) 0 H0). (**) apply (Rplus_le_compat_l a b (- b)); apply (Rminus_le b (- b)); unfold Rminus in |- *; rewrite (Ropp_involutive b); - generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1; - intro; elim (Rplus_ne b); intros v w; rewrite v in H; - clear v w; generalize (Rlt_trans (b + b) b 0 H r); + generalize (Rplus_lt_compat_l b b 0 r); clear r0 r1; + intro; elim (Rplus_ne b); intros v w; rewrite v in H; + clear v w; generalize (Rlt_trans (b + b) b 0 H r); intro; apply (Rlt_le (b + b) 0 H0). (**) unfold Rle in |- *; right; reflexivity. @@ -430,25 +430,25 @@ Proof. Qed. (* ||a|-|b||<=|a-b| *) -Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b). +Lemma Rabs_triang_inv2 : forall a b:R, Rabs (Rabs a - Rabs b) <= Rabs (a - b). Proof. cut - (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)). + (forall a b:R, Rabs b <= Rabs a -> Rabs (Rabs a - Rabs b) <= Rabs (a - b)). intros; destruct (Rtotal_order (Rabs a) (Rabs b)) as [Hlt| [Heq| Hgt]]. rewrite <- (Rabs_Ropp (Rabs a - Rabs b)); rewrite <- (Rabs_Ropp (a - b)); - do 2 rewrite Ropp_minus_distr. - apply H; left; assumption. + do 2 rewrite Ropp_minus_distr. + apply H; left; assumption. rewrite Heq; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; - apply Rabs_pos. - apply H; left; assumption. - intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b). - apply Rabs_triang_inv. + apply Rabs_pos. + apply H; left; assumption. + intros; replace (Rabs (Rabs a - Rabs b)) with (Rabs a - Rabs b). + apply Rabs_triang_inv. rewrite (Rabs_right (Rabs a - Rabs b)); [ reflexivity | apply Rle_ge; apply Rplus_le_reg_l with (Rabs b); rewrite Rplus_0_r; - replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a); - [ assumption | ring ] ]. -Qed. + replace (Rabs b + (Rabs a - Rabs b)) with (Rabs a); + [ assumption | ring ] ]. +Qed. (*********) Lemma Rabs_def1 : forall x a:R, x < a -> - a < x -> Rabs x < a. @@ -464,13 +464,13 @@ Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x. Proof. unfold Rabs in |- *; intro x; case (Rcase_abs x); intros. generalize (Ropp_gt_lt_0_contravar x r); unfold Rgt in |- *; intro; - generalize (Rlt_trans 0 (- x) a H0 H); intro; split. + generalize (Rlt_trans 0 (- x) a H0 H); intro; split. apply (Rlt_trans x 0 a r H1). generalize (Ropp_lt_gt_contravar (- x) a H); rewrite (Ropp_involutive x); unfold Rgt in |- *; trivial. fold (a > x) in H; generalize (Rgt_ge_trans a x 0 H r); intro; generalize (Ropp_lt_gt_0_contravar a H0); intro; fold (0 > - a) in |- *; - generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *; + generalize (Rge_gt_trans x 0 (- a) r H1); unfold Rgt in |- *; intro; split; assumption. Qed. @@ -508,7 +508,7 @@ Proof. intros p0; rewrite Rabs_Ropp. apply Rabs_right; auto with real zarith. Qed. - + Lemma abs_IZR : forall z, IZR (Zabs z) = Rabs (IZR z). Proof. intros. diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index 897d5c7100..023cfc93c3 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -30,8 +30,8 @@ Parameter R1 : R. Parameter Rplus : R -> R -> R. Parameter Rmult : R -> R -> R. Parameter Ropp : R -> R. -Parameter Rinv : R -> R. -Parameter Rlt : R -> R -> Prop. +Parameter Rinv : R -> R. +Parameter Rlt : R -> R -> Prop. Parameter up : R -> Z. Infix "+" := Rplus : R_scope. diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index 398d840d90..3309f7d503 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -39,15 +39,15 @@ Lemma cont_deriv : D_in f d D x0 -> continue_in f D x0. Proof. unfold continue_in in |- *; unfold D_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; unfold Rdiv in |- *; simpl in |- *; - intros; elim (H eps H0); clear H; intros; elim H; + unfold limit_in in |- *; unfold Rdiv in |- *; simpl in |- *; + intros; elim (H eps H0); clear H; intros; elim H; clear H; intros; elim (Req_dec (d x0) 0); intro. split with (Rmin 1 x); split. elim (Rmin_Rgt 1 x 0); intros a b; apply (b (conj Rlt_0_1 H)). intros; elim H3; clear H3; intros; generalize (let (H1, H2) := Rmin_Rgt 1 x (R_dist x1 x0) in H1); - unfold Rgt in |- *; intro; elim (H5 H4); clear H5; - intros; generalize (H1 x1 (conj H3 H6)); clear H1; + unfold Rgt in |- *; intro; elim (H5 H4); clear H5; + intros; generalize (H1 x1 (conj H3 H6)); clear H1; intro; unfold D_x in H3; elim H3; intros. rewrite H2 in H1; unfold R_dist in |- *; unfold R_dist in H1; cut (Rabs (f x1 - f x0) < eps * Rabs (x1 - x0)). @@ -84,10 +84,10 @@ Proof. generalize (let (H1, H2) := Rmin_Rgt (Rmin (/ 2) x) (eps * / Rabs (2 * d x0)) (R_dist x1 x0) in - H1); unfold Rgt in |- *; intro; elim (H5 H4); clear H5; + H1); unfold Rgt in |- *; intro; elim (H5 H4); clear H5; intros; generalize (let (H1, H2) := Rmin_Rgt (/ 2) x (R_dist x1 x0) in H1); - unfold Rgt in |- *; intro; elim (H7 H5); clear H7; - intros; clear H4 H5; generalize (H1 x1 (conj H3 H8)); + unfold Rgt in |- *; intro; elim (H7 H5); clear H7; + intros; clear H4 H5; generalize (H1 x1 (conj H3 H8)); clear H1; intro; unfold D_x in H3; elim H3; intros; generalize (sym_not_eq H5); clear H5; intro H5; generalize (Rminus_eq_contra x1 x0 H5); intro; generalize H1; @@ -114,11 +114,11 @@ Proof. rewrite (Rinv_r (Rabs (x1 - x0)) (Rabs_no_R0 (x1 - x0) H9)); rewrite (let (H1, H2) := Rmult_ne (Rabs (f x1 - f x0 + (x1 - x0) * - d x0)) in H2) - ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0)); + ; generalize (Rabs_triang_inv (f x1 - f x0) ((x1 - x0) * d x0)); intro; rewrite (Rmult_comm (x1 - x0) (- d x0)); rewrite (Ropp_mult_distr_l_reverse (d x0) (x1 - x0)); fold (f x1 - f x0 - d x0 * (x1 - x0)) in |- *; - rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1; + rewrite (Rmult_comm (x1 - x0) (d x0)) in H10; clear H1; intro; generalize (Rle_lt_trans (Rabs (f x1 - f x0) - Rabs (d x0 * (x1 - x0))) @@ -132,15 +132,15 @@ Proof. rewrite <- (Rplus_assoc (Rabs (d x0 * (x1 - x0))) (- Rabs (d x0 * (x1 - x0))) (Rabs (f x1 - f x0))); rewrite (Rplus_opp_r (Rabs (d x0 * (x1 - x0)))); - rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2); + rewrite (let (H1, H2) := Rplus_ne (Rabs (f x1 - f x0)) in H2); clear H1; intro; cut (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps < eps). intro; apply (Rlt_trans (Rabs (f x1 - f x0)) - (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11). + (Rabs (d x0 * (x1 - x0)) + Rabs (x1 - x0) * eps) eps H1 H11). clear H1 H5 H3 H10; generalize (Rabs_pos_lt (d x0) H2); intro; unfold Rgt in H0; - generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7); + generalize (Rmult_lt_compat_l eps (R_dist x1 x0) (/ 2) H0 H7); clear H7; intro; generalize (Rmult_lt_compat_l (Rabs (d x0)) (R_dist x1 x0) ( @@ -164,7 +164,7 @@ Proof. intro; rewrite H7 in H5; generalize (Rplus_lt_compat (Rabs (d x0 * (x1 - x0))) (eps * / 2) - (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro; + (Rabs (x1 - x0) * eps) (eps * / 2) H5 H3); intro; rewrite eps2 in H10; assumption. unfold Rabs in |- *; case (Rcase_abs 2); auto. intro; cut (0 < 2). @@ -180,7 +180,7 @@ Lemma Dconst : forall (D:R -> Prop) (y x0:R), D_in (fun x:R => y) (fun x:R => 0) D x0. Proof. unfold D_in in |- *; intros; unfold limit1_in in |- *; - unfold limit_in in |- *; unfold Rdiv in |- *; intros; + unfold limit_in in |- *; unfold Rdiv in |- *; intros; simpl in |- *; split with eps; split; auto. intros; rewrite (Rminus_diag_eq y y (refl_equal y)); rewrite Rmult_0_l; unfold R_dist in |- *; rewrite (Rminus_diag_eq 0 0 (refl_equal 0)); @@ -195,7 +195,7 @@ Lemma Dx : forall (D:R -> Prop) (x0:R), D_in (fun x:R => x) (fun x:R => 1) D x0. Proof. unfold D_in in |- *; unfold Rdiv in |- *; intros; unfold limit1_in in |- *; - unfold limit_in in |- *; intros; simpl in |- *; split with eps; + unfold limit_in in |- *; intros; simpl in |- *; split with eps; split; auto. intros; elim H0; clear H0; intros; unfold D_x in H0; elim H0; intros; rewrite (Rinv_r (x - x0) (Rminus_eq_contra x x0 (sym_not_eq H3))); @@ -204,7 +204,7 @@ Proof. absurd (0 < 0); auto. red in |- *; intro; apply (Rlt_irrefl 0 r). unfold Rgt in H; assumption. -Qed. +Qed. (*********) Lemma Dadd : @@ -218,9 +218,9 @@ Proof. (limit_plus (fun x:R => (f x - f x0) * / (x - x0)) (fun x:R => (g x - g x0) * / (x - x0)) (D_x D x0) ( df x0) (dg x0) x0 H H0); clear H H0; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; intros; elim (H eps H0); - clear H; intros; elim H; clear H; intros; split with x; - split; auto; intros; generalize (H1 x1 H2); clear H1; + unfold limit_in in |- *; simpl in |- *; intros; elim (H eps H0); + clear H; intros; elim H; clear H; intros; split with x; + split; auto; intros; generalize (H1 x1 H2); clear H1; intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1; rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1; rewrite <- (Rmult_plus_distr_l (/ (x1 - x0)) (f x1 - f x0) (g x1 - g x0)) @@ -239,11 +239,11 @@ Lemma Dmult : D_in (fun x:R => f x * g x) (fun x:R => df x * g x + f x * dg x) D x0. Proof. intros; unfold D_in in |- *; generalize H H0; intros; unfold D_in in H, H0; - generalize (cont_deriv f df D x0 H1); unfold continue_in in |- *; + generalize (cont_deriv f df D x0 H1); unfold continue_in in |- *; intro; generalize (limit_mul (fun x:R => (g x - g x0) * / (x - x0)) ( - fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3); + fun x:R => f x) (D_x D x0) (dg x0) (f x0) x0 H0 H3); intro; cut (limit1_in (fun x:R => g x0) (D_x D x0) (g x0) x0). intro; generalize @@ -253,11 +253,11 @@ Proof. generalize (limit_plus (fun x:R => (f x - f x0) * / (x - x0) * g x0) (fun x:R => (g x - g x0) * / (x - x0) * f x) ( - D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4); - clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H; - simpl in H; unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; intros; elim (H eps H0); clear H; intros; - elim H; clear H; intros; split with x; split; auto; + D_x D x0) (df x0 * g x0) (dg x0 * f x0) x0 H H4); + clear H4 H; intro; unfold limit1_in in H; unfold limit_in in H; + simpl in H; unfold limit1_in in |- *; unfold limit_in in |- *; + simpl in |- *; intros; elim (H eps H0); clear H; intros; + elim H; clear H; intros; split with x; split; auto; intros; generalize (H1 x1 H2); clear H1; intro; rewrite (Rmult_comm (f x1 - f x0) (/ (x1 - x0))) in H1; rewrite (Rmult_comm (g x1 - g x0) (/ (x1 - x0))) in H1; @@ -275,7 +275,7 @@ Proof. ring. unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; split with eps; split; auto; intros; elim (R_dist_refl (g x0) (g x0)); - intros a b; rewrite (b (refl_equal (g x0))); unfold Rgt in H; + intros a b; rewrite (b (refl_equal (g x0))); unfold Rgt in H; assumption. Qed. @@ -287,7 +287,7 @@ Proof. intros; generalize (Dmult D (fun _:R => 0) df (fun _:R => a) f x0 (Dconst D a x0) H); unfold D_in in |- *; intros; rewrite (Rmult_0_l (f x0)) in H0; - rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0; + rewrite (let (H1, H2) := Rplus_ne (a * df x0) in H2) in H0; assumption. Qed. @@ -297,9 +297,9 @@ Lemma Dopp : D_in f df D x0 -> D_in (fun x:R => - f x) (fun x:R => - df x) D x0. Proof. intros; generalize (Dmult_const D f df x0 (-1) H); unfold D_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - intros; generalize (H0 eps H1); clear H0; intro; elim H0; - clear H0; intros; elim H0; clear H0; simpl in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; + intros; generalize (H0 eps H1); clear H0; intro; elim H0; + clear H0; intros; elim H0; clear H0; simpl in |- *; intros; split with x; split; auto. intros; generalize (H2 x1 H3); clear H2; intro; rewrite Ropp_mult_distr_l_reverse in H2; @@ -307,7 +307,7 @@ Proof. rewrite Ropp_mult_distr_l_reverse in H2; rewrite (let (H1, H2) := Rmult_ne (f x1) in H2) in H2; rewrite (let (H1, H2) := Rmult_ne (f x0) in H2) in H2; - rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2; + rewrite (let (H1, H2) := Rmult_ne (df x0) in H2) in H2; assumption. Qed. @@ -319,8 +319,8 @@ Lemma Dminus : D_in (fun x:R => f x - g x) (fun x:R => df x - dg x) D x0. Proof. unfold Rminus in |- *; intros; generalize (Dopp D g dg x0 H0); intro; - apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0); - assumption. + apply (Dadd D df (fun x:R => - dg x) f (fun x:R => - g x) x0); + assumption. Qed. (*********) @@ -336,8 +336,8 @@ Proof. (Dmult D (fun _:R => 1) (fun x:R => INR n0 * x ^ (n0 - 1)) ( fun x:R => x) (fun x:R => x ^ n0) x0 (Dx D x0) ( H D x0)); unfold D_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; intros; elim (H0 eps H1); - clear H0; intros; elim H0; clear H0; intros; split with x; + unfold limit_in in |- *; simpl in |- *; intros; elim (H0 eps H1); + clear H0; intros; elim H0; clear H0; intros; split with x; split; auto. intros; generalize (H2 x1 H3); clear H2 H3; intro; rewrite (let (H1, H2) := Rmult_ne (x0 ^ n0) in H2) in H2; @@ -365,9 +365,9 @@ Proof. unfold Rdiv in |- *; intros; generalize (limit_comp f (fun x:R => (g x - g (f x0)) * / (x - f x0)) ( - D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0); - intro; generalize (cont_deriv f df Df x0 H); intro; - unfold continue_in in H4; generalize (H3 H4 H2); clear H3; + D_x Df x0) (D_x Dg (f x0)) (f x0) (dg (f x0)) x0); + intro; generalize (cont_deriv f df Df x0 H); intro; + unfold continue_in in H4; generalize (H3 H4 H2); clear H3; intro; generalize (limit_mul (fun x:R => (g (f x) - g (f x0)) * / (f x - f x0)) @@ -381,16 +381,16 @@ Proof. generalize (limit_mul (fun x:R => (f x - f x0) * / (x - x0)) ( fun x:R => dg (f x0)) (D_x Df x0) (df x0) (dg (f x0)) x0 H1 - (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0)); - intro; unfold limit1_in in |- *; unfold limit_in in |- *; + (limit_free (fun x:R => dg (f x0)) (D_x Df x0) x0 x0)); + intro; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; unfold limit1_in in H5, H7; unfold limit_in in H5, H7; - simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8); - clear H5 H7; intros; elim H5; elim H7; clear H5 H7; + simpl in H5, H7; intros; elim (H5 eps H8); elim (H7 eps H8); + clear H5 H7; intros; elim H5; elim H7; clear H5 H7; intros; split with (Rmin x x1); split. elim (Rmin_Rgt x x1 0); intros a b; apply (b (conj H9 H5)); clear a b. intros; elim H11; clear H11; intros; elim (Rmin_Rgt x x1 (R_dist x2 x0)); - intros a b; clear b; unfold Rgt in a; elim (a H12); - clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10; + intros a b; clear b; unfold Rgt in a; elim (a H12); + clear H5 a; intros; unfold D_x, Dgf in H11, H7, H10; clear H12; elim (classic (f x2 = f x0)); intro. elim H11; clear H11; intros; elim H11; clear H11; intros; generalize (H10 x2 (conj (conj H11 H14) H5)); intro; @@ -412,12 +412,12 @@ Proof. rewrite (let (H1, H2) := Rmult_ne (/ (x2 - x0)) in H2) in H15; rewrite (Rmult_comm (df x0) (dg (f x0))); assumption. clear H5 H3 H4 H2; unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; unfold limit1_in in H1; unfold limit_in in H1; - simpl in H1; intros; elim (H1 eps H2); clear H1; intros; - elim H1; clear H1; intros; split with x; split; auto; - intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4; + simpl in |- *; unfold limit1_in in H1; unfold limit_in in H1; + simpl in H1; intros; elim (H1 eps H2); clear H1; intros; + elim H1; clear H1; intros; split with x; split; auto; + intros; unfold D_x, Dgf in H4, H3; elim H4; clear H4; intros; elim H4; clear H4; intros; exact (H3 x1 (conj H4 H5)). -Qed. +Qed. (*********) Lemma D_pow_n : @@ -430,11 +430,11 @@ Proof. intros n D x0 expr dexpr H; generalize (Dcomp D D dexpr (fun x:R => INR n * x ^ (n - 1)) expr ( - fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0))); + fun x:R => x ^ n) x0 H (Dx_pow_n n D (expr x0))); intro; unfold D_in in |- *; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; unfold D_in in H0; - unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; - elim (H0 eps H1); clear H0; intros; elim H0; clear H0; + unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; + elim (H0 eps H1); clear H0; intros; elim H0; clear H0; intros; split with x; split; intros; auto. cut (dexpr x0 * (INR n * expr x0 ^ (n - 1)) = diff --git a/theories/Reals/Reals.v b/theories/Reals/Reals.v index 8c3d3feacd..d18213db49 100644 --- a/theories/Reals/Reals.v +++ b/theories/Reals/Reals.v @@ -23,7 +23,7 @@ - Sup: for goals like ``?1 0. Proof. intro; red in |- *; intro; apply (not_O_INR (fact n) (fact_neq_0 n)); assumption. -Qed. +Qed. (*********) Lemma fact_simpl : forall n:nat, fact (S n) = (S n * fact n)%nat. Proof. intro; reflexivity. -Qed. +Qed. (*********) Lemma simpl_fact : @@ -160,7 +160,7 @@ Proof. rewrite <- (let (H1, H2) := Rmult_ne (x ^ a) in H1); rewrite (Rmult_comm (INR n) (x ^ a)); rewrite <- (Rmult_plus_distr_l (x ^ a) 1 (INR n)); - rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n); + rewrite (Rplus_comm 1 (INR n)); rewrite <- (S_INR n); apply Rmult_comm. Qed. @@ -185,7 +185,7 @@ Proof. fold (x > 0) in H; apply (Rlt_0_sqr x (Rlt_dichotomy_converse x 0 (or_intror (x < 0) H))). rewrite (S_INR n0); ring. - unfold Rle in H0; elim H0; intro. + unfold Rle in H0; elim H0; intro. unfold Rle in |- *; left; apply Rmult_lt_compat_l. rewrite Rplus_comm; apply (Rle_lt_0_plus_1 x (Rlt_le 0 x H)). assumption. @@ -288,7 +288,7 @@ Lemma pow_lt_1_zero : 0 < y -> exists N : nat, (forall n:nat, (n >= N)%nat -> Rabs (x ^ n) < y). Proof. - intros; elim (Req_dec x 0); intro. + intros; elim (Req_dec x 0); intro. exists 1%nat; rewrite H1; intros n GE; rewrite pow_ne_zero. rewrite Rabs_R0; assumption. inversion GE; auto. @@ -758,7 +758,7 @@ Proof. rewrite (Ropp_minus_distr y x) in H; generalize (Rlt_asym (x - y) 0 r0); intro; unfold Rgt in H; elimtype False; auto. generalize (minus_Rge y x r); intro; generalize (minus_Rge x y r0); intro; - generalize (Rge_antisym x y H0 H); intro; rewrite H1; + generalize (Rge_antisym x y H0 H); intro; rewrite H1; ring. Qed. @@ -771,7 +771,7 @@ Proof. rewrite (Ropp_minus_distr x y); generalize (sym_eq H); intro; apply (Rminus_diag_eq y x H0). apply (Rminus_diag_uniq x y H). - apply (Rminus_diag_eq x y H). + apply (Rminus_diag_eq x y H). Qed. Lemma R_dist_eq : forall x:R, R_dist x x = 0. diff --git a/theories/Reals/Rgeom.v b/theories/Reals/Rgeom.v index 9e83150fc7..8890cbb508 100644 --- a/theories/Reals/Rgeom.v +++ b/theories/Reals/Rgeom.v @@ -32,7 +32,7 @@ Proof. Qed. Lemma distance_symm : - forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0. + forall x0 y0 x1 y1:R, dist_euc x0 y0 x1 y1 = dist_euc x1 y1 x0 y0. Proof. intros x0 y0 x1 y1; unfold dist_euc in |- *; apply Rsqr_inj; [ apply sqrt_positivity; apply Rplus_le_le_0_compat @@ -187,7 +187,7 @@ Lemma isometric_rot_trans : forall x1 y1 x2 y2 tx ty theta:R, Rsqr (x1 - x2) + Rsqr (y1 - y2) = Rsqr (xr (xt x1 tx) (yt y1 ty) theta - xr (xt x2 tx) (yt y2 ty) theta) + - Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta). + Rsqr (yr (xt x1 tx) (yt y1 ty) theta - yr (xt x2 tx) (yt y2 ty) theta). Proof. intros; rewrite <- isometric_rotation_0; apply isometric_translation. Qed. @@ -196,7 +196,7 @@ Lemma isometric_trans_rot : forall x1 y1 x2 y2 tx ty theta:R, Rsqr (x1 - x2) + Rsqr (y1 - y2) = Rsqr (xt (xr x1 y1 theta) tx - xt (xr x2 y2 theta) tx) + - Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty). + Rsqr (yt (yr x1 y1 theta) ty - yt (yr x2 y2 theta) ty). Proof. intros; rewrite <- isometric_translation; apply isometric_rotation_0. Qed. diff --git a/theories/Reals/RiemannInt.v b/theories/Reals/RiemannInt.v index 79e4fd2a1d..88cead7a5f 100644 --- a/theories/Reals/RiemannInt.v +++ b/theories/Reals/RiemannInt.v @@ -32,8 +32,8 @@ Definition Riemann_integrable (f:R -> R) (a b:R) : Type := Rmin a b <= t <= Rmax a b -> Rabs (f t - phi t) <= psi t) /\ Rabs (RiemannInt_SF psi) < eps } }. -Definition phi_sequence (un:nat -> posreal) (f:R -> R) - (a b:R) (pr:Riemann_integrable f a b) (n:nat) := +Definition phi_sequence (un:nat -> posreal) (f:R -> R) + (a b:R) (pr:Riemann_integrable f a b) (n:nat) := projT1 (pr (un n)). Lemma phi_sequence_prop : @@ -54,7 +54,7 @@ Lemma RiemannInt_P1 : Proof. unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; intros; elim p; clear p; intros; exists (mkStepFun (StepFun_P6 (pre x))); - exists (mkStepFun (StepFun_P6 (pre x0))); + exists (mkStepFun (StepFun_P6 (pre x0))); elim p; clear p; intros; split. intros; apply (H t); elim H1; clear H1; intros; split; [ apply Rle_trans with (Rmin b a); try assumption; right; @@ -97,7 +97,7 @@ Proof. elim (H _ H3); intros N0 H4; exists N0; intros; unfold R_dist in |- *; unfold R_dist in H4; elim (H1 n); elim (H1 m); intros; replace (RiemannInt_SF (vn n) - RiemannInt_SF (vn m)) with - (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m)); + (RiemannInt_SF (vn n) + -1 * RiemannInt_SF (vn m)); [ idtac | ring ]; rewrite <- StepFun_P30; apply Rle_lt_trans with (RiemannInt_SF @@ -131,7 +131,7 @@ Proof. apply Rplus_le_compat; apply RRle_abs. replace (pos (un n)) with (un n - 0); [ idtac | ring ]; replace (pos (un m)) with (un m - 0); [ idtac | ring ]; - rewrite (double_var eps); apply Rplus_lt_compat; apply H4; + rewrite (double_var eps); apply Rplus_lt_compat; apply H4; assumption. Qed. @@ -179,8 +179,8 @@ Proof. rewrite Rabs_Ropp in H4; apply H4. apply H4. assert (H3 := RiemannInt_P2 _ _ _ _ H H1 H2); elim H3; intros; - exists (- x); unfold Un_cv in |- *; unfold Un_cv in p; - intros; elim (p _ H4); intros; exists x0; intros; + exists (- x); unfold Un_cv in |- *; unfold Un_cv in p; + intros; elim (p _ H4); intros; exists x0; intros; generalize (H5 _ H6); unfold R_dist, RiemannInt_SF in |- *; case (Rle_dec b a); case (Rle_dec a b); intros. elim n; assumption. @@ -189,7 +189,7 @@ Proof. (Int_SF (subdivision_val (mkStepFun (StepFun_P6 (pre (vn n0))))) (subdivision (mkStepFun (StepFun_P6 (pre (vn n0)))))); [ unfold Rminus in |- *; rewrite Ropp_involutive; rewrite <- Rabs_Ropp; - rewrite Ropp_plus_distr; rewrite Ropp_involutive; + rewrite Ropp_plus_distr; rewrite Ropp_involutive; apply H7 | symmetry in |- *; apply StepFun_P17 with (fe (vn n0)) a b; [ apply StepFun_P1 @@ -200,7 +200,7 @@ Proof. Qed. Lemma RiemannInt_exists : - forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) + forall (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) (un:nat -> posreal), Un_cv un 0 -> { l:R | Un_cv (fun N:nat => RiemannInt_SF (phi_sequence un pr N)) l }. @@ -281,7 +281,7 @@ Proof. assumption. replace (pos (un n)) with (Rabs (un n - 0)); [ apply H; unfold ge in |- *; apply le_trans with N; try assumption; - unfold N in |- *; apply le_trans with (max N0 N1); + unfold N in |- *; apply le_trans with (max N0 N1); apply le_max_l | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (un n)) ]. @@ -346,7 +346,7 @@ Proof. unfold N in |- *; apply le_trans with (max N0 N1); [ apply le_max_r | apply le_max_l ] | unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; + rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (vn n)) ]. apply Rlt_trans with (pos (un n)). elim H6; intros; apply Rle_lt_trans with (Rabs (RiemannInt_SF psi_un)). @@ -354,7 +354,7 @@ Proof. assumption. replace (pos (un n)) with (Rabs (un n - 0)); [ apply H; unfold ge in |- *; apply le_trans with N; try assumption; - unfold N in |- *; apply le_trans with (max N0 N1); + unfold N in |- *; apply le_trans with (max N0 N1); apply le_max_l | unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (un n)) ]. @@ -382,7 +382,7 @@ Proof. apply le_IZR; left; apply Rlt_trans with (/ eps); [ apply Rinv_0_lt_compat; assumption | assumption ]. elim (IZN _ H2); intros; exists x; intros; unfold R_dist in |- *; - simpl in |- *; unfold Rminus in |- *; rewrite Ropp_0; + simpl in |- *; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; assert (H5 : 0 < INR n + 1). apply Rplus_le_lt_0_compat; [ apply pos_INR | apply Rlt_0_1 ]. rewrite Rabs_right; @@ -406,7 +406,7 @@ Proof. red in |- *; intro; rewrite H6 in H; elim (Rlt_irrefl _ H). Qed. -(**********) +(**********) Definition RiemannInt (f:R -> R) (a b:R) (pr:Riemann_integrable f a b) : R := let (a,_) := RiemannInt_exists pr RinvN RinvN_cv in a. @@ -416,7 +416,7 @@ Lemma RiemannInt_P5 : Proof. intros; unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv); - case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; + case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; eapply UL_sequence; [ apply u0 | apply RiemannInt_P4 with pr2 RinvN; apply RinvN_cv || assumption ]. @@ -452,8 +452,8 @@ Proof. apply le_IZR; simpl in |- *; left; apply Rle_lt_trans with ((b - a) / del); assumption. assert (H5 := IZN _ H4); elim H5; clear H5; intros N H5; - unfold Nbound in |- *; exists N; intros; unfold I in H6; - apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2; + unfold Nbound in |- *; exists N; intros; unfold I in H6; + apply INR_le; rewrite H5 in H2; rewrite <- INR_IZR_INZ in H2; left; apply Rle_lt_trans with ((b - a) / del); try assumption; apply Rmult_le_reg_l with (pos del); [ apply (cond_pos del) @@ -498,11 +498,11 @@ Proof. a <= y <= b -> Rabs (x - y) < l -> Rabs (f x - f y) < eps)); assert (H1 : bound E). unfold bound in |- *; exists (b - a); unfold is_upper_bound in |- *; intros; - unfold E in H1; elim H1; clear H1; intros H1 _; elim H1; + unfold E in H1; elim H1; clear H1; intros H1 _; elim H1; intros; assumption. assert (H2 : exists x : R, E x). assert (H2 := Heine f (fun x:R => a <= x <= b) (compact_P3 a b) H0 eps); - elim H2; intros; exists (Rmin x (b - a)); unfold E in |- *; + elim H2; intros; exists (Rmin x (b - a)); unfold E in |- *; split; [ split; [ unfold Rmin in |- *; case (Rle_dec x (b - a)); intro; @@ -530,7 +530,7 @@ Proof. unfold is_lub in p; unfold is_upper_bound in p; elim p; clear p; intros; split. elim H2; intros; assert (H7 := H4 _ H6); unfold E in H6; elim H6; clear H6; - intros H6 _; elim H6; intros; apply Rlt_le_trans with x0; + intros H6 _; elim H6; intros; apply Rlt_le_trans with x0; assumption. apply H5; intros; unfold E in H6; elim H6; clear H6; intros H6 _; elim H6; intros; assumption. @@ -579,7 +579,7 @@ Proof. | intros; change (pos_Rl (SubEquiN (S n) (a0 + del0) b del0) - (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b) + (pred (Rlength (SubEquiN (S n) (a0 + del0) b del0))) = b) in |- *; apply H ] ]. Qed. @@ -633,7 +633,7 @@ Proof. 2: apply le_lt_n_Sm; assumption. apply Rplus_le_compat_l; rewrite S_INR; rewrite Rmult_plus_distr_r; pattern (INR i * del) at 1 in |- *; rewrite <- Rplus_0_r; - apply Rplus_le_compat_l; rewrite Rmult_1_l; left; + apply Rplus_le_compat_l; rewrite Rmult_1_l; left; apply (cond_pos del). Qed. @@ -686,7 +686,7 @@ Proof. [ reflexivity | elim n; left; assumption ]. elim (Heine_cor2 H0 (mkposreal _ H1)); intros del H4; elim (SubEqui_P9 del f H); intros phi [H5 H6]; split with phi; - split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a))))); + split with (mkStepFun (StepFun_P4 a b (eps / (2 * (b - a))))); split. 2: rewrite StepFun_P18; unfold Rdiv in |- *; rewrite Rinv_mult_distr. 2: do 2 rewrite Rmult_assoc; rewrite <- Rinv_l_sym. @@ -731,7 +731,7 @@ Proof. apply Rplus_lt_reg_r with (pos_Rl (SubEqui del H) (max_N del H)). replace (pos_Rl (SubEqui del H) (max_N del H) + - (t - pos_Rl (SubEqui del H) (max_N del H))) with t; + (t - pos_Rl (SubEqui del H) (max_N del H))) with t; [ idtac | ring ]; apply Rlt_le_trans with b. rewrite H14 in H12; assert (H13 : S (max_N del H) = pred (Rlength (SubEqui del H))). @@ -760,20 +760,20 @@ Proof. intros; assumption. assert (H4 : Nbound I). unfold Nbound in |- *; exists (S (max_N del H)); intros; unfold max_N in |- *; - case (maxN del H); intros; elim a0; clear a0; intros _ H5; + case (maxN del H); intros; elim a0; clear a0; intros _ H5; apply INR_le; apply Rmult_le_reg_l with (pos del). apply (cond_pos del). apply Rplus_le_reg_l with a; do 2 rewrite (Rmult_comm del); apply Rle_trans with t0; unfold I in H4; try assumption; - apply Rle_trans with b; try assumption; elim H8; intros; + apply Rle_trans with b; try assumption; elim H8; intros; assumption. elim (Nzorn H1 H4); intros N [H5 H6]; assert (H7 : (N < S (max_N del H))%nat). unfold max_N in |- *; case (maxN del H); intros; apply INR_lt; apply Rmult_lt_reg_l with (pos del). apply (cond_pos del). apply Rplus_lt_reg_r with a; do 2 rewrite (Rmult_comm del); - apply Rle_lt_trans with t0; unfold I in H5; try assumption; - elim a0; intros; apply Rlt_le_trans with b; try assumption; + apply Rle_lt_trans with t0; unfold I in H5; try assumption; + elim a0; intros; apply Rlt_le_trans with b; try assumption; elim H8; intros. elim H11; intro. assumption. @@ -1027,7 +1027,7 @@ Proof. unfold Riemann_integrable in |- *; intros f g; intros; case (Req_EM_T l 0); intro. elim (X eps); intros; split with x; elim p; intros; split with x0; elim p0; - intros; split; try assumption; rewrite e; intros; + intros; split; try assumption; rewrite e; intros; rewrite Rmult_0_l; rewrite Rplus_0_r; apply H; assumption. assert (H : 0 < eps / 2). unfold Rdiv in |- *; apply Rmult_lt_0_compat; @@ -1038,8 +1038,8 @@ Proof. | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; [ prove_sup0 | apply Rabs_pos_lt; assumption ] ]. elim (X (mkposreal _ H)); intros; elim (X0 (mkposreal _ H0)); intros; - split with (mkStepFun (StepFun_P28 l x x0)); elim p0; - elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2)); + split with (mkStepFun (StepFun_P28 l x x0)); elim p0; + elim p; intros; split with (mkStepFun (StepFun_P28 (Rabs l) x1 x2)); elim p1; elim p2; clear p1 p2 p0 p X X0; intros; split. intros; simpl in |- *; apply Rle_trans with (Rabs (f t - x t) + Rabs (l * (g t - x0 t))). @@ -1098,7 +1098,7 @@ Proof. replace eps with (2 * (eps / 3) + eps / 3). apply Rplus_lt_compat. replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with - (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); + (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); [ idtac | ring ]. rewrite <- StepFun_P30. apply Rle_lt_trans with @@ -1146,7 +1146,7 @@ Proof. apply H; unfold ge in |- *; apply le_trans with N; try assumption; unfold N in |- *; apply le_max_l. unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; + rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (un n)). unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N; try assumption; unfold N in |- *; apply le_max_r. @@ -1172,7 +1172,7 @@ Proof. replace eps with (2 * (eps / 3) + eps / 3). apply Rplus_lt_compat. replace (RiemannInt_SF (phi2 n) - RiemannInt_SF (phi1 n)) with - (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); + (RiemannInt_SF (phi2 n) + -1 * RiemannInt_SF (phi1 n)); [ idtac | ring ]. rewrite <- StepFun_P30. rewrite StepFun_P39. @@ -1238,7 +1238,7 @@ Proof. apply H; unfold ge in |- *; apply le_trans with N; try assumption; unfold N in |- *; apply le_max_l. unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; + rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (un n)). unfold R_dist in H2; apply H2; unfold ge in |- *; apply le_trans with N; try assumption; unfold N in |- *; apply le_max_r. @@ -1258,7 +1258,7 @@ Proof. intro f; intros; case (Req_dec l 0); intro. pattern l at 2 in |- *; rewrite H0; rewrite Rmult_0_l; rewrite Rplus_0_r; unfold RiemannInt in |- *; case (RiemannInt_exists pr3 RinvN RinvN_cv); - case (RiemannInt_exists pr1 RinvN RinvN_cv); intros; + case (RiemannInt_exists pr1 RinvN RinvN_cv); intros; eapply UL_sequence; [ apply u0 | set (psi1 := fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); @@ -1283,13 +1283,13 @@ Proof. intros; apply u. unfold Un_cv in |- *; intros; unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv); - case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv in |- *; + case (RiemannInt_exists pr2 RinvN RinvN_cv); unfold Un_cv in |- *; intros; assert (H2 : 0 < eps / 5). unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. elim (u0 _ H2); clear u0; intros N0 H3; assert (H4 := RinvN_cv); unfold Un_cv in H4; elim (H4 _ H2); clear H4 H2; intros N1 H4; - assert (H5 : 0 < eps / (5 * Rabs l)). + assert (H5 : 0 < eps / (5 * Rabs l)). unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; apply Rmult_lt_0_compat; @@ -1380,7 +1380,7 @@ Proof. (RiemannInt_SF (phi_sequence RinvN pr3 n) + -1 * (RiemannInt_SF (phi_sequence RinvN pr1 n) + - l * RiemannInt_SF (phi_sequence RinvN pr2 n))); + l * RiemannInt_SF (phi_sequence RinvN pr2 n))); [ idtac | ring ]; do 2 rewrite <- StepFun_P30; assert (H10 : Rmin a b = a). unfold Rmin in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n0; assumption ]. @@ -1421,7 +1421,7 @@ Proof. rewrite Rplus_assoc; apply Rplus_le_compat. elim (H9 n); intros; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr; apply H13. - elim H12; intros; split; left; assumption. + elim H12; intros; split; left; assumption. apply Rle_trans with (Rabs (f x1 - phi_sequence RinvN pr1 n x1) + Rabs l * Rabs (g x1 - phi_sequence RinvN pr2 n x1)). @@ -1487,7 +1487,7 @@ Proof. [ unfold Rdiv in |- *; do 2 rewrite Rmult_plus_distr_l; do 3 rewrite (Rmult_comm 5); repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ ring | discrR ] - | discrR ]. + | discrR ]. Qed. Lemma RiemannInt_P13 : @@ -1517,7 +1517,7 @@ Proof. split with (mkStepFun (StepFun_P4 a b c)); split with (mkStepFun (StepFun_P4 a b 0)); split; [ intros; simpl in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r; - rewrite Rabs_R0; unfold fct_cte in |- *; right; + rewrite Rabs_R0; unfold fct_cte in |- *; right; reflexivity | rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; apply (cond_pos eps) ]. @@ -1546,12 +1546,12 @@ Proof. elim H1; clear H1; intros psi1 H1; set (phi2 := fun n:nat => mkStepFun (StepFun_P4 a b c)); set (psi2 := fun n:nat => mkStepFun (StepFun_P4 a b 0)); - apply RiemannInt_P11 with f RinvN phi2 psi2 psi1; + apply RiemannInt_P11 with f RinvN phi2 psi2 psi1; try assumption. apply RinvN_cv. intro; split. intros; unfold f in |- *; simpl in |- *; unfold Rminus in |- *; - rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte in |- *; + rewrite Rplus_opp_r; rewrite Rabs_R0; unfold fct_cte in |- *; right; reflexivity. unfold psi2 in |- *; rewrite StepFun_P18; rewrite Rmult_0_l; rewrite Rabs_R0; apply (cond_pos (RinvN n)). @@ -1594,7 +1594,7 @@ Proof. apply Rmult_eq_reg_l with 2; [ unfold Rdiv in |- *; do 2 rewrite (Rmult_comm 2); rewrite (Rmult_plus_distr_r (- l2) ((l1 + l2) * / 2) 2); - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; + repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ ring | discrR ] | discrR ]. apply Ropp_lt_cancel; apply Rplus_lt_reg_r with l1; @@ -1637,7 +1637,7 @@ Proof. Rabs (Rabs (f t) - phi3 n t) <= psi3 n t) /\ Rabs (RiemannInt_SF (psi3 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). assert (H1 : exists psi2 : nat -> StepFun a b, @@ -1674,7 +1674,7 @@ Lemma RiemannInt_P18 : Proof. intro f; intros; unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv); - case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; + case (RiemannInt_exists pr2 RinvN RinvN_cv); intros; eapply UL_sequence. apply u0. set (phi1 := fun N:nat => phi_sequence RinvN pr1 N); @@ -1688,7 +1688,7 @@ Proof. Rabs (f t - phi1 n t) <= psi1 n t) /\ Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). elim H1; clear H1; intros psi1 H1; set (phi2 := fun N:nat => phi_sequence RinvN pr2 N). set @@ -1712,10 +1712,10 @@ Proof. Rmin a b <= t /\ t <= Rmax a b -> Rabs (g t - phi2 n t) <= psi2 n t) /\ Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). elim H2; clear H2; intros psi2 H2; - apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; - try assumption. + apply RiemannInt_P11 with f RinvN phi2_m psi2 psi1; + try assumption. apply RinvN_cv. intro; elim (H2 n); intros; split; try assumption. intros; unfold phi2_m in |- *; simpl in |- *; unfold phi2_aux in |- *; @@ -1764,11 +1764,11 @@ Proof. right; reflexivity. intro; assert (H2 := pre (phi2 N)); unfold IsStepFun in H2; unfold is_subdivision in H2; elim H2; clear H2; intros l [lf H2]; - split with l; split with lf; unfold adapted_couple in H2; - decompose [and] H2; clear H2; unfold adapted_couple in |- *; + split with l; split with lf; unfold adapted_couple in H2; + decompose [and] H2; clear H2; unfold adapted_couple in |- *; repeat split; try assumption. intros; assert (H9 := H8 i H2); unfold constant_D_eq, open_interval in H9; - unfold constant_D_eq, open_interval in |- *; intros; + unfold constant_D_eq, open_interval in |- *; intros; rewrite <- (H9 x1 H7); assert (H10 : a <= pos_Rl l i). replace a with (Rmin a b). rewrite <- H5; elim (RList_P6 l); intros; apply H10. @@ -1808,7 +1808,7 @@ Proof. (RiemannInt (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))). apply (RiemannInt_P17 (RiemannInt_P10 (-1) pr2 pr1) - (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))); + (RiemannInt_P16 (RiemannInt_P10 (-1) pr2 pr1))); assumption. replace (RiemannInt pr2 + - RiemannInt pr1) with (RiemannInt (RiemannInt_P10 (-1) pr2 pr1)). @@ -1833,7 +1833,7 @@ Proof. Qed. Definition primitive (f:R -> R) (a b:R) (h:a <= b) - (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x) + (pr:forall x:R, a <= x -> x <= b -> Riemann_integrable f a x) (x:R) : R := match Rle_dec a x with | left r => @@ -1977,20 +1977,20 @@ Proof. | elim n0; left; assumption ]. apply StepFun_P46 with b; assumption. assert (H3 := pre psi2); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple in |- *; repeat split; + elim H3; clear H3; intros l1 [lf1 H3]; split with l1; + split with lf1; unfold adapted_couple in H3; decompose [and] H3; + clear H3; unfold adapted_couple in |- *; repeat split; try assumption. intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *; - unfold constant_D_eq, open_interval in H9; intros; + unfold constant_D_eq, open_interval in H9; intros; rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x). apply Rle_lt_trans with (pos_Rl l1 i). replace b with (Rmin b c). rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption. apply le_O_n. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; - apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; - discriminate. + apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; + discriminate. unfold Rmin in |- *; case (Rle_dec b c); intro; [ reflexivity | elim n; assumption ]. elim H7; intros; assumption. @@ -2000,19 +2000,19 @@ Proof. | elim n; apply Rle_trans with b; [ assumption | left; assumption ] | elim n0; apply Rle_trans with b; [ assumption | left; assumption ] ]. assert (H3 := pre psi1); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple in |- *; repeat split; + elim H3; clear H3; intros l1 [lf1 H3]; split with l1; + split with lf1; unfold adapted_couple in H3; decompose [and] H3; + clear H3; unfold adapted_couple in |- *; repeat split; try assumption. intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *; - unfold constant_D_eq, open_interval in H9; intros; + unfold constant_D_eq, open_interval in H9; intros; rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b). apply Rle_trans with (pos_Rl l1 (S i)). elim H7; intros; left; assumption. replace b with (Rmax a b). rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption. apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; - discriminate. + discriminate. unfold Rmax in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. assert (H11 : a <= x). @@ -2021,8 +2021,8 @@ Proof. rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption. apply le_O_n. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; - apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; - discriminate. + apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; + discriminate. unfold Rmin in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. left; elim H7; intros; assumption. @@ -2030,19 +2030,19 @@ Proof. assumption. apply StepFun_P46 with b. assert (H3 := pre phi1); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple in |- *; repeat split; + elim H3; clear H3; intros l1 [lf1 H3]; split with l1; + split with lf1; unfold adapted_couple in H3; decompose [and] H3; + clear H3; unfold adapted_couple in |- *; repeat split; try assumption. intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *; - unfold constant_D_eq, open_interval in H9; intros; + unfold constant_D_eq, open_interval in H9; intros; rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : x <= b). apply Rle_trans with (pos_Rl l1 (S i)). elim H7; intros; left; assumption. replace b with (Rmax a b). rewrite <- H4; elim (RList_P6 l1); intros; apply H10; try assumption. apply lt_pred_n_n; apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; - discriminate. + discriminate. unfold Rmax in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. assert (H11 : a <= x). @@ -2051,28 +2051,28 @@ Proof. rewrite <- H5; elim (RList_P6 l1); intros; apply H11; try assumption. apply le_O_n. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; - apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; - discriminate. + apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H6; + discriminate. unfold Rmin in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. left; elim H7; intros; assumption. unfold phi3 in |- *; case (Rle_dec a x); case (Rle_dec x b); intros; reflexivity || elim n; assumption. assert (H3 := pre phi2); unfold IsStepFun in H3; unfold is_subdivision in H3; - elim H3; clear H3; intros l1 [lf1 H3]; split with l1; - split with lf1; unfold adapted_couple in H3; decompose [and] H3; - clear H3; unfold adapted_couple in |- *; repeat split; + elim H3; clear H3; intros l1 [lf1 H3]; split with l1; + split with lf1; unfold adapted_couple in H3; decompose [and] H3; + clear H3; unfold adapted_couple in |- *; repeat split; try assumption. intros; assert (H9 := H8 i H3); unfold constant_D_eq, open_interval in |- *; - unfold constant_D_eq, open_interval in H9; intros; + unfold constant_D_eq, open_interval in H9; intros; rewrite <- (H9 x H7); unfold psi3 in |- *; assert (H10 : b < x). apply Rle_lt_trans with (pos_Rl l1 i). replace b with (Rmin b c). rewrite <- H5; elim (RList_P6 l1); intros; apply H10; try assumption. apply le_O_n. apply lt_trans with (pred (Rlength l1)); try assumption; apply lt_pred_n_n; - apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; - discriminate. + apply neq_O_lt; red in |- *; intro; rewrite <- H12 in H6; + discriminate. unfold Rmin in |- *; case (Rle_dec b c); intro; [ reflexivity | elim n; assumption ]. elim H7; intros; assumption. @@ -2088,7 +2088,7 @@ Lemma RiemannInt_P22 : Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f a c. Proof. unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; - intros phi [psi H0]; elim H; elim H0; clear H H0; + intros phi [psi H0]; elim H; elim H0; clear H H0; intros; assert (H3 : IsStepFun phi a c). apply StepFun_P44 with b. apply (pre phi). @@ -2178,7 +2178,7 @@ Lemma RiemannInt_P23 : Riemann_integrable f a b -> a <= c <= b -> Riemann_integrable f c b. Proof. unfold Riemann_integrable in |- *; intros; elim (X eps); clear X; - intros phi [psi H0]; elim H; elim H0; clear H H0; + intros phi [psi H0]; elim H; elim H0; clear H H0; intros; assert (H3 : IsStepFun phi c b). apply StepFun_P45 with a. apply (pre phi). @@ -2294,7 +2294,7 @@ Proof. intros f a b c pr1 pr2 pr3 Hyp1 Hyp2; unfold RiemannInt in |- *; case (RiemannInt_exists pr1 RinvN RinvN_cv); case (RiemannInt_exists pr2 RinvN RinvN_cv); - case (RiemannInt_exists pr3 RinvN RinvN_cv); intros; + case (RiemannInt_exists pr3 RinvN RinvN_cv); intros; symmetry in |- *; eapply UL_sequence. apply u. unfold Un_cv in |- *; intros; assert (H0 : 0 < eps / 3). @@ -2309,7 +2309,7 @@ Proof. (RiemannInt_SF (phi_sequence RinvN pr1 n) + RiemannInt_SF (phi_sequence RinvN pr2 n))) 0). intro; elim (H3 _ H0); clear H3; intros N3 H3; - set (N0 := max (max N1 N2) N3); exists N0; intros; + set (N0 := max (max N1 N2) N3); exists N0; intros; unfold R_dist in |- *; apply Rle_lt_trans with (Rabs @@ -2368,7 +2368,7 @@ Proof. Rabs (f t - phi_sequence RinvN pr1 n t) <= psi1 n t) /\ Rabs (RiemannInt_SF (psi1 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr1 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr1 n)). assert (H2 : exists psi2 : nat -> StepFun b c, @@ -2378,7 +2378,7 @@ Proof. Rabs (f t - phi_sequence RinvN pr2 n t) <= psi2 n t) /\ Rabs (RiemannInt_SF (psi2 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr2 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr2 n)). assert (H3 : exists psi3 : nat -> StepFun a c, @@ -2388,9 +2388,9 @@ Proof. Rabs (f t - phi_sequence RinvN pr3 n t) <= psi3 n t) /\ Rabs (RiemannInt_SF (psi3 n)) < RinvN n)). split with (fun n:nat => proj1_sig (phi_sequence_prop RinvN pr3 n)); intro; - apply (proj2_sig (phi_sequence_prop RinvN pr3 n)). + apply (proj2_sig (phi_sequence_prop RinvN pr3 n)). elim H1; clear H1; intros psi1 H1; elim H2; clear H2; intros psi2 H2; elim H3; - clear H3; intros psi3 H3; assert (H := RinvN_cv); + clear H3; intros psi3 H3; assert (H := RinvN_cv); unfold Un_cv in |- *; intros; assert (H4 : 0 < eps / 3). unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup0 ]. @@ -2401,14 +2401,14 @@ Proof. (R_dist (mkposreal (/ (INR n + 1)) (RinvN_pos n)) 0). apply H; assumption. unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0; - rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; + rewrite Rplus_0_r; apply Rabs_right; apply Rle_ge; left; apply (cond_pos (RinvN n)). exists N0; intros; elim (H1 n); elim (H2 n); elim (H3 n); clear H1 H2 H3; - intros; unfold R_dist in |- *; unfold Rminus in |- *; - rewrite Ropp_0; rewrite Rplus_0_r; + intros; unfold R_dist in |- *; unfold Rminus in |- *; + rewrite Ropp_0; rewrite Rplus_0_r; set (phi1 := phi_sequence RinvN pr1 n) in H8 |- *; - set (phi2 := phi_sequence RinvN pr2 n) in H3 |- *; - set (phi3 := phi_sequence RinvN pr3 n) in H1 |- *; + set (phi2 := phi_sequence RinvN pr2 n) in H3 |- *; + set (phi3 := phi_sequence RinvN pr3 n) in H1 |- *; assert (H10 : IsStepFun phi3 a b). apply StepFun_P44 with c. apply (pre phi3). @@ -2832,7 +2832,7 @@ Proof. (derivable_pt_lim ((fct_cte (f b) * (id - fct_cte b))%F + fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b ( - f b + 0)) in |- *. + f b + 0)) in |- *. apply derivable_pt_lim_plus. pattern (f b) at 2 in |- *; replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1). @@ -2899,7 +2899,7 @@ Proof. apply (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))) (RiemannInt_P16 - (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))); + (RiemannInt_P10 (-1) H13 (RiemannInt_P14 (b + h0) b (f b))))); left; assumption. apply Rle_lt_trans with (RiemannInt (RiemannInt_P14 (b + h0) b (eps / 2)) * Rabs (/ h0)). @@ -2953,13 +2953,13 @@ Proof. rewrite RiemannInt_P15. rewrite <- Ropp_mult_distr_l_reverse; apply Rmult_eq_reg_l with h0; [ repeat rewrite (Rmult_comm h0); unfold Rdiv in |- *; - repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; + repeat rewrite Rmult_assoc; rewrite <- Rinv_l_sym; [ ring | assumption ] | assumption ]. cut (a <= b + h0). cut (b + h0 <= b). intros; unfold primitive in |- *; case (Rle_dec a (b + h0)); - case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b); + case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b); intros; try (elim n; right; reflexivity) || (elim n; left; assumption). rewrite <- (RiemannInt_P26 (FTC_P1 h C0 r3 r2) H13 (FTC_P1 h C0 r1 r0)); ring. elim n; assumption. @@ -3083,7 +3083,7 @@ Proof. apply (RiemannInt_P17 (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))) (RiemannInt_P16 - (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))); + (RiemannInt_P10 (-1) H13 (RiemannInt_P14 a (a + h0) (f a))))); left; assumption. apply Rle_lt_trans with (RiemannInt (RiemannInt_P14 a (a + h0) (eps / 2)) * Rabs (/ h0)). @@ -3138,7 +3138,7 @@ Proof. cut (a <= a + h0). cut (a + h0 <= b). intros; unfold primitive in |- *; case (Rle_dec a (a + h0)); - case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); + case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); intros; try (elim n; right; reflexivity) || (elim n; left; assumption). rewrite RiemannInt_P9; unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r; apply RiemannInt_P5. @@ -3174,7 +3174,7 @@ Proof. (derivable_pt_lim ((fct_cte (f b) * (id - fct_cte b))%F + fct_cte (RiemannInt (FTC_P1 h C0 h (Rle_refl b)))) b ( - f b + 0)) in |- *. + f b + 0)) in |- *. apply derivable_pt_lim_plus. pattern (f b) at 2 in |- *; replace (f b) with (0 * (id - fct_cte b)%F b + fct_cte (f b) b * 1). @@ -3198,7 +3198,7 @@ Proof. pattern a at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; assumption. rewrite H1; unfold primitive in |- *; case (Rle_dec a (a + h0)); - case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); + case (Rle_dec (a + h0) b); case (Rle_dec a a); case (Rle_dec a b); intros; try (elim n; right; assumption || reflexivity). elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r3 H10)). elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)). @@ -3216,7 +3216,7 @@ Proof. assumption. elim H8; symmetry in |- *; assumption. rewrite H0 in H1; rewrite H1; unfold primitive in |- *; - case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b); + case (Rle_dec a (b + h0)); case (Rle_dec (b + h0) b); case (Rle_dec a b); case (Rle_dec b b); intros; try (elim n; right; assumption || reflexivity). rewrite H0 in H10; elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ r2 H10)). @@ -3286,7 +3286,7 @@ Proof. intros; apply (cont1 f). rewrite (RiemannInt_P20 H (FTC_P1 H H0) pr); assert (H1 := RiemannInt_P29 H H0); assert (H2 := RiemannInt_P31 f H); - elim (antiderivative_Ucte (derive f (diff0 f)) _ _ _ _ H1 H2); + elim (antiderivative_Ucte (derive f (diff0 f)) _ _ _ _ H1 H2); intros C H3; repeat rewrite H3; [ ring | split; [ right; reflexivity | assumption ] diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 14f1ea6af1..e7f0375f03 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -36,8 +36,8 @@ Proof. intros I H H0; set (E := fun x:R => exists i : nat, I i /\ INR i = x); assert (H1 : bound E). unfold Nbound in H0; elim H0; intros N H1; unfold bound in |- *; - exists (INR N); unfold is_upper_bound in |- *; intros; - unfold E in H2; elim H2; intros; elim H3; intros; + exists (INR N); unfold is_upper_bound in |- *; intros; + unfold E in H2; elim H2; intros; elim H3; intros; rewrite <- H5; apply le_INR; apply H1; assumption. assert (H2 : exists x : R, E x). elim H; intros; exists (INR x); unfold E in |- *; exists x; split; @@ -54,13 +54,13 @@ Proof. assert (H9 : x <= IZR (up x) - 1). apply H5; intros; assert (H10 := H4 _ H9); unfold E in H9; elim H9; intros; elim H11; intros; rewrite <- H13; apply Rplus_le_reg_l with 1; - replace (1 + (IZR (up x) - 1)) with (IZR (up x)); + replace (1 + (IZR (up x) - 1)) with (IZR (up x)); [ idtac | ring ]; replace (1 + INR x1) with (INR (S x1)); [ idtac | rewrite S_INR; ring ]. assert (H14 : (0 <= up x)%Z). apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ]. assert (H15 := IZN _ H14); elim H15; clear H15; intros; rewrite H15; - rewrite <- INR_IZR_INZ; apply le_INR; apply lt_le_S; + rewrite <- INR_IZR_INZ; apply le_INR; apply lt_le_S; apply INR_lt; rewrite H13; apply Rle_lt_trans with x; [ assumption | rewrite INR_IZR_INZ; rewrite <- H15; assumption ]. assert (H10 : x = IZR (up x) - 1). @@ -68,7 +68,7 @@ Proof. [ assumption | apply Rplus_le_reg_l with (- x + 1); replace (- x + 1 + (IZR (up x) - 1)) with (IZR (up x) - x); - [ idtac | ring ]; replace (- x + 1 + x) with 1; + [ idtac | ring ]; replace (- x + 1 + x) with 1; [ assumption | ring ] ]. assert (H11 : (0 <= up x)%Z). apply le_IZR; apply Rle_trans with x; [ apply H6 | left; assumption ]. @@ -104,7 +104,7 @@ Proof. simpl in |- *; split. assumption. intros; apply INR_le; rewrite H15; rewrite <- H15; elim H12; intros; - rewrite H20; apply H4; unfold E in |- *; exists i; + rewrite H20; apply H4; unfold E in |- *; exists i; split; [ assumption | reflexivity ]. Qed. @@ -113,7 +113,7 @@ Qed. (*******************************************) Definition open_interval (a b x:R) : Prop := a < x < b. -Definition co_interval (a b x:R) : Prop := a <= x < b. +Definition co_interval (a b x:R) : Prop := a <= x < b. Definition adapted_couple (f:R -> R) (a b:R) (l lf:Rlist) : Prop := ordered_Rlist l /\ @@ -174,7 +174,7 @@ Definition RiemannInt_SF (a b:R) (f:StepFun a b) : R := Lemma StepFun_P1 : forall (a b:R) (f:StepFun a b), adapted_couple f a b (subdivision f) (subdivision_val f). -Proof. +Proof. intros a b f; unfold subdivision_val in |- *; case (projT2 (pre f)); intros; apply a0. Qed. @@ -182,7 +182,7 @@ Qed. Lemma StepFun_P2 : forall (a b:R) (f:R -> R) (l lf:Rlist), adapted_couple f a b l lf -> adapted_couple f b a l lf. -Proof. +Proof. unfold adapted_couple in |- *; intros; decompose [and] H; clear H; repeat split; try assumption. rewrite H2; unfold Rmin in |- *; case (Rle_dec a b); intro; @@ -199,7 +199,7 @@ Lemma StepFun_P3 : forall a b c:R, a <= b -> adapted_couple (fct_cte c) a b (cons a (cons b nil)) (cons c nil). -Proof. +Proof. intros; unfold adapted_couple in |- *; repeat split. unfold ordered_Rlist in |- *; intros; simpl in H0; inversion H0; [ simpl in |- *; assumption | elim (le_Sn_O _ H2) ]. @@ -212,19 +212,19 @@ Proof. Qed. Lemma StepFun_P4 : forall a b c:R, IsStepFun (fct_cte c) a b. -Proof. +Proof. intros; unfold IsStepFun in |- *; case (Rle_dec a b); intro. apply existT with (cons a (cons b nil)); unfold is_subdivision in |- *; apply existT with (cons c nil); apply (StepFun_P3 c r). apply existT with (cons b (cons a nil)); unfold is_subdivision in |- *; - apply existT with (cons c nil); apply StepFun_P2; + apply existT with (cons c nil); apply StepFun_P2; apply StepFun_P3; auto with real. Qed. Lemma StepFun_P5 : forall (a b:R) (f:R -> R) (l:Rlist), is_subdivision f a b l -> is_subdivision f b a l. -Proof. +Proof. destruct 1 as (x,(H0,(H1,(H2,(H3,H4))))); exists x; repeat split; try assumption. rewrite H1; apply Rmin_comm. @@ -233,7 +233,7 @@ Qed. Lemma StepFun_P6 : forall (f:R -> R) (a b:R), IsStepFun f a b -> IsStepFun f b a. -Proof. +Proof. unfold IsStepFun in |- *; intros; elim X; intros; apply existT with x; apply StepFun_P5; assumption. Qed. @@ -243,7 +243,7 @@ Lemma StepFun_P7 : a <= b -> adapted_couple f a b (cons r1 (cons r2 l)) (cons r3 lf) -> adapted_couple f r2 b (cons r2 l) lf. -Proof. +Proof. unfold adapted_couple in |- *; intros; decompose [and] H0; clear H0; assert (H5 : Rmax a b = b). unfold Rmax in |- *; case (Rle_dec a b); intro; @@ -258,7 +258,7 @@ Proof. unfold Rmax in |- *; case (Rle_dec r2 b); intro; [ rewrite H5 in H2; rewrite <- H2; reflexivity | elim n; assumption ]. simpl in H4; simpl in |- *; apply INR_eq; apply Rplus_eq_reg_l with 1; - do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR; + do 2 rewrite (Rplus_comm 1); do 2 rewrite <- S_INR; rewrite H4; reflexivity. intros; unfold constant_D_eq, open_interval in |- *; intros; unfold constant_D_eq, open_interval in H6; @@ -270,7 +270,7 @@ Qed. Lemma StepFun_P8 : forall (f:R -> R) (l1 lf1:Rlist) (a b:R), adapted_couple f a b l1 lf1 -> a = b -> Int_SF lf1 l1 = 0. -Proof. +Proof. simple induction l1. intros; induction lf1 as [| r lf1 Hreclf1]; reflexivity. simple induction r0. @@ -285,7 +285,7 @@ Proof. ring. rewrite H3; apply StepFun_P7 with a r r3; [ right; assumption | assumption ]. clear H H0 Hreclf1 r0; unfold adapted_couple in H1; decompose [and] H1; - intros; simpl in H4; rewrite H4; unfold Rmin in |- *; + intros; simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intro; [ assumption | reflexivity ]. unfold adapted_couple in H1; decompose [and] H1; intros; apply Rle_antisym. apply (H3 0%nat); simpl in |- *; apply lt_O_Sn. @@ -299,14 +299,14 @@ Qed. Lemma StepFun_P9 : forall (a b:R) (f:R -> R) (l lf:Rlist), adapted_couple f a b l lf -> a <> b -> (2 <= Rlength l)%nat. -Proof. +Proof. intros; unfold adapted_couple in H; decompose [and] H; clear H; induction l as [| r l Hrecl]; [ simpl in H4; discriminate | induction l as [| r0 l Hrecl0]; [ simpl in H3; simpl in H2; generalize H3; generalize H2; - unfold Rmin, Rmax in |- *; case (Rle_dec a b); - intros; elim H0; rewrite <- H5; rewrite <- H7; + unfold Rmin, Rmax in |- *; case (Rle_dec a b); + intros; elim H0; rewrite <- H5; rewrite <- H7; reflexivity | simpl in |- *; do 2 apply le_n_S; apply le_O_n ] ]. Qed. @@ -317,13 +317,13 @@ Lemma StepFun_P10 : adapted_couple f a b l lf -> exists l' : Rlist, (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). -Proof. +Proof. simple induction l. intros; unfold adapted_couple in H0; decompose [and] H0; simpl in H4; discriminate. intros; case (Req_dec a b); intro. exists (cons a nil); exists nil; unfold adapted_couple_opt in |- *; - unfold adapted_couple in |- *; unfold ordered_Rlist in |- *; + unfold adapted_couple in |- *; unfold ordered_Rlist in |- *; repeat split; try (intros; simpl in H3; elim (lt_n_O _ H3)). simpl in |- *; rewrite <- H2; unfold Rmin in |- *; case (Rle_dec a a); intro; reflexivity. @@ -341,7 +341,7 @@ Proof. replace a with t2. apply H6. rewrite <- Hyp_eq; rewrite H3 in H1; unfold adapted_couple in H1; - decompose [and] H1; clear H1; simpl in H9; rewrite H9; + decompose [and] H1; clear H1; simpl in H9; rewrite H9; unfold Rmin in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. elim H6; clear H6; intros l' [lf' H6]; case (Req_dec t2 b); intro. @@ -360,7 +360,7 @@ Proof. decompose [and] H1; apply (H16 0%nat). simpl in |- *; apply lt_O_Sn. unfold open_interval in |- *; simpl in |- *; rewrite H7; simpl in H13; - rewrite H13; unfold Rmin in |- *; case (Rle_dec a b); + rewrite H13; unfold Rmin in |- *; case (Rle_dec a b); intro; [ assumption | elim n; assumption ]. elim (le_Sn_O _ H10). intros; simpl in H8; elim (lt_n_O _ H8). @@ -377,7 +377,7 @@ Proof. clear Hreclf'; case (Req_dec r1 r2); intro. case (Req_dec (f t2) r1); intro. exists (cons t1 (cons s2 s3)); exists (cons r1 lf'); rewrite H3 in H1; - rewrite H9 in H6; unfold adapted_couple in H6, H1; + rewrite H9 in H6; unfold adapted_couple in H6, H1; decompose [and] H1; decompose [and] H6; clear H1 H6; unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; repeat split. @@ -417,7 +417,7 @@ Proof. change (pos_Rl (cons r2 lf') i <> pos_Rl (cons r2 lf') (S i) \/ f (pos_Rl (cons s1 (cons s2 s3)) (S i)) <> pos_Rl (cons r2 lf') i) - in |- *; rewrite <- H9; elim H8; intros; apply H6; + in |- *; rewrite <- H9; elim H8; intros; apply H6; simpl in |- *; apply H1. intros; induction i as [| i Hreci]. simpl in |- *; red in |- *; intro; elim Hyp_eq; apply Rle_antisym. @@ -427,7 +427,7 @@ Proof. elim H8; intros; rewrite H9 in H21; apply (H21 (S i)); simpl in |- *; simpl in H1; apply H1. exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6; - rewrite H3 in H1; unfold adapted_couple in H1, H6; + rewrite H3 in H1; unfold adapted_couple in H1, H6; decompose [and] H6; decompose [and] H1; clear H6 H1; unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; repeat split. @@ -438,7 +438,7 @@ Proof. simpl in H14; rewrite H14; rewrite Hyp_min; reflexivity. change (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i)) - in |- *; apply (H12 i); simpl in |- *; apply lt_S_n; + in |- *; apply (H12 i); simpl in |- *; apply lt_S_n; assumption. simpl in |- *; simpl in H19; apply H19. rewrite H9; simpl in |- *; simpl in H13; rewrite H13; unfold Rmax in |- *; @@ -470,7 +470,7 @@ Proof. elim H8; intros; rewrite <- H9; apply (H21 i); rewrite H9; rewrite H9 in H1; simpl in |- *; simpl in H1; apply lt_S_n; apply H1. exists (cons t1 l'); exists (cons r1 (cons r2 lf')); rewrite H9 in H6; - rewrite H3 in H1; unfold adapted_couple in H1, H6; + rewrite H3 in H1; unfold adapted_couple in H1, H6; decompose [and] H6; decompose [and] H1; clear H6 H1; unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; repeat split. @@ -481,7 +481,7 @@ Proof. simpl in H13; rewrite H13; rewrite Hyp_min; reflexivity. change (pos_Rl (cons s1 (cons s2 s3)) i <= pos_Rl (cons s1 (cons s2 s3)) (S i)) - in |- *; apply (H11 i); simpl in |- *; apply lt_S_n; + in |- *; apply (H11 i); simpl in |- *; apply lt_S_n; assumption. simpl in |- *; simpl in H18; apply H18. rewrite H9; simpl in |- *; simpl in H12; rewrite H12; unfold Rmax in |- *; @@ -518,14 +518,14 @@ Proof. Qed. Lemma StepFun_P11 : - forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) + forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) (f:R -> R), a < b -> adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) -> adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2. -Proof. +Proof. intros; unfold adapted_couple_opt in H1; elim H1; clear H1; intros; - unfold adapted_couple in H0, H1; decompose [and] H0; + unfold adapted_couple in H0, H1; decompose [and] H0; decompose [and] H1; clear H0 H1; assert (H12 : r = s1). simpl in H10; simpl in H5; rewrite H10; rewrite H5; reflexivity. assert (H14 := H3 0%nat (lt_O_Sn _)); simpl in H14; elim H14; intro. @@ -542,7 +542,7 @@ Proof. clear Hreclf2; assert (H17 : r3 = r4). set (x := (r + s2) / 2); assert (H17 := H8 0%nat (lt_O_Sn _)); assert (H18 := H13 0%nat (lt_O_Sn _)); - unfold constant_D_eq, open_interval in H17, H18; simpl in H17; + unfold constant_D_eq, open_interval in H17, H18; simpl in H17; simpl in H18; rewrite <- (H17 x). rewrite <- (H18 x). reflexivity. @@ -582,7 +582,7 @@ Proof. | unfold open_interval in |- *; simpl in |- *; split; assumption ]. assert (H19 : r3 = r5). assert (H19 := H7 1%nat); simpl in H19; - assert (H20 := H19 (lt_n_S _ _ (lt_O_Sn _))); elim H20; + assert (H20 := H19 (lt_n_S _ _ (lt_O_Sn _))); elim H20; intro. set (x := (s2 + Rmin r1 r0) / 2); assert (H22 := H8 0%nat); assert (H23 := H13 1%nat); simpl in H22; simpl in H23; @@ -595,7 +595,7 @@ Proof. | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; - unfold Rmin in |- *; case (Rle_dec r1 r0); intro; + unfold Rmin in |- *; case (Rle_dec r1 r0); intro; assumption | discrR ] ]. apply Rmult_lt_reg_l with 2; @@ -616,7 +616,7 @@ Proof. | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; - unfold Rmin in |- *; case (Rle_dec r1 r0); + unfold Rmin in |- *; case (Rle_dec r1 r0); intro; assumption | discrR ] ] ]. apply Rmult_lt_reg_l with 2; @@ -630,7 +630,7 @@ Proof. | apply Rplus_le_compat_l; apply Rmin_l ] | discrR ] ]. elim H2; clear H2; intros; assert (H23 := H22 1%nat); simpl in H23; - assert (H24 := H23 (lt_n_S _ _ (lt_O_Sn _))); elim H24; + assert (H24 := H23 (lt_n_S _ _ (lt_O_Sn _))); elim H24; assumption. elim H2; intros; assert (H22 := H20 0%nat); simpl in H22; assert (H23 := H22 (lt_O_Sn _)); elim H23; intro; @@ -644,7 +644,7 @@ Qed. Lemma StepFun_P12 : forall (a b:R) (f:R -> R) (l lf:Rlist), adapted_couple_opt f a b l lf -> adapted_couple_opt f b a l lf. -Proof. +Proof. unfold adapted_couple_opt in |- *; unfold adapted_couple in |- *; intros; decompose [and] H; clear H; repeat split; try assumption. rewrite H0; unfold Rmin in |- *; case (Rle_dec a b); intro; @@ -658,12 +658,12 @@ Proof. Qed. Lemma StepFun_P13 : - forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) + forall (a b r r1 r3 s1 s2 r4:R) (r2 lf1 s3 lf2:Rlist) (f:R -> R), a <> b -> adapted_couple f a b (cons r (cons r1 r2)) (cons r3 lf1) -> adapted_couple_opt f a b (cons s1 (cons s2 s3)) (cons r4 lf2) -> r1 <= s2. -Proof. +Proof. intros; case (total_order_T a b); intro. elim s; intro. eapply StepFun_P11; [ apply a0 | apply H0 | apply H1 ]. @@ -677,7 +677,7 @@ Lemma StepFun_P14 : a <= b -> adapted_couple f a b l1 lf1 -> adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. -Proof. +Proof. simple induction l1. intros l2 lf1 lf2 a b Hyp H H0; unfold adapted_couple in H; decompose [and] H; clear H H0 H2 H3 H1 H6; simpl in H4; discriminate. @@ -705,7 +705,7 @@ Proof. clear H H2 H4 H5 H3 H6 H8 H7 H11; simpl in H9; discriminate. clear Hreclf2; assert (H6 : r = s1). unfold adapted_couple in H, H2; decompose [and] H; decompose [and] H2; - clear H H2; simpl in H13; simpl in H8; rewrite H13; + clear H H2; simpl in H13; simpl in H8; rewrite H13; rewrite H8; reflexivity. assert (H7 : r3 = r4 \/ r = r1). case (Req_dec r r1); intro. @@ -718,7 +718,7 @@ Proof. rewrite <- (H20 (lt_O_Sn _) x). reflexivity. assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21; intro; - [ idtac | elim H7; assumption ]; unfold x in |- *; + [ idtac | elim H7; assumption ]; unfold x in |- *; split. apply Rmult_lt_reg_l with 2; [ prove_sup0 @@ -734,7 +734,7 @@ Proof. apply Rplus_lt_compat_l; apply H | discrR ] ]. rewrite <- H6; assert (H21 := H13 0%nat (lt_O_Sn _)); simpl in H21; elim H21; - intro; [ idtac | elim H7; assumption ]; unfold x in |- *; + intro; [ idtac | elim H7; assumption ]; unfold x in |- *; split. apply Rmult_lt_reg_l with 2; [ prove_sup0 @@ -884,7 +884,7 @@ Lemma StepFun_P15 : forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R), adapted_couple f a b l1 lf1 -> adapted_couple_opt f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. -Proof. +Proof. intros; case (Rle_dec a b); intro; [ apply (StepFun_P14 r H H0) | assert (H1 : b <= a); @@ -897,8 +897,8 @@ Lemma StepFun_P16 : forall (f:R -> R) (l lf:Rlist) (a b:R), adapted_couple f a b l lf -> exists l' : Rlist, - (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). -Proof. + (exists lf' : Rlist, adapted_couple_opt f a b l' lf'). +Proof. intros; case (Rle_dec a b); intro; [ apply (StepFun_P10 r H) | assert (H1 : b <= a); @@ -912,14 +912,14 @@ Lemma StepFun_P17 : forall (f:R -> R) (l1 l2 lf1 lf2:Rlist) (a b:R), adapted_couple f a b l1 lf1 -> adapted_couple f a b l2 lf2 -> Int_SF lf1 l1 = Int_SF lf2 l2. -Proof. +Proof. intros; elim (StepFun_P16 H); intros l' [lf' H1]; rewrite (StepFun_P15 H H1); rewrite (StepFun_P15 H0 H1); reflexivity. Qed. Lemma StepFun_P18 : forall a b c:R, RiemannInt_SF (mkStepFun (StepFun_P4 a b c)) = c * (b - a). -Proof. +Proof. intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro. replace (Int_SF (subdivision_val (mkStepFun (StepFun_P4 a b c))) @@ -943,7 +943,7 @@ Lemma StepFun_P19 : forall (l1:Rlist) (f g:R -> R) (l:R), Int_SF (FF l1 (fun x:R => f x + l * g x)) l1 = Int_SF (FF l1 f) l1 + l * Int_SF (FF l1 g) l1. -Proof. +Proof. intros; induction l1 as [| r l1 Hrecl1]; [ simpl in |- *; ring | induction l1 as [| r0 l1 Hrecl0]; simpl in |- *; @@ -953,7 +953,7 @@ Qed. Lemma StepFun_P20 : forall (l:Rlist) (f:R -> R), (0 < Rlength l)%nat -> Rlength l = S (Rlength (FF l f)). -Proof. +Proof. intros l f H; induction l; [ elim (lt_irrefl _ H) | simpl in |- *; rewrite RList_P18; rewrite RList_P14; reflexivity ]. @@ -962,9 +962,9 @@ Qed. Lemma StepFun_P21 : forall (a b:R) (f:R -> R) (l:Rlist), is_subdivision f a b l -> adapted_couple f a b l (FF l f). -Proof. +Proof. intros; unfold adapted_couple in |- *; unfold is_subdivision in X; - unfold adapted_couple in X; elim X; clear X; intros; + unfold adapted_couple in X; elim X; clear X; intros; decompose [and] p; clear p; repeat split; try assumption. apply StepFun_P20; rewrite H2; apply lt_O_Sn. intros; assert (H5 := H4 _ H3); unfold constant_D_eq, open_interval in H5; @@ -974,7 +974,7 @@ Proof. unfold FF in |- *; rewrite RList_P12. simpl in |- *; change (f x0 = f (pos_Rl (mid_Rlist (cons r l) r) (S i))) in |- *; - rewrite RList_P13; try assumption; rewrite (H5 x0 H6); + rewrite RList_P13; try assumption; rewrite (H5 x0 H6); rewrite H5. reflexivity. split. @@ -990,7 +990,7 @@ Proof. | unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym; [ rewrite Rmult_1_l; rewrite double; - rewrite (Rplus_comm (pos_Rl (cons r l) i)); + rewrite (Rplus_comm (pos_Rl (cons r l) i)); apply Rplus_lt_compat_l; elim H6; intros; apply Rlt_trans with x0; assumption | discrR ] ]. @@ -1002,7 +1002,7 @@ Lemma StepFun_P22 : a <= b -> is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg). -Proof. +Proof. unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0; clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a). unfold Rmin in |- *; case (Rle_dec a b); intro; @@ -1011,9 +1011,9 @@ Proof. unfold Rmax in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. apply existT with (FF (cons_ORlist lf lg) f); unfold adapted_couple in p, p0; - decompose [and] p; decompose [and] p0; clear p p0; + decompose [and] p; decompose [and] p0; clear p p0; rewrite Hyp_min in H6; rewrite Hyp_min in H1; rewrite Hyp_max in H0; - rewrite Hyp_max in H5; unfold adapted_couple in |- *; + rewrite Hyp_max in H5; unfold adapted_couple in |- *; repeat split. apply RList_P2; assumption. rewrite Hyp_min; symmetry in |- *; apply Rle_antisym. @@ -1024,25 +1024,25 @@ Proof. In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)). elim (RList_P3 (cons_ORlist (cons r lf) lg) - (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; + (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; apply H10; exists 0%nat; split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ]. elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H12 _; assert (H13 := H12 H10); elim H13; intro. elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0)); - intros H11 _; assert (H14 := H11 H8); elim H14; intros; + intros H11 _; assert (H14 := H11 H8); elim H14; intros; elim H15; clear H15; intros; rewrite H15; rewrite <- H6; elim (RList_P6 (cons r lf)); intros; apply H17; [ assumption | apply le_O_n | assumption ]. elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _; - assert (H14 := H11 H8); elim H14; intros; elim H15; - clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); + assert (H14 := H11 H8); elim H14; intros; elim H15; + clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); intros; apply H17; [ assumption | apply le_O_n | assumption ]. induction lf as [| r lf Hreclf]. simpl in |- *; right; assumption. assert (H8 : In a (cons_ORlist (cons r lf) lg)). elim (RList_P9 (cons r lf) lg a); intros; apply H10; left; - elim (RList_P3 (cons r lf) a); intros; apply H12; + elim (RList_P3 (cons r lf) a); intros; apply H12; exists 0%nat; split; [ symmetry in |- *; assumption | simpl in |- *; apply lt_O_Sn ]. apply RList_P5; [ apply RList_P2; assumption | assumption ]. @@ -1058,21 +1058,21 @@ Proof. elim (RList_P3 (cons_ORlist (cons r lf) lg) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (Rlength (cons_ORlist (cons r lf) lg))))); intros _ H10; apply H10; - exists (pred (Rlength (cons_ORlist (cons r lf) lg))); + exists (pred (Rlength (cons_ORlist (cons r lf) lg))); split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ]. elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (Rlength (cons_ORlist (cons r lf) lg))))); intros H10 _. assert (H11 := H10 H8); elim H11; intro. elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; + (pred (Rlength (cons_ORlist (cons r lf) lg))))); + intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros; rewrite H15; rewrite <- H5; elim (RList_P6 (cons r lf)); intros; apply H17; [ assumption @@ -1081,8 +1081,8 @@ Proof. elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; + (pred (Rlength (cons_ORlist (cons r lf) lg))))); + intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros. rewrite H15; assert (H17 : Rlength lg = S (pred (Rlength lg))). apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro; @@ -1187,7 +1187,7 @@ Proof. apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H5; rewrite <- H6 in H11; rewrite <- H5 in H11; elim (Rlt_irrefl _ H11). assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14; - exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval in |- *; + exists (pos_Rl lf0 x0); unfold constant_D_eq, open_interval in |- *; intros; assert (H16 := H9 x0); assert (H17 : (x0 < pred (Rlength lf))%nat). elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros; apply lt_S_n; replace (S (pred (Rlength lf))) with (Rlength lf). @@ -1232,7 +1232,7 @@ Proof. clear b0; apply RList_P17; try assumption. apply RList_P2; assumption. elim (RList_P9 lf lg (pos_Rl lf (S x0))); intros; apply H25; left; - elim (RList_P3 lf (pos_Rl lf (S x0))); intros; apply H27; + elim (RList_P3 lf (pos_Rl lf (S x0))); intros; apply H27; exists (S x0); split; [ reflexivity | apply H22 ]. Qed. @@ -1240,7 +1240,7 @@ Lemma StepFun_P23 : forall (a b:R) (f g:R -> R) (lf lg:Rlist), is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision f a b (cons_ORlist lf lg). -Proof. +Proof. intros; case (Rle_dec a b); intro; [ apply StepFun_P22 with g; assumption | apply StepFun_P5; apply StepFun_P22 with g; @@ -1254,7 +1254,7 @@ Lemma StepFun_P24 : a <= b -> is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg). -Proof. +Proof. unfold is_subdivision in |- *; intros a b f g lf lg Hyp X X0; elim X; elim X0; clear X X0; intros lg0 p lf0 p0; assert (Hyp_min : Rmin a b = a). unfold Rmin in |- *; case (Rle_dec a b); intro; @@ -1263,9 +1263,9 @@ Proof. unfold Rmax in |- *; case (Rle_dec a b); intro; [ reflexivity | elim n; assumption ]. apply existT with (FF (cons_ORlist lf lg) g); unfold adapted_couple in p, p0; - decompose [and] p; decompose [and] p0; clear p p0; + decompose [and] p; decompose [and] p0; clear p p0; rewrite Hyp_min in H1; rewrite Hyp_min in H6; rewrite Hyp_max in H0; - rewrite Hyp_max in H5; unfold adapted_couple in |- *; + rewrite Hyp_max in H5; unfold adapted_couple in |- *; repeat split. apply RList_P2; assumption. rewrite Hyp_min; symmetry in |- *; apply Rle_antisym. @@ -1276,25 +1276,25 @@ Proof. In (pos_Rl (cons_ORlist (cons r lf) lg) 0) (cons_ORlist (cons r lf) lg)). elim (RList_P3 (cons_ORlist (cons r lf) lg) - (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; + (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros _ H10; apply H10; exists 0%nat; split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_O_Sn ]. elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H12 _; assert (H13 := H12 H10); elim H13; intro. elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) 0)); - intros H11 _; assert (H14 := H11 H8); elim H14; intros; + intros H11 _; assert (H14 := H11 H8); elim H14; intros; elim H15; clear H15; intros; rewrite H15; rewrite <- H6; elim (RList_P6 (cons r lf)); intros; apply H17; [ assumption | apply le_O_n | assumption ]. elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) 0)); intros H11 _; - assert (H14 := H11 H8); elim H14; intros; elim H15; - clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); + assert (H14 := H11 H8); elim H14; intros; elim H15; + clear H15; intros; rewrite H15; rewrite <- H1; elim (RList_P6 lg); intros; apply H17; [ assumption | apply le_O_n | assumption ]. induction lf as [| r lf Hreclf]. simpl in |- *; right; assumption. assert (H8 : In a (cons_ORlist (cons r lf) lg)). elim (RList_P9 (cons r lf) lg a); intros; apply H10; left; - elim (RList_P3 (cons r lf) a); intros; apply H12; + elim (RList_P3 (cons r lf) a); intros; apply H12; exists 0%nat; split; [ symmetry in |- *; assumption | simpl in |- *; apply lt_O_Sn ]. apply RList_P5; [ apply RList_P2; assumption | assumption ]. @@ -1310,20 +1310,20 @@ Proof. elim (RList_P3 (cons_ORlist (cons r lf) lg) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (Rlength (cons_ORlist (cons r lf) lg))))); intros _ H10; apply H10; - exists (pred (Rlength (cons_ORlist (cons r lf) lg))); + exists (pred (Rlength (cons_ORlist (cons r lf) lg))); split; [ reflexivity | rewrite RList_P11; simpl in |- *; apply lt_n_Sn ]. elim (RList_P9 (cons r lf) lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); + (pred (Rlength (cons_ORlist (cons r lf) lg))))); intros H10 _; assert (H11 := H10 H8); elim H11; intro. elim (RList_P3 (cons r lf) (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; + (pred (Rlength (cons_ORlist (cons r lf) lg))))); + intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros; rewrite H15; rewrite <- H5; elim (RList_P6 (cons r lf)); intros; apply H17; [ assumption @@ -1332,8 +1332,8 @@ Proof. elim (RList_P3 lg (pos_Rl (cons_ORlist (cons r lf) lg) - (pred (Rlength (cons_ORlist (cons r lf) lg))))); - intros H13 _; assert (H14 := H13 H12); elim H14; intros; + (pred (Rlength (cons_ORlist (cons r lf) lg))))); + intros H13 _; assert (H14 := H13 H12); elim H14; intros; elim H15; clear H15; intros; rewrite H15; assert (H17 : Rlength lg = S (pred (Rlength lg))). apply S_pred with 0%nat; apply neq_O_lt; red in |- *; intro; @@ -1436,7 +1436,7 @@ Proof. apply neq_O_lt; red in |- *; intro; rewrite <- H13 in H0; rewrite <- H1 in H11; rewrite <- H0 in H11; elim (Rlt_irrefl _ H11). assert (H14 := Nzorn H13 H12); elim H14; clear H14; intros x0 H14; - exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval in |- *; + exists (pos_Rl lg0 x0); unfold constant_D_eq, open_interval in |- *; intros; assert (H16 := H4 x0); assert (H17 : (x0 < pred (Rlength lg))%nat). elim H14; clear H14; intros; unfold I in H14; elim H14; clear H14; intros; apply lt_S_n; replace (S (pred (Rlength lg))) with (Rlength lg). @@ -1481,7 +1481,7 @@ Proof. clear b0; apply RList_P17; try assumption; [ apply RList_P2; assumption | elim (RList_P9 lf lg (pos_Rl lg (S x0))); intros; apply H25; right; - elim (RList_P3 lg (pos_Rl lg (S x0))); intros; + elim (RList_P3 lg (pos_Rl lg (S x0))); intros; apply H27; exists (S x0); split; [ reflexivity | apply H22 ] ]. Qed. @@ -1489,7 +1489,7 @@ Lemma StepFun_P25 : forall (a b:R) (f g:R -> R) (lf lg:Rlist), is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision g a b (cons_ORlist lf lg). -Proof. +Proof. intros a b f g lf lg H H0; case (Rle_dec a b); intro; [ apply StepFun_P24 with f; assumption | apply StepFun_P5; apply StepFun_P24 with f; @@ -1504,12 +1504,12 @@ Lemma StepFun_P26 : is_subdivision g a b l1 -> is_subdivision (fun x:R => f x + l * g x) a b l1. Proof. - intros a b l f g l1 (x0,(H0,(H1,(H2,(H3,H4))))) + intros a b l f g l1 (x0,(H0,(H1,(H2,(H3,H4))))) (x,(_,(_,(_,(_,H9))))). exists (FF l1 (fun x:R => f x + l * g x)); repeat split; try assumption. apply StepFun_P20; rewrite H3; auto with arith. - intros i H8 x1 H10; unfold open_interval in H10, H9, H4; - rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10); + intros i H8 x1 H10; unfold open_interval in H10, H9, H4; + rewrite (H9 _ H8 _ H10); rewrite (H4 _ H8 _ H10); assert (H11 : l1 <> nil). red in |- *; intro H11; rewrite H11 in H8; elim (lt_n_O _ H8). destruct (RList_P19 _ H11) as (r,(r0,H12)); @@ -1548,7 +1548,7 @@ Lemma StepFun_P27 : is_subdivision f a b lf -> is_subdivision g a b lg -> is_subdivision (fun x:R => f x + l * g x) a b (cons_ORlist lf lg). -Proof. +Proof. intros a b l f g lf lg H H0; apply StepFun_P26; [ apply StepFun_P23 with g; assumption | apply StepFun_P25 with f; assumption ]. @@ -1557,16 +1557,16 @@ Qed. (** The set of step functions on [a,b] is a vectorial space *) Lemma StepFun_P28 : forall (a b l:R) (f g:StepFun a b), IsStepFun (fun x:R => f x + l * g x) a b. -Proof. +Proof. intros a b l f g; unfold IsStepFun in |- *; assert (H := pre f); - assert (H0 := pre g); unfold IsStepFun in H, H0; elim H; - elim H0; intros; apply existT with (cons_ORlist x0 x); + assert (H0 := pre g); unfold IsStepFun in H, H0; elim H; + elim H0; intros; apply existT with (cons_ORlist x0 x); apply StepFun_P27; assumption. Qed. Lemma StepFun_P29 : forall (a b:R) (f:StepFun a b), is_subdivision f a b (subdivision f). -Proof. +Proof. intros a b f; unfold is_subdivision in |- *; apply existT with (subdivision_val f); apply StepFun_P1. Qed. @@ -1575,7 +1575,7 @@ Lemma StepFun_P30 : forall (a b l:R) (f g:StepFun a b), RiemannInt_SF (mkStepFun (StepFun_P28 l f g)) = RiemannInt_SF f + l * RiemannInt_SF g. -Proof. +Proof. intros a b l f g; unfold RiemannInt_SF in |- *; case (Rle_dec a b); (intro; replace @@ -1612,29 +1612,29 @@ Lemma StepFun_P31 : forall (a b:R) (f:R -> R) (l lf:Rlist), adapted_couple f a b l lf -> adapted_couple (fun x:R => Rabs (f x)) a b l (app_Rlist lf Rabs). -Proof. +Proof. unfold adapted_couple in |- *; intros; decompose [and] H; clear H; repeat split; try assumption. symmetry in |- *; rewrite H3; rewrite RList_P18; reflexivity. intros; unfold constant_D_eq, open_interval in |- *; - unfold constant_D_eq, open_interval in H5; intros; + unfold constant_D_eq, open_interval in H5; intros; rewrite (H5 _ H _ H4); rewrite RList_P12; [ reflexivity | rewrite H3 in H; simpl in H; apply H ]. Qed. Lemma StepFun_P32 : forall (a b:R) (f:StepFun a b), IsStepFun (fun x:R => Rabs (f x)) a b. -Proof. +Proof. intros a b f; unfold IsStepFun in |- *; apply existT with (subdivision f); unfold is_subdivision in |- *; - apply existT with (app_Rlist (subdivision_val f) Rabs); + apply existT with (app_Rlist (subdivision_val f) Rabs); apply StepFun_P31; apply StepFun_P1. Qed. Lemma StepFun_P33 : forall l2 l1:Rlist, ordered_Rlist l1 -> Rabs (Int_SF l2 l1) <= Int_SF (app_Rlist l2 Rabs) l1. -Proof. +Proof. simple induction l2; intros. simpl in |- *; rewrite Rabs_R0; right; reflexivity. simpl in |- *; induction l1 as [| r1 l1 Hrecl1]. @@ -1653,14 +1653,14 @@ Lemma StepFun_P34 : forall (a b:R) (f:StepFun a b), a <= b -> Rabs (RiemannInt_SF f) <= RiemannInt_SF (mkStepFun (StepFun_P32 f)). -Proof. +Proof. intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro. replace (Int_SF (subdivision_val (mkStepFun (StepFun_P32 f))) (subdivision (mkStepFun (StepFun_P32 f)))) with (Int_SF (app_Rlist (subdivision_val f) Rabs) (subdivision f)). apply StepFun_P33; assert (H0 := StepFun_P29 f); unfold is_subdivision in H0; - elim H0; intros; unfold adapted_couple in p; decompose [and] p; + elim H0; intros; unfold adapted_couple in p; decompose [and] p; assumption. apply StepFun_P17 with (fun x:R => Rabs (f x)) a b; [ apply StepFun_P31; apply StepFun_P1 @@ -1675,7 +1675,7 @@ Lemma StepFun_P35 : pos_Rl l (pred (Rlength l)) = b -> (forall x:R, a < x < b -> f x <= g x) -> Int_SF (FF l f) l <= Int_SF (FF l g) l. -Proof. +Proof. simple induction l; intros. right; reflexivity. simpl in |- *; induction r0 as [| r0 r1 Hrecr0]. @@ -1742,7 +1742,7 @@ Lemma StepFun_P36 : is_subdivision g a b l -> (forall x:R, a < x < b -> f x <= g x) -> RiemannInt_SF f <= RiemannInt_SF g. -Proof. +Proof. intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); intro. replace (Int_SF (subdivision_val f) (subdivision f)) with (Int_SF (FF l f) l). replace (Int_SF (subdivision_val g) (subdivision g)) with (Int_SF (FF l g) l). @@ -1768,7 +1768,7 @@ Lemma StepFun_P37 : a <= b -> (forall x:R, a < x < b -> f x <= g x) -> RiemannInt_SF f <= RiemannInt_SF g. -Proof. +Proof. intros; eapply StepFun_P36; try assumption. eapply StepFun_P25; apply StepFun_P29. eapply StepFun_P23; apply StepFun_P29. @@ -1785,8 +1785,8 @@ Lemma StepFun_P38 : (i < pred (Rlength l))%nat -> constant_D_eq g (co_interval (pos_Rl l i) (pos_Rl l (S i))) (f (pos_Rl l i))) }. -Proof. - intros l a b f; generalize a; clear a; induction l. +Proof. + intros l a b f; generalize a; clear a; induction l. intros a H H0 H1; simpl in H0; simpl in H1; exists (mkStepFun (StepFun_P4 a b (f b))); split. reflexivity. @@ -1812,7 +1812,7 @@ Proof. rewrite <- H4; apply RList_P7; [ assumption | left; reflexivity ]. assert (H8 : IsStepFun g' a b). unfold IsStepFun in |- *; assert (H8 := pre g); unfold IsStepFun in H8; - elim H8; intros lg H9; unfold is_subdivision in H9; + elim H8; intros lg H9; unfold is_subdivision in H9; elim H9; clear H9; intros lg2 H9; split with (cons a lg); unfold is_subdivision in |- *; split with (cons (f a) lg2); unfold adapted_couple in H9; decompose [and] H9; clear H9; @@ -1896,7 +1896,7 @@ Proof. assert (H11 : (i < pred (Rlength (cons r1 l)))%nat). simpl in |- *; apply lt_S_n; assumption. assert (H12 := H10 H11); unfold constant_D_eq, co_interval in H12; - unfold constant_D_eq, co_interval in |- *; intros; + unfold constant_D_eq, co_interval in |- *; intros; rewrite <- (H12 _ H13); simpl in |- *; unfold g' in |- *; case (Rle_dec r1 x); intro. reflexivity. @@ -1913,7 +1913,7 @@ Qed. Lemma StepFun_P39 : forall (a b:R) (f:StepFun a b), RiemannInt_SF f = - RiemannInt_SF (mkStepFun (StepFun_P6 (pre f))). -Proof. +Proof. intros; unfold RiemannInt_SF in |- *; case (Rle_dec a b); case (Rle_dec b a); intros. assert (H : adapted_couple f a b (subdivision f) (subdivision_val f)); @@ -1931,12 +1931,12 @@ Proof. rewrite Ropp_involutive; eapply StepFun_P17; [ apply StepFun_P1 | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H; - elim H; intros; unfold is_subdivision in |- *; + elim H; intros; unfold is_subdivision in |- *; elim p; intros; apply p0 ]. apply Ropp_eq_compat; eapply StepFun_P17; [ apply StepFun_P1 | apply StepFun_P2; set (H := StepFun_P6 (pre f)); unfold IsStepFun in H; - elim H; intros; unfold is_subdivision in |- *; + elim H; intros; unfold is_subdivision in |- *; elim p; intros; apply p0 ]. assert (H : a < b); [ auto with real @@ -1951,9 +1951,9 @@ Lemma StepFun_P40 : adapted_couple f a b l1 lf1 -> adapted_couple f b c l2 lf2 -> adapted_couple f a c (cons_Rlist l1 l2) (FF (cons_Rlist l1 l2) f). -Proof. +Proof. intros f a b c l1 l2 lf1 lf2 H H0 H1 H2; unfold adapted_couple in H1, H2; - unfold adapted_couple in |- *; decompose [and] H1; + unfold adapted_couple in |- *; decompose [and] H1; decompose [and] H2; clear H1 H2; repeat split. apply RList_P25; try assumption. rewrite H10; rewrite H4; unfold Rmin, Rmax in |- *; case (Rle_dec a b); @@ -2030,7 +2030,7 @@ Proof. pos_Rl (cons r1 (cons r2 r3)) (S i)) in H14; rewrite H14; change (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) = - pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; + pos_Rl (cons r1 (cons r2 r3)) (S (S i))) in H15; rewrite H15; assert (H18 := H8 (S i)); unfold constant_D_eq, open_interval in H18; assert (H19 : (S i < pred (Rlength l1))%nat). @@ -2112,11 +2112,11 @@ Proof. rewrite H19 in H16; rewrite H19 in H17; change (pos_Rl (cons_Rlist (cons r2 r3) l2) i = - pos_Rl l2 (S i - Rlength (cons r1 (cons r2 r3)))) + pos_Rl l2 (S i - Rlength (cons r1 (cons r2 r3)))) in H16; rewrite H16; change (pos_Rl (cons_Rlist (cons r2 r3) l2) (S i) = - pos_Rl l2 (S (S i - Rlength (cons r1 (cons r2 r3))))) + pos_Rl l2 (S (S i - Rlength (cons r1 (cons r2 r3))))) in H17; rewrite H17; assert (H20 := H13 (S i - Rlength l1)%nat); unfold constant_D_eq, open_interval in H20; assert (H21 : (S i - Rlength l1 < pred (Rlength l2))%nat). @@ -2154,7 +2154,7 @@ Proof. rewrite double; apply Rplus_lt_compat_l; assumption | discrR ] ]. rewrite <- H19 in H16; rewrite <- H19 in H17; elim H2; intros; - rewrite H19 in H25; rewrite H19 in H26; simpl in H25; + rewrite H19 in H25; rewrite H19 in H26; simpl in H25; simpl in H16; rewrite H16 in H25; simpl in H26; simpl in H17; rewrite H17 in H26; simpl in H24; rewrite H24 in H25; elim (Rlt_irrefl _ (Rlt_trans _ _ _ H25 H26)). @@ -2189,7 +2189,7 @@ Lemma StepFun_P42 : pos_Rl l1 (pred (Rlength l1)) = pos_Rl l2 0 -> Int_SF (FF (cons_Rlist l1 l2) f) (cons_Rlist l1 l2) = Int_SF (FF l1 f) l1 + Int_SF (FF l2 f) l2. -Proof. +Proof. intros l1 l2 f; induction l1 as [| r l1 IHl1]; intros H; [ simpl in |- *; ring | destruct l1 as [| r0 r1]; @@ -2200,11 +2200,11 @@ Proof. Qed. Lemma StepFun_P43 : - forall (f:R -> R) (a b c:R) (pr1:IsStepFun f a b) + forall (f:R -> R) (a b c:R) (pr1:IsStepFun f a b) (pr2:IsStepFun f b c) (pr3:IsStepFun f a c), RiemannInt_SF (mkStepFun pr1) + RiemannInt_SF (mkStepFun pr2) = RiemannInt_SF (mkStepFun pr3). -Proof. +Proof. intros f; intros. pose proof pr1 as (l1,(lf1,H1)). pose proof pr2 as (l2,(lf2,H2)). @@ -2441,7 +2441,7 @@ Qed. Lemma StepFun_P44 : forall (f:R -> R) (a b c:R), IsStepFun f a b -> a <= c <= b -> IsStepFun f a c. -Proof. +Proof. intros f; intros; assert (H0 : a <= b). elim H; intros; apply Rle_trans with c; assumption. elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X; @@ -2479,7 +2479,7 @@ Proof. case (Rle_dec c r1); intro; [ left; assumption | right; auto with real ]. elim H1; intro. split with (cons r (cons c nil)); split with (cons r3 nil); - unfold adapted_couple in H; decompose [and] H; clear H; + unfold adapted_couple in H; decompose [and] H; clear H; assert (H6 : r = a). simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intro; [ reflexivity @@ -2497,7 +2497,7 @@ Proof. assert (H12 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat). simpl in |- *; apply lt_O_Sn. apply (H10 H12); unfold open_interval in |- *; simpl in |- *; - rewrite H11 in H9; simpl in H9; elim H9; clear H9; + rewrite H11 in H9; simpl in H9; elim H9; clear H9; intros; split; try assumption. apply Rlt_le_trans with c; assumption. elim (le_Sn_O _ H11). @@ -2505,8 +2505,8 @@ Proof. cut (r1 <= c <= b). intros. elim (X0 _ _ _ _ _ H3 H2); intros l1' [lf1' H4]; split with (cons r l1'); - split with (cons r3 lf1'); unfold adapted_couple in H, H4; - decompose [and] H; decompose [and] H4; clear H H4 X0; + split with (cons r3 lf1'); unfold adapted_couple in H, H4; + decompose [and] H; decompose [and] H4; clear H H4 X0; assert (H14 : a <= b). elim H0; intros; apply Rle_trans with c; assumption. assert (H16 : r = a). @@ -2538,7 +2538,7 @@ Proof. assert (H18 : (0 < pred (Rlength (cons r (cons r1 r2))))%nat). simpl in |- *; apply lt_O_Sn. apply (H17 H18); unfold open_interval in |- *; simpl in |- *; simpl in H4; - elim H4; clear H4; intros; split; try assumption; + elim H4; clear H4; intros; split; try assumption; replace r1 with r4. assumption. simpl in H12; rewrite H12; unfold Rmin in |- *; case (Rle_dec r1 c); intro; @@ -2557,7 +2557,7 @@ Qed. Lemma StepFun_P45 : forall (f:R -> R) (a b c:R), IsStepFun f a b -> a <= c <= b -> IsStepFun f c b. -Proof. +Proof. intros f; intros; assert (H0 : a <= b). elim H; intros; apply Rle_trans with c; assumption. elim H; clear H; intros; unfold IsStepFun in X; unfold is_subdivision in X; @@ -2614,7 +2614,7 @@ Proof. apply (H7 0%nat). simpl in |- *; apply lt_O_Sn. unfold open_interval in |- *; simpl in |- *; simpl in H6; elim H6; clear H6; - intros; split; try assumption; apply Rle_lt_trans with c; + intros; split; try assumption; apply Rle_lt_trans with c; try assumption; replace r with a. elim H0; intros; assumption. simpl in H4; rewrite H4; unfold Rmin in |- *; case (Rle_dec a b); intros; @@ -2634,7 +2634,7 @@ Qed. Lemma StepFun_P46 : forall (f:R -> R) (a b c:R), IsStepFun f a b -> IsStepFun f b c -> IsStepFun f a c. -Proof. +Proof. intros f; intros; case (Rle_dec a b); case (Rle_dec b c); intros. apply StepFun_P41 with b; assumption. case (Rle_dec a c); intro. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index 287fda4937..810a7de032 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -85,7 +85,7 @@ Proof. fourier. discrR. ring. -Qed. +Qed. (*********) Lemma prop_eps : forall r:R, (forall eps:R, eps > 0 -> r < eps) -> r <= 0. @@ -148,7 +148,7 @@ Qed. (*******************************) (*********) -Record Metric_Space : Type := +Record Metric_Space : Type := {Base : Type; dist : Base -> Base -> R; dist_pos : forall x y:Base, dist x y >= 0; @@ -167,7 +167,7 @@ Definition limit_in (X X':Metric_Space) (f:Base X -> Base X') eps > 0 -> exists alp : R, alp > 0 /\ - (forall x:Base X, D x /\ dist X x x0 < alp -> dist X' (f x) l < eps). + (forall x:Base X, D x /\ dist X x x0 < alp -> dist X' (f x) l < eps). (*******************************) (** ** R is a metric space *) @@ -214,7 +214,7 @@ Qed. Lemma lim_x : forall (D:R -> Prop) (x0:R), limit1_in (fun x:R => x) D x0 x0. Proof. unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; - split with eps; split; auto; intros; elim H0; intros; + split with eps; split; auto; intros; elim H0; intros; auto. Qed. @@ -226,7 +226,7 @@ Lemma limit_plus : Proof. intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; elim (H (eps * / 2) (eps2_Rgt_R0 eps H1)); - elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl in |- *; + elim (H0 (eps * / 2) (eps2_Rgt_R0 eps H1)); simpl in |- *; clear H H0; intros; elim H; elim H0; clear H H0; intros; split with (Rmin x1 x); split. exact (Rmin_Rgt_r x1 x 0 (conj H H2)). @@ -248,11 +248,11 @@ Lemma limit_Ropp : limit1_in f D l x0 -> limit1_in (fun x:R => - f x) D (- l) x0. Proof. unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; - elim (H eps H0); clear H; intros; elim H; clear H; - intros; split with x; split; auto; intros; generalize (H1 x1 H2); + elim (H eps H0); clear H; intros; elim H; clear H; + intros; split with x; split; auto; intros; generalize (H1 x1 H2); clear H1; intro; unfold R_dist in |- *; unfold Rminus in |- *; rewrite (Ropp_involutive l); rewrite (Rplus_comm (- f x1) l); - fold (l - f x1) in |- *; fold (R_dist l (f x1)) in |- *; + fold (l - f x1) in |- *; fold (R_dist l (f x1)) in |- *; rewrite R_dist_sym; assumption. Qed. @@ -273,7 +273,7 @@ Lemma limit_free : Proof. unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; split with eps; split; auto; intros; elim (R_dist_refl (f x) (f x)); - intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H; + intros a b; rewrite (b (refl_equal (f x))); unfold Rgt in H; assumption. Qed. @@ -286,13 +286,13 @@ Proof. intros; unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; intros; elim (H (Rmin 1 (eps * mul_factor l l')) (mul_factor_gt_f eps l l' H1)); - elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1)); - clear H H0; simpl in |- *; intros; elim H; elim H0; + elim (H0 (eps * mul_factor l l') (mul_factor_gt eps l l' H1)); + clear H H0; simpl in |- *; intros; elim H; elim H0; clear H H0; intros; split with (Rmin x1 x); split. exact (Rmin_Rgt_r x1 x 0 (conj H H2)). intros; elim H4; clear H4; intros; unfold R_dist in |- *; replace (f x2 * g x2 - l * l') with (f x2 * (g x2 - l') + l' * (f x2 - l)). - cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps). + cut (Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l)) < eps). cut (Rabs (f x2 * (g x2 - l') + l' * (f x2 - l)) <= Rabs (f x2 * (g x2 - l')) + Rabs (l' * (f x2 - l))). @@ -353,19 +353,19 @@ Proof. unfold Rabs in |- *; case (Rcase_abs (l - l')); intros. cut (forall eps:R, eps > 0 -> - (l - l') < eps). intro; generalize (prop_eps (- (l - l')) H1); intro; - generalize (Ropp_gt_lt_0_contravar (l - l') r); intro; - unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3); + generalize (Ropp_gt_lt_0_contravar (l - l') r); intro; + unfold Rgt in H3; generalize (Rgt_not_le (- (l - l')) 0 H3); intro; elimtype False; auto. intros; cut (eps * / 2 > 0). intro; generalize (H0 (eps * / 2) H2); rewrite (Rmult_comm eps (/ 2)); rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2). elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro; - unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); - intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; + unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); + intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; clear a b; apply (Rlt_trans 0 1 2 H3 H4). unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2)); - rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); + rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); auto. apply (Rinv_0_lt_compat 2); cut (1 < 2). intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2). @@ -374,7 +374,7 @@ Proof. (**) cut (forall eps:R, eps > 0 -> l - l' < eps). intro; generalize (prop_eps (l - l') H1); intro; elim (Rle_le_eq (l - l') 0); - intros a b; clear b; apply (Rminus_diag_uniq l l'); + intros a b; clear b; apply (Rminus_diag_uniq l l'); apply a; split. assumption. apply (Rge_le (l - l') 0 r). @@ -383,11 +383,11 @@ Proof. rewrite <- (Rmult_assoc 2 (/ 2) eps); rewrite (Rinv_r 2). elim (Rmult_ne eps); intros a b; rewrite b; clear a b; trivial. apply (Rlt_dichotomy_converse 2 0); right; generalize Rlt_0_1; intro; - unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); - intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; + unfold Rgt in |- *; generalize (Rplus_lt_compat_l 1 0 1 H3); + intro; elim (Rplus_ne 1); intros a b; rewrite a in H4; clear a b; apply (Rlt_trans 0 1 2 H3 H4). unfold Rgt in |- *; unfold Rgt in H1; rewrite (Rmult_comm eps (/ 2)); - rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); + rewrite <- (Rmult_0_r (/ 2)); apply (Rmult_lt_compat_l (/ 2) 0 eps); auto. apply (Rinv_0_lt_compat 2); cut (1 < 2). intro; apply (Rlt_trans 0 1 2 Rlt_0_1 H2). @@ -395,21 +395,21 @@ Proof. rewrite a; clear a b; trivial. (**) intros; unfold adhDa in H; elim (H0 eps H2); intros; elim (H1 eps H2); intros; - clear H0 H1; elim H3; elim H4; clear H3 H4; intros; - simpl in |- *; simpl in H1, H4; generalize (Rmin_Rgt x x1 0); + clear H0 H1; elim H3; elim H4; clear H3 H4; intros; + simpl in |- *; simpl in H1, H4; generalize (Rmin_Rgt x x1 0); intro; elim H5; intros; clear H5; elim (H (Rmin x x1) (H7 (conj H3 H0))); intros; elim H5; intros; clear H5 H H6 H7; - generalize (Rmin_Rgt x x1 (R_dist x2 x0)); intro; - elim H; intros; clear H H6; unfold Rgt in H5; elim (H5 H9); + generalize (Rmin_Rgt x x1 (R_dist x2 x0)); intro; + elim H; intros; clear H H6; unfold Rgt in H5; elim (H5 H9); intros; clear H5 H9; generalize (H1 x2 (conj H8 H6)); - generalize (H4 x2 (conj H8 H)); clear H8 H H6 H1 H4 H0 H3; + generalize (H4 x2 (conj H8 H)); clear H8 H H6 H1 H4 H0 H3; intros; generalize (Rplus_lt_compat (R_dist (f x2) l) eps (R_dist (f x2) l') eps H H0); unfold R_dist in |- *; intros; rewrite (Rabs_minus_sym (f x2) l) in H1; rewrite (Rmult_comm 2 eps); rewrite (Rmult_plus_distr_l eps 1 1); elim (Rmult_ne eps); intros a b; rewrite a; clear a b; - generalize (R_dist_tri l l' (f x2)); unfold R_dist in |- *; + generalize (R_dist_tri l l' (f x2)); unfold R_dist in |- *; intros; apply (Rle_lt_trans (Rabs (l - l')) (Rabs (l - f x2) + Rabs (f x2 - l')) @@ -449,7 +449,7 @@ Proof. intro H7; intro H10; elim H10; intros; cut (D x /\ Rabs (x - x0) < delta1). cut (D x /\ Rabs (x - x0) < delta2). intros; generalize (H5 H11); clear H5; intro H5; generalize (H7 H12); - clear H7; intro H7; generalize (Rabs_triang_inv l (f x)); + clear H7; intro H7; generalize (Rabs_triang_inv l (f x)); intro; rewrite Rabs_minus_sym in H7; generalize (Rle_lt_trans (Rabs l - Rabs (f x)) (Rabs (l - f x)) (Rabs l / 2) H13 H7); diff --git a/theories/Reals/Rlogic.v b/theories/Reals/Rlogic.v index e535a55683..d940a1d112 100644 --- a/theories/Reals/Rlogic.v +++ b/theories/Reals/Rlogic.v @@ -34,7 +34,7 @@ Require Import PartSum. Require Import SeqSeries. Require Import RiemannInt. Require Import Fourier. - + Section Arithmetical_dec. Variable P : nat -> Prop. @@ -108,7 +108,7 @@ rewrite Rabs_pos_eq. intro i. unfold f, g. elim (HP i); intro; ring_simplify; auto with *. - cut (sum_f_R0 g m <= sum_f_R0 g n). + cut (sum_f_R0 g m <= sum_f_R0 g n). intro; fourier. apply (ge_fun_sums_ge m n g Hnm). intro. unfold g. diff --git a/theories/Reals/Rpower.v b/theories/Reals/Rpower.v index 6dfb2d604d..57bc050a90 100644 --- a/theories/Reals/Rpower.v +++ b/theories/Reals/Rpower.v @@ -7,7 +7,7 @@ (************************************************************************) (*i $Id$ i*) -(*i Due to L.Thery i*) +(*i Due to L.Thery i*) (************************************************************) (* Definitions of log and Rpower : R->R->R; main properties *) @@ -86,7 +86,7 @@ Proof. apply INR_fact_neq_0. apply INR_fact_neq_0. assert (H0 := cv_speed_pow_fact 1); unfold Un_cv in |- *; unfold Un_cv in H0; - intros; elim (H0 _ H1); intros; exists x0; intros; + intros; elim (H0 _ H1); intros; exists x0; intros; unfold R_dist in H2; unfold R_dist in |- *; replace (/ INR (fact n)) with (1 ^ n / INR (fact n)). apply (H2 _ H3). @@ -139,8 +139,8 @@ Qed. Lemma exp_ineq1 : forall x:R, 0 < x -> 1 + x < exp x. Proof. intros; apply Rplus_lt_reg_r with (- exp 0); rewrite <- (Rplus_comm (exp x)); - assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0; - intros; elim H1; intros; unfold Rminus in H2; rewrite H2; + assert (H0 := MVT_cor1 exp 0 x derivable_exp H); elim H0; + intros; elim H1; intros; unfold Rminus in H2; rewrite H2; rewrite Ropp_0; rewrite Rplus_0_r; replace (derive_pt exp x0 (derivable_exp x0)) with (exp x0). rewrite exp_0; rewrite <- Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_l; @@ -162,7 +162,7 @@ Proof. pose proof (IVT_cor f 0 y H2 (Rlt_le _ _ H0) H4) as (t,(_,H7)); exists t; unfold f in H7; apply Rminus_diag_uniq_sym; exact H7. pattern 0 at 2 in |- *; rewrite <- (Rmult_0_r (f y)); - rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l; + rewrite (Rmult_comm (f 0)); apply Rmult_le_compat_l; assumption. unfold f in |- *; apply Rplus_le_reg_l with y; left; apply Rlt_trans with (1 + y). @@ -191,7 +191,7 @@ Proof. apply Rmult_eq_reg_l with (exp x / y). unfold Rdiv in |- *; rewrite Rmult_assoc; rewrite <- Rinv_l_sym. rewrite Rmult_1_r; rewrite <- (Rmult_comm (/ y)); rewrite Rmult_assoc; - rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; + rewrite <- exp_plus; rewrite Rplus_opp_r; rewrite exp_0; rewrite Rmult_1_r; symmetry in |- *; apply p. red in |- *; intro H3; rewrite H3 in H; elim (Rlt_irrefl _ H). unfold Rdiv in |- *; apply prod_neq_R0. @@ -216,7 +216,7 @@ Lemma exp_ln : forall x:R, 0 < x -> exp (ln x) = x. Proof. intros; unfold ln in |- *; case (Rlt_dec 0 x); intro. unfold Rln in |- *; - case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r))); + case (ln_exists (mkposreal x r) (cond_pos (mkposreal x r))); intros. simpl in e; symmetry in |- *; apply e. elim n; apply H. @@ -248,7 +248,7 @@ Qed. Theorem ln_increasing : forall x y:R, 0 < x -> x < y -> ln x < ln y. Proof. intros x y H H0; apply exp_lt_inv. - repeat rewrite exp_ln. + repeat rewrite exp_ln. apply H0. apply Rlt_trans with x; assumption. apply H. @@ -270,7 +270,7 @@ Theorem ln_lt_inv : forall x y:R, 0 < x -> 0 < y -> ln x < ln y -> x < y. Proof. intros x y H H0 H1; rewrite <- (exp_ln x); try rewrite <- (exp_ln y). apply exp_increasing; apply H1. - assumption. + assumption. assumption. Qed. @@ -299,7 +299,7 @@ Theorem ln_Rinv : forall x:R, 0 < x -> ln (/ x) = - ln x. Proof. intros x H; apply exp_inv; repeat rewrite exp_ln || rewrite exp_Ropp. reflexivity. - assumption. + assumption. apply Rinv_0_lt_compat; assumption. Qed. @@ -325,7 +325,7 @@ Proof. unfold dist, R_met, R_dist in |- *; simpl in |- *. intros x [[H3 H4] H5]. cut (y * (x * / y) = x). - intro Hxyy. + intro Hxyy. replace (ln x - ln y) with (ln (x * / y)). case (Rtotal_order x y); [ intros Hxy | intros [Hxy| Hxy] ]. rewrite Rabs_left. @@ -580,8 +580,8 @@ Proof. (l := ln y) (g := fun x:R => (exp x - exp (ln y)) / (x - ln y)) (f := ln). apply ln_continue; auto. assert (H0 := derivable_pt_lim_exp (ln y)); unfold derivable_pt_lim in H0; - unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H); + unfold limit1_in in |- *; unfold limit_in in |- *; + simpl in |- *; unfold R_dist in |- *; intros; elim (H0 _ H); intros; exists (pos x); split. apply (cond_pos x). intros; pattern y at 3 in |- *; rewrite <- exp_ln. @@ -589,7 +589,7 @@ Proof. [ idtac | ring ]. apply H1. elim H2; intros H3 _; unfold D_x in H3; elim H3; clear H3; intros _ H3; - apply Rminus_eq_contra; apply (sym_not_eq (A:=R)); + apply Rminus_eq_contra; apply (sym_not_eq (A:=R)); apply H3. elim H2; clear H2; intros _ H2; apply H2. assumption. @@ -600,7 +600,7 @@ Lemma derivable_pt_lim_ln : forall x:R, 0 < x -> derivable_pt_lim ln x (/ x). Proof. intros; assert (H0 := Dln x H); unfold D_in in H0; unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; unfold R_dist in H0; - unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1); + unfold derivable_pt_lim in |- *; intros; elim (H0 _ H1); intros; elim H2; clear H2; intros; set (alp := Rmin x0 (x / 2)); assert (H4 : 0 < alp). unfold alp in |- *; unfold Rmin in |- *; case (Rle_dec x0 (x / 2)); intro. diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index e6801e6d6f..f02b77564f 100644 --- a/theories/Reals/Rprod.v +++ b/theories/Reals/Rprod.v @@ -43,7 +43,7 @@ Proof. rewrite Hrecn; [ ring | assumption ]. omega. omega. -Qed. +Qed. (**********) Lemma prod_SO_pos : @@ -80,9 +80,9 @@ Qed. (** Application to factorial *) Lemma fact_prodSO : - forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat => - (match (eq_nat_dec k 0) with - | left _ => 1%R + forall n:nat, INR (fact n) = prod_f_R0 (fun k:nat => + (match (eq_nat_dec k 0) with + | left _ => 1%R | right _ => INR k end)) n. Proof. @@ -102,7 +102,7 @@ Proof. replace (S (S (2 * n0))) with (2 * n0 + 2)%nat; [ idtac | ring ]. replace (S n0) with (n0 + 1)%nat; [ idtac | ring ]. ring. -Qed. +Qed. (** We prove that (N!)^2<=(2N-k)!*k! forall k in [|O;2N|] *) Lemma RfactN_fact2N_factk : @@ -112,7 +112,7 @@ Lemma RfactN_fact2N_factk : Proof. assert (forall (n:nat), 0 <= (if eq_nat_dec n 0 then 1 else INR n)). intros; case (eq_nat_dec n 0); auto with real. - assert (forall (n:nat), (0 < n)%nat -> + assert (forall (n:nat), (0 < n)%nat -> (if eq_nat_dec n 0 then 1 else INR n) = INR n). intros n; case (eq_nat_dec n 0); auto with real. intros; absurd (0 < n)%nat; omega. @@ -125,7 +125,7 @@ Proof. rewrite Rmult_assoc; apply Rmult_le_compat_l. apply prod_SO_pos; intros; auto. replace (2 * N - k - N-1)%nat with (N - k-1)%nat. - rewrite Rmult_comm; rewrite (prod_SO_split + rewrite Rmult_comm; rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) N k). apply Rmult_le_compat_l. apply prod_SO_pos; intros; auto. @@ -138,14 +138,14 @@ Proof. assumption. omega. omega. - rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat => + rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) k)); - rewrite (prod_SO_split (fun l:nat => + rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) k N). rewrite Rmult_assoc; apply Rmult_le_compat_l. apply prod_SO_pos; intros; auto. rewrite Rmult_comm; - rewrite (prod_SO_split (fun l:nat => + rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) N (2 * N - k)). apply Rmult_le_compat_l. apply prod_SO_pos; intros; auto. @@ -160,7 +160,7 @@ Proof. omega. assumption. omega. -Qed. +Qed. (**********) diff --git a/theories/Reals/Rseries.v b/theories/Reals/Rseries.v index 5436b4daa3..62f1940bfe 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -71,7 +71,7 @@ Section sequence. forall x:R, (forall n:nat, Un n <= x) -> is_upper_bound EUn x. Proof. intros; unfold is_upper_bound in |- *; intros; unfold EUn in H0; elim H0; - clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1; + clear H0; intros; generalize (H x1); intro; rewrite <- H0 in H1; trivial. Qed. @@ -106,11 +106,11 @@ Section sequence. Lemma Un_cv_crit : Un_growing -> bound EUn -> exists l : R, Un_cv l. Proof. unfold Un_growing, Un_cv in |- *; intros; - generalize (completeness_weak EUn H0 EUn_noempty); - intro; elim H1; clear H1; intros; split with x; intros; + generalize (completeness_weak EUn H0 EUn_noempty); + intro; elim H1; clear H1; intros; split with x; intros; unfold is_lub in H1; unfold bound in H0; unfold is_upper_bound in H0, H1; - elim H0; clear H0; intros; elim H1; clear H1; intros; - generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x); + elim H0; clear H0; intros; elim H1; clear H1; intros; + generalize (H3 x0 H0); intro; cut (forall n:nat, Un n <= x); intro. cut (exists N : nat, x - eps < Un N). intro; elim H6; clear H6; intros; split with x1. @@ -131,10 +131,10 @@ Section sequence. apply (Rnot_lt_ge (x - eps) (Un N) (H7 N)). red in |- *; intro; cut (forall N:nat, Un N <= x - eps). intro; generalize (Un_bound_imp (x - eps) H7); intro; - unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); + unfold is_upper_bound in H8; generalize (H3 (x - eps) H8); intro; generalize (Rle_minus x (x - eps) H9); unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r; - rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2); + rewrite (let (H1, H2) := Rplus_ne (- - eps) in H2); rewrite Ropp_involutive; intro; unfold Rgt in H2; generalize (Rgt_not_le eps 0 H2); intro; auto. intro; elim (H6 N); intro; unfold Rle in |- *. @@ -151,7 +151,7 @@ Section sequence. split with (Un 0); intros; rewrite (le_n_O_eq n H); apply (Req_le (Un n) (Un n) (refl_equal (Un n))). elim HrecN; clear HrecN; intros; split with (Rmax (Un (S N)) x); intros; - elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1; + elim (Rmax_Rle (Un (S N)) x (Un n)); intros; clear H1; inversion H0. rewrite <- H1; rewrite <- H1 in H2; apply @@ -163,21 +163,21 @@ Section sequence. Lemma cauchy_bound : Cauchy_crit -> bound EUn. Proof. unfold Cauchy_crit, bound in |- *; intros; unfold is_upper_bound in |- *; - unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros; + unfold Rgt in H; elim (H 1 Rlt_0_1); clear H; intros; generalize (H x); intro; generalize (le_dec x); intro; - elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1)); - clear H; intros; unfold EUn in H; elim H; clear H; + elim (finite_greater x); intros; split with (Rmax x0 (Un x + 1)); + clear H; intros; unfold EUn in H; elim H; clear H; intros; elim (H1 x2); clear H1; intro y. unfold ge in H0; generalize (H0 x2 (le_n x) y); clear H0; intro; rewrite <- H in H0; unfold R_dist in H0; elim (Rabs_def2 (Un x - x1) 1 H0); - clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1); + clear H0; intros; elim (Rmax_Rle x0 (Un x + 1) x1); intros; apply H4; clear H3 H4; right; clear H H0 y; apply (Rlt_le x1 (Un x + 1)); generalize (Rlt_minus (-1) (Un x - x1) H1); clear H1; intro; apply (Rminus_lt x1 (Un x + 1)); cut (-1 - (Un x - x1) = x1 - (Un x + 1)); [ intro; rewrite H0 in H; assumption | ring ]. generalize (H2 x2 y); clear H2 H0; intro; rewrite <- H in H0; - elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1; + elim (Rmax_Rle x0 (Un x + 1) x1); intros; clear H1; apply H2; left; assumption. Qed. @@ -248,7 +248,7 @@ Proof. cut (Rabs x * (eps * (Rabs (1 - x) * Rabs (/ x))) = Rabs x * Rabs (/ x) * (eps * Rabs (1 - x))). - clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r. + clear H8; intros; rewrite H8; rewrite <- Rabs_mult; rewrite Rinv_r. rewrite Rabs_R1; cut (1 * (eps * Rabs (1 - x)) = Rabs (1 - x) * eps). intros; rewrite H9; unfold Rle in |- *; right; reflexivity. ring. diff --git a/theories/Reals/Rsqrt_def.v b/theories/Reals/Rsqrt_def.v index b228f89851..33c20355cc 100644 --- a/theories/Reals/Rsqrt_def.v +++ b/theories/Reals/Rsqrt_def.v @@ -23,7 +23,7 @@ Boxed Fixpoint Dichotomy_lb (x y:R) (P:R -> bool) (N:nat) {struct N} : R := let up := Dichotomy_ub x y P n in let z := (down + up) / 2 in if P z then down else z end - + with Dichotomy_ub (x y:R) (P:R -> bool) (N:nat) {struct N} : R := match N with | O => y @@ -471,8 +471,8 @@ Proof. intros. cut (x <= y). intro. - generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). - generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). + generalize (dicho_lb_cv x y (fun z:R => cond_positivity (f z)) H3). + generalize (dicho_up_cv x y (fun z:R => cond_positivity (f z)) H3). intros X X0. elim X; intros. elim X0; intros. @@ -667,7 +667,7 @@ Proof. apply Ropp_0_gt_lt_contravar; assumption. Qed. -(** We can now define the square root function as the reciprocal +(** We can now define the square root function as the reciprocal transformation of the square root function *) Lemma Rsqrt_exists : forall y:R, 0 <= y -> { z:R | 0 <= z /\ y = Rsqr z }. @@ -698,7 +698,7 @@ Proof. rewrite Rsqr_1. apply Rplus_le_reg_l with y. rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *; - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; + rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; left; assumption. exists 1. split. diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index c36542d2b7..c115969e33 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -33,8 +33,8 @@ Definition interior (D:R -> Prop) (x:R) : Prop := neighbourhood D x. Lemma interior_P1 : forall D:R -> Prop, included (interior D) D. Proof. intros; unfold included in |- *; unfold interior in |- *; intros; - unfold neighbourhood in H; elim H; intros; unfold included in H0; - apply H0; unfold disc in |- *; unfold Rminus in |- *; + unfold neighbourhood in H; elim H; intros; unfold included in H0; + apply H0; unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos x0). Qed. @@ -98,7 +98,7 @@ Lemma complementary_P1 : ~ (exists y : R, intersection_domain D (complementary D) y). Proof. intro; red in |- *; intro; elim H; intros; - unfold intersection_domain, complementary in H0; elim H0; + unfold intersection_domain, complementary in H0; elim H0; intros; elim H2; assumption. Qed. @@ -110,23 +110,23 @@ Proof. elim H1; intro. assumption. assert (H3 := H _ H2); assert (H4 := H0 _ H3); elim H4; intros; - unfold intersection_domain in H5; elim H5; intros; + unfold intersection_domain in H5; elim H5; intros; elim H6; assumption. Qed. Lemma adherence_P3 : forall D:R -> Prop, closed_set (adherence D). Proof. intro; unfold closed_set, adherence in |- *; - unfold open_set, complementary, point_adherent in |- *; + unfold open_set, complementary, point_adherent in |- *; intros; set (P := fun V:R -> Prop => neighbourhood V x -> exists y : R, intersection_domain V D y); - assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1; + assert (H0 := not_all_ex_not _ P H); elim H0; intros V0 H1; unfold P in H1; assert (H2 := imply_to_and _ _ H1); unfold neighbourhood in |- *; elim H2; intros; unfold neighbourhood in H3; - elim H3; intros; exists x0; unfold included in |- *; + elim H3; intros; exists x0; unfold included in |- *; intros; red in |- *; intro. assert (H8 := H7 V0); cut (exists delta : posreal, (forall x:R, disc x1 delta x -> V0 x)). @@ -170,7 +170,7 @@ Proof. apply adherence_P2; assumption. unfold eq_Dom in |- *; unfold included in |- *; intros; assert (H0 := adherence_P3 D); unfold closed_set in H0; - unfold closed_set in |- *; unfold open_set in |- *; + unfold closed_set in |- *; unfold open_set in |- *; unfold open_set in H0; intros; assert (H2 : complementary (adherence D) x). unfold complementary in |- *; unfold complementary in H1; red in |- *; intro; elim H; clear H; intros _ H; elim H1; apply (H _ H2). @@ -178,7 +178,7 @@ Proof. unfold neighbourhood in H3; elim H3; intros; exists x0; unfold included in |- *; unfold included in H4; intros; assert (H6 := H4 _ H5); unfold complementary in H6; - unfold complementary in |- *; red in |- *; intro; + unfold complementary in |- *; red in |- *; intro; elim H; clear H; intros H _; elim H6; apply (H _ H7). Qed. @@ -187,7 +187,7 @@ Lemma neighbourhood_P1 : included D1 D2 -> neighbourhood D1 x -> neighbourhood D2 x. Proof. unfold included, neighbourhood in |- *; intros; elim H0; intros; exists x0; - intros; unfold included in |- *; unfold included in H1; + intros; unfold included in |- *; unfold included in H1; intros; apply (H _ (H1 _ H2)). Qed. @@ -211,8 +211,8 @@ Proof. unfold open_set in |- *; intros; unfold intersection_domain in H1; elim H1; intros. assert (H4 := H _ H2); assert (H5 := H0 _ H3); - unfold intersection_domain in |- *; unfold neighbourhood in H4, H5; - elim H4; clear H; intros del1 H; elim H5; clear H0; + unfold intersection_domain in |- *; unfold neighbourhood in H4, H5; + elim H4; clear H; intros del1 H; elim H5; clear H0; intros del2 H0; cut (0 < Rmin del1 del2). intro; set (del := mkposreal _ H6). exists del; unfold included in |- *; intros; unfold included in H, H0; @@ -292,7 +292,7 @@ Proof. apply (sym_not_eq (A:=R)); apply H7. unfold disc in H6; apply H6. intros; unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; intros. assert (H1 := H (disc (f x) (mkposreal eps H0))). cut (neighbourhood (disc (f x) (mkposreal eps H0)) (f x)). @@ -317,8 +317,8 @@ Proof. intros; unfold open_set in H0; unfold open_set in |- *; intros; assert (H2 := continuity_P1 f x); elim H2; intros H3 _; assert (H4 := H3 (H x)); unfold neighbourhood, image_rec in |- *; - unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1)); - elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7; + unfold image_rec in H1; assert (H5 := H4 D (H0 (f x) H1)); + elim H5; intros V0 H6; elim H6; intros; unfold neighbourhood in H7; elim H7; intros del H9; exists del; unfold included in H9; unfold included in |- *; intros; apply (H8 _ (H9 _ H10)). Qed. @@ -333,7 +333,7 @@ Proof. intros; apply continuity_P2; assumption. intros; unfold continuity in |- *; unfold continuity_pt in |- *; unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; + unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros; cut (open_set (disc (f x) (mkposreal _ H0))). intro; assert (H2 := H _ H1). unfold open_set, image_rec in H2; cut (disc (f x) (mkposreal _ H0) (f x)). @@ -466,7 +466,7 @@ Proof. cut (covering_open_set X f0). intro; assert (H3 := H1 H2); elim H3; intros D' H4; unfold covering_finite in H4; elim H4; intros; unfold family_finite in H6; - unfold domain_finite in H6; elim H6; intros l H7; + unfold domain_finite in H6; elim H6; intros l H7; unfold bounded in |- *; set (r := MaxRlist l). exists (- r); exists r; intros. unfold covering in H5; assert (H9 := H5 _ H8); elim H9; intros; @@ -538,9 +538,9 @@ Proof. intro; assert (H10 := H0 (disc x (mkposreal _ H9))); cut (neighbourhood (disc x (mkposreal alp H9)) x). intro; assert (H12 := H10 H11); elim H12; clear H12; intros y H12; - unfold intersection_domain in H12; elim H12; clear H12; - intros; assert (H14 := H7 _ H13); elim H14; clear H14; - intros y0 H14; elim H14; clear H14; intros; unfold g in H14; + unfold intersection_domain in H12; elim H12; clear H12; + intros; assert (H14 := H7 _ H13); elim H14; clear H14; + intros y0 H14; elim H14; clear H14; intros; unfold g in H14; elim H14; clear H14; intros; unfold disc in H12; simpl in H12; cut (alp <= Rabs (y0 - x) / 2). intro; assert (H18 := Rlt_le_trans _ _ _ H12 H17); @@ -557,10 +557,10 @@ Proof. unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; apply H9. unfold alp in |- *; apply MinRlist_P2; intros; - assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10; - intros z H10; elim H10; clear H10; intros; rewrite H11; + assert (H10 := AbsList_P2 _ _ _ H9); elim H10; clear H10; + intros z H10; elim H10; clear H10; intros; rewrite H11; apply H2; elim (H8 z); clear H8; intros; assert (H13 := H12 H10); - unfold intersection_domain, D in H13; elim H13; clear H13; + unfold intersection_domain, D in H13; elim H13; clear H13; intros; assumption. unfold covering_open_set in |- *; split. unfold covering in |- *; intros; exists x0; simpl in |- *; unfold g in |- *; @@ -577,7 +577,7 @@ Proof. rewrite <- (Rabs_Ropp (x0 - x1)); rewrite Ropp_minus_distr; apply H6. apply H5. unfold included, disc in |- *; simpl in |- *; intros; elim H6; intros; - rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr; + rewrite <- (Rabs_Ropp (x1 - x0)); rewrite Ropp_minus_distr; apply H7. apply open_set_P6 with (fun z:R => False). apply open_set_P4. @@ -639,8 +639,8 @@ Proof. intro; assert (H3 := completeness A H1 H2); elim H3; clear H3; intros m H3; unfold is_lub in H3; cut (a <= m <= b). intro; unfold covering_open_set in H; elim H; clear H; intros; - unfold covering in H; assert (H6 := H m H4); elim H6; - clear H6; intros y0 H6; unfold family_open_set in H5; + unfold covering in H; assert (H6 := H m H4); elim H6; + clear H6; intros y0 H6; unfold family_open_set in H5; assert (H7 := H5 y0); unfold open_set in H7; assert (H8 := H7 m H6); unfold neighbourhood in H8; elim H8; clear H8; intros eps H8; cut (exists x : R, A x /\ m - eps < x <= m). @@ -651,11 +651,11 @@ Proof. set (Db := fun x:R => Dx x \/ x = y0); exists Db; unfold covering_finite in |- *; split. unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12; - intros; unfold covering in H12; case (Rle_dec x0 x); + intros; unfold covering in H12; case (Rle_dec x0 x); intro. cut (a <= x0 <= x). intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1; - simpl in H16; simpl in |- *; unfold Db in |- *; elim H16; + simpl in H16; simpl in |- *; unfold Db in |- *; elim H16; clear H16; intros; split; [ apply H16 | left; apply H17 ]. split. elim H14; intros; assumption. @@ -672,9 +672,9 @@ Proof. apply Rge_minus; apply Rle_ge; elim H14; intros _ H15; apply H15. unfold Db in |- *; right; reflexivity. unfold family_finite in |- *; unfold domain_finite in |- *; - unfold covering_finite in H12; elim H12; clear H12; - intros; unfold family_finite in H13; unfold domain_finite in H13; - elim H13; clear H13; intros l H13; exists (cons y0 l); + unfold covering_finite in H12; elim H12; clear H12; + intros; unfold family_finite in H13; unfold domain_finite in H13; + elim H13; clear H13; intros l H13; exists (cons y0 l); intro; split. intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0); clear H13; intros; case (Req_dec x0 y0); intro. @@ -723,7 +723,7 @@ Proof. set (Db := fun x:R => Dx x \/ x = y0); exists Db; unfold covering_finite in |- *; split. unfold covering in |- *; unfold covering_finite in H12; elim H12; clear H12; - intros; unfold covering in H12; case (Rle_dec x0 x); + intros; unfold covering in H12; case (Rle_dec x0 x); intro. cut (a <= x0 <= x). intro; assert (H16 := H12 x0 H15); elim H16; clear H16; intros; exists x1; @@ -758,15 +758,15 @@ Proof. ring. unfold Db in |- *; right; reflexivity. unfold family_finite in |- *; unfold domain_finite in |- *; - unfold covering_finite in H12; elim H12; clear H12; - intros; unfold family_finite in H13; unfold domain_finite in H13; - elim H13; clear H13; intros l H13; exists (cons y0 l); + unfold covering_finite in H12; elim H12; clear H12; + intros; unfold family_finite in H13; unfold domain_finite in H13; + elim H13; clear H13; intros l H13; exists (cons y0 l); intro; split. intro; simpl in H14; unfold intersection_domain in H14; elim (H13 x0); clear H13; intros; case (Req_dec x0 y0); intro. simpl in |- *; left; apply H16. simpl in |- *; right; apply H13; simpl in |- *; - unfold intersection_domain in |- *; unfold Db in H14; + unfold intersection_domain in |- *; unfold Db in H14; decompose [and or] H14. split; assumption. elim H16; assumption. @@ -793,7 +793,7 @@ Proof. set (P := fun n:R => A n /\ m - eps < n <= m); assert (H12 := not_ex_all_not _ P H9); unfold P in H12; unfold is_upper_bound in |- *; intros; - assert (H14 := not_and_or _ _ (H12 x)); elim H14; + assert (H14 := not_and_or _ _ (H12 x)); elim H14; intro. elim H15; apply H13. elim (not_and_or _ _ H15); intro. @@ -806,11 +806,11 @@ Proof. split. apply (H3 _ H0). apply (H4 b); unfold is_upper_bound in |- *; intros; unfold A in H5; elim H5; - clear H5; intros H5 _; elim H5; clear H5; intros _ H5; + clear H5; intros H5 _; elim H5; clear H5; intros _ H5; apply H5. exists a; apply H0. unfold bound in |- *; exists b; unfold is_upper_bound in |- *; intros; - unfold A in H1; elim H1; clear H1; intros H1 _; elim H1; + unfold A in H1; elim H1; clear H1; intros H1 _; elim H1; clear H1; intros _ H1; apply H1. unfold A in |- *; split. split; [ right; reflexivity | apply r ]. @@ -862,15 +862,15 @@ Proof. elim H10; intros H11 _; unfold complementary in H11; elim H11; apply H7. apply H9. unfold family_finite in |- *; unfold domain_finite in |- *; - unfold family_finite in H6; unfold domain_finite in H6; + unfold family_finite in H6; unfold domain_finite in H6; elim H6; clear H6; intros l H6; exists l; intro; assert (H7 := H6 x); elim H7; clear H7; intros. split. intro; apply H7; simpl in |- *; unfold intersection_domain in |- *; - simpl in H9; unfold intersection_domain in H9; unfold D' in |- *; + simpl in H9; unfold intersection_domain in H9; unfold D' in |- *; apply H9. intro; assert (H10 := H8 H9); simpl in H10; unfold intersection_domain in H10; - simpl in |- *; unfold intersection_domain in |- *; + simpl in |- *; unfold intersection_domain in |- *; unfold D' in H10; apply H10. unfold covering_open_set in |- *; unfold covering_open_set in H2; elim H2; clear H2; intros. @@ -964,14 +964,14 @@ Proof. simpl in H11; elim H11; intros z H12; exists z; unfold g in H12; unfold image_rec in H12; rewrite H9; apply H12. unfold family_finite in H6; unfold domain_finite in H6; - unfold family_finite in |- *; unfold domain_finite in |- *; - elim H6; intros l H7; exists l; intro; elim (H7 x); + unfold family_finite in |- *; unfold domain_finite in |- *; + elim H6; intros l H7; exists l; intro; elim (H7 x); intros; split; intro. apply H8; simpl in H10; simpl in |- *; apply H10. apply (H9 H10). unfold covering_open_set in |- *; split. unfold covering in |- *; intros; simpl in |- *; unfold covering in H1; - unfold image_dir in H1; unfold g in |- *; unfold image_rec in |- *; + unfold image_dir in H1; unfold g in |- *; unfold image_rec in |- *; apply H1. exists x; split; [ reflexivity | apply H4 ]. unfold family_open_set in |- *; unfold family_open_set in H2; intro; @@ -1014,8 +1014,8 @@ Proof. exists h; split. unfold continuity in |- *; intro; case (Rtotal_order x a); intro. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; unfold R_dist in |- *; intros; exists (a - x); + unfold limit1_in in |- *; unfold limit_in in |- *; + simpl in |- *; unfold R_dist in |- *; intros; exists (a - x); split. change (0 < a - x) in |- *; apply Rlt_Rminus; assumption. intros; elim H5; clear H5; intros _ H5; unfold h in |- *. @@ -1034,8 +1034,8 @@ Proof. unfold limit1_in in H6; unfold limit_in in H6; simpl in H6; unfold R_dist in H6; unfold continuity_pt in |- *; unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; - intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a)); + unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; + intros; elim (H6 _ H7); intros; exists (Rmin x0 (b - a)); split. unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro. elim H8; intros; assumption. @@ -1067,8 +1067,8 @@ Proof. unfold limit1_in in H7; unfold limit_in in H7; simpl in H7; unfold R_dist in H7; unfold continuity_pt in |- *; unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; - intros; elim (H7 _ H8); intros; elim H9; clear H9; + unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; + intros; elim (H7 _ H8); intros; elim H9; clear H9; intros. assert (H11 : 0 < x - a). apply Rlt_Rminus; assumption. @@ -1119,8 +1119,8 @@ Proof. unfold limit1_in in H8; unfold limit_in in H8; simpl in H8; unfold R_dist in H8; unfold continuity_pt in |- *; unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; - intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a)); + unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; + intros; elim (H8 _ H9); intros; exists (Rmin x0 (b - a)); split. unfold Rmin in |- *; case (Rle_dec x0 (b - a)); intro. elim H10; intros; assumption. @@ -1152,8 +1152,8 @@ Proof. assumption. apply Rmin_r. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - simpl in |- *; unfold R_dist in |- *; intros; exists (x - b); + unfold limit1_in in |- *; unfold limit_in in |- *; + simpl in |- *; unfold R_dist in |- *; intros; exists (x - b); split. change (0 < x - b) in |- *; apply Rlt_Rminus; assumption. intros; elim H8; clear H8; intros. @@ -1210,8 +1210,8 @@ Proof. intro; unfold image_dir in H8; elim H8; clear H8; intros Mxx H8; elim H8; clear H8; intros; exists Mxx; split. intros; rewrite <- (Heq c H10); rewrite <- (Heq Mxx H9); intros; - rewrite <- H8; unfold is_lub in H7; elim H7; clear H7; - intros H7 _; unfold is_upper_bound in H7; apply H7; + rewrite <- H8; unfold is_lub in H7; elim H7; clear H7; + intros H7 _; unfold is_upper_bound in H7; apply H7; unfold image_dir in |- *; exists c; split; [ reflexivity | apply H10 ]. apply H9. elim (classic (image_dir g (fun c:R => a <= c <= b) M)); intro. @@ -1298,7 +1298,7 @@ Proof. intro; assert (H2 := continuity_ab_maj (- f0)%F a b H H1); elim H2; intros x0 H3; exists x0; intros; split. intros; rewrite <- (Ropp_involutive (f0 x0)); - rewrite <- (Ropp_involutive (f0 c)); apply Ropp_le_contravar; + rewrite <- (Ropp_involutive (f0 c)); apply Ropp_le_contravar; elim H3; intros; unfold opp_fct in H5; apply H5; apply H4. elim H3; intros; assumption. intros. @@ -1348,10 +1348,10 @@ Lemma ValAdh_un_prop : Proof. intros; split; intro. unfold ValAdh in H; unfold ValAdh_un in |- *; - unfold intersection_family in |- *; simpl in |- *; + unfold intersection_family in |- *; simpl in |- *; intros; elim H0; intros N H1; unfold adherence in |- *; - unfold point_adherent in |- *; intros; elim (H V N H2); - intros; exists (un x0); unfold intersection_domain in |- *; + unfold point_adherent in |- *; intros; elim (H V N H2); + intros; exists (un x0); unfold intersection_domain in |- *; elim H3; clear H3; intros; split. assumption. split. @@ -1367,9 +1367,9 @@ Proof. (exists n : nat, INR N = INR n)) x). apply H; exists N; reflexivity. unfold adherence in H1; unfold point_adherent in H1; assert (H2 := H1 _ H0); - elim H2; intros; unfold intersection_domain in H3; - elim H3; clear H3; intros; elim H4; clear H4; intros; - elim H4; clear H4; intros; elim H4; clear H4; intros; + elim H2; intros; unfold intersection_domain in H3; + elim H3; clear H3; intros; elim H4; clear H4; intros; + elim H4; clear H4; intros; elim H4; clear H4; intros; exists x1; split. apply (INR_le _ _ H6). rewrite H4 in H3; apply H3. @@ -1379,7 +1379,7 @@ Lemma adherence_P4 : forall F G:R -> Prop, included F G -> included (adherence F) (adherence G). Proof. unfold adherence, included in |- *; unfold point_adherent in |- *; intros; - elim (H0 _ H1); unfold intersection_domain in |- *; + elim (H0 _ H1); unfold intersection_domain in |- *; intros; elim H2; clear H2; intros; exists x0; split; [ assumption | apply (H _ H3) ]. Qed. @@ -1392,7 +1392,7 @@ Definition intersection_vide_in (D:R -> Prop) (f:family) : Prop := (ind f x -> included (f x) D) /\ ~ (exists y : R, intersection_family f y). -Definition intersection_vide_finite_in (D:R -> Prop) +Definition intersection_vide_finite_in (D:R -> Prop) (f:family) : Prop := intersection_vide_in D f /\ family_finite f. (**********) @@ -1417,9 +1417,9 @@ Proof. elim (H1 x); intros; unfold intersection_family in H5; assert (H6 := not_ex_all_not _ (fun y:R => forall y0:R, ind g y0 -> g y0 y) H5 x); - assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6); - elim H7; intros; exists x0; elim (imply_to_and _ _ H8); - intros; unfold f0 in |- *; simpl in |- *; unfold f' in |- *; + assert (H7 := not_all_ex_not _ (fun y0:R => ind g y0 -> g y0 x) H6); + elim H7; intros; exists x0; elim (imply_to_and _ _ H8); + intros; unfold f0 in |- *; simpl in |- *; unfold f' in |- *; split; [ apply H10 | apply H9 ]. unfold family_open_set in |- *; intro; elim (classic (D' x)); intro. apply open_set_P6 with (complementary (g x)). @@ -1448,7 +1448,7 @@ Proof. unfold covering in H4; elim (H4 x0 H7); intros; simpl in H8; unfold intersection_domain in H6; cut (ind g x1 /\ SF x1). intro; assert (H10 := H6 x1 H9); elim H10; clear H10; intros H10 _; elim H8; - clear H8; intros H8 _; unfold f' in H8; unfold complementary in H8; + clear H8; intros H8 _; unfold f' in H8; unfold complementary in H8; elim H8; clear H8; intros H8 _; elim H8; assumption. split. apply (cond_fam f0). @@ -1463,15 +1463,15 @@ Proof. unfold covering_finite in H4; elim H4; clear H4; intros H4 _; cut (exists z : R, X z). intro; elim H5; clear H5; intros; unfold covering in H4; elim (H4 x0 H5); - intros; simpl in H6; elim Hyp'; exists x1; elim H6; + intros; simpl in H6; elim Hyp'; exists x1; elim H6; intros; unfold intersection_domain in |- *; split. apply (cond_fam f0); exists x0; apply H7. apply H8. apply Hyp. unfold covering_finite in H4; elim H4; clear H4; intros; unfold family_finite in H5; unfold domain_finite in H5; - unfold family_finite in |- *; unfold domain_finite in |- *; - elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x); + unfold family_finite in |- *; unfold domain_finite in |- *; + elim H5; clear H5; intros l H5; exists l; intro; elim (H5 x); intros; split; intro; [ apply H6; simpl in |- *; simpl in H8; apply H8 | apply (H7 H8) ]. Qed. @@ -1506,7 +1506,7 @@ Proof. intro; cut (intersection_vide_in X f0). intro; assert (H7 := H3 H5 H6). elim H7; intros SF H8; unfold intersection_vide_finite_in in H8; elim H8; - clear H8; intros; unfold intersection_vide_in in H8; + clear H8; intros; unfold intersection_vide_in in H8; elim (H8 0); intros _ H10; elim H10; unfold family_finite in H9; unfold domain_finite in H9; elim H9; clear H9; intros l H9; set (r := MaxRlist l); cut (D r). @@ -1536,7 +1536,7 @@ Proof. assert (H17 := not_ex_all_not _ (fun z:R => intersection_domain (ind f0) SF z) H13); - assert (H18 := H16 x); unfold intersection_family in H18; + assert (H18 := H16 x); unfold intersection_family in H18; simpl in H18; assert (H19 := @@ -1604,8 +1604,8 @@ Proof. elim Hyp; clear Hyp; intro Hyp. (* X possède un seul élément *) unfold uniform_continuity in |- *; intros; exists (mkposreal _ Rlt_0_1); - intros; elim Hyp; clear Hyp; intros; elim H4; clear H4; - intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2); + intros; elim Hyp; clear Hyp; intros; elim H4; clear H4; + intros; assert (H6 := H5 _ H1); assert (H7 := H5 _ H2); rewrite H6; rewrite H7; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; apply (cond_pos eps). (* X possède au moins deux éléments distincts *) @@ -1616,8 +1616,8 @@ Proof. elim H2; intros; exists x; exists x0; split. apply H3. elim Hyp; intros; elim H4; intros; decompose [and] H5; - assert (H10 := H3 _ H6); assert (H11 := H3 _ H8); - elim H10; intros; elim H11; intros; case (total_order_T x x0); + assert (H10 := H3 _ H6); assert (H11 := H3 _ H8); + elim H10; intros; elim H11; intros; case (total_order_T x x0); intro. elim s; intro. assumption. @@ -1652,7 +1652,7 @@ Proof. assumption. assert (H4 := H _ H3); unfold continuity_pt in H4; unfold continue_in in H4; unfold limit1_in in H4; unfold limit_in in H4; simpl in H4; - unfold R_dist in H4; elim (H4 (eps / 2) (H1 eps)); + unfold R_dist in H4; elim (H4 (eps / 2) (H1 eps)); intros; set (E := @@ -1661,7 +1661,7 @@ Proof. (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2)); assert (H6 : bound E). unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *; - unfold E in |- *; intros; elim H6; clear H6; intros H6 _; + unfold E in |- *; intros; elim H6; clear H6; intros H6 _; elim H6; clear H6; intros _ H6; apply H6. assert (H7 : exists x : R, E x). elim H5; clear H5; intros; exists (Rmin x0 (M - m)); unfold E in |- *; intros; @@ -1693,14 +1693,14 @@ Proof. intro; assert (H16 := H14 _ H15); elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H10 H16)). unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H13; - assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x))); + assert (H16 := H13 _ H15); case (Rle_dec x2 (Rabs (z - x))); intro. assumption. elim (H12 x2); split; [ split; [ auto with real | assumption ] | assumption ]. split. apply p. unfold disc in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r; - rewrite Rabs_R0; simpl in |- *; unfold Rdiv in |- *; + rewrite Rabs_R0; simpl in |- *; unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ apply H8 | apply Rinv_0_lt_compat; prove_sup0 ]. elim H7; intros; unfold E in H8; elim H8; intros H9 _; elim H9; intros H10 _; unfold is_lub in p; elim p; intros; unfold is_upper_bound in H12; @@ -1711,8 +1711,8 @@ Proof. unfold family_open_set in |- *; intro; simpl in |- *; elim (classic (X x)); intro. unfold g in |- *; unfold open_set in |- *; intros; elim H4; clear H4; - intros _ H4; elim H4; clear H4; intros; elim H4; clear H4; - intros; unfold neighbourhood in |- *; case (Req_dec x x0); + intros _ H4; elim H4; clear H4; intros; elim H4; clear H4; + intros; unfold neighbourhood in |- *; case (Req_dec x x0); intro. exists (mkposreal _ (H1 x1)); rewrite <- H6; unfold included in |- *; intros; split. @@ -1745,7 +1745,7 @@ Proof. intros; unfold g in H4; elim H4; clear H4; intros H4 _; elim H3; apply H4. elim (H0 _ H3); intros DF H4; unfold covering_finite in H4; elim H4; clear H4; intros; unfold family_finite in H5; unfold domain_finite in H5; - unfold covering in H4; simpl in H4; simpl in H5; elim H5; + unfold covering in H4; simpl in H4; simpl in H5; elim H5; clear H5; intros l H5; unfold intersection_domain in H5; cut (forall x:R, @@ -1761,8 +1761,8 @@ Proof. (fun x del:R => 0 < del /\ (forall z:R, Rabs (z - x) < del -> Rabs (f0 z - f0 x) < eps / 2) /\ - included (g x) (fun z:R => Rabs (z - x) < del / 2)) H6); - elim H7; clear H7; intros l' H7; elim H7; clear H7; + included (g x) (fun z:R => Rabs (z - x) < del / 2)) H6); + elim H7; clear H7; intros l' H7; elim H7; clear H7; intros; set (D := MinRlist l'); cut (0 < D / 2). intro; exists (mkposreal _ H9); intros; assert (H13 := H4 _ H10); elim H13; clear H13; intros xi H13; assert (H14 : In xi l). @@ -1785,8 +1785,8 @@ Proof. rewrite double; apply Rplus_lt_compat_l; apply H19. discrR. assert (H19 := H8 i H17); elim H19; clear H19; intros; rewrite <- H18 in H20; - elim H20; clear H20; intros; rewrite <- Rabs_Ropp; - rewrite Ropp_minus_distr; apply H20; unfold included in H21; + elim H20; clear H20; intros; rewrite <- Rabs_Ropp; + rewrite Ropp_minus_distr; apply H20; unfold included in H21; elim H13; intros; assert (H24 := H21 x H22); apply Rle_lt_trans with (Rabs (y - x) + Rabs (x - xi)). replace (y - xi) with (y - x + (x - xi)); [ apply Rabs_triang | ring ]. @@ -1803,7 +1803,7 @@ Proof. unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ unfold D in |- *; apply MinRlist_P2; intros; elim (pos_Rl_P2 l' y); intros; elim (H10 H9); intros; elim H12; intros; rewrite H14; - rewrite <- H7 in H13; elim (H8 x H13); intros; + rewrite <- H7 in H13; elim (H8 x H13); intros; apply H15 | apply Rinv_0_lt_compat; prove_sup0 ]. intros; elim (H5 x); intros; elim (H8 H6); intros; @@ -1814,14 +1814,14 @@ Proof. (forall z:R, Rabs (z - x) < zeta -> Rabs (f0 z - f0 x) < eps / 2)); assert (H11 : bound E). unfold bound in |- *; exists (M - m); unfold is_upper_bound in |- *; - unfold E in |- *; intros; elim H11; clear H11; intros H11 _; + unfold E in |- *; intros; elim H11; clear H11; intros H11 _; elim H11; clear H11; intros _ H11; apply H11. assert (H12 : exists x : R, E x). assert (H13 := H _ H9); unfold continuity_pt in H13; - unfold continue_in in H13; unfold limit1_in in H13; + unfold continue_in in H13; unfold limit1_in in H13; unfold limit_in in H13; simpl in H13; unfold R_dist in H13; - elim (H13 _ (H1 eps)); intros; elim H12; clear H12; - intros; exists (Rmin x0 (M - m)); unfold E in |- *; + elim (H13 _ (H1 eps)); intros; elim H12; clear H12; + intros; exists (Rmin x0 (M - m)); unfold E in |- *; intros; split. split; [ unfold Rmin in |- *; case (Rle_dec x0 (M - m)); intro; @@ -1850,7 +1850,7 @@ Proof. intro; assert (H21 := H19 _ H20); elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H15 H21)). unfold is_upper_bound in |- *; intros; unfold is_upper_bound in H18; - assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x))); + assert (H21 := H18 _ H20); case (Rle_dec x1 (Rabs (z - x))); intro. assumption. elim (H17 x1); split. @@ -1864,7 +1864,7 @@ Proof. apply H21. elim H12; intros; unfold E in H13; elim H13; intros H14 _; elim H14; intros H15 _; unfold is_lub in p; elim p; intros; - unfold is_upper_bound in H16; unfold is_upper_bound in H17; + unfold is_upper_bound in H16; unfold is_upper_bound in H17; split. apply Rlt_le_trans with x1; [ assumption | apply (H16 _ H13) ]. apply H17; intros; unfold E in H18; elim H18; intros; elim H19; intros; diff --git a/theories/Reals/Rtrigo.v b/theories/Reals/Rtrigo.v index c9f83d639a..c637b7ab94 100644 --- a/theories/Reals/Rtrigo.v +++ b/theories/Reals/Rtrigo.v @@ -32,7 +32,7 @@ Proof. elim (Rlt_irrefl _ H0). Qed. -(**********) +(**********) Lemma cos_minus : forall x y:R, cos (x - y) = cos x * cos y + sin x * sin y. Proof. intros; unfold Rminus in |- *; rewrite cos_plus. @@ -50,7 +50,7 @@ Lemma cos2 : forall x:R, Rsqr (cos x) = 1 - Rsqr (sin x). Proof. intro x; generalize (sin2_cos2 x); intro H1; rewrite <- H1; unfold Rminus in |- *; rewrite <- (Rplus_comm (Rsqr (cos x))); - rewrite Rplus_assoc; rewrite Rplus_opp_r; symmetry in |- *; + rewrite Rplus_assoc; rewrite Rplus_opp_r; symmetry in |- *; apply Rplus_0_r. Qed. @@ -151,7 +151,7 @@ Proof. rewrite <- Rinv_r_sym. rewrite Rmult_1_l; rewrite (Rmult_comm (sin x)); rewrite <- Ropp_mult_distr_r_reverse; repeat rewrite Rmult_assoc; - apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y)); + apply Rmult_eq_compat_l; rewrite (Rmult_comm (/ cos y)); rewrite Rmult_assoc; rewrite <- Rinv_r_sym. apply Rmult_1_r. assumption. @@ -185,7 +185,7 @@ Qed. Lemma cos_2a_cos : forall x:R, cos (2 * x) = 2 * cos x * cos x - 1. Proof. intro x; rewrite double; unfold Rminus in |- *; rewrite Rmult_assoc; - rewrite cos_plus; generalize (sin2_cos2 x); rewrite double; + rewrite cos_plus; generalize (sin2_cos2 x); rewrite double; intro H1; rewrite <- H1; ring_Rsqr. Qed. @@ -219,7 +219,7 @@ Qed. Lemma tan_0 : tan 0 = 0. Proof. unfold tan in |- *; rewrite sin_0; rewrite cos_0. - unfold Rdiv in |- *; apply Rmult_0_l. + unfold Rdiv in |- *; apply Rmult_0_l. Qed. Lemma tan_neg : forall x:R, tan (- x) = - tan x. @@ -320,7 +320,7 @@ Lemma PI2_RGT_0 : 0 < PI / 2. Proof. unfold Rdiv in |- *; apply Rmult_lt_0_compat; [ apply PI_RGT_0 | apply Rinv_0_lt_compat; prove_sup ]. -Qed. +Qed. Lemma SIN_bound : forall x:R, -1 <= sin x <= 1. Proof. @@ -331,13 +331,13 @@ Proof. intro; generalize (Rsqr_incrst_1 1 (sin x) H (Rlt_le 0 1 Rlt_0_1) - (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); + (Rlt_le 0 (sin x) (Rlt_trans 0 1 (sin x) Rlt_0_1 H))); rewrite Rsqr_1; intro; rewrite sin2 in H0; unfold Rminus in H0; generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; + repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); - repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); + repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)). auto with real. cut (sin x < -1). @@ -346,13 +346,13 @@ Proof. generalize (Rsqr_incrst_1 1 (- sin x) H (Rlt_le 0 1 Rlt_0_1) (Rlt_le 0 (- sin x) (Rlt_trans 0 1 (- sin x) Rlt_0_1 H))); - rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; + rewrite Rsqr_1; intro; rewrite <- Rsqr_neg in H0; rewrite sin2 in H0; unfold Rminus in H0; generalize (Rplus_lt_compat_l (-1) 1 (1 + - Rsqr (cos x)) H0); - repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; + repeat rewrite <- Rplus_assoc; repeat rewrite Rplus_opp_l; rewrite Rplus_0_l; intro; rewrite <- Ropp_0 in H1; generalize (Ropp_lt_gt_contravar (-0) (- Rsqr (cos x)) H1); - repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); + repeat rewrite Ropp_involutive; intro; generalize (Rle_0_sqr (cos x)); intro; elim (Rlt_irrefl 0 (Rle_lt_trans 0 (Rsqr (cos x)) 0 H3 H2)). auto with real. Qed. @@ -366,7 +366,7 @@ Lemma cos_sin_0 : forall x:R, ~ (cos x = 0 /\ sin x = 0). Proof. intro; red in |- *; intro; elim H; intros; generalize (sin2_cos2 x); intro; rewrite H0 in H2; rewrite H1 in H2; repeat rewrite Rsqr_0 in H2; - rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro; + rewrite Rplus_0_r in H2; generalize Rlt_0_1; intro; rewrite <- H2 in H3; elim (Rlt_irrefl 0 H3). Qed. @@ -399,18 +399,18 @@ Proof. repeat rewrite Rmult_1_l; repeat rewrite Rmult_1_r; replace (-1 * Un 1%nat) with (- Un 1%nat); [ idtac | ring ]; replace (-1 * -1 * Un 2%nat) with (Un 2%nat); [ idtac | ring ]; - replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat); + replace (-1 * (-1 * -1) * Un 3%nat) with (- Un 3%nat); [ idtac | ring ]; replace (Un 0%nat + - Un 1%nat + Un 2%nat + - Un 3%nat) with (Un 0%nat - Un 1%nat + (Un 2%nat - Un 3%nat)); [ idtac | ring ]. apply Rplus_lt_0_compat. unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 1%nat); - rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat)); - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; + rewrite Rplus_0_r; rewrite (Rplus_comm (Un 1%nat)); + rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; apply H1. unfold Rminus in |- *; apply Rplus_lt_reg_r with (Un 3%nat); - rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat)); - rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; + rewrite Rplus_0_r; rewrite (Rplus_comm (Un 3%nat)); + rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; apply H1. intro; unfold Un in |- *. cut ((2 * S n + 1)%nat = (2 * n + 1 + 2)%nat). @@ -533,7 +533,7 @@ Proof. (SIN (PI - x) (Rlt_le 0 (PI - x) H7) (Rlt_le (PI - x) PI (Rlt_trans (PI - x) (PI / 2) PI H5 PI2_Rlt_PI))); intros H8 _; - generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5)); + generalize (sin_lb_gt_0 (PI - x) H7 (Rlt_le (PI - x) (PI / 2) H5)); intro H9; apply (Rlt_le_trans 0 (sin_lb (PI - x)) (sin (PI - x)) H9 H8). reflexivity. pattern PI at 2 in |- *; rewrite double_var; ring. @@ -545,7 +545,7 @@ Proof. intros; rewrite cos_sin; generalize (Rplus_lt_compat_l (PI / 2) (- (PI / 2)) x H). rewrite Rplus_opp_r; intro H1; - generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0); + generalize (Rplus_lt_compat_l (PI / 2) x (PI / 2) H0); rewrite <- double_var; intro H2; apply (sin_gt_0 (PI / 2 + x) H1 H2). Qed. @@ -599,7 +599,7 @@ Proof. replace (PI / 2) with (- PI + 3 * (PI / 2)). apply Rplus_le_compat_l; assumption. pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr; - ring. + ring. unfold INR in |- *; ring. Qed. @@ -625,7 +625,7 @@ Proof. intros; generalize (Rplus_lt_compat_l (2 * PI) (- PI) x H); replace (2 * PI + - PI) with PI; [ intro H1; rewrite Rplus_comm in H1; - generalize (Rplus_lt_compat_l (2 * PI) x 0 H0); + generalize (Rplus_lt_compat_l (2 * PI) x 0 H0); intro H2; rewrite (Rplus_comm (2 * PI)) in H2; rewrite <- (Rplus_comm 0) in H2; rewrite Rplus_0_l in H2; rewrite <- (sin_period x 1); unfold INR in |- *; @@ -644,12 +644,12 @@ Proof. unfold Rminus in |- *; rewrite (Rplus_comm x); apply Rplus_lt_compat_l; assumption. pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr; - ring. + ring. unfold Rminus in |- *; rewrite Rplus_comm; replace (PI / 2) with (- PI + 3 * (PI / 2)). apply Rplus_lt_compat_l; assumption. pattern PI at 1 in |- *; rewrite (double_var PI); rewrite Ropp_plus_distr; - ring. + ring. unfold INR in |- *; ring. Qed. @@ -658,7 +658,7 @@ Proof. intros x H1 H2; unfold tan in |- *; generalize _PI2_RLT_0; generalize (Rlt_trans 0 x (PI / 2) H1 H2); intros; generalize (Rlt_trans (- (PI / 2)) 0 x H0 H1); intro H5; - generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI); + generalize (Rlt_trans x (PI / 2) PI H2 PI2_Rlt_PI); intro H7; unfold Rdiv in |- *; apply Rmult_lt_0_compat. apply sin_gt_0; assumption. apply Rinv_0_lt_compat; apply cos_gt_0; assumption. @@ -667,7 +667,7 @@ Qed. Lemma tan_lt_0 : forall x:R, - (PI / 2) < x -> x < 0 -> tan x < 0. Proof. intros x H1 H2; unfold tan in |- *; - generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0)); + generalize (cos_gt_0 x H1 (Rlt_trans x 0 (PI / 2) H2 PI2_RGT_0)); intro H3; rewrite <- Ropp_0; replace (sin x / cos x) with (- (- sin x / cos x)). rewrite <- sin_neg; apply Ropp_gt_lt_contravar; @@ -688,11 +688,11 @@ Proof. intros; rewrite <- cos_neg; rewrite <- (cos_period (- x) 1); unfold INR in |- *; replace (- x + 2 * 1 * PI) with (2 * PI - x). generalize (Ropp_le_ge_contravar x (2 * PI) H0); intro H1; - generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1; + generalize (Rge_le (- x) (- (2 * PI)) H1); clear H1; intro H1; generalize (Rplus_le_compat_l (2 * PI) (- (2 * PI)) (- x) H1). - rewrite Rplus_opp_r. + rewrite Rplus_opp_r. intro H2; generalize (Ropp_le_ge_contravar (3 * (PI / 2)) x H); intro H3; - generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3; + generalize (Rge_le (- (3 * (PI / 2))) (- x) H3); clear H3; intro H3; generalize (Rplus_le_compat_l (2 * PI) (- x) (- (3 * (PI / 2))) H3). replace (2 * PI + - (3 * (PI / 2))) with (PI / 2). @@ -780,11 +780,11 @@ Proof. generalize (Rmult_le_compat_l (/ 2) (x - y) PI (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H8). - repeat rewrite (Rmult_comm (/ 2)). + repeat rewrite (Rmult_comm (/ 2)). intro H9; generalize (sin_gt_0 ((x - y) / 2) H6 - (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI)); + (Rle_lt_trans ((x - y) / 2) (PI / 2) PI H9 PI2_Rlt_PI)); intro H10; elim (Rlt_irrefl (sin ((x - y) / 2)) @@ -799,7 +799,7 @@ Proof. generalize (Rmult_le_compat_l (/ 2) (x + y) PI (Rlt_le 0 (/ 2) (Rinv_0_lt_compat 2 Hyp)) H4). - repeat rewrite (Rmult_comm (/ 2)). + repeat rewrite (Rmult_comm (/ 2)). clear H4; intro H4; generalize (Rplus_le_compat (- (PI / 2)) x (- (PI / 2)) y H H1); replace (- (PI / 2) + - (PI / 2)) with (- PI). @@ -813,7 +813,7 @@ Proof. elim H5; intro H50. generalize (cos_gt_0 ((x + y) / 2) H50 H40); intro H6; generalize (Rmult_lt_compat_l 2 0 (cos ((x + y) / 2)) Hyp H6). - rewrite Rmult_0_r. + rewrite Rmult_0_r. clear H6; intro H6; case (Rcase_abs (sin ((x - y) / 2))); intro H7. assumption. generalize (Rge_le (sin ((x - y) / 2)) 0 H7); clear H7; intro H7; @@ -824,7 +824,7 @@ Proof. (Rle_lt_trans 0 (2 * cos ((x + y) / 2) * sin ((x - y) / 2)) 0 H8 H3); intro H9; elim (Rlt_irrefl 0 H9). rewrite <- H50 in H3; rewrite cos_neg in H3; rewrite cos_PI2 in H3; - rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; + rewrite Rmult_0_r in H3; rewrite Rmult_0_l in H3; elim (Rlt_irrefl 0 H3). unfold Rdiv in H3. rewrite H40 in H3; assert (H50 := cos_PI2); unfold Rdiv in H50; @@ -865,8 +865,8 @@ Proof. clear H5 H6 H7; intro H5; generalize (Ropp_le_ge_contravar (- (PI / 2)) y H1); rewrite Ropp_involutive; clear H1; intro H1; generalize (Rge_le (PI / 2) (- y) H1); clear H1; intro H1; - generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2; - intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2); + generalize (Ropp_le_ge_contravar y (PI / 2) H2); clear H2; + intro H2; generalize (Rge_le (- y) (- (PI / 2)) H2); clear H2; intro H2; generalize (Rplus_lt_compat_l (- y) x y H3); replace (- y + x) with (x - y). rewrite Rplus_opp_l. @@ -885,12 +885,12 @@ Proof. replace (/ 2 * (x - y)) with ((x - y) / 2). clear H7; intro H7; clear H H0 H1 H2; apply Rminus_lt; rewrite form4; generalize (cos_gt_0 ((x + y) / 2) H4 H5); intro H8; - generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8); + generalize (Rmult_lt_0_compat 2 (cos ((x + y) / 2)) Hyp H8); clear H8; intro H8; cut (- PI < - (PI / 2)). intro H9; generalize (sin_lt_0_var ((x - y) / 2) - (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6); + (Rlt_le_trans (- PI) (- (PI / 2)) ((x - y) / 2) H9 H7) H6); intro H10; generalize (Rmult_lt_gt_compat_neg_l (sin ((x - y) / 2)) 0 ( @@ -1012,21 +1012,21 @@ Proof. replace (-3 * (PI / 2) + y) with (y - 3 * (PI / 2)). apply (sin_increasing_0 (x - 3 * (PI / 2)) (y - 3 * (PI / 2)) H4 H3 H2 H1 H5). unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. + rewrite Ropp_mult_distr_l_reverse. + apply Rplus_comm. unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. + rewrite Ropp_mult_distr_l_reverse. + apply Rplus_comm. pattern PI at 3 in |- *; rewrite double_var. ring. rewrite double; pattern PI at 3 4 in |- *; rewrite double_var. ring. unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. + rewrite Ropp_mult_distr_l_reverse. + apply Rplus_comm. unfold Rminus in |- *. - rewrite Ropp_mult_distr_l_reverse. - apply Rplus_comm. + rewrite Ropp_mult_distr_l_reverse. + apply Rplus_comm. rewrite Rmult_1_r. rewrite (double PI); pattern PI at 3 4 in |- *; rewrite double_var. ring. @@ -1110,7 +1110,7 @@ Lemma tan_diff : cos x <> 0 -> cos y <> 0 -> tan x - tan y = sin (x - y) / (cos x * cos y). Proof. intros; unfold tan in |- *; rewrite sin_minus. - unfold Rdiv in |- *. + unfold Rdiv in |- *. unfold Rminus in |- *. rewrite Rmult_plus_distr_r. rewrite Rinv_mult_distr. @@ -1143,7 +1143,7 @@ Lemma tan_increasing_0 : x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> tan x < tan y -> x < y. Proof. intros; generalize PI4_RLT_PI2; intro H4; - generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); + generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); intro H5; change (- (PI / 2) < - (PI / 4)) in H5; generalize (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) @@ -1155,20 +1155,20 @@ Proof. (sym_not_eq (Rlt_not_eq 0 (cos x) (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) - (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); + (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); intro H6; generalize (sym_not_eq (Rlt_not_eq 0 (cos y) (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1) - (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); + (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); intro H7; generalize (tan_diff x y H6 H7); intro H8; - generalize (Rlt_minus (tan x) (tan y) H3); clear H3; + generalize (Rlt_minus (tan x) (tan y) H3); clear H3; intro H3; rewrite H8 in H3; cut (sin (x - y) < 0). intro H9; generalize (Ropp_le_ge_contravar (- (PI / 4)) y H1); rewrite Ropp_involutive; intro H10; generalize (Rge_le (PI / 4) (- y) H10); clear H10; intro H10; generalize (Ropp_le_ge_contravar y (PI / 4) H2); - intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); + intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); clear H11; intro H11; generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11); generalize (Rplus_le_compat x (PI / 4) (- y) (PI / 4) H0 H10); @@ -1180,7 +1180,7 @@ Proof. (sin_gt_0 (x - y) H14 (Rle_lt_trans (x - y) (PI / 2) PI H12 PI2_Rlt_PI)); intro H15; elim (Rlt_irrefl 0 (Rlt_trans 0 (sin (x - y)) 0 H15 H9)). elim H14; intro H15. - rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9). + rewrite <- H15 in H9; rewrite sin_0 in H9; elim (Rlt_irrefl 0 H9). apply Rminus_lt; assumption. pattern PI at 1 in |- *; rewrite double_var. unfold Rdiv in |- *. @@ -1218,7 +1218,7 @@ Proof. elim (Rlt_irrefl 0 (Rle_lt_trans 0 (sin (x - y) * / (cos x * cos y)) 0 H13 H3)). rewrite Rinv_mult_distr. - reflexivity. + reflexivity. assumption. assumption. Qed. @@ -1229,7 +1229,7 @@ Lemma tan_increasing_1 : x <= PI / 4 -> - (PI / 4) <= y -> y <= PI / 4 -> x < y -> tan x < tan y. Proof. intros; apply Rminus_lt; generalize PI4_RLT_PI2; intro H4; - generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); + generalize (Ropp_lt_gt_contravar (PI / 4) (PI / 2) H4); intro H5; change (- (PI / 2) < - (PI / 4)) in H5; generalize (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) @@ -1241,27 +1241,27 @@ Proof. (sym_not_eq (Rlt_not_eq 0 (cos x) (cos_gt_0 x (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) x H5 H) - (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); + (Rle_lt_trans x (PI / 4) (PI / 2) H0 H4)))); intro H6; generalize (sym_not_eq (Rlt_not_eq 0 (cos y) (cos_gt_0 y (Rlt_le_trans (- (PI / 2)) (- (PI / 4)) y H5 H1) - (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); + (Rle_lt_trans y (PI / 4) (PI / 2) H2 H4)))); intro H7; rewrite (tan_diff x y H6 H7); generalize (Rinv_0_lt_compat (cos x) HP1); intro H10; generalize (Rinv_0_lt_compat (cos y) HP2); intro H11; generalize (Rmult_lt_0_compat (/ cos x) (/ cos y) H10 H11); replace (/ cos x * / cos y) with (/ (cos x * cos y)). clear H10 H11; intro H8; generalize (Ropp_le_ge_contravar y (PI / 4) H2); - intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); + intro H11; generalize (Rge_le (- y) (- (PI / 4)) H11); clear H11; intro H11; generalize (Rplus_le_compat (- (PI / 4)) x (- (PI / 4)) (- y) H H11); replace (x + - y) with (x - y). replace (- (PI / 4) + - (PI / 4)) with (- (PI / 2)). clear H11; intro H9; generalize (Rlt_minus x y H3); clear H3; intro H3; - clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI; - intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1); + clear H H0 H1 H2 H4 H5 HP1 HP2; generalize PI2_Rlt_PI; + intro H1; generalize (Ropp_lt_gt_contravar (PI / 2) PI H1); clear H1; intro H1; generalize (sin_lt_0_var (x - y) (Rlt_le_trans (- PI) (- (PI / 2)) (x - y) H1 H9) H3); @@ -1576,13 +1576,13 @@ Proof. Qed. Lemma cos_eq_0_0 : - forall x:R, cos x = 0 -> exists k : Z, x = IZR k * PI + PI / 2. + forall x:R, cos x = 0 -> exists k : Z, x = IZR k * PI + PI / 2. Proof. intros x H; rewrite cos_sin in H; generalize (sin_eq_0_0 (PI / INR 2 + x) H); intro H2; elim H2; intros x0 H3; exists (x0 - Z_of_nat 1)%Z; rewrite <- Z_R_minus; simpl. unfold INR in H3. field_simplify [(sym_eq H3)]. field. -(** +(** ring_simplify. (* rewrite (Rmult_comm PI);*) (* old ring compat *) rewrite <- H3; simpl; @@ -1618,7 +1618,7 @@ Proof. (Rlt_le 0 (/ PI) (Rinv_0_lt_compat PI PI_RGT_0)) H0); repeat rewrite Rmult_assoc; repeat rewrite <- Rinv_r_sym. repeat rewrite Rmult_1_r; intro; - generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H5); + generalize (Rplus_lt_compat_l (IZR (-2)) 1 (IZR k0) H5); rewrite <- plus_IZR. replace (IZR (-2) + 1) with (-1). intro; generalize (Rplus_le_compat_l (IZR (-2)) (IZR k0) 2 H6); @@ -1710,7 +1710,7 @@ Proof. apply Rplus_le_le_0_compat. left; unfold Rdiv in |- *; apply Rmult_lt_0_compat. apply PI_RGT_0. - apply Rinv_0_lt_compat; prove_sup0. + apply Rinv_0_lt_compat; prove_sup0. assumption. elim H2; intro. right; assumption. diff --git a/theories/Reals/Rtrigo_alt.v b/theories/Reals/Rtrigo_alt.v index 36ed0c1a03..fe2da83911 100644 --- a/theories/Reals/Rtrigo_alt.v +++ b/theories/Reals/Rtrigo_alt.v @@ -48,9 +48,9 @@ Theorem sin_bound : Proof. intros; case (Req_dec a 0); intro Hyp_a. rewrite Hyp_a; rewrite sin_0; split; right; unfold sin_approx in |- *; - apply sum_eq_R0 || (symmetry in |- *; apply sum_eq_R0); - intros; unfold sin_term in |- *; rewrite pow_add; - simpl in |- *; unfold Rdiv in |- *; rewrite Rmult_0_l; + apply sum_eq_R0 || (symmetry in |- *; apply sum_eq_R0); + intros; unfold sin_term in |- *; rewrite pow_add; + simpl in |- *; unfold Rdiv in |- *; rewrite Rmult_0_l; ring. unfold sin_approx in |- *; cut (0 < a). intro Hyp_a_pos. @@ -123,7 +123,7 @@ Proof. simpl in |- *; ring. ring. assert (H3 := cv_speed_pow_fact a); unfold Un in |- *; unfold Un_cv in H3; - unfold R_dist in H3; unfold Un_cv in |- *; unfold R_dist in |- *; + unfold R_dist in H3; unfold Un_cv in |- *; unfold R_dist in |- *; intros; elim (H3 eps H4); intros N H5. exists N; intros; apply H5. replace (2 * S n0 + 1)%nat with (S (2 * S n0)). @@ -138,7 +138,7 @@ Proof. assert (X := exist_sin (Rsqr a)); elim X; intros. cut (x = sin a / a). intro; rewrite H3 in p; unfold sin_in in p; unfold infinite_sum in p; - unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; + unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; intros. cut (0 < eps / Rabs a). intro; elim (p _ H5); intros N H6. @@ -146,9 +146,9 @@ Proof. replace (sum_f_R0 (tg_alt Un) n0) with (a * (1 - sum_f_R0 (fun i:nat => sin_n i * Rsqr a ^ i) (S n0))). unfold Rminus in |- *; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r; - rewrite Ropp_plus_distr; rewrite Ropp_involutive; + rewrite Ropp_plus_distr; rewrite Ropp_involutive; repeat rewrite Rplus_assoc; rewrite (Rplus_comm a); - rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc; + rewrite (Rplus_comm (- a)); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; apply Rmult_lt_reg_l with (/ Rabs a). apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption. pattern (/ Rabs a) at 1 in |- *; rewrite <- (Rabs_Rinv a Hyp_a). @@ -163,7 +163,7 @@ Proof. simpl in |- *; rewrite Rmult_1_r; unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l; rewrite Ropp_mult_distr_r_reverse; - rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum; + rewrite <- Ropp_mult_distr_l_reverse; rewrite scal_sum; apply sum_eq. intros; unfold sin_n, Un, tg_alt in |- *; replace ((-1) ^ S i) with (- (-1) ^ i). @@ -230,7 +230,7 @@ Lemma cos_bound : forall (a:R) (n:nat), - PI / 2 <= a -> a <= PI / 2 -> - cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). + cos_approx a (2 * n + 1) <= cos a <= cos_approx a (2 * (n + 1)). Proof. cut ((forall (a:R) (n:nat), @@ -318,7 +318,7 @@ Proof. simpl in |- *; ring. ring. assert (H4 := cv_speed_pow_fact a0); unfold Un in |- *; unfold Un_cv in H4; - unfold R_dist in H4; unfold Un_cv in |- *; unfold R_dist in |- *; + unfold R_dist in H4; unfold Un_cv in |- *; unfold R_dist in |- *; intros; elim (H4 eps H5); intros N H6; exists N; intros. apply H6; unfold ge in |- *; apply le_trans with (2 * S N)%nat. apply le_trans with (2 * N)%nat. @@ -328,7 +328,7 @@ Proof. assert (X := exist_cos (Rsqr a0)); elim X; intros. cut (x = cos a0). intro; rewrite H4 in p; unfold cos_in in p; unfold infinite_sum in p; - unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; + unfold R_dist in p; unfold Un_cv in |- *; unfold R_dist in |- *; intros. elim (p _ H5); intros N H6. exists N; intros. @@ -336,9 +336,9 @@ Proof. (1 - sum_f_R0 (fun i:nat => cos_n i * Rsqr a0 ^ i) (S n1)). unfold Rminus in |- *; rewrite Ropp_plus_distr; rewrite Ropp_involutive; repeat rewrite Rplus_assoc; rewrite (Rplus_comm 1); - rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; + rewrite (Rplus_comm (-1)); repeat rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r; rewrite <- Rabs_Ropp; - rewrite Ropp_plus_distr; rewrite Ropp_involutive; + rewrite Ropp_plus_distr; rewrite Ropp_involutive; unfold Rminus in H6; apply H6. unfold ge in |- *; apply le_trans with n1. exact H7. @@ -351,7 +351,7 @@ Proof. replace (- sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1) with (-1 * sum_f_R0 (fun i:nat => cos_n (S i) * (Rsqr a0 * Rsqr a0 ^ i)) n1); - [ idtac | ring ]; rewrite scal_sum; apply sum_eq; + [ idtac | ring ]; rewrite scal_sum; apply sum_eq; intros; unfold cos_n, Un, tg_alt in |- *. replace ((-1) ^ S i) with (- (-1) ^ i). replace (a0 ^ (2 * S i)) with (Rsqr a0 * Rsqr a0 ^ i). diff --git a/theories/Reals/Rtrigo_calc.v b/theories/Reals/Rtrigo_calc.v index d6a0f262a1..a7fddb4731 100644 --- a/theories/Reals/Rtrigo_calc.v +++ b/theories/Reals/Rtrigo_calc.v @@ -18,7 +18,7 @@ Open Local Scope R_scope. Lemma tan_PI : tan PI = 0. Proof. unfold tan in |- *; rewrite sin_PI; rewrite cos_PI; unfold Rdiv in |- *; - apply Rmult_0_l. + apply Rmult_0_l. Qed. Lemma sin_3PI2 : sin (3 * (PI / 2)) = -1. @@ -129,7 +129,7 @@ Qed. Lemma R1_sqrt2_neq_0 : 1 / sqrt 2 <> 0. Proof. generalize (Rinv_neq_0_compat (sqrt 2) sqrt2_neq_0); intro H; - generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H); + generalize (prod_neq_R0 1 (/ sqrt 2) R1_neq_R0 H); intro H0; assumption. Qed. @@ -163,9 +163,9 @@ Proof. | generalize (Rlt_le 0 2 Hyp); intro H1; assert (Hyp2 : 0 < 3); [ prove_sup0 | generalize (Rlt_le 0 3 Hyp2); intro H2; - generalize (lt_INR_0 1 (neq_O_lt 1 H0)); + generalize (lt_INR_0 1 (neq_O_lt 1 H0)); unfold INR in |- *; intro H3; - generalize (Rplus_lt_compat_l 2 0 1 H3); + generalize (Rplus_lt_compat_l 2 0 1 H3); rewrite Rplus_comm; rewrite Rplus_0_l; replace (2 + 1) with 3; [ intro H4; generalize (sqrt_lt_1 2 3 H1 H2 H4); clear H3; intro H3; apply (Rlt_trans 0 (sqrt 2) (sqrt 3) Rlt_sqrt2_0 H3) @@ -303,7 +303,7 @@ Lemma sin_2PI3 : sin (2 * (PI / 3)) = sqrt 3 / 2. Proof. rewrite double; rewrite sin_plus; rewrite sin_PI3; rewrite cos_PI3; unfold Rdiv in |- *; repeat rewrite Rmult_1_l; rewrite (Rmult_comm (/ 2)); - repeat rewrite <- Rmult_assoc; rewrite double_var; + repeat rewrite <- Rmult_assoc; rewrite double_var; reflexivity. Qed. @@ -385,7 +385,7 @@ Proof. replace (PI + PI / 2) with (3 * (PI / 2)). rewrite Rplus_0_r; intro H2; assumption. pattern PI at 2 in |- *; rewrite double_var; ring. -Qed. +Qed. Lemma Rlt_3PI2_2PI : 3 * (PI / 2) < 2 * PI. Proof. @@ -450,7 +450,7 @@ Proof. left; apply sin_lb_gt_0; assumption. elim H1; intro. rewrite <- H2; unfold sin_lb in |- *; unfold sin_approx in |- *; - unfold sum_f_R0 in |- *; unfold sin_term in |- *; + unfold sum_f_R0 in |- *; unfold sin_term in |- *; repeat rewrite pow_ne_zero. unfold Rdiv in |- *; repeat rewrite Rmult_0_l; repeat rewrite Rmult_0_r; repeat rewrite Rplus_0_r; right; reflexivity. diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index 7f62f538b2..9588e44380 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -63,7 +63,7 @@ Proof. Defined. (* Value of [exp 0] *) -Lemma exp_0 : exp 0 = 1. +Lemma exp_0 : exp 0 = 1. Proof. cut (exp_in 0 (exp 0)). cut (exp_in 0 1). @@ -96,7 +96,7 @@ Qed. Definition cos_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n)). Lemma simpl_cos_n : - forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)). + forall n:nat, cos_n (S n) / cos_n n = - / INR (2 * S n * (2 * n + 1)). Proof. intro; unfold cos_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ]. rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr. @@ -176,7 +176,7 @@ Proof. assert (H0 := archimed_cor1 eps H). elim H0; intros; exists x. intros; rewrite simpl_cos_n; unfold R_dist in |- *; unfold Rminus in |- *; - rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; + rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; rewrite Rabs_Ropp; rewrite Rabs_right. rewrite mult_INR; rewrite Rinv_mult_distr. cut (/ INR (2 * S n) < 1). @@ -250,7 +250,7 @@ Definition cos (x:R) : R := let (a,_) := exist_cos (Rsqr x) in a. Definition sin_n (n:nat) : R := (-1) ^ n / INR (fact (2 * n + 1)). Lemma simpl_sin_n : - forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)). + forall n:nat, sin_n (S n) / sin_n n = - / INR ((2 * S n + 1) * (2 * S n)). Proof. intro; unfold sin_n in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ]. rewrite pow_add; unfold Rdiv in |- *; rewrite Rinv_mult_distr. @@ -300,7 +300,7 @@ Proof. unfold Un_cv in |- *; intros; assert (H0 := archimed_cor1 eps H). elim H0; intros; exists x. intros; rewrite simpl_sin_n; unfold R_dist in |- *; unfold Rminus in |- *; - rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; + rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu; rewrite Rabs_Ropp; rewrite Rabs_right. rewrite mult_INR; rewrite Rinv_mult_distr. cut (/ INR (2 * S n) < 1). @@ -382,7 +382,7 @@ Qed. Lemma sin_antisym : forall x:R, sin (- x) = - sin x. Proof. intro; unfold sin in |- *; replace (Rsqr (- x)) with (Rsqr x); - [ idtac | apply Rsqr_neg ]. + [ idtac | apply Rsqr_neg ]. case (exist_sin (Rsqr x)); intros; ring. Qed. diff --git a/theories/Reals/Rtrigo_fun.v b/theories/Reals/Rtrigo_fun.v index 173fe49600..cb53b5346e 100644 --- a/theories/Reals/Rtrigo_fun.v +++ b/theories/Reals/Rtrigo_fun.v @@ -33,7 +33,7 @@ Proof. generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H2); replace (1 + (/ eps + -1)) with (/ eps); [ clear H2; intro | ring ]. rewrite (Rplus_comm 1 (INR n)) in H2; rewrite <- (S_INR n) in H2; - generalize (Rmult_gt_0_compat (/ INR (S n)) eps H1 H); + generalize (Rmult_gt_0_compat (/ INR (S n)) eps H1 H); intro; unfold Rgt in H3; generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H3 H2); intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H4; @@ -42,11 +42,11 @@ Proof. rewrite (Rmult_comm (/ INR (S n))) in H4; rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H4; rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H4; - rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4; + rewrite (let (H1, H2) := Rmult_ne eps in H1) in H4; assumption. apply Rlt_minus; unfold Rgt in a; rewrite <- Rinv_1; apply (Rinv_lt_contravar 1 eps); auto; - rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H; + rewrite (let (H1, H2) := Rmult_ne eps in H2); unfold Rgt in H; assumption. unfold Rgt in H1; apply Rlt_le; assumption. unfold Rgt in |- *; apply Rinv_0_lt_compat; apply lt_INR_0; apply lt_O_Sn. @@ -61,12 +61,12 @@ Proof. intro ; generalize (Rlt_le_trans (/ eps - 1) (INR x) (INR n) H4 - (le_INR x n H2)); + (le_INR x n H2)); clear H4; intro; unfold Rminus in H4; generalize (Rplus_lt_compat_l 1 (/ eps + -1) (INR n) H4); replace (1 + (/ eps + -1)) with (/ eps); [ clear H4; intro | ring ]. rewrite (Rplus_comm 1 (INR n)) in H4; rewrite <- (S_INR n) in H4; - generalize (Rmult_gt_0_compat (/ INR (S n)) eps H3 H); + generalize (Rmult_gt_0_compat (/ INR (S n)) eps H3 H); intro; unfold Rgt in H5; generalize (Rmult_lt_compat_l (/ INR (S n) * eps) (/ eps) (INR (S n)) H5 H4); intro; rewrite (Rmult_assoc (/ INR (S n)) eps (/ eps)) in H6; @@ -75,7 +75,7 @@ Proof. rewrite (Rmult_comm (/ INR (S n))) in H6; rewrite (Rmult_assoc eps (/ INR (S n)) (INR (S n))) in H6; rewrite (Rinv_l (INR (S n)) (not_O_INR (S n) (sym_not_equal (O_S n)))) in H6; - rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6; + rewrite (let (H1, H2) := Rmult_ne eps in H1) in H6; assumption. cut (IZR (up (/ eps - 1)) = IZR (Z_of_nat x)); [ intro | rewrite H1; trivial ]. @@ -92,8 +92,8 @@ Proof. rewrite (Rinv_l eps (sym_not_eq (Rlt_dichotomy_converse 0 eps (or_introl (0 > eps) H)))) - ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1); - intro; fold (/ eps - 1 > 0) in |- *; apply Rgt_minus; + ; rewrite (let (H1, H2) := Rmult_ne (/ eps) in H1); + intro; fold (/ eps - 1 > 0) in |- *; apply Rgt_minus; unfold Rgt in |- *; assumption. right; rewrite H0; rewrite Rinv_1; apply sym_eq; apply Rminus_diag_eq; auto. elim (archimed (/ eps - 1)); intros; clear H1; unfold Rgt in H0; apply Rlt_le; diff --git a/theories/Reals/Rtrigo_reg.v b/theories/Reals/Rtrigo_reg.v index dc65dd2e99..5b731488b1 100644 --- a/theories/Reals/Rtrigo_reg.v +++ b/theories/Reals/Rtrigo_reg.v @@ -131,7 +131,7 @@ Proof. apply SFL_continuity; assumption. unfold continuity in |- *; unfold continuity_pt in |- *; unfold continue_in in |- *; unfold limit1_in in |- *; - unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; + unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros. elim (H1 x _ H2); intros. exists x0; intros. @@ -172,7 +172,7 @@ Proof. unfold continuity_pt in H0; unfold continue_in in H0; unfold limit1_in in H0; unfold limit_in in H0; simpl in H0; unfold R_dist in H0; unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros. elim (H0 _ H); intros. exists x0; intros. @@ -186,7 +186,7 @@ Proof. trivial. red in |- *; intro; unfold D_x, no_cond in H5; elim H5; intros _ H8; elim H8; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive x1); - apply Ropp_eq_compat; apply Rplus_eq_reg_l with (PI / 2); + apply Ropp_eq_compat; apply Rplus_eq_reg_l with (PI / 2); apply H7. replace (PI / 2 - x1 - (PI / 2 - x)) with (x - x1); [ idtac | ring ]; rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H6. @@ -420,7 +420,7 @@ Proof. elim H9; intros; assumption. cut (Rabs (h / 2) < del). intro; cut (h / 2 <> 0). - intro; assert (H11 := H2 _ H10 H9). + intro; assert (H11 := H2 _ H10 H9). rewrite Rplus_0_l in H11; rewrite sin_0 in H11. rewrite Rminus_0_r in H11; apply H11. unfold Rdiv in |- *; apply prod_neq_R0. @@ -436,7 +436,7 @@ Proof. unfold delta in |- *; simpl in |- *; apply Rmin_l. apply Rle_ge; left; apply Rinv_0_lt_compat; prove_sup0. rewrite <- (Rplus_0_r (del / 2)); pattern del at 1 in |- *; - rewrite (double_var del); apply Rplus_lt_compat_l; + rewrite (double_var del); apply Rplus_lt_compat_l; unfold Rdiv in |- *; apply Rmult_lt_0_compat. apply (cond_pos del). apply Rinv_0_lt_compat; prove_sup0. diff --git a/theories/Reals/SeqSeries.v b/theories/Reals/SeqSeries.v index e41addadb2..dbfc85bb94 100644 --- a/theories/Reals/SeqSeries.v +++ b/theories/Reals/SeqSeries.v @@ -25,7 +25,7 @@ Open Local Scope R_scope. (**********) Lemma sum_maj1 : - forall (fn:nat -> R -> R) (An:nat -> R) (x l1 l2:R) + forall (fn:nat -> R -> R) (An:nat -> R) (x l1 l2:R) (N:nat), Un_cv (fun n:nat => SP fn n x) l1 -> Un_cv (fun n:nat => sum_f_R0 An n) l2 -> @@ -92,7 +92,7 @@ Proof. (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with (sum_f_R0 (fun k:nat => fn k x) N + - sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); + sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); [ idtac | ring ]. replace (sum_f_R0 (fun k:nat => fn k x) N + @@ -170,7 +170,7 @@ Proof. (sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - (l1 - sum_f_R0 (fun k:nat => fn k x) N)) with (sum_f_R0 (fun k:nat => fn k x) N + - sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); + sum_f_R0 (fun l:nat => fn (S N + l)%nat x) n - l1); [ idtac | ring ]. replace (sum_f_R0 (fun k:nat => fn k x) N + @@ -241,13 +241,13 @@ Proof. apply Rle_ge; apply cond_pos_sum; intro. elim (H (S n + n0)%nat); intros; assumption. rewrite b; unfold R_dist in |- *; unfold Rminus in |- *; - do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right; + do 2 rewrite Rplus_opp_r; rewrite Rabs_R0; right; reflexivity. rewrite (tech2 An m n); [ idtac | assumption ]. rewrite (tech2 Bn m n); [ idtac | assumption ]. unfold R_dist in |- *; unfold Rminus in |- *; do 2 rewrite Rplus_assoc; rewrite (Rplus_comm (sum_f_R0 An m)); rewrite (Rplus_comm (sum_f_R0 Bn m)); - do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l; + do 2 rewrite Rplus_assoc; do 2 rewrite Rplus_opp_l; do 2 rewrite Rplus_0_r; repeat rewrite Rabs_right. apply sum_Rle; intros. elim (H (S m + n0)%nat); intros; apply H8. diff --git a/theories/Reals/Sqrt_reg.v b/theories/Reals/Sqrt_reg.v index 42860180f4..4f336648b9 100644 --- a/theories/Reals/Sqrt_reg.v +++ b/theories/Reals/Sqrt_reg.v @@ -11,7 +11,7 @@ Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. -Require Import R_sqrt. +Require Import R_sqrt. Open Local Scope R_scope. (**********) @@ -104,8 +104,8 @@ Qed. Lemma sqrt_continuity_pt_R1 : continuity_pt sqrt 1. Proof. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; + unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; intros. set (alpha := Rmin eps 1). exists alpha; intros. @@ -129,8 +129,8 @@ Lemma sqrt_continuity_pt : forall x:R, 0 < x -> continuity_pt sqrt x. Proof. intros; generalize sqrt_continuity_pt_R1. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; - unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; + unfold dist in |- *; simpl in |- *; unfold R_dist in |- *; intros. cut (0 < eps / sqrt x). intro; elim (H0 _ H2); intros alp_1 H3. @@ -153,7 +153,7 @@ Proof. unfold Rdiv in H5. case (Req_dec x x0); intro. rewrite H7; unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r; - rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r; + rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r; rewrite Rabs_R0. apply Rmult_lt_0_compat. assumption. @@ -238,7 +238,7 @@ Proof. intro; cut (g 0 <> 0). intro; assert (H2 := continuity_pt_inv g 0 H0 H1). unfold derivable_pt_lim in |- *; intros; unfold continuity_pt in H2; - unfold continue_in in H2; unfold limit1_in in H2; + unfold continue_in in H2; unfold limit1_in in H2; unfold limit_in in H2; simpl in H2; unfold R_dist in H2. elim (H2 eps H3); intros alpha H4. elim H4; intros. @@ -333,7 +333,7 @@ Proof. apply (sqrt_continuity_pt x H0). elim H0; intro. unfold continuity_pt in |- *; unfold continue_in in |- *; - unfold limit1_in in |- *; unfold limit_in in |- *; + unfold limit1_in in |- *; unfold limit_in in |- *; simpl in |- *; unfold R_dist in |- *; intros. exists (Rsqr eps); intros. split. diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index 2ced22298a..d35841e00d 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -24,7 +24,7 @@ Section Properties. Variable R : relation A. Let incl (R1 R2:relation A) : Prop := forall x y:A, R1 x y -> R2 x y. - + Section Clos_Refl_Trans. (** Correctness of the reflexive-transitive closure operator *) @@ -33,7 +33,7 @@ Section Properties. Proof. apply Build_preorder. exact (rt_refl A R). - + exact (rt_trans A R). Qed. @@ -114,7 +114,7 @@ Section Properties. apply t1n_trans; auto. Qed. - Lemma t1n_trans_equiv : forall x y, + Lemma t1n_trans_equiv : forall x y, clos_trans A R x y <-> clos_trans_1n A R x y. Proof. split. @@ -144,7 +144,7 @@ Section Properties. right with y0; auto. Qed. - Lemma tn1_trans_equiv : forall x y, + Lemma tn1_trans_equiv : forall x y, clos_trans A R x y <-> clos_trans_n1 A R x y. Proof. split. @@ -152,7 +152,7 @@ Section Properties. apply tn1_trans. Qed. - (** Direct reflexive-transitive closure is equivalent to + (** Direct reflexive-transitive closure is equivalent to transitivity by left-step extension *) Lemma R_rt1n : forall x y, R x y -> clos_refl_trans_1n A R x y. @@ -167,7 +167,7 @@ Section Properties. right with x;[assumption|left]. Qed. - Lemma rt1n_trans : forall x y, + Lemma rt1n_trans : forall x y, clos_refl_trans_1n A R x y -> clos_refl_trans A R x y. Proof. induction 1. @@ -176,7 +176,7 @@ Section Properties. constructor 1; auto. Qed. - Lemma trans_rt1n : forall x y, + Lemma trans_rt1n : forall x y, clos_refl_trans A R x y -> clos_refl_trans_1n A R x y. Proof. induction 1. @@ -190,7 +190,7 @@ Section Properties. apply rt1n_trans; auto. Qed. - Lemma rt1n_trans_equiv : forall x y, + Lemma rt1n_trans_equiv : forall x y, clos_refl_trans A R x y <-> clos_refl_trans_1n A R x y. Proof. split. @@ -198,7 +198,7 @@ Section Properties. apply rt1n_trans. Qed. - (** Direct reflexive-transitive closure is equivalent to + (** Direct reflexive-transitive closure is equivalent to transitivity by right-step extension *) Lemma rtn1_trans : forall x y, @@ -210,7 +210,7 @@ Section Properties. constructor 1; assumption. Qed. - Lemma trans_rtn1 : forall x y, + Lemma trans_rtn1 : forall x y, clos_refl_trans A R x y -> clos_refl_trans_n1 A R x y. Proof. induction 1. @@ -221,7 +221,7 @@ Section Properties. right with y0; auto. Qed. - Lemma rtn1_trans_equiv : forall x y, + Lemma rtn1_trans_equiv : forall x y, clos_refl_trans A R x y <-> clos_refl_trans_n1 A R x y. Proof. split. @@ -240,7 +240,7 @@ Section Properties. revert H H0. induction H1; intros; auto with sets. apply H1 with x; auto with sets. - + apply IHclos_refl_trans2. apply IHclos_refl_trans1; auto with sets. @@ -270,10 +270,10 @@ Section Properties. eauto. Qed. - (** Direct reflexive-symmetric-transitive closure is equivalent to + (** Direct reflexive-symmetric-transitive closure is equivalent to transitivity by symmetric left-step extension *) - Lemma rts1n_rts : forall x y, + Lemma rts1n_rts : forall x y, clos_refl_sym_trans_1n A R x y -> clos_refl_sym_trans A R x y. Proof. induction 1. @@ -283,7 +283,7 @@ Section Properties. Qed. Lemma rts_1n_trans : forall x y, clos_refl_sym_trans_1n A R x y -> - forall z, clos_refl_sym_trans_1n A R y z -> + forall z, clos_refl_sym_trans_1n A R y z -> clos_refl_sym_trans_1n A R x z. induction 1. auto. @@ -301,7 +301,7 @@ Section Properties. left. Qed. - Lemma rts_rts1n : forall x y, + Lemma rts_rts1n : forall x y, clos_refl_sym_trans A R x y -> clos_refl_sym_trans_1n A R x y. induction 1. constructor 2 with y; auto. @@ -311,7 +311,7 @@ Section Properties. eapply rts_1n_trans; eauto. Qed. - Lemma rts_rts1n_equiv : forall x y, + Lemma rts_rts1n_equiv : forall x y, clos_refl_sym_trans A R x y <-> clos_refl_sym_trans_1n A R x y. Proof. split. @@ -319,10 +319,10 @@ Section Properties. apply rts1n_rts. Qed. - (** Direct reflexive-symmetric-transitive closure is equivalent to + (** Direct reflexive-symmetric-transitive closure is equivalent to transitivity by symmetric right-step extension *) - Lemma rtsn1_rts : forall x y, + Lemma rtsn1_rts : forall x y, clos_refl_sym_trans_n1 A R x y -> clos_refl_sym_trans A R x y. Proof. induction 1. @@ -332,7 +332,7 @@ Section Properties. Qed. Lemma rtsn1_trans : forall y z, clos_refl_sym_trans_n1 A R y z-> - forall x, clos_refl_sym_trans_n1 A R x y -> + forall x, clos_refl_sym_trans_n1 A R x y -> clos_refl_sym_trans_n1 A R x z. Proof. induction 1. @@ -352,7 +352,7 @@ Section Properties. left. Qed. - Lemma rts_rtsn1 : forall x y, + Lemma rts_rtsn1 : forall x y, clos_refl_sym_trans A R x y -> clos_refl_sym_trans_n1 A R x y. Proof. induction 1. @@ -363,7 +363,7 @@ Section Properties. eapply rtsn1_trans; eauto. Qed. - Lemma rts_rtsn1_equiv : forall x y, + Lemma rts_rtsn1_equiv : forall x y, clos_refl_sym_trans A R x y <-> clos_refl_sym_trans_n1 A R x y. Proof. split. diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v index 977135fab7..c03c4b95f9 100644 --- a/theories/Relations/Relation_Definitions.v +++ b/theories/Relations/Relation_Definitions.v @@ -11,14 +11,14 @@ Section Relation_Definition. Variable A : Type. - + Definition relation := A -> A -> Prop. Variable R : relation. - + Section General_Properties_of_Relations. - + Definition reflexive : Prop := forall x:A, R x x. Definition transitive : Prop := forall x y z:A, R x y -> R y z -> R x z. Definition symmetric : Prop := forall x y:A, R x y -> R y x. @@ -32,33 +32,33 @@ Section Relation_Definition. Section Sets_of_Relations. - - Record preorder : Prop := + + Record preorder : Prop := { preord_refl : reflexive; preord_trans : transitive}. - - Record order : Prop := + + Record order : Prop := { ord_refl : reflexive; ord_trans : transitive; ord_antisym : antisymmetric}. - - Record equivalence : Prop := + + Record equivalence : Prop := { equiv_refl : reflexive; equiv_trans : transitive; equiv_sym : symmetric}. - + Record PER : Prop := {per_sym : symmetric; per_trans : transitive}. End Sets_of_Relations. Section Relations_of_Relations. - + Definition inclusion (R1 R2:relation) : Prop := forall x y:A, R1 x y -> R2 x y. - + Definition same_relation (R1 R2:relation) : Prop := inclusion R1 R2 /\ inclusion R2 R1. - + Definition commut (R1 R2:relation) : Prop := forall x y:A, R1 y x -> forall z:A, R2 z y -> exists2 y' : A, R2 y' x & R1 z y'. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index eec3f8ebd1..2d1503f23c 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -65,7 +65,7 @@ Section Reflexive_Transitive_Closure. Inductive clos_refl_trans_1n (x: A) : A -> Prop := | rt1n_refl : clos_refl_trans_1n x x - | rt1n_trans (y z:A) : + | rt1n_trans (y z:A) : R x y -> clos_refl_trans_1n y z -> clos_refl_trans_1n x z. (** Alternative definition by transitive extension on the right *) @@ -82,7 +82,7 @@ End Reflexive_Transitive_Closure. Section Reflexive_Symetric_Transitive_Closure. Variable A : Type. Variable R : relation A. - + (** Definition by direct reflexive-symmetric-transitive closure *) Inductive clos_refl_sym_trans : relation A := @@ -104,7 +104,7 @@ Section Reflexive_Symetric_Transitive_Closure. Inductive clos_refl_sym_trans_n1 (x: A) : A -> Prop := | rtsn1_refl : clos_refl_sym_trans_n1 x x - | rtsn1_trans (y z:A) : R y z \/ R z y -> + | rtsn1_trans (y z:A) : R y z \/ R z y -> clos_refl_sym_trans_n1 x y -> clos_refl_sym_trans_n1 x z. End Reflexive_Symetric_Transitive_Closure. @@ -139,7 +139,7 @@ Inductive le_AsB : A + B -> A + B -> Prop := | le_ab (x:A) (y:B) : le_AsB (inl _ x) (inr _ y) | le_bb (x y:B) : leB x y -> le_AsB (inr _ x) (inr _ y). -End Disjoint_Union. +End Disjoint_Union. (** ** Lexicographic order on dependent pairs *) @@ -189,12 +189,12 @@ End Swap. Section Lexicographic_Exponentiation. - + Variable A : Set. Variable leA : A -> A -> Prop. Let Nil := nil (A:=A). Let List := list A. - + Inductive Ltl : List -> List -> Prop := | Lt_nil (a:A) (x:List) : Ltl Nil (a :: x) | Lt_hd (a b:A) : leA a b -> forall x y:list A, Ltl (a :: x) (b :: y) @@ -207,7 +207,7 @@ Section Lexicographic_Exponentiation. leA x y -> Desc (l ++ y :: Nil) -> Desc ((l ++ y :: Nil) ++ x :: Nil). Definition Pow : Set := sig Desc. - + Definition lex_exp (a b:Pow) : Prop := Ltl (proj1_sig a) (proj1_sig b). End Lexicographic_Exponentiation. diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index 9eef2bc1d6..c5530e7ca4 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -29,35 +29,35 @@ Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y - unfold Setoid_Theory. intros ; transitivity y ; assumption. Defined. -(** Some tactics for manipulating Setoid Theory not officially +(** Some tactics for manipulating Setoid Theory not officially declared as Setoid. *) Ltac trans_st x := idtac "trans_st on Setoid_Theory is OBSOLETE"; idtac "use transitivity on Equivalence instead"; match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => apply (Seq_trans _ _ H) with x; auto end. Ltac sym_st := idtac "sym_st on Setoid_Theory is OBSOLETE"; idtac "use symmetry on Equivalence instead"; - match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => apply (Seq_sym _ _ H); auto end. Ltac refl_st := idtac "refl_st on Setoid_Theory is OBSOLETE"; idtac "use reflexivity on Equivalence instead"; - match goal with - | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => apply (Seq_refl _ _ H); auto end. Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A). -Proof. - constructor; congruence. +Proof. + constructor; congruence. Qed. - + diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v index 62fd4df1aa..5f68609970 100644 --- a/theories/Sets/Classical_sets.v +++ b/theories/Sets/Classical_sets.v @@ -56,7 +56,7 @@ Section Ensembles_classical. forall X Y:Ensemble U, Included U X Y -> ~ Included U Y X -> Inhabited U (Setminus U Y X). Proof. - intros X Y I NI. + intros X Y I NI. elim (not_all_ex_not U (fun x:U => In U Y x -> In U X x) NI). intros x YX. apply Inhabited_intro with x. @@ -78,7 +78,7 @@ Section Ensembles_classical. unfold Subtract at 1 in |- *; auto with sets. Qed. Hint Resolve Subtract_intro : sets. - + Lemma Subtract_inv : forall (A:Ensemble U) (x y:U), In U (Subtract U A x) y -> In U A y /\ x <> y. Proof. diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index 65ce03e28b..0719365f14 100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -30,7 +30,7 @@ Require Export Ensembles. Section Ensembles_facts. Variable U : Type. - + Lemma Extension : forall B C:Ensemble U, B = C -> Same_set U B C. Proof. intros B C H'; rewrite H'; auto with sets. @@ -52,7 +52,7 @@ Section Ensembles_facts. Proof. unfold Add at 1 in |- *; auto with sets. Qed. - + Lemma Add_intro2 : forall (A:Ensemble U) (x:U), In U (Add U A x) x. Proof. unfold Add at 1 in |- *; auto with sets. @@ -98,15 +98,15 @@ Section Ensembles_facts. Proof. intros B C x H'; elim H'; auto with sets. Qed. - + Lemma Add_inv : forall (A:Ensemble U) (x y:U), In U (Add U A x) y -> In U A y \/ x = y. Proof. - intros A x y H'; induction H'. + intros A x y H'; induction H'. left; assumption. right; apply Singleton_inv; assumption. Qed. - + Lemma Intersection_inv : forall (B C:Ensemble U) (x:U), In U (Intersection U B C) x -> In U B x /\ In U C x. @@ -125,7 +125,7 @@ Section Ensembles_facts. Proof. unfold Setminus at 1 in |- *; red in |- *; auto with sets. Qed. - + Lemma Strict_Included_intro : forall X Y:Ensemble U, Included U X Y /\ X <> Y -> Strict_Included U X Y. Proof. diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index c1e64babc2..8c69e68771 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -35,7 +35,7 @@ Section Bounds. Variable D : PO U. Let C := Carrier_of U D. - + Let R := Rel_of U D. Inductive Upper_Bound (B:Ensemble U) (x:U) : Prop := @@ -45,7 +45,7 @@ Section Bounds. Inductive Lower_Bound (B:Ensemble U) (x:U) : Prop := Lower_Bound_definition : In U C x -> (forall y:U, In U B y -> R x y) -> Lower_Bound B x. - + Inductive Lub (B:Ensemble U) (x:U) : Prop := Lub_definition : Upper_Bound B x -> (forall y:U, Upper_Bound B y -> R x y) -> Lub B x. @@ -57,7 +57,7 @@ Section Bounds. Inductive Bottom (bot:U) : Prop := Bottom_definition : In U C bot -> (forall y:U, In U C y -> R bot y) -> Bottom bot. - + Inductive Totally_ordered (B:Ensemble U) : Prop := Totally_ordered_definition : (Included U B C -> @@ -77,7 +77,7 @@ Section Bounds. Included U (Couple U x1 x2) X -> exists x3 : _, In U X x3 /\ Upper_Bound (Couple U x1 x2) x3) -> Directed X. - + Inductive Complete : Prop := Definition_of_Complete : (exists bot : _, Bottom bot) -> @@ -102,7 +102,7 @@ Section Specific_orders. Record Cpo : Type := Definition_of_cpo {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}. - + Record Chain : Type := Definition_of_chain {PO_of_chain : PO U; Chain_cond : Totally_ordered U PO_of_chain (Carrier_of U PO_of_chain)}. diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v index 3392985727..0fa9c74a82 100644 --- a/theories/Sets/Ensembles.v +++ b/theories/Sets/Ensembles.v @@ -28,23 +28,23 @@ Section Ensembles. Variable U : Type. - - Definition Ensemble := U -> Prop. + + Definition Ensemble := U -> Prop. Definition In (A:Ensemble) (x:U) : Prop := A x. - + Definition Included (B C:Ensemble) : Prop := forall x:U, In B x -> In C x. - + Inductive Empty_set : Ensemble :=. - + Inductive Full_set : Ensemble := Full_intro : forall x:U, In Full_set x. -(** NB: The following definition builds-in equality of elements in [U] as - Leibniz equality. +(** NB: The following definition builds-in equality of elements in [U] as + Leibniz equality. - This may have to be changed if we replace [U] by a Setoid on [U] - with its own equality [eqs], with + This may have to be changed if we replace [U] by a Setoid on [U] + with its own equality [eqs], with [In_singleton: (y: U)(eqs x y) -> (In (Singleton x) y)]. *) Inductive Singleton (x:U) : Ensemble := @@ -55,7 +55,7 @@ Section Ensembles. | Union_intror : forall x:U, In C x -> In (Union B C) x. Definition Add (B:Ensemble) (x:U) : Ensemble := Union B (Singleton x). - + Inductive Intersection (B C:Ensemble) : Ensemble := Intersection_intro : forall x:U, In B x -> In C x -> In (Intersection B C) x. @@ -63,29 +63,29 @@ Section Ensembles. Inductive Couple (x y:U) : Ensemble := | Couple_l : In (Couple x y) x | Couple_r : In (Couple x y) y. - + Inductive Triple (x y z:U) : Ensemble := | Triple_l : In (Triple x y z) x | Triple_m : In (Triple x y z) y | Triple_r : In (Triple x y z) z. - + Definition Complement (A:Ensemble) : Ensemble := fun x:U => ~ In A x. - + Definition Setminus (B C:Ensemble) : Ensemble := fun x:U => In B x /\ ~ In C x. - + Definition Subtract (B:Ensemble) (x:U) : Ensemble := Setminus B (Singleton x). - + Inductive Disjoint (B C:Ensemble) : Prop := Disjoint_intro : (forall x:U, ~ In (Intersection B C) x) -> Disjoint B C. Inductive Inhabited (B:Ensemble) : Prop := Inhabited_intro : forall x:U, In B x -> Inhabited B. - + Definition Strict_Included (B C:Ensemble) : Prop := Included B C /\ B <> C. - + Definition Same_set (B C:Ensemble) : Prop := Included B C /\ Included C B. - + (** Extensionality Axiom *) Axiom Extensionality_Ensembles : forall A B:Ensemble, Same_set A B -> A = B. diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v index a75c3b7671..019c25a556 100644 --- a/theories/Sets/Finite_sets.v +++ b/theories/Sets/Finite_sets.v @@ -52,7 +52,7 @@ Require Import Constructive_sets. Section Ensembles_finis_facts. Variable U : Type. - + Lemma cardinal_invert : forall (X:Ensemble U) (p:nat), cardinal U X p -> diff --git a/theories/Sets/Finite_sets_facts.v b/theories/Sets/Finite_sets_facts.v index 0615c9c9d7..fdcc4150ff 100644 --- a/theories/Sets/Finite_sets_facts.v +++ b/theories/Sets/Finite_sets_facts.v @@ -72,7 +72,7 @@ Section Finite_sets_facts. Proof. intros X Y H; induction H as [|A Fin_A Hind x]. rewrite (Empty_set_zero U Y). trivial. - intros. + intros. rewrite (Union_commutative U (Add U A x) Y). rewrite <- (Union_add U Y A x). rewrite (Union_commutative U Y A). @@ -98,7 +98,7 @@ Section Finite_sets_facts. Proof. intros A H' X; apply Finite_downward_closed with A; auto with sets. Qed. - + Lemma cardinalO_empty : forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U. Proof. @@ -212,7 +212,7 @@ Section Finite_sets_facts. Proof. intros; apply cardinal_is_functional with X X; auto with sets. Qed. - + Lemma card_Add_gen : forall (A:Ensemble U) (x:U) (n n':nat), cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n. @@ -279,7 +279,7 @@ Section Finite_sets_facts. intro E; rewrite E; auto with sets arith. apply cardinal_unicity with X; auto with sets arith. Qed. - + Lemma G_aux : forall P:Ensemble U -> Prop, (forall X:Ensemble U, diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v index da3aec320c..64c341bd37 100644 --- a/theories/Sets/Image.v +++ b/theories/Sets/Image.v @@ -40,10 +40,10 @@ Require Export Finite_sets_facts. Section Image. Variables U V : Type. - + Inductive Im (X:Ensemble U) (f:U -> V) : Ensemble V := Im_intro : forall x:U, In _ X x -> forall y:V, y = f x -> In _ (Im X f) y. - + Lemma Im_def : forall (X:Ensemble U) (f:U -> V) (x:U), In _ X x -> In _ (Im X f) (f x). Proof. @@ -62,13 +62,13 @@ Section Image. rewrite H0. elim Add_inv with U X x x1; auto using Im_def with sets. destruct 1; auto using Im_def with sets. - elim Add_inv with V (Im X f) (f x) x0. + elim Add_inv with V (Im X f) (f x) x0. destruct 1 as [x0 H y H0]. rewrite H0; auto using Im_def with sets. destruct 1; auto using Im_def with sets. trivial. Qed. - + Lemma image_empty : forall f:U -> V, Im (Empty_set U) f = Empty_set V. Proof. intro f; try assumption. @@ -88,7 +88,7 @@ Section Image. rewrite (Im_add A x f); auto with sets. apply Add_preserves_Finite; auto with sets. Qed. - + Lemma Im_inv : forall (X:Ensemble U) (f:U -> V) (y:V), In _ (Im X f) y -> exists x : U, In _ X x /\ f x = y. @@ -97,9 +97,9 @@ Section Image. intros x H'0 y0 H'1; rewrite H'1. exists x; auto with sets. Qed. - + Definition injective (f:U -> V) := forall x y:U, f x = f y -> x = y. - + Lemma not_injective_elim : forall f:U -> V, ~ injective f -> exists x : _, (exists y : _, f x = f y /\ x <> y). @@ -115,7 +115,7 @@ Section Image. destruct 1 as [y D]; exists y. apply imply_to_and; trivial with sets. Qed. - + Lemma cardinal_Im_intro : forall (A:Ensemble U) (f:U -> V) (n:nat), cardinal _ A n -> exists p : nat, cardinal _ (Im A f) p. @@ -124,7 +124,7 @@ Section Image. apply finite_cardinal; apply finite_image. apply cardinal_finite with n; trivial with sets. Qed. - + Lemma In_Image_elim : forall (A:Ensemble U) (f:U -> V), injective f -> forall x:U, In _ (Im A f) (f x) -> In _ A x. @@ -134,7 +134,7 @@ Section Image. intros z C; elim C; intros InAz E. elim (H z x E); trivial with sets. Qed. - + Lemma injective_preserves_cardinal : forall (A:Ensemble U) (f:U -> V) (n:nat), injective f -> @@ -158,7 +158,7 @@ Section Image. red in |- *; intro; apply H'2. apply In_Image_elim with f; trivial with sets. Qed. - + Lemma cardinal_decreases : forall (A:Ensemble U) (f:U -> V) (n:nat), cardinal U A n -> forall n':nat, cardinal V (Im A f) n' -> n' <= n. @@ -188,7 +188,7 @@ Section Image. apply injective_preserves_cardinal with (A := A) (f := f) (n := n); trivial with sets. Qed. - + Lemma Pigeonhole_principle : forall (A:Ensemble U) (f:U -> V) (n:nat), cardinal _ A n -> diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index 6b02e8383f..b63ec1d472 100644 --- a/theories/Sets/Infinite_sets.v +++ b/theories/Sets/Infinite_sets.v @@ -50,7 +50,7 @@ Hint Resolve Defn_of_Approximant. Section Infinite_sets. Variable U : Type. - + Lemma make_new_approximant : forall A X:Ensemble U, ~ Finite U A -> Approximant U A X -> Inhabited U (Setminus U A X). @@ -61,7 +61,7 @@ Section Infinite_sets. red in |- *; intro H'3; apply H'. rewrite <- H'3; auto with sets. Qed. - + Lemma approximants_grow : forall A X:Ensemble U, ~ Finite U A -> @@ -101,7 +101,7 @@ Section Infinite_sets. apply Defn_of_Approximant; auto with sets. apply cardinal_finite with (n := S n0); auto with sets. Qed. - + Lemma approximants_grow' : forall A X:Ensemble U, ~ Finite U A -> @@ -121,7 +121,7 @@ Section Infinite_sets. apply cardinal_finite with (n := S n); auto with sets. apply approximants_grow with (X := X); auto with sets. Qed. - + Lemma approximant_can_be_any_size : forall A X:Ensemble U, ~ Finite U A -> @@ -135,7 +135,7 @@ Section Infinite_sets. Qed. Variable V : Type. - + Theorem Image_set_continuous : forall (A:Ensemble U) (f:U -> V) (X:Ensemble V), Finite V X -> @@ -230,7 +230,7 @@ Section Infinite_sets. rewrite H'4; auto with sets. elim H'3; auto with sets. Qed. - + Theorem Pigeonhole_ter : forall (A:Ensemble U) (f:U -> V) (n:nat), injective U V f -> Finite V (Im U V A f) -> Finite U A. diff --git a/theories/Sets/Integers.v b/theories/Sets/Integers.v index ec44a6e582..443713211b 100644 --- a/theories/Sets/Integers.v +++ b/theories/Sets/Integers.v @@ -45,7 +45,7 @@ Require Export Partial_Order. Require Export Cpo. Section Integers_sect. - + Inductive Integers : Ensemble nat := Integers_defn : forall x:nat, In nat Integers x. @@ -53,7 +53,7 @@ Section Integers_sect. Proof. red in |- *; auto with arith. Qed. - + Lemma le_antisym : Antisymmetric nat le. Proof. red in |- *; intros x y H H'; rewrite (le_antisym x y); auto. @@ -63,12 +63,12 @@ Section Integers_sect. Proof. red in |- *; intros; apply le_trans with y; auto. Qed. - + Lemma le_Order : Order nat le. Proof. - split; [exact le_reflexive | exact le_trans | exact le_antisym]. + split; [exact le_reflexive | exact le_trans | exact le_antisym]. Qed. - + Lemma triv_nat : forall n:nat, In nat Integers n. Proof. exact Integers_defn. @@ -77,11 +77,11 @@ Section Integers_sect. Definition nat_po : PO nat. apply Definition_of_PO with (Carrier_of := Integers) (Rel_of := le); auto with sets arith. - apply Inhabited_intro with (x := 0). + apply Inhabited_intro with (x := 0). apply Integers_defn. exact le_Order. Defined. - + Lemma le_total_order : Totally_ordered nat nat_po Integers. Proof. apply Totally_ordered_definition. @@ -92,7 +92,7 @@ Section Integers_sect. intro H'1; right. cut (y <= x); auto with sets arith. Qed. - + Lemma Finite_subset_has_lub : forall X:Ensemble nat, Finite nat X -> exists m : nat, Upper_Bound nat nat_po X m. @@ -124,7 +124,7 @@ Section Integers_sect. apply H'4 with (y := x0). elim H'3; simpl in |- *; auto with sets arith. trivial. intros x1 H'4; elim H'4. unfold nat_po; simpl; trivial. exists x0. - apply Upper_Bound_definition. + apply Upper_Bound_definition. unfold nat_po. simpl. apply triv_nat. intros y H'1; elim H'1. intros x1 H'4; try assumption. @@ -148,7 +148,7 @@ Section Integers_sect. absurd (S x <= x); auto with arith. apply triv_nat. Qed. - + Lemma Integers_infinite : ~ Finite nat Integers. Proof. generalize Integers_has_no_ub. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index 42130bbb5b..75b9f2efa3 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -22,7 +22,7 @@ Section multiset_defs. Inductive multiset : Type := Bag : (A -> nat) -> multiset. - + Definition EmptyBag := Bag (fun a:A => 0). Definition SingletonBag (a:A) := Bag (fun a':A => match Aeq_dec a a' with @@ -31,23 +31,23 @@ Section multiset_defs. end). Definition multiplicity (m:multiset) (a:A) : nat := let (f) := m in f a. - + (** multiset equality *) Definition meq (m1 m2:multiset) := forall a:A, multiplicity m1 a = multiplicity m2 a. - + Lemma meq_refl : forall x:multiset, meq x x. Proof. destruct x; unfold meq; reflexivity. Qed. - + Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z. Proof. unfold meq in |- *. destruct x; destruct y; destruct z. intros; rewrite H; auto. Qed. - + Lemma meq_sym : forall x y:multiset, meq x y -> meq y x. Proof. unfold meq in |- *. @@ -62,7 +62,7 @@ Section multiset_defs. Proof. unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto. Qed. - + Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag). Proof. unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto. @@ -70,7 +70,7 @@ Section multiset_defs. Require Plus. (* comm. and ass. of plus *) - + Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x). Proof. unfold meq in |- *; unfold multiplicity in |- *; unfold munion in |- *. @@ -106,28 +106,28 @@ Section multiset_defs. Lemma munion_rotate : forall x y z:multiset, meq (munion x (munion y z)) (munion z (munion x y)). Proof. - intros; apply (op_rotate multiset munion meq). + intros; apply (op_rotate multiset munion meq). apply munion_comm. apply munion_ass. exact meq_trans. exact meq_sym. trivial. Qed. - + Lemma meq_congr : forall x y z t:multiset, meq x y -> meq z t -> meq (munion x z) (munion y t). Proof. intros; apply (cong_congr multiset munion meq); auto using meq_left, meq_right. exact meq_trans. Qed. - + Lemma munion_perm_left : forall x y z:multiset, meq (munion x (munion y z)) (munion y (munion x z)). Proof. intros; apply (perm_left multiset munion meq); auto using munion_comm, munion_ass, meq_left, meq_right, meq_sym. exact meq_trans. Qed. - + Lemma multiset_twist1 : forall x y z t:multiset, meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z). @@ -156,7 +156,7 @@ Section multiset_defs. apply meq_right; apply meq_left; trivial. apply multiset_twist1. Qed. - + Lemma treesort_twist2 : forall x y z t u:multiset, meq u (munion y z) -> @@ -168,7 +168,7 @@ Section multiset_defs. Qed. -(*i theory of minter to do similarly +(*i theory of minter to do similarly Require Min. (* multiset intersection *) Definition minter := [m1,m2:multiset] diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 8589f387e1..4fe8f4f6a4 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -31,20 +31,20 @@ Require Export Relations_1. Section Partial_orders. Variable U : Type. - + Definition Carrier := Ensemble U. - + Definition Rel := Relation U. - + Record PO : Type := Definition_of_PO { Carrier_of : Ensemble U; Rel_of : Relation U; PO_cond1 : Inhabited U Carrier_of; PO_cond2 : Order U Rel_of }. Variable p : PO. - + Definition Strict_Rel_of : Rel := fun x y:U => Rel_of p x y /\ x <> y. - + Inductive covers (y x:U) : Prop := Definition_of_covers : Strict_Rel_of x y -> @@ -60,7 +60,7 @@ Hint Resolve Definition_of_covers: sets v62. Section Partial_order_facts. Variable U : Type. Variable D : PO U. - + Lemma Strict_Rel_Transitive_with_Rel : forall x y z:U, Strict_Rel_of U D x y -> Rel_of U D y z -> Strict_Rel_of U D x z. diff --git a/theories/Sets/Permut.v b/theories/Sets/Permut.v index 6c9a064c14..f593031a0f 100644 --- a/theories/Sets/Permut.v +++ b/theories/Sets/Permut.v @@ -36,23 +36,23 @@ Section Axiomatisation. apply cong_left; trivial. apply cong_right; trivial. Qed. - + Lemma comm_right : forall x y z:U, cong (op x (op y z)) (op x (op z y)). Proof. intros; apply cong_right; apply op_comm. Qed. - + Lemma comm_left : forall x y z:U, cong (op (op x y) z) (op (op y x) z). Proof. intros; apply cong_left; apply op_comm. Qed. - + Lemma perm_right : forall x y z:U, cong (op (op x y) z) (op (op x z) y). Proof. intros. apply cong_trans with (op x (op y z)). apply op_ass. - apply cong_trans with (op x (op z y)). + apply cong_trans with (op x (op z y)). apply cong_right; apply op_comm. apply cong_sym; apply op_ass. Qed. @@ -66,7 +66,7 @@ Section Axiomatisation. apply cong_left; apply op_comm. apply op_ass. Qed. - + Lemma op_rotate : forall x y z t:U, cong (op x (op y z)) (op z (op x y)). Proof. intros; apply cong_trans with (op (op x y) z). diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v index 8116045b69..36d2150c3d 100644 --- a/theories/Sets/Powerset_Classical_facts.v +++ b/theories/Sets/Powerset_Classical_facts.v @@ -40,7 +40,7 @@ Require Export Classical_sets. Section Sets_as_an_algebra. Variable U : Type. - + Lemma sincl_add_x : forall (A B:Ensemble U) (x:U), ~ In U A x -> @@ -63,7 +63,7 @@ Section Sets_as_an_algebra. intros X x H'; red in |- *. intros x0 H'0; elim H'0; auto with sets. Qed. - + Lemma incl_soustr : forall (X Y:Ensemble U) (x:U), Included U X Y -> Included U (Subtract U X x) (Subtract U Y x). @@ -73,7 +73,7 @@ Section Sets_as_an_algebra. intros H'1 H'2. apply Subtract_intro; auto with sets. Qed. - + Lemma incl_soustr_add_l : forall (X:Ensemble U) (x:U), Included U (Subtract U (Add U X x) x) X. Proof. @@ -93,7 +93,7 @@ Section Sets_as_an_algebra. red in |- *; intro H'1; apply H'; rewrite H'1; auto with sets. Qed. Hint Resolve incl_soustr_add_r: sets v62. - + Lemma add_soustr_2 : forall (X:Ensemble U) (x:U), In U X x -> Included U X (Add U (Subtract U X x) x). @@ -103,7 +103,7 @@ Section Sets_as_an_algebra. elim (classic (x = x0)); intro K; auto with sets. elim K; auto with sets. Qed. - + Lemma add_soustr_1 : forall (X:Ensemble U) (x:U), In U X x -> Included U (Add U (Subtract U X x) x) X. @@ -114,7 +114,7 @@ Section Sets_as_an_algebra. intros t H'1; try assumption. rewrite <- (Singleton_inv U x t); auto with sets. Qed. - + Lemma add_soustr_xy : forall (X:Ensemble U) (x y:U), x <> y -> Subtract U (Add U X x) y = Add U (Subtract U X y) x. @@ -133,7 +133,7 @@ Section Sets_as_an_algebra. intro H'0; elim H'0; auto with sets. intro H'0; rewrite <- H'0; auto with sets. Qed. - + Lemma incl_st_add_soustr : forall (X Y:Ensemble U) (x:U), ~ In U X x -> @@ -151,13 +151,13 @@ Section Sets_as_an_algebra. red in |- *; intro H'0; apply H'2. rewrite H'0; auto 8 using add_soustr_xy, add_soustr_1, add_soustr_2 with sets. Qed. - + Lemma Sub_Add_new : forall (X:Ensemble U) (x:U), ~ In U X x -> X = Subtract U (Add U X x) x. Proof. auto using incl_soustr_add_l with sets. Qed. - + Lemma Simplify_add : forall (X X0:Ensemble U) (x:U), ~ In U X x -> ~ In U X0 x -> Add U X x = Add U X0 x -> X = X0. @@ -167,7 +167,7 @@ Section Sets_as_an_algebra. rewrite (Sub_Add_new X0 x); auto with sets. rewrite H'1; auto with sets. Qed. - + Lemma Included_Add : forall (X A:Ensemble U) (x:U), Included U X (Add U A x) -> @@ -201,7 +201,7 @@ Section Sets_as_an_algebra. absurd (In U X x0); auto with sets. rewrite <- H'5; auto with sets. Qed. - + Lemma setcover_inv : forall A x y:Ensemble U, covers (Ensemble U) (Power_set_PO U A) y x -> @@ -219,7 +219,7 @@ Section Sets_as_an_algebra. elim H'1. exists z; auto with sets. Qed. - + Theorem Add_covers : forall A a:Ensemble U, Included U a A -> @@ -255,7 +255,7 @@ Section Sets_as_an_algebra. intros x1 H'10; elim H'10; auto with sets. intros x2 H'11; elim H'11; auto with sets. Qed. - + Theorem covers_Add : forall A a a':Ensemble U, Included U a A -> @@ -301,7 +301,7 @@ Section Sets_as_an_algebra. intros x H'1; elim H'1; intros H'2 H'3; rewrite H'2; clear H'1. apply Add_covers; intuition. Qed. - + Theorem Singleton_atomic : forall (x:U) (A:Ensemble U), In U A x -> @@ -311,7 +311,7 @@ Section Sets_as_an_algebra. rewrite <- (Empty_set_zero' U x). apply Add_covers; auto with sets. Qed. - + Lemma less_than_singleton : forall (X:Ensemble U) (x:U), Strict_Included U X (Singleton U x) -> X = Empty_set U. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index dee4af65a2..76f7f1ec89 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -41,34 +41,34 @@ Section Sets_as_an_algebra. Proof. auto 6 with sets. Qed. - + Theorem Empty_set_zero' : forall x:U, Add U (Empty_set U) x = Singleton U x. Proof. unfold Add at 1 in |- *; auto using Empty_set_zero with sets. Qed. - + Lemma less_than_empty : forall X:Ensemble U, Included U X (Empty_set U) -> X = Empty_set U. Proof. auto with sets. Qed. - + Theorem Union_commutative : forall A B:Ensemble U, Union U A B = Union U B A. Proof. auto with sets. Qed. - + Theorem Union_associative : forall A B C:Ensemble U, Union U (Union U A B) C = Union U A (Union U B C). Proof. auto 9 with sets. Qed. - + Theorem Union_idempotent : forall A:Ensemble U, Union U A A = A. Proof. auto 7 with sets. Qed. - + Lemma Union_absorbs : forall A B:Ensemble U, Included U B A -> Union U A B = A. Proof. @@ -82,7 +82,7 @@ Section Sets_as_an_algebra. intros x0 H'; elim H'; (intros x1 H'0; elim H'0; auto with sets). intros x0 H'; elim H'; auto with sets. Qed. - + Theorem Triple_as_union : forall x y z:U, Union U (Union U (Singleton U x) (Singleton U y)) (Singleton U z) = @@ -94,7 +94,7 @@ Section Sets_as_an_algebra. intros x1 H'0; elim H'0; auto with sets. intros x0 H'; elim H'; auto with sets. Qed. - + Theorem Triple_as_Couple : forall x y:U, Couple U x y = Triple U x x y. Proof. intros x y. @@ -102,7 +102,7 @@ Section Sets_as_an_algebra. rewrite <- (Union_idempotent (Singleton U x)). apply Triple_as_union. Qed. - + Theorem Triple_as_Couple_Singleton : forall x y z:U, Triple U x y z = Union U (Couple U x y) (Singleton U z). Proof. @@ -110,7 +110,7 @@ Section Sets_as_an_algebra. rewrite <- (Triple_as_union x y z). rewrite <- (Couple_as_union x y); auto with sets. Qed. - + Theorem Intersection_commutative : forall A B:Ensemble U, Intersection U A B = Intersection U B A. Proof. @@ -118,7 +118,7 @@ Section Sets_as_an_algebra. apply Extensionality_Ensembles. split; red in |- *; intros x H'; elim H'; auto with sets. Qed. - + Theorem Distributivity : forall A B C:Ensemble U, Intersection U A (Union U B C) = @@ -132,7 +132,7 @@ Section Sets_as_an_algebra. elim H'1; auto with sets. elim H'; intros x0 H'0; elim H'0; auto with sets. Qed. - + Theorem Distributivity' : forall A B C:Ensemble U, Union U A (Intersection U B C) = @@ -149,13 +149,13 @@ Section Sets_as_an_algebra. generalize H'1. elim H'2; auto with sets. Qed. - + Theorem Union_add : forall (A B:Ensemble U) (x:U), Add U (Union U A B) x = Union U A (Add U B x). Proof. unfold Add in |- *; auto using Union_associative with sets. Qed. - + Theorem Non_disjoint_union : forall (X:Ensemble U) (x:U), In U X x -> Add U X x = X. Proof. @@ -165,7 +165,7 @@ Section Sets_as_an_algebra. intros x0 H'0; elim H'0; auto with sets. intros t H'1; elim H'1; auto with sets. Qed. - + Theorem Non_disjoint_union' : forall (X:Ensemble U) (x:U), ~ In U X x -> Subtract U X x = X. Proof. @@ -178,12 +178,12 @@ Section Sets_as_an_algebra. lapply (Singleton_inv U x x0); auto with sets. intro H'4; apply H'; rewrite H'4; auto with sets. Qed. - + Lemma singlx : forall x y:U, In U (Add U (Empty_set U) x) y -> x = y. Proof. intro x; rewrite (Empty_set_zero' x); auto with sets. Qed. - + Lemma incl_add : forall (A B:Ensemble U) (x:U), Included U A B -> Included U (Add U A x) (Add U B x). @@ -209,7 +209,7 @@ Section Sets_as_an_algebra. absurd (In U A x0); auto with sets. rewrite <- H'4; auto with sets. Qed. - + Lemma Add_commutative : forall (A:Ensemble U) (x y:U), Add U (Add U A x) y = Add U (Add U A y) x. Proof. @@ -220,7 +220,7 @@ Section Sets_as_an_algebra. rewrite <- (Union_associative A (Singleton U y) (Singleton U x)); auto with sets. Qed. - + Lemma Add_commutative' : forall (A:Ensemble U) (x y z:U), Add U (Add U (Add U A x) y) z = Add U (Add U (Add U A z) x) y. @@ -229,7 +229,7 @@ Section Sets_as_an_algebra. rewrite (Add_commutative (Add U A x) y z). rewrite (Add_commutative A x z); auto with sets. Qed. - + Lemma Add_distributes : forall (A B:Ensemble U) (x y:U), Included U B A -> Add U (Add U A x) y = Union U (Add U A x) (Add U B y). diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v index f15bf19e64..85d0cffccc 100644 --- a/theories/Sets/Relations_1.v +++ b/theories/Sets/Relations_1.v @@ -28,38 +28,38 @@ Section Relations_1. Variable U : Type. - + Definition Relation := U -> U -> Prop. Variable R : Relation. - + Definition Reflexive : Prop := forall x:U, R x x. - + Definition Transitive : Prop := forall x y z:U, R x y -> R y z -> R x z. - + Definition Symmetric : Prop := forall x y:U, R x y -> R y x. - + Definition Antisymmetric : Prop := forall x y:U, R x y -> R y x -> x = y. - + Definition contains (R R':Relation) : Prop := forall x y:U, R' x y -> R x y. - + Definition same_relation (R R':Relation) : Prop := contains R R' /\ contains R' R. - + Inductive Preorder : Prop := Definition_of_preorder : Reflexive -> Transitive -> Preorder. - + Inductive Order : Prop := Definition_of_order : Reflexive -> Transitive -> Antisymmetric -> Order. - + Inductive Equivalence : Prop := Definition_of_equivalence : Reflexive -> Transitive -> Symmetric -> Equivalence. - + Inductive PER : Prop := Definition_of_PER : Symmetric -> Transitive -> PER. - + End Relations_1. Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains same_relation: sets v62. diff --git a/theories/Sets/Relations_2_facts.v b/theories/Sets/Relations_2_facts.v index d5257c12c1..3554901b93 100644 --- a/theories/Sets/Relations_2_facts.v +++ b/theories/Sets/Relations_2_facts.v @@ -140,7 +140,7 @@ intros U R H' x b H'0; elim H'0. intros x0 a H'1; exists a; auto with sets. intros x0 y z H'1 H'2 H'3 a H'4. red in H'. -specialize H' with (x := x0) (a := a) (b := y); lapply H'; +specialize H' with (x := x0) (a := a) (b := y); lapply H'; [ intro H'8; lapply H'8; [ intro H'9; try exact H'9; clear H'8 H' | clear H'8 H' ] | clear H' ]; auto with sets. diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v index ec8fb7e6d2..970db1827b 100644 --- a/theories/Sets/Relations_3.v +++ b/theories/Sets/Relations_3.v @@ -32,26 +32,26 @@ Require Export Relations_2. Section Relations_3. Variable U : Type. Variable R : Relation U. - + Definition coherent (x y:U) : Prop := exists z : _, Rstar U R x z /\ Rstar U R y z. - + Definition locally_confluent (x:U) : Prop := forall y z:U, R x y -> R x z -> coherent y z. - + Definition Locally_confluent : Prop := forall x:U, locally_confluent x. - + Definition confluent (x:U) : Prop := forall y z:U, Rstar U R x y -> Rstar U R x z -> coherent y z. - + Definition Confluent : Prop := forall x:U, confluent x. - + Inductive noetherian (x: U) : Prop := definition_of_noetherian : (forall y:U, R x y -> noetherian y) -> noetherian x. - + Definition Noetherian : Prop := forall x:U, noetherian x. - + End Relations_3. Hint Unfold coherent: sets v62. Hint Unfold locally_confluent: sets v62. diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 03dc55ef9f..909c798380 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -90,10 +90,10 @@ Qed. Definition union (m1 m2:uniset) := Charac (fun a:A => orb (charac m1 a) (charac m2 a)). -Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). -Proof. -unfold seq in |- *; unfold union in |- *; simpl in |- *; auto. -Qed. +Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). +Proof. +unfold seq in |- *; unfold union in |- *; simpl in |- *; auto. +Qed. Hint Resolve union_empty_left. Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset). @@ -203,7 +203,7 @@ apply uniset_twist2. Qed. -(*i theory of minter to do similarly +(*i theory of minter to do similarly Require Min. (* uniset intersection *) Definition minter := [m1,m2:uniset] diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 2d639d0968..6d5564ed75 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -25,7 +25,7 @@ Section defs. Variable eqA : relation A. Let gtA (x y:A) := ~ leA x y. - + Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}. Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y. @@ -37,7 +37,7 @@ Section defs. Let emptyBag := EmptyBag A. Let singletonBag := SingletonBag _ eqA_dec. - + Inductive Tree := | Tree_Leaf : Tree | Tree_Node : A -> Tree -> Tree -> Tree. @@ -92,7 +92,7 @@ Section defs. forall T:Tree, is_heap T -> P T. Proof. simple induction T; auto with datatypes. - intros a G PG D PD PN. + intros a G PG D PD PN. elim (invert_heap a G D); auto with datatypes. intros H1 H2; elim H2; intros H3 H4; elim H4; intros. apply X0; auto with datatypes. @@ -109,7 +109,7 @@ Section defs. forall T:Tree, is_heap T -> P T. Proof. simple induction T; auto with datatypes. - intros a G PG D PD PN. + intros a G PG D PD PN. elim (invert_heap a G D); auto with datatypes. intros H1 H2; elim H2; intros H3 H4; elim H4; intros. apply X; auto with datatypes. @@ -167,15 +167,15 @@ Section defs. elim (X a0); intros. apply insert_exist with (Tree_Node a T2 T0); auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. - simpl in |- *; apply treesort_twist1; trivial with datatypes. + simpl in |- *; apply treesort_twist1; trivial with datatypes. elim (X a); intros T3 HeapT3 ConT3 LeA. - apply insert_exist with (Tree_Node a0 T2 T3); + apply insert_exist with (Tree_Node a0 T2 T3); auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. apply node_is_heap; auto using node_is_heap, nil_is_heap, leA_Tree_Leaf with datatypes. - apply low_trans with a; auto with datatypes. + apply low_trans with a; auto with datatypes. apply LeA; auto with datatypes. apply low_trans with a; auto with datatypes. - simpl in |- *; apply treesort_twist2; trivial with datatypes. + simpl in |- *; apply treesort_twist2; trivial with datatypes. Qed. @@ -186,7 +186,7 @@ Section defs. forall T:Tree, is_heap T -> meq (list_contents _ eqA_dec l) (contents T) -> build_heap l. - + Lemma list_to_heap : forall l:list A, build_heap l. Proof. simple induction l. @@ -204,7 +204,7 @@ Section defs. (** ** Building the sorted list *) - + Inductive flat_spec (T:Tree) : Type := flat_exist : forall l:list A, diff --git a/theories/Sorting/PermutEq.v b/theories/Sorting/PermutEq.v index f7bd37ee26..9bfe31ed1c 100644 --- a/theories/Sorting/PermutEq.v +++ b/theories/Sorting/PermutEq.v @@ -13,22 +13,22 @@ Require Import Omega Relations Setoid List Multiset Permutation. Set Implicit Arguments. (** This file is similar to [PermutSetoid], except that the equality used here - is Coq usual one instead of a setoid equality. In particular, we can then - prove the equivalence between [List.Permutation] and + is Coq usual one instead of a setoid equality. In particular, we can then + prove the equivalence between [List.Permutation] and [Permutation.permutation]. *) Section Perm. - + Variable A : Type. Hypothesis eq_dec : forall x y:A, {x=y} + {~ x=y}. - + Notation permutation := (permutation _ eq_dec). Notation list_contents := (list_contents _ eq_dec). (** we can use [multiplicity] to define [In] and [NoDup]. *) - Lemma multiplicity_In : + Lemma multiplicity_In : forall l a, In a l <-> 0 < multiplicity (list_contents l) a. Proof. induction l. @@ -49,18 +49,18 @@ Section Perm. Lemma multiplicity_In_O : forall l a, ~ In a l -> multiplicity (list_contents l) a = 0. Proof. - intros l a; rewrite multiplicity_In; + intros l a; rewrite multiplicity_In; destruct (multiplicity (list_contents l) a); auto. destruct 1; auto with arith. Qed. - + Lemma multiplicity_In_S : forall l a, In a l -> multiplicity (list_contents l) a >= 1. Proof. intros l a; rewrite multiplicity_In; auto. Qed. - Lemma multiplicity_NoDup : + Lemma multiplicity_NoDup : forall l, NoDup l <-> (forall a, multiplicity (list_contents l) a <= 1). Proof. induction l. @@ -78,7 +78,7 @@ Section Perm. generalize (H a). destruct (eq_dec a a) as [H0|H0]. destruct (multiplicity (list_contents l) a); auto with arith. - simpl; inversion 1. + simpl; inversion 1. inversion H3. destruct H0; auto. rewrite IHl; intros. @@ -86,13 +86,13 @@ Section Perm. destruct (eq_dec a a0); simpl; auto with arith. Qed. - Lemma NoDup_permut : - forall l l', NoDup l -> NoDup l' -> + Lemma NoDup_permut : + forall l l', NoDup l -> NoDup l' -> (forall x, In x l <-> In x l') -> permutation l l'. Proof. intros. red; unfold meq; intros. - rewrite multiplicity_NoDup in H, H0. + rewrite multiplicity_NoDup in H, H0. generalize (H a) (H0 a) (H1 a); clear H H0 H1. do 2 rewrite multiplicity_In. destruct 3; omega. @@ -128,11 +128,11 @@ Section Perm. intro Abs; generalize (permut_In_In _ Abs H). inversion 1. Qed. - - (** When used with [eq], this permutation notion is equivalent to + + (** When used with [eq], this permutation notion is equivalent to the one defined in [List.v]. *) - Lemma permutation_Permutation : + Lemma permutation_Permutation : forall l l', Permutation l l' <-> permutation l l'. Proof. split. @@ -165,7 +165,7 @@ Section Perm. destruct (eq_dec b b) as [H|H]; [ | destruct H; auto]. destruct (eq_dec a b); simpl; auto; intros; discriminate. Qed. - + Lemma permut_length_2 : forall a1 b1 a2 b2, permutation (a1 :: b1 :: nil) (a2 :: b2 :: nil) -> (a1=a2) /\ (b1=b2) \/ (a1=b2) /\ (a2=b1). @@ -177,7 +177,7 @@ Section Perm. apply permut_length_1. red; red; intros. generalize (P a); clear P; simpl. - destruct (eq_dec a1 a) as [H2|H2]; + destruct (eq_dec a1 a) as [H2|H2]; destruct (eq_dec a2 a) as [H3|H3]; auto. destruct H3; transitivity a1; auto. destruct H2; transitivity a2; auto. @@ -187,7 +187,7 @@ Section Perm. apply permut_length_1. red; red; intros. generalize (P a); clear P; simpl. - destruct (eq_dec a1 a) as [H2|H2]; + destruct (eq_dec a1 a) as [H2|H2]; destruct (eq_dec b2 a) as [H3|H3]; auto. simpl; rewrite <- plus_n_Sm; inversion 1; auto. destruct H3; transitivity a1; auto. @@ -210,12 +210,12 @@ Section Perm. Qed. Variable B : Type. - Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }. + Variable eqB_dec : forall x y:B, { x=y }+{ ~x=y }. (** Permutation is compatible with map. *) Lemma permutation_map : - forall f l1 l2, permutation l1 l2 -> + forall f l1 l2, permutation l1 l2 -> Permutation.permutation _ eqB_dec (map f l1) (map f l2). Proof. intros f; induction l1. diff --git a/theories/Sorting/PermutSetoid.v b/theories/Sorting/PermutSetoid.v index 1ea71972b5..803a6143f3 100644 --- a/theories/Sorting/PermutSetoid.v +++ b/theories/Sorting/PermutSetoid.v @@ -12,8 +12,8 @@ Require Import Omega Relations Multiset Permutation SetoidList. Set Implicit Arguments. -(** This file contains additional results about permutations - with respect to a setoid equality (i.e. an equivalence relation). +(** This file contains additional results about permutations + with respect to a setoid equality (i.e. an equivalence relation). *) Section Perm. @@ -33,7 +33,7 @@ Variable eqA_trans : forall x y z, eqA x y -> eqA y z -> eqA x z. (** we can use [multiplicity] to define [InA] and [NoDupA]. *) -Lemma multiplicity_InA : +Lemma multiplicity_InA : forall l a, InA eqA a l <-> 0 < multiplicity (list_contents l) a. Proof. induction l. @@ -54,7 +54,7 @@ Qed. Lemma multiplicity_InA_O : forall l a, ~ InA eqA a l -> multiplicity (list_contents l) a = 0. Proof. - intros l a; rewrite multiplicity_InA; + intros l a; rewrite multiplicity_InA; destruct (multiplicity (list_contents l) a); auto with arith. destruct 1; auto with arith. Qed. @@ -65,7 +65,7 @@ Proof. intros l a; rewrite multiplicity_InA; auto with arith. Qed. -Lemma multiplicity_NoDupA : forall l, +Lemma multiplicity_NoDupA : forall l, NoDupA eqA l <-> (forall a, multiplicity (list_contents l) a <= 1). Proof. induction l. @@ -83,7 +83,7 @@ Proof. generalize (H a). destruct (eqA_dec a a) as [H0|H0]. destruct (multiplicity (list_contents l) a); auto with arith. - simpl; inversion 1. + simpl; inversion 1. inversion H3. destruct H0; auto. rewrite IHl; intros. @@ -140,7 +140,7 @@ Proof. apply permut_length_1. red; red; intros. generalize (P a); clear P; simpl. - destruct (eqA_dec a1 a) as [H2|H2]; + destruct (eqA_dec a1 a) as [H2|H2]; destruct (eqA_dec a2 a) as [H3|H3]; auto. destruct H3; apply eqA_trans with a1; auto. destruct H2; apply eqA_trans with a2; auto. @@ -150,7 +150,7 @@ Proof. apply permut_length_1. red; red; intros. generalize (P a); clear P; simpl. - destruct (eqA_dec a1 a) as [H2|H2]; + destruct (eqA_dec a1 a) as [H2|H2]; destruct (eqA_dec b2 a) as [H3|H3]; auto. simpl; rewrite <- plus_n_Sm; inversion 1; auto. destruct H3; apply eqA_trans with a1; auto. @@ -174,19 +174,19 @@ Proof. apply permut_tran with (a::l1); auto. revert H1; unfold Permutation.permutation, meq; simpl. intros; f_equal; auto. - destruct (eqA_dec b a0) as [H2|H2]; + destruct (eqA_dec b a0) as [H2|H2]; destruct (eqA_dec a a0) as [H3|H3]; auto. destruct H3; apply eqA_trans with b; auto. destruct H2; apply eqA_trans with a; auto. Qed. -Lemma NoDupA_equivlistA_permut : - forall l l', NoDupA eqA l -> NoDupA eqA l' -> +Lemma NoDupA_equivlistA_permut : + forall l l', NoDupA eqA l -> NoDupA eqA l' -> equivlistA eqA l l' -> permutation l l'. Proof. intros. red; unfold meq; intros. - rewrite multiplicity_NoDupA in H, H0. + rewrite multiplicity_NoDupA in H, H0. generalize (H a) (H0 a) (H1 a); clear H H0 H1. do 2 rewrite multiplicity_InA. destruct 3; omega. @@ -195,15 +195,15 @@ Qed. Variable B : Type. Variable eqB : B->B->Prop. -Variable eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. +Variable eqB_dec : forall x y:B, { eqB x y }+{ ~eqB x y }. Variable eqB_trans : forall x y z, eqB x y -> eqB y z -> eqB x z. (** Permutation is compatible with map. *) Lemma permut_map : - forall f, + forall f, (forall x y, eqA x y -> eqB (f x) (f y)) -> - forall l1 l2, permutation l1 l2 -> + forall l1 l2, permutation l1 l2 -> Permutation.permutation _ eqB_dec (map f l1) (map f l2). Proof. intros f; induction l1. @@ -218,7 +218,7 @@ Proof. apply permut_tran with (f b :: map f l1). revert H1; unfold Permutation.permutation, meq; simpl. intros; f_equal; auto. - destruct (eqB_dec (f b) a0) as [H2|H2]; + destruct (eqB_dec (f b) a0) as [H2|H2]; destruct (eqB_dec (f a) a0) as [H3|H3]; auto. destruct H3; apply eqB_trans with (f b); auto. destruct H2; apply eqB_trans with (f a); auto. @@ -229,7 +229,7 @@ Proof. apply permut_tran with (a::l1); auto. revert H1; unfold Permutation.permutation, meq; simpl. intros; f_equal; auto. - destruct (eqA_dec b a0) as [H2|H2]; + destruct (eqA_dec b a0) as [H2|H2]; destruct (eqA_dec a a0) as [H3|H3]; auto. destruct H3; apply eqA_trans with b; auto. destruct H2; apply eqA_trans with a; auto. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index a922120545..9daf71b2bf 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -10,9 +10,9 @@ Require Import Relations List Multiset Arith. -(** This file define a notion of permutation for lists, based on multisets: - there exists a permutation between two lists iff every elements have - the same multiplicity in the two lists. +(** This file define a notion of permutation for lists, based on multisets: + there exists a permutation between two lists iff every elements have + the same multiplicity in the two lists. Unlike [List.Permutation], the present notion of permutation requires the domain to be equipped with a decidable equality. This @@ -22,10 +22,10 @@ Require Import Relations List Multiset Arith. The present file contains basic results, obtained without any particular assumption on the decidable equality used. - File [PermutSetoid] contains additional results about permutations - with respect to an setoid equality (i.e. an equivalence relation). + File [PermutSetoid] contains additional results about permutations + with respect to an setoid equality (i.e. an equivalence relation). - Finally, file [PermutEq] concerns Coq equality : this file is similar + Finally, file [PermutEq] concerns Coq equality : this file is similar to the previous one, but proves in addition that [List.Permutation] and [permutation] are equivalent in this context. *) @@ -62,9 +62,9 @@ Section defs. auto with datatypes. Qed. - + (** * [permutation]: definition and basic properties *) - + Definition permutation (l m:list A) := meq (list_contents l) (list_contents m). @@ -72,42 +72,42 @@ Section defs. Proof. unfold permutation in |- *; auto with datatypes. Qed. - + Lemma permut_sym : forall l1 l2 : list A, permutation l1 l2 -> permutation l2 l1. Proof. unfold permutation, meq; intros; apply sym_eq; trivial. Qed. - + Lemma permut_tran : forall l m n:list A, permutation l m -> permutation m n -> permutation l n. Proof. unfold permutation in |- *; intros. apply meq_trans with (list_contents m); auto with datatypes. Qed. - + Lemma permut_cons : forall l m:list A, permutation l m -> forall a:A, permutation (a :: l) (a :: m). Proof. unfold permutation in |- *; simpl in |- *; auto with datatypes. Qed. - + Lemma permut_app : forall l l' m m':list A, permutation l l' -> permutation m m' -> permutation (l ++ m) (l' ++ m'). Proof. unfold permutation in |- *; intros. - apply meq_trans with (munion (list_contents l) (list_contents m)); + apply meq_trans with (munion (list_contents l) (list_contents m)); auto using permut_cons, list_contents_app with datatypes. - apply meq_trans with (munion (list_contents l') (list_contents m')); + apply meq_trans with (munion (list_contents l') (list_contents m')); auto using permut_cons, list_contents_app with datatypes. apply meq_trans with (munion (list_contents l') (list_contents m)); auto using permut_cons, list_contents_app with datatypes. Qed. Lemma permut_add_inside : - forall a l1 l2 l3 l4, + forall a l1 l2 l3 l4, permutation (l1 ++ l2) (l3 ++ l4) -> permutation (l1 ++ a :: l2) (l3 ++ a :: l4). Proof. @@ -118,9 +118,9 @@ Section defs. destruct (eqA_dec a a0); simpl; auto with arith. do 2 rewrite <- plus_n_Sm; f_equal; auto. Qed. - + Lemma permut_add_cons_inside : - forall a l l1 l2, + forall a l l1 l2, permutation l (l1 ++ l2) -> permutation (a :: l) (l1 ++ a :: l2). Proof. @@ -134,17 +134,17 @@ Section defs. Proof. intros; apply permut_add_cons_inside; auto using permut_sym, permut_refl. Qed. - + Lemma permut_sym_app : forall l1 l2, permutation (l1 ++ l2) (l2 ++ l1). Proof. intros l1 l2; - unfold permutation, meq; - intro a; do 2 rewrite list_contents_app; simpl; + unfold permutation, meq; + intro a; do 2 rewrite list_contents_app; simpl; auto with arith. Qed. - Lemma permut_rev : + Lemma permut_rev : forall l, permutation l (rev l). Proof. induction l. @@ -162,7 +162,7 @@ Section defs. generalize (H a); apply plus_reg_l. Qed. - Lemma permut_app_inv1 : + Lemma permut_app_inv1 : forall l l1 l2, permutation (l1 ++ l) (l2 ++ l) -> permutation l1 l2. Proof. intros l l1 l2; unfold permutation, meq; simpl; @@ -174,7 +174,7 @@ Section defs. trivial. Qed. - Lemma permut_app_inv2 : + Lemma permut_app_inv2 : forall l l1 l2, permutation (l ++ l1) (l ++ l2) -> permutation l1 l2. Proof. intros l l1 l2; unfold permutation, meq; simpl; @@ -186,7 +186,7 @@ Section defs. Qed. Lemma permut_remove_hd : - forall l l1 l2 a, + forall l l1 l2 a, permutation (a :: l) (l1 ++ a :: l2) -> permutation l (l1 ++ l2). Proof. intros l l1 l2 a; unfold permutation, meq; simpl; intros H a0; generalize (H a0); clear H. @@ -200,6 +200,6 @@ Section defs. End defs. -(** For compatibilty *) +(** For compatibilty *) Notation permut_right := permut_cons. Unset Implicit Arguments. diff --git a/theories/Sorting/Sorting.v b/theories/Sorting/Sorting.v index 4c81731720..2d76b25a20 100644 --- a/theories/Sorting/Sorting.v +++ b/theories/Sorting/Sorting.v @@ -19,7 +19,7 @@ Section defs. Variable eqA : relation A. Let gtA (x y:A) := ~ leA x y. - + Hypothesis leA_dec : forall x y:A, {leA x y} + {leA y x}. Hypothesis eqA_dec : forall x y:A, {eqA x y} + {~ eqA x y}. Hypothesis leA_refl : forall x y:A, eqA x y -> leA x y. @@ -112,7 +112,7 @@ Section defs. (* 2 (leA a0 a) *) elim X0; simpl in |- *; intros. - apply merge_exist with (a0 :: l3); simpl in |- *; + apply merge_exist with (a0 :: l3); simpl in |- *; auto using cons_sort, cons_leA with datatypes. apply meq_trans with (munion (singletonBag a0) diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 5a2cc96957..6d3dc02a92 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -18,26 +18,26 @@ Declare ML Module "ascii_syntax_plugin". (** * Definition of ascii characters *) (** Definition of ascii character as a 8 bits constructor *) - + Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool). Delimit Scope char_scope with char. Bind Scope char_scope with ascii. - + Definition zero := Ascii false false false false false false false false. - + Definition one := Ascii true false false false false false false false. - + Definition app1 (f : bool -> bool) (a : ascii) := match a with | Ascii a1 a2 a3 a4 a5 a6 a7 a8 => Ascii (f a1) (f a2) (f a3) (f a4) (f a5) (f a6) (f a7) (f a8) end. - + Definition app2 (f : bool -> bool -> bool) (a b : ascii) := match a, b with | Ascii a1 a2 a3 a4 a5 a6 a7 a8, Ascii b1 b2 b3 b4 b5 b6 b7 b8 => - Ascii (f a1 b1) (f a2 b2) (f a3 b3) (f a4 b4) + Ascii (f a1 b1) (f a2 b2) (f a3 b3) (f a4 b4) (f a5 b5) (f a6 b6) (f a7 b7) (f a8 b8) end. @@ -47,7 +47,7 @@ Definition shift (c : bool) (a : ascii) := end. (** Definition of a decidable function that is effective *) - + Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}. decide equality; apply bool_dec. Defined. @@ -57,7 +57,7 @@ Defined. (** Auxillary function that turns a positive into an ascii by looking at the last n bits, ie z mod 2^n *) -Fixpoint ascii_of_pos_aux (res acc : ascii) (z : positive) +Fixpoint ascii_of_pos_aux (res acc : ascii) (z : positive) (n : nat) {struct n} : ascii := match n with | O => res @@ -72,7 +72,7 @@ Fixpoint ascii_of_pos_aux (res acc : ascii) (z : positive) (** Function that turns a positive into an ascii by looking at the last 8 bits, ie a mod 8 *) - + Definition ascii_of_pos (a : positive) := ascii_of_pos_aux zero one a 8. (** Function that turns a Peano number into an ascii by converting it @@ -83,7 +83,7 @@ Definition ascii_of_nat (a : nat) := | O => zero | S a' => ascii_of_pos (P_of_succ_nat a') end. - + (** The opposite function *) Definition nat_of_ascii (a : ascii) : nat := @@ -103,7 +103,7 @@ Definition nat_of_ascii (a : ascii) : nat := + (if a2 then 1 else 0)) + (if a1 then 1 else 0). -Theorem ascii_nat_embedding : +Theorem ascii_nat_embedding : forall a : ascii, ascii_of_nat (nat_of_ascii a) = a. Proof. destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity. @@ -124,7 +124,7 @@ Qed. Notice that the ascii characters of code >= 128 do not denote stand-alone utf8 characters so that only the notation "nnn" is available for them (unless your terminal is able to represent them, - which is typically not the case in coqide). + which is typically not the case in coqide). *) Open Local Scope char_scope. diff --git a/theories/Strings/String.v b/theories/Strings/String.v index 7d6696b782..82a60c189d 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -18,7 +18,7 @@ Declare ML Module "string_syntax_plugin". (** *** Definition of strings *) (** Implementation of string as list of ascii characters *) - + Inductive string : Set := | EmptyString : string | String : ascii -> string -> string. @@ -48,7 +48,7 @@ where "s1 ++ s2" := (append s1 s2) : string_scope. (******************************) (** Length *) (******************************) - + Fixpoint length (s : string) : nat := match s with | EmptyString => 0 @@ -58,7 +58,7 @@ Fixpoint length (s : string) : nat := (******************************) (** Nth character of a string *) (******************************) - + Fixpoint get (n : nat) (s : string) {struct s} : option ascii := match s with | EmptyString => None @@ -69,7 +69,7 @@ Fixpoint get (n : nat) (s : string) {struct s} : option ascii := end. (** Two lists that are identical through get are syntactically equal *) - + Theorem get_correct : forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2. Proof. @@ -90,7 +90,7 @@ rewrite H1; auto. Qed. (** The first elements of [s1 ++ s2] are the ones of [s1] *) - + Theorem append_correct1 : forall (s1 s2 : string) (n : nat), n < length s1 -> get n s1 = get n (s1 ++ s2). @@ -103,7 +103,7 @@ apply lt_S_n; auto. Qed. (** The last elements of [s1 ++ s2] are the ones of [s2] *) - + Theorem append_correct2 : forall (s1 s2 : string) (n : nat), get n s2 = get (n + length s1) (s1 ++ s2). @@ -120,7 +120,7 @@ Qed. (** [substring n m s] returns the substring of [s] that starts at position [n] and of length [m]; if this does not make sense it returns [""] *) - + Fixpoint substring (n m : nat) (s : string) {struct s} : string := match n, m, s with | 0, 0, _ => EmptyString @@ -131,7 +131,7 @@ Fixpoint substring (n m : nat) (s : string) {struct s} : string := end. (** The substring is included in the initial string *) - + Theorem substring_correct1 : forall (s : string) (n m p : nat), p < m -> get p (substring n m s) = get (p + n) s. @@ -149,7 +149,7 @@ intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto. Qed. (** The substring has at most [m] elements *) - + Theorem substring_correct2 : forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None. Proof. @@ -167,7 +167,7 @@ Qed. (** *** Test functions *) (** Test if [s1] is a prefix of [s2] *) - + Fixpoint prefix (s1 s2 : string) {struct s2} : bool := match s1 with | EmptyString => true @@ -184,7 +184,7 @@ Fixpoint prefix (s1 s2 : string) {struct s2} : bool := (** If [s1] is a prefix of [s2], it is the [substring] of length [length s1] starting at position [O] of [s2] *) - + Theorem prefix_correct : forall s1 s2 : string, prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1. @@ -203,7 +203,7 @@ Qed. (** Test if, starting at position [n], [s1] occurs in [s2]; if so it returns the position *) - + Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat := match s2, n with | EmptyString, 0 => @@ -212,7 +212,7 @@ Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat := | String a s1' => None end | EmptyString, S n' => None - | String b s2', 0 => + | String b s2', 0 => if prefix s1 s2 then Some 0 else match index 0 s1 s2' with @@ -230,7 +230,7 @@ Fixpoint index (n : nat) (s1 s2 : string) {struct s2} : option nat := Opaque prefix. (** If the result of [index] is [Some m], [s1] in [s2] at position [m] *) - + Theorem index_correct1 : forall (n m : nat) (s1 s2 : string), index n s1 s2 = Some m -> substring m (length s1) s2 = s1. @@ -260,9 +260,9 @@ intros x H H1; apply H; injection H1; intros H2; injection H2; auto. intros; discriminate. Qed. -(** If the result of [index] is [Some m], +(** If the result of [index] is [Some m], [s1] does not occur in [s2] before [m] *) - + Theorem index_correct2 : forall (n m : nat) (s1 s2 : string), index n s1 s2 = Some m -> @@ -305,9 +305,9 @@ apply Lt.lt_S_n; auto. intros; discriminate. Qed. -(** If the result of [index] is [None], [s1] does not occur in [s2] +(** If the result of [index] is [None], [s1] does not occur in [s2] after [n] *) - + Theorem index_correct3 : forall (n m : nat) (s1 s2 : string), index n s1 s2 = None -> @@ -349,7 +349,7 @@ Transparent prefix. (** If we are searching for the [Empty] string and the answer is no this means that [n] is greater than the size of [s] *) - + Theorem index_correct4 : forall (n : nat) (s : string), index n EmptyString s = None -> length s < n. @@ -368,7 +368,7 @@ Qed. (** Same as [index] but with no optional type, we return [0] when it does not occur *) - + Definition findex n s1 s2 := match index n s1 s2 with | Some n => n diff --git a/theories/Unicode/Utf8.v b/theories/Unicode/Utf8.v index 6b6a55d996..940cec9bd3 100644 --- a/theories/Unicode/Utf8.v +++ b/theories/Unicode/Utf8.v @@ -19,11 +19,11 @@ Notation "∀ x y z u , P" := (forall x y z u , P) : type_scope. Notation "∀ x : t , P" := (forall x : t , P) (at level 200, x ident, right associativity) : type_scope. -Notation "∀ x y : t , P" := (forall x y : t , P) +Notation "∀ x y : t , P" := (forall x y : t , P) (at level 200, x ident, y ident, right associativity) : type_scope. Notation "∀ x y z : t , P" := (forall x y z : t , P) (at level 200, x ident, y ident, z ident, right associativity) : type_scope. -Notation "∀ x y z u : t , P" := (forall x y z u : t , P) +Notation "∀ x y z u : t , P" := (forall x y z u : t , P) (at level 200, x ident, y ident, z ident, u ident, right associativity) : type_scope. diff --git a/theories/Wellfounded/Disjoint_Union.v b/theories/Wellfounded/Disjoint_Union.v index f6ce84f986..785d623b46 100644 --- a/theories/Wellfounded/Disjoint_Union.v +++ b/theories/Wellfounded/Disjoint_Union.v @@ -9,8 +9,8 @@ (*i $Id$ i*) (** Author: Cristina Cornes - From : Constructing Recursion Operators in Type Theory - L. Paulson JSC (1986) 2, 325-355 *) + From : Constructing Recursion Operators in Type Theory + L. Paulson JSC (1986) 2, 325-355 *) Require Import Relation_Operators. @@ -20,7 +20,7 @@ Section Wf_Disjoint_Union. Variable leB : B -> B -> Prop. Notation Le_AsB := (le_AsB A B leA leB). - + Lemma acc_A_sum : forall x:A, Acc leA x -> Acc Le_AsB (inl B x). Proof. induction 1. @@ -47,7 +47,7 @@ Section Wf_Disjoint_Union. destruct a as [a| b]. apply (acc_A_sum a). apply (H a). - + apply (acc_B_sum H b). apply (H0 b). Qed. diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v index e72b1e11d6..01049989e3 100644 --- a/theories/Wellfounded/Inclusion.v +++ b/theories/Wellfounded/Inclusion.v @@ -21,7 +21,7 @@ Section WfInclusion. induction 2. apply Acc_intro; auto with sets. Qed. - + Hint Resolve Acc_incl. Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1. diff --git a/theories/Wellfounded/Inverse_Image.v b/theories/Wellfounded/Inverse_Image.v index df6a61198a..c57e707259 100644 --- a/theories/Wellfounded/Inverse_Image.v +++ b/theories/Wellfounded/Inverse_Image.v @@ -47,8 +47,8 @@ Section Inverse_Image. destruct H3. apply (IHAcc x1); auto. Qed. - - + + Theorem wf_inverse_rel : well_founded R -> well_founded RoF. Proof. red in |- *; constructor; intros. diff --git a/theories/Wellfounded/Lexicographic_Exponentiation.v b/theories/Wellfounded/Lexicographic_Exponentiation.v index 69421255d7..ff18890005 100644 --- a/theories/Wellfounded/Lexicographic_Exponentiation.v +++ b/theories/Wellfounded/Lexicographic_Exponentiation.v @@ -10,7 +10,7 @@ (** Author: Cristina Cornes - From : Constructing Recursion Operators in Type Theory + From : Constructing Recursion Operators in Type Theory L. Paulson JSC (1986) 2, 325-355 *) Require Import List. @@ -20,12 +20,12 @@ Require Import Transitive_Closure. Section Wf_Lexicographic_Exponentiation. Variable A : Set. Variable leA : A -> A -> Prop. - + Notation Power := (Pow A leA). Notation Lex_Exp := (lex_exp A leA). Notation ltl := (Ltl A leA). Notation Descl := (Desc A leA). - + Notation List := (list A). Notation Nil := (nil (A:=A)). (* useless but symmetric *) @@ -33,13 +33,13 @@ Section Wf_Lexicographic_Exponentiation. Notation "<< x , y >>" := (exist Descl x y) (at level 0, x, y at level 100). (* Hint Resolve d_one d_nil t_step. *) - + Lemma left_prefix : forall x y z:List, ltl (x ++ y) z -> ltl x z. Proof. simple induction x. simple induction z. simpl in |- *; intros H. - inversion_clear H. + inversion_clear H. simpl in |- *; intros; apply (Lt_nil A leA). intros a l HInd. simpl in |- *. @@ -71,12 +71,12 @@ Section Wf_Lexicographic_Exponentiation. rewrite H8. right; exists x2; auto with sets. Qed. - + Lemma desc_prefix : forall (x:List) (a:A), Descl (x ++ Cons a Nil) -> Descl x. Proof. intros. inversion H. - generalize (app_cons_not_nil _ _ _ H1); simple induction 1. + generalize (app_cons_not_nil _ _ _ H1); simple induction 1. cut (x ++ Cons a Nil = Cons x0 Nil); auto with sets. intro. generalize (app_eq_unit _ _ H0). @@ -87,7 +87,7 @@ Section Wf_Lexicographic_Exponentiation. simple induction 1; intros. rewrite <- H4; auto with sets. Qed. - + Lemma desc_tail : forall (x:List) (a b:A), Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b. @@ -99,7 +99,7 @@ Section Wf_Lexicographic_Exponentiation. forall a b:A, Descl (Cons b (x ++ Cons a Nil)) -> clos_trans A leA a b). intros. - + inversion H. cut (Cons b (Cons a Nil) = (Nil ++ Cons b Nil) ++ Cons a Nil); auto with sets; intro. @@ -108,17 +108,17 @@ Section Wf_Lexicographic_Exponentiation. generalize (app_inj_tail (l ++ Cons y Nil) (Nil ++ Cons b Nil) _ _ H4); simple induction 1. intros. - + generalize (app_inj_tail _ _ _ _ H6); simple induction 1; intros. generalize H1. rewrite <- H10; rewrite <- H7; intro. apply (t_step A leA); auto with sets. - + intros. inversion H0. generalize (app_cons_not_nil _ _ _ H3); intro. elim H1. - + generalize H0. generalize (app_comm_cons (l ++ Cons x0 Nil) (Cons a Nil) b); simple induction 1. @@ -127,11 +127,11 @@ Section Wf_Lexicographic_Exponentiation. generalize (H x0 b H6). intro. apply t_trans with (A := A) (y := x0); auto with sets. - + apply t_step. generalize H1. rewrite H4; intro. - + generalize (app_inj_tail _ _ _ _ H8); simple induction 1. intros. generalize H2; generalize (app_comm_cons l (Cons x0 Nil) b). @@ -154,7 +154,7 @@ Section Wf_Lexicographic_Exponentiation. generalize (app_eq_nil _ _ H0); simple induction 1. intros. rewrite H2; rewrite H3; split; apply d_nil. - + intros. cut (x0 ++ y = Cons x Nil); auto with sets. intros E. @@ -162,15 +162,15 @@ Section Wf_Lexicographic_Exponentiation. simple induction 1; intros. rewrite H2; rewrite H3; split. apply d_nil. - + apply d_one. - + simple induction 1; intros. rewrite H2; rewrite H3; split. apply d_one. - + apply d_nil. - + do 5 intro. intros Hind. do 2 intro. @@ -181,13 +181,13 @@ Section Wf_Lexicographic_Exponentiation. forall x0:List, (l ++ Cons y Nil) ++ Cons x Nil = x0 ++ y0 -> Descl x0 /\ Descl y0). - + intro. generalize (app_nil_end x1); simple induction 1; simple induction 1. split. apply d_conc; auto with sets. - + apply d_nil. - + do 3 intro. generalize x1. apply rev_ind with @@ -202,7 +202,7 @@ Section Wf_Lexicographic_Exponentiation. split. generalize (app_inj_tail _ _ _ _ H2); simple induction 1. simple induction 1; auto with sets. - + apply d_one. do 5 intro. generalize (app_ass x4 (l1 ++ Cons x2 Nil) (Cons x3 Nil)). @@ -219,7 +219,7 @@ Section Wf_Lexicographic_Exponentiation. generalize (Hind x4 (l1 ++ Cons x2 Nil) H11). simple induction 1; split. auto with sets. - + generalize H14. rewrite <- H10; intro. apply d_conc; auto with sets. @@ -233,11 +233,11 @@ Section Wf_Lexicographic_Exponentiation. intros. apply (dist_aux (x ++ y) H x y); auto with sets. Qed. - + Lemma desc_end : forall (a b:A) (x:List), Descl (x ++ Cons a Nil) /\ ltl (x ++ Cons a Nil) (Cons b Nil) -> - clos_trans A leA a b. + clos_trans A leA a b. Proof. intros a b x. case x. @@ -246,14 +246,14 @@ Section Wf_Lexicographic_Exponentiation. intros. inversion H1; auto with sets. inversion H3. - + simple induction 1. generalize (app_comm_cons l (Cons a Nil) a0). intros E; rewrite <- E; intros. generalize (desc_tail l a a0 H0); intro. inversion H1. apply t_trans with (y := a0); auto with sets. - + inversion H4. Qed. @@ -268,15 +268,15 @@ Section Wf_Lexicographic_Exponentiation. intro. case x. intros; apply (Lt_nil A leA). - + simpl in |- *; intros. inversion_clear H0. apply (Lt_hd A leA a b); auto with sets. - + inversion_clear H1. Qed. - - + + Lemma acc_app : forall (x1 x2:List) (y1:Descl (x1 ++ x2)), Acc Lex_Exp << x1 ++ x2, y1 >> -> @@ -285,11 +285,11 @@ Section Wf_Lexicographic_Exponentiation. intros. apply (Acc_inv (R:=Lex_Exp) (x:=<< x1 ++ x2, y1 >>)). auto with sets. - + unfold lex_exp in |- *; simpl in |- *; auto with sets. Qed. - - + + Theorem wf_lex_exp : well_founded leA -> well_founded Lex_Exp. Proof. unfold well_founded at 2 in |- *. @@ -303,7 +303,7 @@ Section Wf_Lexicographic_Exponentiation. forall (x0:List) (y:Descl x0), ltl x0 x -> Acc Lex_Exp << x0, y >>). intros. inversion_clear H0. - + intro. generalize (well_founded_ind (wf_clos_trans A leA H)). intros GR. @@ -318,7 +318,7 @@ Section Wf_Lexicographic_Exponentiation. generalize (right_prefix x2 l (Cons x1 Nil) H1). simple induction 1. intro; apply (H0 x2 y1 H3). - + simple induction 1. intro; simple induction 1. clear H4 H2. @@ -340,8 +340,8 @@ Section Wf_Lexicographic_Exponentiation. unfold lex_exp at 1 in |- *. simpl in |- *; intros x4 y3. intros. apply (H0 x4 y3); auto with sets. - - intros. + + intros. generalize (dist_Desc_concat l (l0 ++ Cons x4 Nil) y1). simple induction 1. intros. diff --git a/theories/Wellfounded/Lexicographic_Product.v b/theories/Wellfounded/Lexicographic_Product.v index f41b6e93d0..5144c0bee7 100644 --- a/theories/Wellfounded/Lexicographic_Product.v +++ b/theories/Wellfounded/Lexicographic_Product.v @@ -14,7 +14,7 @@ Require Import Eqdep. Require Import Relation_Operators. Require Import Transitive_Closure. -(** From : Constructing Recursion Operators in Type Theory +(** From : Constructing Recursion Operators in Type Theory L. Paulson JSC (1986) 2, 325-355 *) Section WfLexicographic_Product. @@ -24,7 +24,7 @@ Section WfLexicographic_Product. Variable leB : forall x:A, B x -> B x -> Prop. Notation LexProd := (lexprod A B leA leB). - + Lemma acc_A_B_lexprod : forall x:A, Acc leA x -> @@ -41,16 +41,16 @@ Section WfLexicographic_Product. intros. apply H2. apply t_trans with x2; auto with sets. - + red in H2. apply H2. auto with sets. - + injection H1. destruct 2. injection H3. destruct 2; auto with sets. - + rewrite <- H1. injection H3; intros _ Hx1. subst x1. @@ -105,7 +105,7 @@ End Wf_Symmetric_Product. Section Swap. - + Variable A : Type. Variable R : A -> A -> Prop. @@ -121,13 +121,13 @@ Section Swap. inversion_clear H; inversion_clear H1; apply H0. apply sp_swap. apply right_sym; auto with sets. - + apply sp_swap. apply left_sym; auto with sets. - + apply sp_noswap. apply right_sym; auto with sets. - + apply sp_noswap. apply left_sym; auto with sets. Qed. @@ -147,20 +147,20 @@ Section Swap. destruct y; intro H5. inversion_clear H5. inversion_clear H0; auto with sets. - + apply swap_Acc. inversion_clear H0; auto with sets. - + intros. apply IHAcc1; auto with sets; intros. apply Acc_inv with (y0, x1); auto with sets. apply sp_noswap. apply right_sym; auto with sets. - + auto with sets. Qed. - + Lemma wf_swapprod : well_founded R -> well_founded SwapProd. Proof. red in |- *. diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v index 5e33da5ff7..bce32af486 100644 --- a/theories/Wellfounded/Transitive_Closure.v +++ b/theories/Wellfounded/Transitive_Closure.v @@ -18,7 +18,7 @@ Section Wf_Transitive_Closure. Variable R : relation A. Notation trans_clos := (clos_trans A R). - + Lemma incl_clos_trans : inclusion A R trans_clos. red in |- *; auto with sets. Qed. diff --git a/theories/Wellfounded/Union.v b/theories/Wellfounded/Union.v index ebf4ba98e5..fbb3d9e3c9 100644 --- a/theories/Wellfounded/Union.v +++ b/theories/Wellfounded/Union.v @@ -17,9 +17,9 @@ Require Import Transitive_Closure. Section WfUnion. Variable A : Type. Variables R1 R2 : relation A. - + Notation Union := (union A R1 R2). - + Remark strip_commut : commut A R1 R2 -> forall x y:A, @@ -29,7 +29,7 @@ Section WfUnion. induction 2 as [x y| x y z H0 IH1 H1 IH2]; intros. elim H with y x z; auto with sets; intros x0 H2 H3. exists x0; auto with sets. - + elim IH1 with z0; auto with sets; intros. elim IH2 with x0; auto with sets; intros. exists x1; auto with sets. @@ -50,7 +50,7 @@ Section WfUnion. elim H8; intros. apply H6; auto with sets. apply t_trans with x0; auto with sets. - + elim strip_commut with x x0 y0; auto with sets; intros. apply Acc_inv_trans with x1; auto with sets. unfold union in |- *. @@ -63,7 +63,7 @@ Section WfUnion. apply Acc_intro; auto with sets. Qed. - + Theorem wf_union : commut A R1 R2 -> well_founded R1 -> well_founded R2 -> well_founded Union. Proof. diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index 7296897ef3..e11b892484 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -16,15 +16,15 @@ Require Import Eqdep. Section WellOrdering. Variable A : Type. - Variable B : A -> Type. - + Variable B : A -> Type. + Inductive WO : Type := sup : forall (a:A) (f:B a -> WO), WO. Inductive le_WO : WO -> WO -> Prop := le_sup : forall (a:A) (f:B a -> WO) (v:B a), le_WO (f v) (sup a f). - + Theorem wf_WO : well_founded le_WO. Proof. unfold well_founded in |- *; intro. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index a0bf8e3f84..b8301d0f4e 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -336,8 +336,8 @@ Proof. rewrite nat_of_P_gt_Gt_compare_complement_morphism; [ discriminate | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0); - elim (ZL4 x); intros k E2; rewrite E2; - simpl in |- *; unfold gt, lt in |- *; + elim (ZL4 x); intros k E2; rewrite E2; + simpl in |- *; unfold gt, lt in |- *; apply le_n_S; apply le_plus_r ] | assumption ] | absurd ((x + y ?= z)%positive Eq = Lt); @@ -345,8 +345,8 @@ Proof. rewrite nat_of_P_gt_Gt_compare_complement_morphism; [ discriminate | rewrite nat_of_P_plus_morphism; rewrite (Pcompare_Eq_eq y z E0); - elim (ZL4 x); intros k E2; rewrite E2; - simpl in |- *; unfold gt, lt in |- *; + elim (ZL4 x); intros k E2; rewrite E2; + simpl in |- *; unfold gt, lt in |- *; apply le_n_S; apply le_plus_r ] | assumption ] | rewrite (Pcompare_Eq_eq y z E0); @@ -377,7 +377,7 @@ Proof. [ intros i H5; elim H5; intros H6 H7; elim H7; intros H8 H9; elim (Pminus_mask_Gt z (x + y)); [ intros j H10; elim H10; intros H11 H12; elim H12; - intros H13 H14; unfold Pminus in |- *; + intros H13 H14; unfold Pminus in |- *; rewrite H6; rewrite H11; cut (i = j); [ intros E; rewrite E; auto with arith | apply (Pplus_reg_l (x + y)); rewrite H13; @@ -388,7 +388,7 @@ Proof. | apply nat_of_P_lt_Lt_compare_complement_morphism; apply plus_lt_reg_l with (p := nat_of_P y); do 2 rewrite <- nat_of_P_plus_morphism; - apply nat_of_P_lt_Lt_compare_morphism; + apply nat_of_P_lt_Lt_compare_morphism; rewrite H3; rewrite Pplus_comm; assumption ] | apply ZC2; assumption ] | elim (Pminus_mask_Gt z y); @@ -399,22 +399,22 @@ Proof. unfold Pminus in |- *; rewrite H1; rewrite H6; cut ((x ?= k)%positive Eq = Gt); [ intros H10; elim (Pminus_mask_Gt x k H10); intros j H11; - elim H11; intros H12 H13; elim H13; - intros H14 H15; rewrite H10; rewrite H12; + elim H11; intros H12 H13; elim H13; + intros H14 H15; rewrite H10; rewrite H12; cut (i = j); [ intros H16; rewrite H16; auto with arith | apply (Pplus_reg_l (z + k)); rewrite <- (Pplus_assoc z k j); rewrite H14; rewrite (Pplus_comm z k); rewrite <- Pplus_assoc; rewrite H8; rewrite (Pplus_comm x y); rewrite Pplus_assoc; - rewrite (Pplus_comm k y); rewrite H3; + rewrite (Pplus_comm k y); rewrite H3; trivial with arith ] | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold lt, gt in |- *; apply plus_lt_reg_l with (p := nat_of_P y); do 2 rewrite <- nat_of_P_plus_morphism; - apply nat_of_P_lt_Lt_compare_morphism; - rewrite H3; rewrite Pplus_comm; apply ZC1; + apply nat_of_P_lt_Lt_compare_morphism; + rewrite H3; rewrite Pplus_comm; apply ZC1; assumption ] | assumption ] | apply ZC2; assumption ] @@ -437,14 +437,14 @@ Proof. | assumption ] | elim Pminus_mask_Gt with (1 := E0); intros k H1; (* Case 9 *) - elim Pminus_mask_Gt with (1 := E1); intros i H2; - elim H1; intros H3 H4; elim H4; intros H5 H6; - elim H2; intros H7 H8; elim H8; intros H9 H10; + elim Pminus_mask_Gt with (1 := E1); intros i H2; + elim H1; intros H3 H4; elim H4; intros H5 H6; + elim H2; intros H7 H8; elim H8; intros H9 H10; unfold Pminus in |- *; rewrite H3; rewrite H7; cut ((x + k)%positive = i); [ intros E; rewrite E; auto with arith | apply (Pplus_reg_l z); rewrite (Pplus_comm x k); rewrite Pplus_assoc; - rewrite H5; rewrite H9; rewrite Pplus_comm; + rewrite H5; rewrite H9; rewrite Pplus_comm; trivial with arith ] ] ]. Qed. @@ -460,7 +460,7 @@ Proof. rewrite Zplus_comm; rewrite <- weak_assoc; rewrite (Zplus_comm (- Zpos p1)); rewrite (Zplus_comm (Zpos p0 + - Zpos p1)); rewrite (weak_assoc p); - rewrite weak_assoc; rewrite (Zplus_comm (Zpos p0)); + rewrite weak_assoc; rewrite (Zplus_comm (Zpos p0)); trivial with arith | rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0) (Zpos p)); rewrite <- weak_assoc; rewrite Zplus_comm; rewrite (Zplus_comm (Zpos p0)); @@ -503,7 +503,7 @@ Qed. Lemma Zplus_succ_l : forall n m:Z, Zsucc n + m = Zsucc (n + m). Proof. intros x y; unfold Zsucc in |- *; rewrite (Zplus_comm (x + y)); - rewrite Zplus_assoc; rewrite (Zplus_comm (Zpos 1)); + rewrite Zplus_assoc; rewrite (Zplus_comm (Zpos 1)); trivial with arith. Qed. @@ -706,7 +706,7 @@ Lemma Zplus_minus_eq : forall n m p:Z, n = m + p -> p = n - m. Proof. intros n m p H; unfold Zminus in |- *; apply (Zplus_reg_l m); rewrite (Zplus_comm m (n + - m)); rewrite <- Zplus_assoc; - rewrite Zplus_opp_l; rewrite Zplus_0_r; rewrite H; + rewrite Zplus_opp_l; rewrite Zplus_0_r; rewrite H; trivial with arith. Qed. @@ -747,7 +747,7 @@ Proof. reflexivity. Qed. -Lemma Zpos_minus_morphism : forall a b:positive, Pcompare a b Eq = Lt -> +Lemma Zpos_minus_morphism : forall a b:positive, Pcompare a b Eq = Lt -> Zpos (b-a) = Zpos b - Zpos a. Proof. intros. @@ -773,7 +773,7 @@ Qed. (**********************************************************************) (** * Properties of multiplication on binary integer numbers *) -Theorem Zpos_mult_morphism : +Theorem Zpos_mult_morphism : forall p q:positive, Zpos (p*q) = Zpos p * Zpos q. Proof. auto. @@ -862,7 +862,7 @@ Lemma Zmult_1_inversion_l : Proof. intros x y; destruct x as [| p| p]; intro; [ discriminate | left | right ]; (destruct y as [| q| q]; try discriminate; simpl in H; injection H; clear H; - intro H; rewrite Pmult_1_inversion_l with (1 := H); + intro H; rewrite Pmult_1_inversion_l with (1 := H); reflexivity). Qed. @@ -873,7 +873,7 @@ Proof. reflexivity. Qed. -Lemma Zdouble_plus_one_mult : forall z, +Lemma Zdouble_plus_one_mult : forall z, Zdouble_plus_one z = (Zpos 2) * z + (Zpos 1). Proof. destruct z; simpl; auto with zarith. @@ -927,13 +927,13 @@ Proof. [ intros E; rewrite E; rewrite Pmult_minus_distr_l; [ trivial with arith | apply ZC2; assumption ] | apply nat_of_P_lt_Lt_compare_complement_morphism; - do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); + do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); intros h H1; rewrite H1; apply mult_S_lt_compat_l; exact (nat_of_P_lt_Lt_compare_morphism z y E0) ] | cut ((x * z ?= x * y)%positive Eq = Gt); [ intros E; rewrite E; rewrite Pmult_minus_distr_l; auto with arith | apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *; - do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); + do 2 rewrite nat_of_P_mult_morphism; elim (ZL4 x); intros h H1; rewrite H1; apply mult_S_lt_compat_l; exact (nat_of_P_gt_Gt_compare_morphism z y E0) ] ]). Qed. @@ -963,7 +963,7 @@ Proof. apply Zmult_plus_distr_l. Qed. - + Lemma Zmult_minus_distr_l : forall n m p:Z, p * (n - m) = p * n - p * m. Proof. intros x y z; rewrite (Zmult_comm z (x - y)). @@ -1007,7 +1007,7 @@ Qed. Lemma Zmult_succ_r : forall n m:Z, n * Zsucc m = n * m + n. Proof. intros n m; unfold Zsucc in |- *; rewrite Zmult_plus_distr_r; - rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l; + rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l; trivial with arith. Qed. @@ -1146,7 +1146,7 @@ Definition Zabs_N (z:Z) := | Zneg p => Npos p end. -Definition Z_of_N (x:N) := +Definition Z_of_N (x:N) := match x with | N0 => Z0 | Npos p => Zpos p diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 24d2696c59..de05c296d2 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -6,22 +6,22 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre +(* Finite sets library. + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre * Institution: LRI, CNRS UMR 8623 - Université Paris Sud * 91405 Orsay, France *) (* $Id$ *) -(** An axiomatization of integers. *) +(** An axiomatization of integers. *) -(** We define a signature for an integer datatype based on [Z]. - The goal is to allow a switch after extraction to ocaml's - [big_int] or even [int] when finiteness isn't a problem - (typically : when mesuring the height of an AVL tree). +(** We define a signature for an integer datatype based on [Z]. + The goal is to allow a switch after extraction to ocaml's + [big_int] or even [int] when finiteness isn't a problem + (typically : when mesuring the height of an AVL tree). *) -Require Import ZArith. +Require Import ZArith. Delimit Scope Int_scope with I. @@ -30,33 +30,33 @@ Delimit Scope Int_scope with I. Module Type Int. Open Scope Int_scope. - - Parameter int : Set. - + + Parameter int : Set. + Parameter i2z : int -> Z. Arguments Scope i2z [ Int_scope ]. - - Parameter _0 : int. - Parameter _1 : int. - Parameter _2 : int. + + Parameter _0 : int. + Parameter _1 : int. + Parameter _2 : int. Parameter _3 : int. - Parameter plus : int -> int -> int. + Parameter plus : int -> int -> int. Parameter opp : int -> int. - Parameter minus : int -> int -> int. + Parameter minus : int -> int -> int. Parameter mult : int -> int -> int. - Parameter max : int -> int -> int. - + Parameter max : int -> int -> int. + Notation "0" := _0 : Int_scope. - Notation "1" := _1 : Int_scope. - Notation "2" := _2 : Int_scope. + Notation "1" := _1 : Int_scope. + Notation "2" := _2 : Int_scope. Notation "3" := _3 : Int_scope. Infix "+" := plus : Int_scope. Infix "-" := minus : Int_scope. Infix "*" := mult : Int_scope. Notation "- x" := (opp x) : Int_scope. - (** For logical relations, we can rely on their counterparts in Z, - since they don't appear after extraction. Moreover, using tactics + (** For logical relations, we can rely on their counterparts in Z, + since they don't appear after extraction. Moreover, using tactics like omega is easier this way. *) Notation "x == y" := (i2z x = i2z y) @@ -69,22 +69,22 @@ Module Type Int. Notation "x <= y < z" := (x <= y /\ y < z) : Int_scope. Notation "x < y < z" := (x < y /\ y < z) : Int_scope. Notation "x < y <= z" := (x < y /\ y <= z) : Int_scope. - + (** Some decidability fonctions (informative). *) - + Axiom gt_le_dec : forall x y: int, {x > y} + {x <= y}. Axiom ge_lt_dec : forall x y : int, {x >= y} + {x < y}. Axiom eq_dec : forall x y : int, { x == y } + {~ x==y }. (** Specifications *) - (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality - [==] and the generic [=] are in fact equivalent. We define [==] + (** First, we ask [i2z] to be injective. Said otherwise, our ad-hoc equality + [==] and the generic [=] are in fact equivalent. We define [==] nonetheless since the translation to [Z] for using automatic tactic is easier. *) - Axiom i2z_eq : forall n p : int, n == p -> n = p. - - (** Then, we express the specifications of the above parameters using their + Axiom i2z_eq : forall n p : int, n == p -> n = p. + + (** Then, we express the specifications of the above parameters using their Z counterparts. *) Open Scope Z_scope. @@ -98,25 +98,25 @@ Module Type Int. Axiom i2z_mult : forall n p, i2z (n * p) = i2z n * i2z p. Axiom i2z_max : forall n p, i2z (max n p) = Zmax (i2z n) (i2z p). -End Int. +End Int. (** * Facts and tactics using [Int] *) Module MoreInt (I:Int). Import I. - + Open Scope Int_scope. - (** A magic (but costly) tactic that goes from [int] back to the [Z] + (** A magic (but costly) tactic that goes from [int] back to the [Z] friendly world ... *) - Hint Rewrite -> + Hint Rewrite -> i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z. - Ltac i2z := match goal with - | H : (eq (A:=int) ?a ?b) |- _ => - generalize (f_equal i2z H); + Ltac i2z := match goal with + | H : (eq (A:=int) ?a ?b) |- _ => + generalize (f_equal i2z H); try autorewrite with i2z; clear H; intro H; i2z | |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); try autorewrite with i2z; i2z | H : _ |- _ => progress autorewrite with i2z in H; i2z @@ -125,25 +125,25 @@ Module MoreInt (I:Int). (** A reflexive version of the [i2z] tactic *) - (** this [i2z_refl] is actually weaker than [i2z]. For instance, if a - [i2z] is buried deep inside a subterm, [i2z_refl] may miss it. - See also the limitation about [Set] or [Type] part below. + (** this [i2z_refl] is actually weaker than [i2z]. For instance, if a + [i2z] is buried deep inside a subterm, [i2z_refl] may miss it. + See also the limitation about [Set] or [Type] part below. Anyhow, [i2z_refl] is enough for applying [romega]. *) - - Ltac i2z_gen := match goal with + + Ltac i2z_gen := match goal with | |- (eq (A:=int) ?a ?b) => apply (i2z_eq a b); i2z_gen - | H : (eq (A:=int) ?a ?b) |- _ => + | H : (eq (A:=int) ?a ?b) |- _ => generalize (f_equal i2z H); clear H; i2z_gen | H : (eq (A:=Z) ?a ?b) |- _ => revert H; i2z_gen | H : (Zlt ?a ?b) |- _ => revert H; i2z_gen | H : (Zle ?a ?b) |- _ => revert H; i2z_gen | H : (Zgt ?a ?b) |- _ => revert H; i2z_gen | H : (Zge ?a ?b) |- _ => revert H; i2z_gen - | H : _ -> ?X |- _ => + | H : _ -> ?X |- _ => (* A [Set] or [Type] part cannot be dealt with easily - using the [ExprP] datatype. So we forget it, leaving + using the [ExprP] datatype. So we forget it, leaving a goal that can be weaker than the original. *) - match type of X with + match type of X with | Type => clear H; i2z_gen | Prop => revert H; i2z_gen end @@ -154,10 +154,10 @@ Module MoreInt (I:Int). | _ => idtac end. - Inductive ExprI : Set := + Inductive ExprI : Set := | EI0 : ExprI | EI1 : ExprI - | EI2 : ExprI + | EI2 : ExprI | EI3 : ExprI | EIplus : ExprI -> ExprI -> ExprI | EIopp : ExprI -> ExprI @@ -166,7 +166,7 @@ Module MoreInt (I:Int). | EImax : ExprI -> ExprI -> ExprI | EIraw : int -> ExprI. - Inductive ExprZ : Set := + Inductive ExprZ : Set := | EZplus : ExprZ -> ExprZ -> ExprZ | EZopp : ExprZ -> ExprZ | EZminus : ExprZ -> ExprZ -> ExprZ @@ -175,12 +175,12 @@ Module MoreInt (I:Int). | EZofI : ExprI -> ExprZ | EZraw : Z -> ExprZ. - Inductive ExprP : Type := - | EPeq : ExprZ -> ExprZ -> ExprP - | EPlt : ExprZ -> ExprZ -> ExprP - | EPle : ExprZ -> ExprZ -> ExprP - | EPgt : ExprZ -> ExprZ -> ExprP - | EPge : ExprZ -> ExprZ -> ExprP + Inductive ExprP : Type := + | EPeq : ExprZ -> ExprZ -> ExprP + | EPlt : ExprZ -> ExprZ -> ExprP + | EPle : ExprZ -> ExprZ -> ExprP + | EPgt : ExprZ -> ExprZ -> ExprP + | EPge : ExprZ -> ExprZ -> ExprP | EPimpl : ExprP -> ExprP -> ExprP | EPequiv : ExprP -> ExprP -> ExprP | EPand : ExprP -> ExprP -> ExprP @@ -190,8 +190,8 @@ Module MoreInt (I:Int). (** [int] to [ExprI] *) - Ltac i2ei trm := - match constr:trm with + Ltac i2ei trm := + match constr:trm with | 0 => constr:EI0 | 1 => constr:EI1 | 2 => constr:EI2 @@ -206,8 +206,8 @@ Module MoreInt (I:Int). (** [Z] to [ExprZ] *) - with z2ez trm := - match constr:trm with + with z2ez trm := + match constr:trm with | (?x+?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey) | (?x-?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey) | (?x*?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey) @@ -218,7 +218,7 @@ Module MoreInt (I:Int). end. (** [Prop] to [ExprP] *) - + Ltac p2ep trm := match constr:trm with | (?x <-> ?y) => let ex := p2ep x with ey := p2ep y in constr:(EPequiv ex ey) @@ -228,11 +228,11 @@ Module MoreInt (I:Int). | (~ ?x) => let ex := p2ep x in constr:(EPneg ex) | (eq (A:=Z) ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EPeq ex ey) | (?x let ex := z2ez x with ey := z2ez y in constr:(EPlt ex ey) - | (?x<=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey) - | (?x>?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey) + | (?x<=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey) + | (?x>?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey) | (?x>=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPge ex ey) | ?x => constr:(EPraw x) - end. + end. (** [ExprI] to [int] *) @@ -241,19 +241,19 @@ Module MoreInt (I:Int). | EI0 => 0 | EI1 => 1 | EI2 => 2 - | EI3 => 3 + | EI3 => 3 | EIplus e1 e2 => (ei2i e1)+(ei2i e2) | EIminus e1 e2 => (ei2i e1)-(ei2i e2) | EImult e1 e2 => (ei2i e1)*(ei2i e2) | EImax e1 e2 => max (ei2i e1) (ei2i e2) | EIopp e => -(ei2i e) - | EIraw i => i - end. + | EIraw i => i + end. (** [ExprZ] to [Z] *) - Fixpoint ez2z (e:ExprZ) : Z := - match e with + Fixpoint ez2z (e:ExprZ) : Z := + match e with | EZplus e1 e2 => ((ez2z e1)+(ez2z e2))%Z | EZminus e1 e2 => ((ez2z e1)-(ez2z e2))%Z | EZmult e1 e2 => ((ez2z e1)*(ez2z e2))%Z @@ -265,8 +265,8 @@ Module MoreInt (I:Int). (** [ExprP] to [Prop] *) - Fixpoint ep2p (e:ExprP) : Prop := - match e with + Fixpoint ep2p (e:ExprP) : Prop := + match e with | EPeq e1 e2 => (ez2z e1) = (ez2z e2) | EPlt e1 e2 => ((ez2z e1)<(ez2z e2))%Z | EPle e1 e2 => ((ez2z e1)<=(ez2z e2))%Z @@ -281,25 +281,25 @@ Module MoreInt (I:Int). end. (** [ExprI] (supposed under a [i2z]) to a simplified [ExprZ] *) - - Fixpoint norm_ei (e:ExprI) : ExprZ := - match e with + + Fixpoint norm_ei (e:ExprI) : ExprZ := + match e with | EI0 => EZraw (0%Z) | EI1 => EZraw (1%Z) | EI2 => EZraw (2%Z) - | EI3 => EZraw (3%Z) + | EI3 => EZraw (3%Z) | EIplus e1 e2 => EZplus (norm_ei e1) (norm_ei e2) | EIminus e1 e2 => EZminus (norm_ei e1) (norm_ei e2) | EImult e1 e2 => EZmult (norm_ei e1) (norm_ei e2) | EImax e1 e2 => EZmax (norm_ei e1) (norm_ei e2) | EIopp e => EZopp (norm_ei e) - | EIraw i => EZofI (EIraw i) + | EIraw i => EZofI (EIraw i) end. (** [ExprZ] to a simplified [ExprZ] *) - Fixpoint norm_ez (e:ExprZ) : ExprZ := - match e with + Fixpoint norm_ez (e:ExprZ) : ExprZ := + match e with | EZplus e1 e2 => EZplus (norm_ez e1) (norm_ez e2) | EZminus e1 e2 => EZminus (norm_ez e1) (norm_ez e2) | EZmult e1 e2 => EZmult (norm_ez e1) (norm_ez e2) @@ -310,9 +310,9 @@ Module MoreInt (I:Int). end. (** [ExprP] to a simplified [ExprP] *) - - Fixpoint norm_ep (e:ExprP) : ExprP := - match e with + + Fixpoint norm_ep (e:ExprP) : ExprP := + match e with | EPeq e1 e2 => EPeq (norm_ez e1) (norm_ez e2) | EPlt e1 e2 => EPlt (norm_ez e1) (norm_ez e2) | EPle e1 e2 => EPle (norm_ez e1) (norm_ez e2) @@ -327,35 +327,35 @@ Module MoreInt (I:Int). end. Lemma norm_ei_correct : forall e:ExprI, ez2z (norm_ei e) = i2z (ei2i e). - Proof. + Proof. induction e; simpl; intros; i2z; auto; try congruence. Qed. Lemma norm_ez_correct : forall e:ExprZ, ez2z (norm_ez e) = ez2z e. Proof. induction e; simpl; intros; i2z; auto; try congruence; apply norm_ei_correct. - Qed. + Qed. - Lemma norm_ep_correct : + Lemma norm_ep_correct : forall e:ExprP, ep2p (norm_ep e) <-> ep2p e. Proof. induction e; simpl; repeat (rewrite norm_ez_correct); intuition. Qed. - Lemma norm_ep_correct2 : + Lemma norm_ep_correct2 : forall e:ExprP, ep2p (norm_ep e) -> ep2p e. Proof. intros; destruct (norm_ep_correct e); auto. Qed. - Ltac i2z_refl := + Ltac i2z_refl := i2z_gen; - match goal with |- ?t => - let e := p2ep t in + match goal with |- ?t => + let e := p2ep t in change (ep2p e); apply norm_ep_correct2; simpl end. - (* i2z_refl can be replaced below by (simpl in *; i2z). + (* i2z_refl can be replaced below by (simpl in *; i2z). The reflexive version improves compilation of AVL files by about 15% *) End MoreInt. @@ -378,7 +378,7 @@ Module Z_as_Int <: Int. Definition minus := Zminus. Definition mult := Zmult. Definition max := Zmax. - Definition gt_le_dec := Z_gt_le_dec. + Definition gt_le_dec := Z_gt_le_dec. Definition ge_lt_dec := Z_ge_lt_dec. Definition eq_dec := Z_eq_dec. Definition i2z : int -> Z := fun n => n. diff --git a/theories/ZArith/Wf_Z.v b/theories/ZArith/Wf_Z.v index 7744b7e540..46f64c88db 100644 --- a/theories/ZArith/Wf_Z.v +++ b/theories/ZArith/Wf_Z.v @@ -40,7 +40,7 @@ Proof. intro x; destruct x; intros; [ exists 0%nat; auto with arith | specialize (ZL4 p); intros Hp; elim Hp; intros; exists (S x); intros; - simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x); + simpl in |- *; specialize (nat_of_P_o_P_of_succ_nat_eq_succ x); intro Hx0; rewrite <- H0 in Hx0; apply f_equal with (f := Zpos); apply nat_of_P_inj; auto with arith | absurd (0 <= Zneg p); @@ -120,13 +120,13 @@ Proof. | assumption ]. Qed. -Section Efficient_Rec. +Section Efficient_Rec. - (** [natlike_rec2] is the same as [natlike_rec], but with a different proof, designed + (** [natlike_rec2] is the same as [natlike_rec], but with a different proof, designed to give a better extracted term. *) Let R (a b:Z) := 0 <= a /\ a < b. - + Let R_wf : well_founded R. Proof. set diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v index 767f9abc41..956221cb35 100644 --- a/theories/ZArith/ZArith_base.v +++ b/theories/ZArith/ZArith_base.v @@ -9,7 +9,7 @@ (* $Id$ *) (** Library for manipulating integers based on binary encoding. - These are the basic modules, required by [Omega] and [Ring] for instance. + These are the basic modules, required by [Omega] and [Ring] for instance. The full library is [ZArith]. *) Require Export BinPos. diff --git a/theories/ZArith/ZArith_dec.v b/theories/ZArith/ZArith_dec.v index f024339d84..6e69350db7 100644 --- a/theories/ZArith/ZArith_dec.v +++ b/theories/ZArith/ZArith_dec.v @@ -28,7 +28,7 @@ Lemma Zcompare_rect : ((n ?= m) = Eq -> P) -> ((n ?= m) = Lt -> P) -> ((n ?= m) = Gt -> P) -> P. Proof. intros * H1 H2 H3. - destruct (n ?= m); auto. + destruct (n ?= m); auto. Defined. Lemma Zcompare_rec : @@ -41,13 +41,13 @@ Defined. Section decidability. Variables x y : Z. - + (** * Decidability of equality on binary integers *) Definition Z_eq_dec : {x = y} + {x <> y}. Proof. decide equality; apply positive_eq_dec. - Defined. + Defined. (** * Decidability of order on binary integers *) @@ -68,7 +68,7 @@ Section decidability. left. rewrite H. discriminate. right. tauto. Defined. - + Definition Z_gt_dec : {x > y} + {~ x > y}. Proof. unfold Zgt in |- *. diff --git a/theories/ZArith/ZOdiv.v b/theories/ZArith/ZOdiv.v index 758b228173..28b664aa48 100644 --- a/theories/ZArith/ZOdiv.v +++ b/theories/ZArith/ZOdiv.v @@ -13,19 +13,19 @@ Require Zdiv. Open Scope Z_scope. -(** This file provides results about the Round-Toward-Zero Euclidean +(** This file provides results about the Round-Toward-Zero Euclidean division [ZOdiv_eucl], whose projections are [ZOdiv] and [ZOmod]. - Definition of this division can be found in file [ZOdiv_def]. + Definition of this division can be found in file [ZOdiv_def]. - This division and the one defined in Zdiv agree only on positive - numbers. Otherwise, Zdiv performs Round-Toward-Bottom. + This division and the one defined in Zdiv agree only on positive + numbers. Otherwise, Zdiv performs Round-Toward-Bottom. - The current approach is compatible with the division of usual - programming languages such as Ocaml. In addition, it has nicer + The current approach is compatible with the division of usual + programming languages such as Ocaml. In addition, it has nicer properties with respect to opposite and other usual operations. *) -(** Since ZOdiv and Zdiv are not meant to be used concurrently, +(** Since ZOdiv and Zdiv are not meant to be used concurrently, we reuse the same notation. *) Infix "/" := ZOdiv : Z_scope. @@ -36,7 +36,7 @@ Infix "mod" := Nmod (at level 40, no associativity) : N_scope. (** Auxiliary results on the ad-hoc comparison [NPgeb]. *) -Lemma NPgeb_Zge : forall (n:N)(p:positive), +Lemma NPgeb_Zge : forall (n:N)(p:positive), NPgeb n p = true -> Z_of_N n >= Zpos p. Proof. destruct n as [|n]; simpl; intros. @@ -44,7 +44,7 @@ Proof. red; simpl; destruct Pcompare; now auto. Qed. -Lemma NPgeb_Zlt : forall (n:N)(p:positive), +Lemma NPgeb_Zlt : forall (n:N)(p:positive), NPgeb n p = false -> Z_of_N n < Zpos p. Proof. destruct n as [|n]; simpl; intros. @@ -54,7 +54,7 @@ Qed. (** * Relation between division on N and on Z. *) -Lemma Ndiv_Z0div : forall a b:N, +Lemma Ndiv_Z0div : forall a b:N, Z_of_N (a/b) = (Z_of_N a / Z_of_N b). Proof. intros. @@ -62,7 +62,7 @@ Proof. unfold Ndiv, ZOdiv; simpl; destruct Pdiv_eucl; auto. Qed. -Lemma Nmod_Z0mod : forall a b:N, +Lemma Nmod_Z0mod : forall a b:N, Z_of_N (a mod b) = (Z_of_N a) mod (Z_of_N b). Proof. intros. @@ -72,11 +72,11 @@ Qed. (** * Characterization of this euclidean division. *) -(** First, the usual equation [a=q*b+r]. Notice that [a mod 0] +(** First, the usual equation [a=q*b+r]. Notice that [a mod 0] has been chosen to be [a], so this equation holds even for [b=0]. *) -Theorem N_div_mod_eq : forall a b, +Theorem N_div_mod_eq : forall a b, a = (b * (Ndiv a b) + (Nmod a b))%N. Proof. intros; generalize (Ndiv_eucl_correct a b). @@ -84,7 +84,7 @@ Proof. intro H; rewrite H; rewrite Nmult_comm; auto. Qed. -Theorem ZO_div_mod_eq : forall a b, +Theorem ZO_div_mod_eq : forall a b, a = b * (ZOdiv a b) + (ZOmod a b). Proof. intros; generalize (ZOdiv_eucl_correct a b). @@ -94,8 +94,8 @@ Qed. (** Then, the inequalities constraining the remainder. *) -Theorem Pdiv_eucl_remainder : forall a b:positive, - Z_of_N (snd (Pdiv_eucl a b)) < Zpos b. +Theorem Pdiv_eucl_remainder : forall a b:positive, + Z_of_N (snd (Pdiv_eucl a b)) < Zpos b. Proof. induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta. intros b; generalize (IHa b); case Pdiv_eucl. @@ -111,7 +111,7 @@ Proof. destruct b; simpl; romega with *. Qed. -Theorem Nmod_lt : forall (a b:N), b<>0%N -> +Theorem Nmod_lt : forall (a b:N), b<>0%N -> (a mod b < b)%N. Proof. destruct b as [ |b]; intro H; try solve [elim H;auto]. @@ -122,20 +122,20 @@ Qed. (** The remainder is bounded by the divisor, in term of absolute values *) -Theorem ZOmod_lt : forall a b:Z, b<>0 -> +Theorem ZOmod_lt : forall a b:Z, b<>0 -> Zabs (a mod b) < Zabs b. Proof. - destruct b as [ |b|b]; intro H; try solve [elim H;auto]; - destruct a as [ |a|a]; try solve [compute;auto]; unfold ZOmod, ZOdiv_eucl; - generalize (Pdiv_eucl_remainder a b); destruct Pdiv_eucl; simpl; + destruct b as [ |b|b]; intro H; try solve [elim H;auto]; + destruct a as [ |a|a]; try solve [compute;auto]; unfold ZOmod, ZOdiv_eucl; + generalize (Pdiv_eucl_remainder a b); destruct Pdiv_eucl; simpl; try rewrite Zabs_Zopp; rewrite Zabs_eq; auto; apply Z_of_N_le_0. Qed. -(** The sign of the remainder is the one of [a]. Due to the possible +(** The sign of the remainder is the one of [a]. Due to the possible nullity of [a], a general result is to be stated in the following form: -*) +*) -Theorem ZOmod_sgn : forall a b:Z, +Theorem ZOmod_sgn : forall a b:Z, 0 <= Zsgn (a mod b) * Zsgn a. Proof. destruct b as [ |b|b]; destruct a as [ |a|a]; simpl; auto with zarith; @@ -150,16 +150,16 @@ Proof. destruct z; simpl; intuition auto with zarith. Qed. -Theorem ZOmod_sgn2 : forall a b:Z, +Theorem ZOmod_sgn2 : forall a b:Z, 0 <= (a mod b) * a. Proof. intros; rewrite <-Zsgn_pos_iff, Zsgn_Zmult; apply ZOmod_sgn. -Qed. +Qed. -(** Reformulation of [ZOdiv_lt] and [ZOmod_sgn] in 2 +(** Reformulation of [ZOdiv_lt] and [ZOmod_sgn] in 2 then 4 particular cases. *) -Theorem ZOmod_lt_pos : forall a b:Z, 0<=a -> b<>0 -> +Theorem ZOmod_lt_pos : forall a b:Z, 0<=a -> b<>0 -> 0 <= a mod b < Zabs b. Proof. intros. @@ -171,7 +171,7 @@ Proof. generalize (ZOmod_lt a b H0); romega with *. Qed. -Theorem ZOmod_lt_neg : forall a b:Z, a<=0 -> b<>0 -> +Theorem ZOmod_lt_neg : forall a b:Z, a<=0 -> b<>0 -> -Zabs b < a mod b <= 0. Proof. intros. @@ -209,49 +209,49 @@ Qed. Theorem ZOdiv_opp_l : forall a b:Z, (-a)/b = -(a/b). Proof. - destruct a; destruct b; simpl; auto; + destruct a; destruct b; simpl; auto; unfold ZOdiv, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. Qed. Theorem ZOdiv_opp_r : forall a b:Z, a/(-b) = -(a/b). Proof. - destruct a; destruct b; simpl; auto; + destruct a; destruct b; simpl; auto; unfold ZOdiv, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. Qed. Theorem ZOmod_opp_l : forall a b:Z, (-a) mod b = -(a mod b). Proof. - destruct a; destruct b; simpl; auto; + destruct a; destruct b; simpl; auto; unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. Qed. Theorem ZOmod_opp_r : forall a b:Z, a mod (-b) = a mod b. Proof. - destruct a; destruct b; simpl; auto; + destruct a; destruct b; simpl; auto; unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. Qed. Theorem ZOdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b. Proof. - destruct a; destruct b; simpl; auto; + destruct a; destruct b; simpl; auto; unfold ZOdiv, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. Qed. Theorem ZOmod_opp_opp : forall a b:Z, (-a) mod (-b) = -(a mod b). Proof. - destruct a; destruct b; simpl; auto; + destruct a; destruct b; simpl; auto; unfold ZOmod, ZOdiv_eucl; destruct Pdiv_eucl; simpl; auto with zarith. Qed. (** * Unicity results *) -Definition Remainder a b r := +Definition Remainder a b r := (0 <= a /\ 0 <= r < Zabs b) \/ (a <= 0 /\ -Zabs b < r <= 0). -Definition Remainder_alt a b r := +Definition Remainder_alt a b r := Zabs r < Zabs b /\ 0 <= r * a. -Lemma Remainder_equiv : forall a b r, +Lemma Remainder_equiv : forall a b r, Remainder a b r <-> Remainder_alt a b r. Proof. unfold Remainder, Remainder_alt; intuition. @@ -259,12 +259,12 @@ Proof. romega with *. rewrite <-(Zmult_opp_opp). apply Zmult_le_0_compat; romega. - assert (0 <= Zsgn r * Zsgn a) by (rewrite <-Zsgn_Zmult, Zsgn_pos_iff; auto). + assert (0 <= Zsgn r * Zsgn a) by (rewrite <-Zsgn_Zmult, Zsgn_pos_iff; auto). destruct r; simpl Zsgn in *; romega with *. Qed. Theorem ZOdiv_mod_unique_full: - forall a b q r, Remainder a b r -> + forall a b q r, Remainder a b r -> a = b*q + r -> q = a/b /\ r = a mod b. Proof. destruct 1 as [(H,H0)|(H,H0)]; intros. @@ -281,30 +281,30 @@ Proof. romega with *. Qed. -Theorem ZOdiv_unique_full: - forall a b q r, Remainder a b r -> +Theorem ZOdiv_unique_full: + forall a b q r, Remainder a b r -> a = b*q + r -> q = a/b. Proof. intros; destruct (ZOdiv_mod_unique_full a b q r); auto. Qed. Theorem ZOdiv_unique: - forall a b q r, 0 <= a -> 0 <= r < b -> + forall a b q r, 0 <= a -> 0 <= r < b -> a = b*q + r -> q = a/b. Proof. intros; eapply ZOdiv_unique_full; eauto. red; romega with *. Qed. -Theorem ZOmod_unique_full: - forall a b q r, Remainder a b r -> +Theorem ZOmod_unique_full: + forall a b q r, Remainder a b r -> a = b*q + r -> r = a mod b. Proof. intros; destruct (ZOdiv_mod_unique_full a b q r); auto. Qed. Theorem ZOmod_unique: - forall a b q r, 0 <= a -> 0 <= r < b -> + forall a b q r, 0 <= a -> 0 <= r < b -> a = b*q + r -> r = a mod b. Proof. intros; eapply ZOmod_unique_full; eauto. @@ -345,7 +345,7 @@ Proof. rewrite Remainder_equiv; red; simpl; auto with zarith. Qed. -Hint Resolve ZOmod_0_l ZOmod_0_r ZOdiv_0_l ZOdiv_0_r ZOdiv_1_r ZOmod_1_r +Hint Resolve ZOmod_0_l ZOmod_0_r ZOdiv_0_l ZOdiv_0_r ZOdiv_1_r ZOmod_1_r : zarith. Lemma ZOdiv_1_l: forall a, 1 < a -> 1/a = 0. @@ -381,7 +381,7 @@ Qed. Lemma ZO_div_mult : forall a b:Z, b <> 0 -> (a*b)/b = a. Proof. - intros; symmetry; apply ZOdiv_unique_full with 0; auto with zarith; + intros; symmetry; apply ZOdiv_unique_full with 0; auto with zarith; [ red; romega with * | ring]. Qed. @@ -403,12 +403,12 @@ Proof. subst b; rewrite ZOdiv_0_r; auto. Qed. -(** As soon as the divisor is greater or equal than 2, +(** As soon as the divisor is greater or equal than 2, the division is strictly decreasing. *) Lemma ZO_div_lt : forall a b:Z, 0 < a -> 2 <= b -> a/b < a. Proof. - intros. + intros. assert (Hb : 0 < b) by romega. assert (H1 : 0 <= a/b) by (apply ZO_div_pos; auto with zarith). assert (H2 : 0 <= a mod b < b) by (apply ZOmod_lt_pos_pos; auto with zarith). @@ -441,7 +441,7 @@ Lemma ZO_div_monotone_pos : forall a b c:Z, 0<=c -> 0<=a<=b -> a/c <= b/c. Proof. intros. destruct H0. - destruct (Zle_lt_or_eq 0 c H); + destruct (Zle_lt_or_eq 0 c H); [ clear H | subst c; do 2 rewrite ZOdiv_0_r; auto]. generalize (ZO_div_mod_eq a c). generalize (ZOmod_lt_pos_pos a c H0 H2). @@ -452,7 +452,7 @@ Proof. intro. absurd (a - b >= 1). omega. - replace (a-b) with (c * (a/c-b/c) + a mod c - b mod c) by + replace (a-b) with (c * (a/c-b/c) + a mod c - b mod c) by (symmetry; pattern a at 1; rewrite H5; pattern b at 1; rewrite H3; ring). assert (c * (a / c - b / c) >= c * 1). apply Zmult_ge_compat_l. @@ -519,7 +519,7 @@ Proof. apply ZO_div_pos; auto with zarith. Qed. -(** The previous inequalities between [b*(a/b)] and [a] are exact +(** The previous inequalities between [b*(a/b)] and [a] are exact iff the modulo is zero. *) Lemma ZO_div_exact_full_1 : forall a b:Z, a = b*(a/b) -> a mod b = 0. @@ -535,7 +535,7 @@ Qed. (** A modulo cannot grow beyond its starting point. *) Theorem ZOmod_le: forall a b, 0 <= a -> 0 <= b -> a mod b <= a. -Proof. +Proof. intros a b H1 H2. destruct (Zle_lt_or_eq _ _ H2). case (Zle_or_lt b a); intros H3. @@ -546,7 +546,7 @@ Qed. (** Some additionnal inequalities about Zdiv. *) -Theorem ZOdiv_le_upper_bound: +Theorem ZOdiv_le_upper_bound: forall a b q, 0 < b -> a <= q*b -> a/b <= q. Proof. intros. @@ -572,21 +572,21 @@ Proof. apply ZO_div_monotone; auto with zarith. Qed. -Theorem ZOdiv_sgn: forall a b, +Theorem ZOdiv_sgn: forall a b, 0 <= Zsgn (a/b) * Zsgn a * Zsgn b. Proof. - destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; + destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; unfold ZOdiv; simpl; destruct Pdiv_eucl; simpl; destruct n; simpl; auto with zarith. Qed. (** * Relations between usual operations and Zmod and Zdiv *) -(** First, a result that used to be always valid with Zdiv, - but must be restricted here. +(** First, a result that used to be always valid with Zdiv, + but must be restricted here. For instance, now (9+(-5)*2) mod 2 = -1 <> 1 = 9 mod 2 *) -Lemma ZO_mod_plus : forall a b c:Z, - 0 <= (a+b*c) * a -> +Lemma ZO_mod_plus : forall a b c:Z, + 0 <= (a+b*c) * a -> (a + b * c) mod c = a mod c. Proof. intros; destruct (Z_eq_dec a 0) as [Ha|Ha]. @@ -605,8 +605,8 @@ Proof. generalize (ZO_div_mod_eq a c); romega. Qed. -Lemma ZO_div_plus : forall a b c:Z, - 0 <= (a+b*c) * a -> c<>0 -> +Lemma ZO_div_plus : forall a b c:Z, + 0 <= (a+b*c) * a -> c<>0 -> (a + b * c) / c = a / c + b. Proof. intros; destruct (Z_eq_dec a 0) as [Ha|Ha]. @@ -624,17 +624,17 @@ Proof. generalize (ZO_div_mod_eq a c); romega. Qed. -Theorem ZO_div_plus_l: forall a b c : Z, - 0 <= (a*b+c)*c -> b<>0 -> +Theorem ZO_div_plus_l: forall a b c : Z, + 0 <= (a*b+c)*c -> b<>0 -> b<>0 -> (a * b + c) / b = a + c / b. Proof. intros a b c; rewrite Zplus_comm; intros; rewrite ZO_div_plus; - try apply Zplus_comm; auto with zarith. + try apply Zplus_comm; auto with zarith. Qed. (** Cancellations. *) -Lemma ZOdiv_mult_cancel_r : forall a b c:Z, +Lemma ZOdiv_mult_cancel_r : forall a b c:Z, c<>0 -> (a*c)/(b*c) = a/b. Proof. intros a b c Hc. @@ -655,7 +655,7 @@ Proof. pattern a at 1; rewrite (ZO_div_mod_eq a b); ring. Qed. -Lemma ZOdiv_mult_cancel_l : forall a b c:Z, +Lemma ZOdiv_mult_cancel_l : forall a b c:Z, c<>0 -> (c*a)/(c*b) = a/b. Proof. intros. @@ -663,7 +663,7 @@ Proof. apply ZOdiv_mult_cancel_r; auto. Qed. -Lemma ZOmult_mod_distr_l: forall a b c, +Lemma ZOmult_mod_distr_l: forall a b c, (c*a) mod (c*b) = c * (a mod b). Proof. intros; destruct (Z_eq_dec c 0) as [Hc|Hc]. @@ -678,7 +678,7 @@ Proof. ring. Qed. -Lemma ZOmult_mod_distr_r: forall a b c, +Lemma ZOmult_mod_distr_r: forall a b c, (a*c) mod (b*c) = (a mod b) * c. Proof. intros; repeat rewrite (fun x => (Zmult_comm x c)). @@ -706,7 +706,7 @@ Proof. pattern a at 2 3; rewrite (ZO_div_mod_eq a n); auto with zarith. pattern b at 2 3; rewrite (ZO_div_mod_eq b n); auto with zarith. set (A:=a mod n); set (B:=b mod n); set (A':=a/n); set (B':=b/n). - replace (A*(n*A'+A)*(B*(n*B'+B))) with (((n*A' + A) * (n*B' + B))*(A*B)) + replace (A*(n*A'+A)*(B*(n*B'+B))) with (((n*A' + A) * (n*B' + B))*(A*B)) by ring. replace ((n*A' + A) * (n*B' + B)) with (A*B + (A'*B+B'*A+n*A'*B')*n) by ring. @@ -715,15 +715,15 @@ Proof. Qed. (** addition and modulo - - Generally speaking, unlike with Zdiv, we don't have - (a+b) mod n = (a mod n + b mod n) mod n - for any a and b. - For instance, take (8 + (-10)) mod 3 = -2 whereas + + Generally speaking, unlike with Zdiv, we don't have + (a+b) mod n = (a mod n + b mod n) mod n + for any a and b. + For instance, take (8 + (-10)) mod 3 = -2 whereas (8 mod 3 + (-10 mod 3)) mod 3 = 1. *) Theorem ZOplus_mod: forall a b n, - 0 <= a * b -> + 0 <= a * b -> (a + b) mod n = (a mod n + b mod n) mod n. Proof. assert (forall a b n, 0 0 @@ -755,16 +755,16 @@ Proof. rewrite <-(Zopp_involutive a), <-(Zopp_involutive b). rewrite <- Zopp_plus_distr; rewrite ZOmod_opp_l. rewrite (ZOmod_opp_l (-a)),(ZOmod_opp_l (-b)). - match goal with |- _ = (-?x+-?y) mod n => + match goal with |- _ = (-?x+-?y) mod n => rewrite <-(Zopp_plus_distr x y), ZOmod_opp_l end. f_equal; apply H; auto with zarith. Qed. -Lemma ZOplus_mod_idemp_l: forall a b n, - 0 <= a * b -> +Lemma ZOplus_mod_idemp_l: forall a b n, + 0 <= a * b -> (a mod n + b) mod n = (a + b) mod n. Proof. - intros. + intros. rewrite ZOplus_mod. rewrite ZOmod_mod. symmetry. @@ -785,8 +785,8 @@ Proof. destruct b; simpl; auto with zarith. Qed. -Lemma ZOplus_mod_idemp_r: forall a b n, - 0 <= a*b -> +Lemma ZOplus_mod_idemp_r: forall a b n, + 0 <= a*b -> (b + a mod n) mod n = (b + a) mod n. Proof. intros. @@ -816,12 +816,12 @@ Proof. replace (b * (c * (a / b / c) + (a / b) mod c) + a mod b) with ((a / b / c)*(b * c) + (b * ((a / b) mod c) + a mod b)) by ring. assert (b*c<>0). - intro H2; - assert (H3: c <> 0) by auto with zarith; + intro H2; + assert (H3: c <> 0) by auto with zarith; rewrite (Zmult_integral_l _ _ H3 H2) in H0; auto with zarith. assert (0<=a/b) by (apply (ZO_div_pos a b); auto with zarith). assert (0<=a mod b < b) by (apply ZOmod_lt_pos_pos; auto with zarith). - assert (0<=(a/b) mod c < c) by + assert (0<=(a/b) mod c < c) by (apply ZOmod_lt_pos_pos; auto with zarith). rewrite ZO_div_plus_l; auto with zarith. rewrite (ZOdiv_small (b * ((a / b) mod c) + a mod b)). @@ -846,14 +846,14 @@ Proof. intros; destruct b as [ |b|b]. repeat rewrite ZOdiv_0_r; reflexivity. apply H0; auto with zarith. - change (Zneg b) with (-Zpos b); + change (Zneg b) with (-Zpos b); repeat (rewrite ZOdiv_opp_r || rewrite ZOdiv_opp_l || rewrite <- Zopp_mult_distr_l). f_equal; apply H0; auto with zarith. (* a b c general *) intros; destruct c as [ |c|c]. rewrite Zmult_0_r; repeat rewrite ZOdiv_0_r; reflexivity. apply H1; auto with zarith. - change (Zneg c) with (-Zpos c); + change (Zneg c) with (-Zpos c); rewrite <- Zopp_mult_distr_r; do 2 rewrite ZOdiv_opp_r. f_equal; apply H1; auto with zarith. Qed. @@ -864,11 +864,11 @@ Theorem ZOdiv_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b. Proof. intros a b c Ha Hb Hc. - destruct (Zle_lt_or_eq _ _ Ha); + destruct (Zle_lt_or_eq _ _ Ha); [ | subst; rewrite ZOdiv_0_l, Zmult_0_r, ZOdiv_0_l; auto]. - destruct (Zle_lt_or_eq _ _ Hb); + destruct (Zle_lt_or_eq _ _ Hb); [ | subst; rewrite ZOdiv_0_r, ZOdiv_0_r, Zmult_0_r; auto]. - destruct (Zle_lt_or_eq _ _ Hc); + destruct (Zle_lt_or_eq _ _ Hc); [ | subst; rewrite ZOdiv_0_l; auto]. case (ZOmod_lt_pos_pos a b); auto with zarith; intros Hu1 Hu2. case (ZOmod_lt_pos_pos c b); auto with zarith; intros Hv1 Hv2. @@ -884,14 +884,14 @@ Proof. apply (ZOmod_le ((c mod b) * (a mod b)) b); auto with zarith. apply Zmult_le_compat_r; auto with zarith. apply (ZOmod_le c b); auto. - pattern (c * a) at 1; rewrite (ZO_div_mod_eq (c * a) b); try ring; + pattern (c * a) at 1; rewrite (ZO_div_mod_eq (c * a) b); try ring; auto with zarith. pattern a at 1; rewrite (ZO_div_mod_eq a b); try ring; auto with zarith. Qed. (** ZOmod is related to divisibility (see more in Znumtheory) *) -Lemma ZOmod_divides : forall a b, +Lemma ZOmod_divides : forall a b, a mod b = 0 <-> exists c, a = b*c. Proof. split; intros. @@ -910,7 +910,7 @@ Qed. (** They agree at least on positive numbers: *) -Theorem ZOdiv_eucl_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b -> +Theorem ZOdiv_eucl_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b -> a/b = Zdiv.Zdiv a b /\ a mod b = Zdiv.Zmod a b. Proof. intros. @@ -921,7 +921,7 @@ Proof. symmetry; apply ZO_div_mod_eq; auto with *. Qed. -Theorem ZOdiv_Zdiv_pos : forall a b, 0 <= a -> 0 <= b -> +Theorem ZOdiv_Zdiv_pos : forall a b, 0 <= a -> 0 <= b -> a/b = Zdiv.Zdiv a b. Proof. intros a b Ha Hb. @@ -930,7 +930,7 @@ Proof. subst; rewrite ZOdiv_0_r, Zdiv.Zdiv_0_r; reflexivity. Qed. -Theorem ZOmod_Zmod_pos : forall a b, 0 <= a -> 0 < b -> +Theorem ZOmod_Zmod_pos : forall a b, 0 <= a -> 0 < b -> a mod b = Zdiv.Zmod a b. Proof. intros a b Ha Hb; generalize (ZOdiv_eucl_Zdiv_eucl_pos a b Ha Hb); @@ -939,9 +939,9 @@ Qed. (** Modulos are null at the same places *) -Theorem ZOmod_Zmod_zero : forall a b, b<>0 -> +Theorem ZOmod_Zmod_zero : forall a b, b<>0 -> (a mod b = 0 <-> Zdiv.Zmod a b = 0). Proof. intros. rewrite ZOmod_divides, Zdiv.Zmod_divides; intuition. -Qed. +Qed. diff --git a/theories/ZArith/ZOdiv_def.v b/theories/ZArith/ZOdiv_def.v index 2c84765eef..c73b6f0916 100644 --- a/theories/ZArith/ZOdiv_def.v +++ b/theories/ZArith/ZOdiv_def.v @@ -19,7 +19,7 @@ Definition NPgeb (a:N)(b:positive) := Fixpoint Pdiv_eucl (a b:positive) {struct a} : N * N := match a with - | xH => + | xH => match b with xH => (1, 0)%N | _ => (0, 1)%N end | xO a' => let (q, r) := Pdiv_eucl a' b in @@ -33,21 +33,21 @@ Fixpoint Pdiv_eucl (a b:positive) {struct a} : N * N := else (2 * q, r')%N end. -Definition ZOdiv_eucl (a b:Z) : Z * Z := +Definition ZOdiv_eucl (a b:Z) : Z * Z := match a, b with | Z0, _ => (Z0, Z0) | _, Z0 => (Z0, a) - | Zpos na, Zpos nb => - let (nq, nr) := Pdiv_eucl na nb in + | Zpos na, Zpos nb => + let (nq, nr) := Pdiv_eucl na nb in (Z_of_N nq, Z_of_N nr) - | Zneg na, Zpos nb => - let (nq, nr) := Pdiv_eucl na nb in + | Zneg na, Zpos nb => + let (nq, nr) := Pdiv_eucl na nb in (Zopp (Z_of_N nq), Zopp (Z_of_N nr)) - | Zpos na, Zneg nb => - let (nq, nr) := Pdiv_eucl na nb in + | Zpos na, Zneg nb => + let (nq, nr) := Pdiv_eucl na nb in (Zopp (Z_of_N nq), Z_of_N nr) - | Zneg na, Zneg nb => - let (nq, nr) := Pdiv_eucl na nb in + | Zneg na, Zneg nb => + let (nq, nr) := Pdiv_eucl na nb in (Z_of_N nq, Zopp (Z_of_N nr)) end. @@ -55,7 +55,7 @@ Definition ZOdiv a b := fst (ZOdiv_eucl a b). Definition ZOmod a b := snd (ZOdiv_eucl a b). -Definition Ndiv_eucl (a b:N) : N * N := +Definition Ndiv_eucl (a b:N) : N * N := match a, b with | N0, _ => (N0, N0) | _, N0 => (N0, a) @@ -68,13 +68,13 @@ Definition Nmod a b := snd (Ndiv_eucl a b). (* Proofs of specifications for these euclidean divisions. *) -Theorem NPgeb_correct: forall (a:N)(b:positive), +Theorem NPgeb_correct: forall (a:N)(b:positive), if NPgeb a b then a = (Nminus a (Npos b) + Npos b)%N else True. Proof. destruct a; intros; simpl; auto. generalize (Pcompare_Eq_eq p b). case_eq (Pcompare p b Eq); intros; auto. - rewrite H0; auto. + rewrite H0; auto. now rewrite Pminus_mask_diag. destruct (Pminus_mask_Gt p b H) as [d [H2 [H3 _]]]. rewrite H2. rewrite <- H3. @@ -82,11 +82,11 @@ Proof. Qed. Hint Rewrite Z_of_N_plus Z_of_N_mult Z_of_N_minus Zmult_1_l Zmult_assoc - Zmult_plus_distr_l Zmult_plus_distr_r : zdiv. -Hint Rewrite <- Zplus_assoc : zdiv. + Zmult_plus_distr_l Zmult_plus_distr_r : zdiv. +Hint Rewrite <- Zplus_assoc : zdiv. Theorem Pdiv_eucl_correct: forall a b, - let (q,r) := Pdiv_eucl a b in + let (q,r) := Pdiv_eucl a b in Zpos a = Z_of_N q * Zpos b + Z_of_N r. Proof. induction a; cbv beta iota delta [Pdiv_eucl]; fold Pdiv_eucl; cbv zeta. diff --git a/theories/ZArith/Zabs.v b/theories/ZArith/Zabs.v index a52df1bfc4..51c2a2905a 100644 --- a/theories/ZArith/Zabs.v +++ b/theories/ZArith/Zabs.v @@ -77,9 +77,9 @@ Proof. (intros H2; rewrite H2); auto. Qed. -Lemma Zabs_spec : forall x:Z, - 0 <= x /\ Zabs x = x \/ - 0 > x /\ Zabs x = -x. +Lemma Zabs_spec : forall x:Z, + 0 <= x /\ Zabs x = x \/ + 0 > x /\ Zabs x = -x. Proof. intros; unfold Zabs, Zle, Zgt; destruct x; simpl; intuition discriminate. Qed. @@ -142,7 +142,7 @@ Lemma Zabs_nat_mult: forall n m:Z, Zabs_nat (n*m) = (Zabs_nat n * Zabs_nat m)%na Proof. intros; apply inj_eq_rev. rewrite inj_mult; repeat rewrite inj_Zabs_nat; apply Zabs_Zmult. -Qed. +Qed. Lemma Zabs_nat_Zsucc: forall p, 0 <= p -> Zabs_nat (Zsucc p) = S (Zabs_nat p). @@ -151,13 +151,13 @@ Proof. rewrite inj_S; repeat rewrite inj_Zabs_nat, Zabs_eq; auto with zarith. Qed. -Lemma Zabs_nat_Zplus: +Lemma Zabs_nat_Zplus: forall x y, 0<=x -> 0<=y -> Zabs_nat (x+y) = (Zabs_nat x + Zabs_nat y)%nat. Proof. intros; apply inj_eq_rev. rewrite inj_plus; repeat rewrite inj_Zabs_nat, Zabs_eq; auto with zarith. apply Zplus_le_0_compat; auto. -Qed. +Qed. Lemma Zabs_nat_Zminus: forall x y, 0 <= x <= y -> Zabs_nat (y - x) = (Zabs_nat y - Zabs_nat x)%nat. @@ -200,11 +200,11 @@ Qed. (** A characterization of the sign function: *) -Lemma Zsgn_spec : forall x:Z, - 0 < x /\ Zsgn x = 1 \/ - 0 = x /\ Zsgn x = 0 \/ +Lemma Zsgn_spec : forall x:Z, + 0 < x /\ Zsgn x = 1 \/ + 0 = x /\ Zsgn x = 0 \/ 0 > x /\ Zsgn x = -1. -Proof. +Proof. intros; unfold Zsgn, Zle, Zgt; destruct x; compute; intuition. Qed. diff --git a/theories/ZArith/Zbinary.v b/theories/ZArith/Zbinary.v index 3149572be5..4c9ee24057 100644 --- a/theories/ZArith/Zbinary.v +++ b/theories/ZArith/Zbinary.v @@ -8,7 +8,7 @@ (*i $Id$ i*) -(** Bit vectors interpreted as integers. +(** Bit vectors interpreted as integers. Contribution by Jean Duprat (ENS Lyon). *) Require Import Bvector. @@ -17,7 +17,7 @@ Require Export Zpower. Require Import Omega. (** L'évaluation des vecteurs de booléens se font à la fois en binaire et - en complément à  deux. Le nombre appartient à  Z. + en complément à  deux. Le nombre appartient à  Z. On utilise donc Omega pour faire les calculs dans Z. De plus, on utilise les fonctions 2^n où n est un naturel, ici la longueur. two_power_nat = [n:nat](POS (shift_nat n xH)) @@ -32,10 +32,10 @@ Require Import Omega. Section VALUE_OF_BOOLEAN_VECTORS. (** Les calculs sont effectués dans la convention positive usuelle. - Les valeurs correspondent soit à  l'écriture binaire (nat), + Les valeurs correspondent soit à  l'écriture binaire (nat), soit au complément à  deux (int). On effectue le calcul suivant le schéma de Horner. - Le complément à  deux n'a de sens que sur les vecteurs de taille + Le complément à  deux n'a de sens que sur les vecteurs de taille supérieure ou égale à  un, le bit de signe étant évalué négativement. *) @@ -44,12 +44,12 @@ Section VALUE_OF_BOOLEAN_VECTORS. | true => 1%Z | false => 0%Z end. - + Lemma binary_value : forall n:nat, Bvector n -> Z. Proof. simple induction n; intros. exact 0%Z. - + inversion H0. exact (bit_value a + 2 * H H2)%Z. Defined. @@ -98,19 +98,19 @@ Section ENCODING_VALUE. Proof. destruct z; simpl in |- *. trivial. - + destruct p; simpl in |- *; trivial. - + destruct p; simpl in |- *. destruct p as [p| p| ]; simpl in |- *. rewrite <- (Pdouble_minus_one_o_succ_eq_xI p); trivial. trivial. - + trivial. - + trivial. - + trivial. Qed. @@ -118,7 +118,7 @@ Section ENCODING_VALUE. Proof. simple induction n; intros. exact Bnil. - + exact (Bcons (Zeven.Zodd_bool H0) n0 (H (Zeven.Zdiv2 H0))). Defined. @@ -126,7 +126,7 @@ Section ENCODING_VALUE. Proof. simple induction n; intros. exact (Bcons (Zeven.Zodd_bool H) 0 Bnil). - + exact (Bcons (Zeven.Zodd_bool H0) (S n0) (H (Zmod2 H0))). Defined. @@ -206,10 +206,10 @@ Section Z_BRIC_A_BRAC. Proof. destruct z as [| p| p]. auto. - + destruct p; auto. simpl in |- *; intros; omega. - + intro H; elim H; trivial. Qed. @@ -221,11 +221,11 @@ Section Z_BRIC_A_BRAC. intros. cut (2 * Zeven.Zdiv2 z < 2 * two_power_nat n)%Z; intros. omega. - + rewrite <- two_power_nat_S. destruct (Zeven.Zeven_odd_dec z); intros. rewrite <- Zeven.Zeven_div2; auto. - + generalize (Zeven.Zodd_div2 z H z0); omega. Qed. @@ -236,7 +236,7 @@ Section Z_BRIC_A_BRAC. Proof. intros; auto. Qed. - + Lemma Zeven_bit_value : forall z:Z, Zeven.Zeven z -> bit_value (Zeven.Zodd_bool z) = 0%Z. Proof. @@ -244,7 +244,7 @@ Section Z_BRIC_A_BRAC. destruct p; tauto || (intro H; elim H). destruct p; tauto || (intro H; elim H). Qed. - + Lemma Zodd_bit_value : forall z:Z, Zeven.Zodd z -> bit_value (Zeven.Zodd_bool z) = 1%Z. Proof. @@ -253,7 +253,7 @@ Section Z_BRIC_A_BRAC. destruct p; tauto || (intros; elim H). destruct p; tauto || (intros; elim H). Qed. - + Lemma Zge_minus_two_power_nat_S : forall (n:nat) (z:Z), (z >= - two_power_nat (S n))%Z -> (Zmod2 z >= - two_power_nat n)%Z. @@ -265,7 +265,7 @@ Section Z_BRIC_A_BRAC. rewrite (Zodd_bit_value z H); intros; omega. Qed. - + Lemma Zlt_two_power_nat_S : forall (n:nat) (z:Z), (z < two_power_nat (S n))%Z -> (Zmod2 z < two_power_nat n)%Z. @@ -282,7 +282,7 @@ End Z_BRIC_A_BRAC. Section COHERENT_VALUE. -(** On vérifie que dans l'intervalle de définition les fonctions sont +(** On vérifie que dans l'intervalle de définition les fonctions sont réciproques l'une de l'autre. Elles utilisent les lemmes du bric-a-brac. *) @@ -291,26 +291,26 @@ Section COHERENT_VALUE. Proof. induction bv as [| a n bv IHbv]. auto. - + rewrite binary_value_Sn. rewrite Z_to_binary_Sn. rewrite IHbv; trivial. - + apply binary_value_pos. Qed. - + Lemma two_compl_to_Z_to_two_compl : forall (n:nat) (bv:Bvector n) (b:bool), Z_to_two_compl n (two_compl_value n (Bcons b n bv)) = Bcons b n bv. Proof. induction bv as [| a n bv IHbv]; intro b. destruct b; auto. - + rewrite two_compl_value_Sn. rewrite Z_to_two_compl_Sn. rewrite IHbv; trivial. Qed. - + Lemma Z_to_binary_to_Z : forall (n:nat) (z:Z), (z >= 0)%Z -> @@ -318,17 +318,17 @@ Section COHERENT_VALUE. Proof. induction n as [| n IHn]. unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros; omega. - + intros; rewrite Z_to_binary_Sn_z. rewrite binary_value_Sn. rewrite IHn. apply Z_div2_value; auto. - + apply Pdiv2; trivial. - + apply Zdiv2_two_power_nat; trivial. Qed. - + Lemma Z_to_two_compl_to_Z : forall (n:nat) (z:Z), (z >= - two_power_nat n)%Z -> @@ -345,7 +345,7 @@ Section COHERENT_VALUE. generalize (Zmod2_twice z); omega. apply Zge_minus_two_power_nat_S; auto. - + apply Zlt_two_power_nat_S; auto. Qed. diff --git a/theories/ZArith/Zcompare.v b/theories/ZArith/Zcompare.v index 35a900afd5..f146a80e13 100644 --- a/theories/ZArith/Zcompare.v +++ b/theories/ZArith/Zcompare.v @@ -40,12 +40,12 @@ Proof. | destruct ((x' ?= y')%positive Eq); reflexivity || discriminate ] ]. Qed. -Ltac destr_zcompare := - match goal with |- context [Zcompare ?x ?y] => - let H := fresh "H" in +Ltac destr_zcompare := + match goal with |- context [Zcompare ?x ?y] => + let H := fresh "H" in case_eq (Zcompare x y); intro H; [generalize (Zcompare_Eq_eq _ _ H); clear H; intro H | - change (xy)%Z in H ] end. @@ -58,7 +58,7 @@ Qed. Lemma Zcompare_antisym : forall n m:Z, CompOpp (n ?= m) = (m ?= n). Proof. intros x y; destruct x; destruct y; simpl in |- *; - reflexivity || discriminate H || rewrite Pcompare_antisym; + reflexivity || discriminate H || rewrite Pcompare_antisym; reflexivity. Qed. @@ -133,7 +133,7 @@ Proof. [ reflexivity | apply H | rewrite (Zcompare_opp x y); rewrite Zcompare_opp; - do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg; + do 2 rewrite Zopp_plus_distr; rewrite Zopp_neg; apply H ]. Qed. @@ -149,7 +149,7 @@ Proof. rewrite nat_of_P_minus_morphism; [ unfold gt in |- *; apply ZL16 | assumption ] | intros p; ElimPcompare z p; intros E; auto with arith; - apply nat_of_P_gt_Gt_compare_complement_morphism; + apply nat_of_P_gt_Gt_compare_complement_morphism; unfold gt in |- *; apply ZL17 | intros p q; ElimPcompare q p; intros E; rewrite E; [ rewrite (Pcompare_Eq_eq q p E); apply Pcompare_refl @@ -174,7 +174,7 @@ Proof. [ apply lt_trans with (m := nat_of_P z); [ apply ZL16 | apply ZL17 ] | assumption ] | intros p q; ElimPcompare z q; intros E0; rewrite E0; ElimPcompare z p; - intros E1; rewrite E1; ElimPcompare q p; intros E2; + intros E1; rewrite E1; ElimPcompare q p; intros E2; rewrite E2; auto with arith; [ absurd ((q ?= p)%positive Eq = Lt); [ rewrite <- (Pcompare_Eq_eq z q E0); @@ -277,7 +277,7 @@ Proof. [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P q); rewrite plus_assoc; rewrite le_plus_minus_r; [ rewrite (plus_comm (nat_of_P q)); apply plus_lt_compat_l; - apply nat_of_P_lt_Lt_compare_morphism; + apply nat_of_P_lt_Lt_compare_morphism; assumption | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption ] @@ -293,7 +293,7 @@ Proof. [ rewrite plus_comm; apply plus_lt_reg_l with (p := nat_of_P p); rewrite plus_assoc; rewrite le_plus_minus_r; [ rewrite (plus_comm (nat_of_P p)); apply plus_lt_compat_l; - apply nat_of_P_lt_Lt_compare_morphism; + apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption | apply lt_le_weak; apply nat_of_P_lt_Lt_compare_morphism; apply ZC1; assumption ] @@ -334,7 +334,7 @@ Qed. Lemma Zcompare_succ_Gt : forall n:Z, (Zsucc n ?= n) = Gt. Proof. intro x; unfold Zsucc in |- *; pattern x at 2 in |- *; - rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat; + rewrite <- (Zplus_0_r x); rewrite Zcompare_plus_compat; reflexivity. Qed. @@ -355,7 +355,7 @@ Proof. apply nat_of_P_lt_Lt_compare_morphism; change ((Zpos h ?= 1) = Lt) in |- *; rewrite <- H2; rewrite <- (fun m n:Z => Zcompare_plus_compat m n y); - rewrite (Zplus_comm x); rewrite Zplus_assoc; + rewrite (Zplus_comm x); rewrite Zplus_assoc; rewrite Zplus_opp_r; simpl in |- *; exact H1 ] ] | intros H1; rewrite H1; discriminate ] | intros H; elim_compare x (y + 1); @@ -373,7 +373,7 @@ Proof. intros n m; unfold Zsucc in |- *; do 2 rewrite (fun t:Z => Zplus_comm t 1); rewrite Zcompare_plus_compat; auto with arith. Qed. - + (** * Multiplication and comparison *) Lemma Zcompare_mult_compat : @@ -398,7 +398,7 @@ Qed. Lemma rename : forall (A:Type) (P:A -> Prop) (x:A), (forall y:A, x = y -> P y) -> P x. Proof. - auto with arith. + auto with arith. Qed. Lemma Zcompare_elim : @@ -477,7 +477,7 @@ Lemma Zge_compare : | Gt => True end. Proof. - intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith. + intros x y; unfold Zge in |- *; elim (x ?= y); auto with arith. Qed. Lemma Zgt_compare : diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index df28b56c8e..293a81f14d 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -19,26 +19,26 @@ Open Local Scope Z_scope. (** About parity *) Lemma two_or_two_plus_one : - forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. + forall n:Z, {y : Z | n = 2 * y} + {y : Z | n = 2 * y + 1}. Proof. intro x; destruct x. left; split with 0; reflexivity. - + destruct p. right; split with (Zpos p); reflexivity. - + left; split with (Zpos p); reflexivity. - + right; split with 0; reflexivity. - + destruct p. right; split with (Zneg (1 + p)). rewrite BinInt.Zneg_xI. rewrite BinInt.Zneg_plus_distr. omega. - + left; split with (Zneg p); reflexivity. - + right; split with (-1); reflexivity. Qed. @@ -64,24 +64,24 @@ Proof. trivial. Qed. -Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. +Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. Proof. unfold floor in |- *. intro a; induction a as [p| p| ]. - + simpl in |- *. repeat rewrite BinInt.Zpos_xI. - rewrite (BinInt.Zpos_xO (xO (floor_pos p))). + rewrite (BinInt.Zpos_xO (xO (floor_pos p))). rewrite (BinInt.Zpos_xO (floor_pos p)). omega. - + simpl in |- *. repeat rewrite BinInt.Zpos_xI. rewrite (BinInt.Zpos_xO (xO (floor_pos p))). rewrite (BinInt.Zpos_xO (floor_pos p)). rewrite (BinInt.Zpos_xO p). omega. - + simpl in |- *; omega. Qed. @@ -128,7 +128,7 @@ Proof. elim (Zabs_dec m); intro eq; rewrite eq; trivial. Qed. -(** To do case analysis over the sign of [z] *) +(** To do case analysis over the sign of [z] *) Lemma Zcase_sign : forall (n:Z) (P:Prop), (n = 0 -> P) -> (n > 0 -> P) -> (n < 0 -> P) -> P. @@ -164,7 +164,7 @@ Fixpoint Zlength_aux (acc:Z) (A:Type) (l:list A) {struct l} : Z := match l with | nil => acc | _ :: l => Zlength_aux (Zsucc acc) A l - end. + end. Definition Zlength := Zlength_aux 0. Implicit Arguments Zlength [A]. @@ -177,7 +177,7 @@ Section Zlength_properties. Lemma Zlength_correct : forall l, Zlength l = Z_of_nat (length l). Proof. - assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)). + assert (forall l (acc:Z), Zlength_aux acc A l = acc + Z_of_nat (length l)). simple induction l. simpl in |- *; auto with zarith. intros; simpl (length (a :: l0)) in |- *; rewrite Znat.inj_S. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index f341b193ea..3435874cce 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -12,7 +12,7 @@ (** Euclidean Division - Defines first of function that allows Coq to normalize. + Defines first of function that allows Coq to normalize. Then only after proves the main required property. *) @@ -26,15 +26,15 @@ Open Local Scope Z_scope. (** * Definitions of Euclidian operations *) -(** Euclidean division of a positive by a integer +(** Euclidean division of a positive by a integer (that is supposed to be positive). Total function than returns an arbitrary value when divisor is not positive - + *) -Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : +Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : Z * Z := match a with | xH => if Zge_bool b 2 then (0, 1) else (1, 0) @@ -50,41 +50,41 @@ Unboxed Fixpoint Zdiv_eucl_POS (a:positive) (b:Z) {struct a} : (** Euclidean division of integers. - - Total function than returns (0,0) when dividing by 0. -*) - -(** + + Total function than returns (0,0) when dividing by 0. +*) + +(** The pseudo-code is: - + if b = 0 : (0,0) - + if b <> 0 and a = 0 : (0,0) - if b > 0 and a < 0 : let (q,r) = div_eucl_pos (-a) b in + if b > 0 and a < 0 : let (q,r) = div_eucl_pos (-a) b in if r = 0 then (-q,0) else (-(q+1),b-r) if b < 0 and a < 0 : let (q,r) = div_eucl (-a) (-b) in (q,-r) - if b < 0 and a > 0 : let (q,r) = div_eucl a (-b) in + if b < 0 and a > 0 : let (q,r) = div_eucl a (-b) in if r = 0 then (-q,0) else (-(q+1),b+r) - In other word, when b is non-zero, q is chosen to be the greatest integer - smaller or equal to a/b. And sgn(r)=sgn(b) and |r| < |b| (at least when - r is not null). + In other word, when b is non-zero, q is chosen to be the greatest integer + smaller or equal to a/b. And sgn(r)=sgn(b) and |r| < |b| (at least when + r is not null). *) (* Nota: At least two others conventions also exist for euclidean division. - They all satify the equation a=b*q+r, but differ on the choice of (q,r) + They all satify the equation a=b*q+r, but differ on the choice of (q,r) on negative numbers. * Ocaml uses Round-Toward-Zero division: (-a)/b = a/(-b) = -(a/b). Hence (-a) mod b = - (a mod b) a mod (-b) = a mod b - And: |r| < |b| and sgn(r) = sgn(a) (notice the a here instead of b). + And: |r| < |b| and sgn(r) = sgn(a) (notice the a here instead of b). - * Another solution is to always pick a non-negative remainder: + * Another solution is to always pick a non-negative remainder: a=b*q+r with 0 <= r < |b| *) @@ -113,7 +113,7 @@ Definition Zdiv_eucl (a b:Z) : Z * Z := Definition Zdiv (a b:Z) : Z := let (q, _) := Zdiv_eucl a b in q. -Definition Zmod (a b:Z) : Z := let (_, r) := Zdiv_eucl a b in r. +Definition Zmod (a b:Z) : Z := let (_, r) := Zdiv_eucl a b in r. (** Syntax *) @@ -122,7 +122,7 @@ Infix "mod" := Zmod (at level 40, no associativity) : Z_scope. (* Tests: -Eval compute in (Zdiv_eucl 7 3). +Eval compute in (Zdiv_eucl 7 3). Eval compute in (Zdiv_eucl (-7) 3). @@ -133,7 +133,7 @@ Eval compute in (Zdiv_eucl (-7) (-3)). *) -(** * Main division theorem *) +(** * Main division theorem *) (** First a lemma for two positive arguments *) @@ -170,7 +170,7 @@ Theorem Z_div_mod : Proof. intros a b; case a; case b; try (simpl in |- *; intros; omega). unfold Zdiv_eucl in |- *; intros; apply Z_div_mod_POS; trivial. - + intros; discriminate. intros. @@ -179,25 +179,25 @@ Proof. case (Zdiv_eucl_POS p0 (Zpos p)). intros z z0. case z0. - + intros [H1 H2]. split; trivial. change (Zneg p0) with (- Zpos p0); rewrite H1; ring. - + intros p1 [H1 H2]. split; trivial. change (Zneg p0) with (- Zpos p0); rewrite H1; ring. generalize (Zorder.Zgt_pos_0 p1); omega. - + intros p1 [H1 H2]. split; trivial. change (Zneg p0) with (- Zpos p0); rewrite H1; ring. generalize (Zorder.Zlt_neg_0 p1); omega. - + intros; discriminate. Qed. -(** For stating the fully general result, let's give a short name +(** For stating the fully general result, let's give a short name to the condition on the remainder. *) Definition Remainder r b := 0 <= r < b \/ b < r <= 0. @@ -206,7 +206,7 @@ Definition Remainder r b := 0 <= r < b \/ b < r <= 0. Definition Remainder_alt r b := Zabs r < Zabs b /\ Zsgn r <> - Zsgn b. -(* In the last formulation, [ Zsgn r <> - Zsgn b ] is less nice than saying +(* In the last formulation, [ Zsgn r <> - Zsgn b ] is less nice than saying [ Zsgn r = Zsgn b ], but at least it works even when [r] is null. *) Lemma Remainder_equiv : forall r b, Remainder r b <-> Remainder_alt r b. @@ -250,7 +250,7 @@ Proof. destruct Zdiv_eucl_POS as (q,r). destruct r as [|r|r]; change (Zneg b) with (-Zpos b). rewrite Zmult_opp_comm; omega with *. - rewrite <- Zmult_opp_comm, Zmult_plus_distr_r; + rewrite <- Zmult_opp_comm, Zmult_plus_distr_r; repeat rewrite Zmult_opp_comm; omega. rewrite Zmult_opp_comm; omega with *. Qed. @@ -331,14 +331,14 @@ elim (Zlt_not_le (Zabs (r2 - r1)) (Zabs b)). omega with *. replace (r2-r1) with (b*(q1-q2)) by (rewrite Zmult_minus_distr_l; omega). replace (Zabs b) with ((Zabs b)*1) by ring. -rewrite Zabs_Zmult. +rewrite Zabs_Zmult. apply Zmult_le_compat_l; auto with *. omega with *. Qed. Theorem Zdiv_mod_unique_2 : forall b q1 q2 r1 r2:Z, - Remainder r1 b -> Remainder r2 b -> + Remainder r1 b -> Remainder r2 b -> b*q1+r1 = b*q2+r2 -> q1=q2 /\ r1=r2. Proof. unfold Remainder. @@ -356,7 +356,7 @@ omega with *. Qed. Theorem Zdiv_unique_full: - forall a b q r, Remainder r b -> + forall a b q r, Remainder r b -> a = b*q + r -> q = a/b. Proof. intros. @@ -368,7 +368,7 @@ Proof. Qed. Theorem Zdiv_unique: - forall a b q r, 0 <= r < b -> + forall a b q r, 0 <= r < b -> a = b*q + r -> q = a/b. Proof. intros; eapply Zdiv_unique_full; eauto. @@ -425,7 +425,7 @@ Proof. intros; symmetry; apply Zdiv_unique with 0; auto with zarith. Qed. -Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r +Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r : zarith. Lemma Zdiv_1_l: forall a, 1 < a -> 1/a = 0. @@ -460,7 +460,7 @@ Qed. Lemma Z_div_mult_full : forall a b:Z, b <> 0 -> (a*b)/b = a. Proof. - intros; symmetry; apply Zdiv_unique_full with 0; auto with zarith; + intros; symmetry; apply Zdiv_unique_full with 0; auto with zarith; [ red; omega | ring]. Qed. @@ -485,7 +485,7 @@ Proof. intros; generalize (Z_div_pos a b H); auto with zarith. Qed. -(** As soon as the divisor is greater or equal than 2, +(** As soon as the divisor is greater or equal than 2, the division is strictly decreasing. *) Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> a/b < a. @@ -530,7 +530,7 @@ Proof. intro. absurd (b - a >= 1). omega. - replace (b-a) with (c * (b/c-a/c) + b mod c - a mod c) by + replace (b-a) with (c * (b/c-a/c) + b mod c - a mod c) by (symmetry; pattern a at 1; rewrite H2; pattern b at 1; rewrite H0; ring). assert (c * (b / c - a / c) >= c * 1). apply Zmult_ge_compat_l. @@ -580,7 +580,7 @@ Qed. (** A modulo cannot grow beyond its starting point. *) Theorem Zmod_le: forall a b, 0 < b -> 0 <= a -> a mod b <= a. -Proof. +Proof. intros a b H1 H2; case (Zle_or_lt b a); intros H3. case (Z_mod_lt a b); auto with zarith. rewrite Zmod_small; auto with zarith. @@ -619,7 +619,7 @@ Qed. Lemma Zdiv_le_compat_l: forall p q r, 0 <= p -> 0 < q < r -> p / r <= p / q. Proof. - intros p q r H H1. + intros p q r H H1. apply Zdiv_le_lower_bound; auto with zarith. rewrite Zmult_comm. pattern p at 2; rewrite (Z_div_mod_eq p r); auto with zarith. @@ -629,11 +629,11 @@ Proof. case (Z_mod_lt p r); auto with zarith. Qed. -Theorem Zdiv_sgn: forall a b, +Theorem Zdiv_sgn: forall a b, 0 <= Zsgn (a/b) * Zsgn a * Zsgn b. Proof. - destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; - generalize (Z_div_pos (Zpos a) (Zpos b)); unfold Zdiv, Zdiv_eucl; + destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; + generalize (Z_div_pos (Zpos a) (Zpos b)); unfold Zdiv, Zdiv_eucl; destruct Zdiv_eucl_POS as (q,r); destruct r; omega with *. Qed. @@ -661,12 +661,12 @@ Qed. Theorem Z_div_plus_full_l: forall a b c : Z, b <> 0 -> (a * b + c) / b = a + c / b. Proof. intros a b c H; rewrite Zplus_comm; rewrite Z_div_plus_full; - try apply Zplus_comm; auto with zarith. + try apply Zplus_comm; auto with zarith. Qed. (** [Zopp] and [Zdiv], [Zmod]. - Due to the choice of convention for our Euclidean division, - some of the relations about [Zopp] and divisions are rather complex. *) + Due to the choice of convention for our Euclidean division, + some of the relations about [Zopp] and divisions are rather complex. *) Lemma Zdiv_opp_opp : forall a b:Z, (-a)/(-b) = a/b. Proof. @@ -695,7 +695,7 @@ Proof. ring. Qed. -Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 -> +Lemma Z_mod_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a) mod b = b - (a mod b). Proof. intros. @@ -714,7 +714,7 @@ Proof. rewrite Z_mod_zero_opp_full; auto. Qed. -Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 -> +Lemma Z_mod_nz_opp_r : forall a b:Z, a mod b <> 0 -> a mod (-b) = (a mod b) - b. Proof. intros. @@ -733,7 +733,7 @@ Proof. rewrite H; ring. Qed. -Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> +Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a)/b = -(a/b)-1. Proof. intros. @@ -751,7 +751,7 @@ Proof. rewrite Z_div_zero_opp_full; auto. Qed. -Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 -> +Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 -> a/(-b) = -(a/b)-1. Proof. intros. @@ -762,7 +762,7 @@ Qed. (** Cancellations. *) -Lemma Zdiv_mult_cancel_r : forall a b c:Z, +Lemma Zdiv_mult_cancel_r : forall a b c:Z, c <> 0 -> (a*c)/(b*c) = a/b. Proof. assert (X: forall a b c, b > 0 -> c > 0 -> (a*c) / (b*c) = a / b). @@ -774,17 +774,17 @@ assert (X: forall a b c, b > 0 -> c > 0 -> (a*c) / (b*c) = a / b). apply Zmult_lt_compat_r; auto with zarith. pattern a at 1; rewrite (Z_div_mod_eq a b Hb); ring. intros a b c Hc. -destruct (Z_dec b 0) as [Hb|Hb]. +destruct (Z_dec b 0) as [Hb|Hb]. destruct Hb as [Hb|Hb]; destruct (not_Zeq_inf _ _ Hc); auto with *. -rewrite <- (Zdiv_opp_opp a), <- (Zmult_opp_opp b), <-(Zmult_opp_opp a); +rewrite <- (Zdiv_opp_opp a), <- (Zmult_opp_opp b), <-(Zmult_opp_opp a); auto with *. -rewrite <- (Zdiv_opp_opp a), <- Zdiv_opp_opp, Zopp_mult_distr_l, +rewrite <- (Zdiv_opp_opp a), <- Zdiv_opp_opp, Zopp_mult_distr_l, Zopp_mult_distr_l; auto with *. rewrite <- Zdiv_opp_opp, Zopp_mult_distr_r, Zopp_mult_distr_r; auto with *. rewrite Hb; simpl; do 2 rewrite Zdiv_0_r; auto. Qed. -Lemma Zdiv_mult_cancel_l : forall a b c:Z, +Lemma Zdiv_mult_cancel_l : forall a b c:Z, c<>0 -> (c*a)/(c*b) = a/b. Proof. intros. @@ -792,7 +792,7 @@ Proof. apply Zdiv_mult_cancel_r; auto. Qed. -Lemma Zmult_mod_distr_l: forall a b c, +Lemma Zmult_mod_distr_l: forall a b c, (c*a) mod (c*b) = c * (a mod b). Proof. intros; destruct (Z_eq_dec c 0) as [Hc|Hc]. @@ -807,7 +807,7 @@ Proof. ring. Qed. -Lemma Zmult_mod_distr_r: forall a b c, +Lemma Zmult_mod_distr_r: forall a b c, (a*c) mod (b*c) = (a mod b) * c. Proof. intros; repeat rewrite (fun x => (Zmult_comm x c)). @@ -975,8 +975,8 @@ Proof. apply Zplus_le_compat;auto with zarith. destruct (Z_mod_lt (a/b) c);auto with zarith. replace (b * (c - 1) + (b - 1)) with (b*c-1);try ring;auto with zarith. - intro H1; - assert (H2: c <> 0) by auto with zarith; + intro H1; + assert (H2: c <> 0) by auto with zarith; rewrite (Zmult_integral_l _ _ H2 H1) in H; auto with zarith. Qed. @@ -989,7 +989,7 @@ Theorem Zdiv_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b. Proof. intros a b c H1 H2 H3. - destruct (Zle_lt_or_eq _ _ H2); + destruct (Zle_lt_or_eq _ _ H2); [ | subst; rewrite Zdiv_0_r, Zdiv_0_r, Zmult_0_r; auto]. case (Z_mod_lt a b); auto with zarith; intros Hu1 Hu2. case (Z_mod_lt c b); auto with zarith; intros Hv1 Hv2. @@ -1005,14 +1005,14 @@ Proof. apply (Zmod_le ((c mod b) * (a mod b)) b); auto with zarith. apply Zmult_le_compat_r; auto with zarith. apply (Zmod_le c b); auto. - pattern (c * a) at 1; rewrite (Z_div_mod_eq (c * a) b); try ring; + pattern (c * a) at 1; rewrite (Z_div_mod_eq (c * a) b); try ring; auto with zarith. pattern a at 1; rewrite (Z_div_mod_eq a b); try ring; auto with zarith. Qed. (** Zmod is related to divisibility (see more in Znumtheory) *) -Lemma Zmod_divides : forall a b, b<>0 -> +Lemma Zmod_divides : forall a b, b<>0 -> (a mod b = 0 <-> exists c, a = b*c). Proof. split; intros. @@ -1159,11 +1159,11 @@ Qed. Implicit Arguments Zdiv_eucl_extended. (** A third convention: Ocaml. - + See files ZOdiv_def.v and ZOdiv.v. - + Ocaml uses Round-Toward-Zero division: (-a)/b = a/(-b) = -(a/b). Hence (-a) mod b = - (a mod b) a mod (-b) = a mod b - And: |r| < |b| and sgn(r) = sgn(a) (notice the a here instead of b). + And: |r| < |b| and sgn(r) = sgn(a) (notice the a here instead of b). *) diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index a0a75cf1eb..091310439d 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -96,32 +96,32 @@ Qed. Lemma Zeven_Sn : forall n:Z, Zodd n -> Zeven (Zsucc n). Proof. intro z; destruct z; unfold Zsucc in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. + [ idtac | destruct p | destruct p ]; simpl in |- *; + trivial. unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. Qed. Lemma Zodd_Sn : forall n:Z, Zeven n -> Zodd (Zsucc n). Proof. intro z; destruct z; unfold Zsucc in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. + [ idtac | destruct p | destruct p ]; simpl in |- *; + trivial. unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. Qed. Lemma Zeven_pred : forall n:Z, Zodd n -> Zeven (Zpred n). Proof. intro z; destruct z; unfold Zpred in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. + [ idtac | destruct p | destruct p ]; simpl in |- *; + trivial. unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. Qed. Lemma Zodd_pred : forall n:Z, Zeven n -> Zodd (Zpred n). Proof. intro z; destruct z; unfold Zpred in |- *; - [ idtac | destruct p | destruct p ]; simpl in |- *; - trivial. + [ idtac | destruct p | destruct p ]; simpl in |- *; + trivial. unfold Pdouble_minus_one in |- *; case p; simpl in |- *; auto. Qed. @@ -132,7 +132,7 @@ Hint Unfold Zeven Zodd: zarith. (** * Definition of [Zdiv2] and properties wrt [Zeven] and [Zodd] *) (** [Zdiv2] is defined on all [Z], but notice that for odd negative - integers it is not the euclidean quotient: in that case we have + integers it is not the euclidean quotient: in that case we have [n = 2*(n/2)-1] *) Definition Zdiv2 (z:Z) := @@ -200,7 +200,7 @@ Proof. intros x. elim (Z_modulo_2 x); intros [y Hy]; rewrite Zmult_comm in Hy; rewrite <- Zplus_diag_eq_mult_2 in Hy. - exists (y, y); split. + exists (y, y); split. assumption. left; reflexivity. exists (y, (y + 1)%Z); split. @@ -239,7 +239,7 @@ Proof. destruct p; simpl; auto. Qed. -Theorem Zeven_plus_Zodd: forall a b, +Theorem Zeven_plus_Zodd: forall a b, Zeven a -> Zodd b -> Zodd (a + b). Proof. intros a b H1 H2; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto. @@ -257,13 +257,13 @@ Proof. apply Zmult_plus_distr_r; auto. Qed. -Theorem Zodd_plus_Zeven: forall a b, +Theorem Zodd_plus_Zeven: forall a b, Zodd a -> Zeven b -> Zodd (a + b). Proof. intros a b H1 H2; rewrite Zplus_comm; apply Zeven_plus_Zodd; auto. Qed. -Theorem Zodd_plus_Zodd: forall a b, +Theorem Zodd_plus_Zodd: forall a b, Zodd a -> Zodd b -> Zeven (a + b). Proof. intros a b H1 H2; case Zodd_ex with (1 := H1); intros x H3; try rewrite H3; auto. @@ -276,7 +276,7 @@ Proof. repeat rewrite <- Zplus_assoc; auto. Qed. -Theorem Zeven_mult_Zeven_l: forall a b, +Theorem Zeven_mult_Zeven_l: forall a b, Zeven a -> Zeven (a * b). Proof. intros a b H1; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto. @@ -285,7 +285,7 @@ Proof. apply Zmult_assoc. Qed. -Theorem Zeven_mult_Zeven_r: forall a b, +Theorem Zeven_mult_Zeven_r: forall a b, Zeven b -> Zeven (a * b). Proof. intros a b H1; case Zeven_ex with (1 := H1); intros x H3; try rewrite H3; auto. @@ -296,10 +296,10 @@ Proof. rewrite (Zmult_comm 2 a); auto. Qed. -Hint Rewrite Zmult_plus_distr_r Zmult_plus_distr_l +Hint Rewrite Zmult_plus_distr_r Zmult_plus_distr_l Zplus_assoc Zmult_1_r Zmult_1_l : Zexpand. -Theorem Zodd_mult_Zodd: forall a b, +Theorem Zodd_mult_Zodd: forall a b, Zodd a -> Zodd b -> Zodd (a * b). Proof. intros a b H1 H2; case Zodd_ex with (1 := H1); intros x H3; try rewrite H3; auto. @@ -308,7 +308,7 @@ Proof. (* ring part *) autorewrite with Zexpand; f_equal. repeat rewrite <- Zplus_assoc; f_equal. - repeat rewrite <- Zmult_assoc; f_equal. + repeat rewrite <- Zmult_assoc; f_equal. repeat rewrite Zmult_assoc; f_equal; apply Zmult_comm. Qed. diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v index 42feedae03..5123621907 100644 --- a/theories/ZArith/Zgcd_alt.v +++ b/theories/ZArith/Zgcd_alt.v @@ -30,7 +30,7 @@ Open Scope Z_scope. (** In Coq, we need to control the number of iteration of modulo. For that, we use an explicit measure in [nat], and we prove later - that using [2*d] is enough, where [d] is the number of binary + that using [2*d] is enough, where [d] is the number of binary digits of the first argument. *) Fixpoint Zgcdn (n:nat) : Z -> Z -> Z := fun a b => @@ -43,17 +43,17 @@ Open Scope Z_scope. end end. - Definition Zgcd_bound (a:Z) := + Definition Zgcd_bound (a:Z) := match a with | Z0 => S O | Zpos p => let n := Psize p in (n+n)%nat | Zneg p => let n := Psize p in (n+n)%nat end. - + Definition Zgcd_alt a b := Zgcdn (Zgcd_bound a) a b. - + (** A first obvious fact : [Zgcd a b] is positive. *) - + Lemma Zgcdn_pos : forall n a b, 0 <= Zgcdn n a b. Proof. @@ -61,16 +61,16 @@ Open Scope Z_scope. simpl; auto with zarith. destruct a; simpl; intros; auto with zarith; auto. Qed. - + Lemma Zgcd_alt_pos : forall a b, 0 <= Zgcd_alt a b. Proof. intros; unfold Zgcd; apply Zgcdn_pos; auto. Qed. - + (** We now prove that Zgcd is indeed a gcd. *) - + (** 1) We prove a weaker & easier bound. *) - + Lemma Zgcdn_linear_bound : forall n a b, Zabs a < Z_of_nat n -> Zis_gcd a b (Zgcdn n a b). Proof. @@ -93,17 +93,17 @@ Open Scope Z_scope. apply Zis_gcd_minus; apply Zis_gcd_sym. apply Zis_gcd_for_euclid2; auto. Qed. - + (** 2) For Euclid's algorithm, the worst-case situation corresponds to Fibonacci numbers. Let's define them: *) - + Fixpoint fibonacci (n:nat) : Z := match n with | O => 1 | S O => 1 | S (S n as p) => fibonacci p + fibonacci n end. - + Lemma fibonacci_pos : forall n, 0 <= fibonacci n. Proof. cut (forall N n, (n 0<=fibonacci n). @@ -118,7 +118,7 @@ Open Scope Z_scope. change (0 <= fibonacci (S n) + fibonacci n). generalize (IHN n) (IHN (S n)); omega. Qed. - + Lemma fibonacci_incr : forall n m, (n<=m)%nat -> fibonacci n <= fibonacci m. Proof. @@ -131,11 +131,11 @@ Open Scope Z_scope. change (fibonacci (S m) <= fibonacci (S m)+fibonacci m). generalize (fibonacci_pos m); omega. Qed. - + (** 3) We prove that fibonacci numbers are indeed worst-case: for a given number [n], if we reach a conclusion about [gcd(a,b)] in exactly [n+1] loops, then [fibonacci (n+1)<=a /\ fibonacci(n+2)<=b] *) - + Lemma Zgcdn_worst_is_fibonacci : forall n a b, 0 < a < b -> Zis_gcd a b (Zgcdn (S n) a b) -> @@ -192,9 +192,9 @@ Open Scope Z_scope. simpl in H5. elim H5; auto. Qed. - + (** 3b) We reformulate the previous result in a more positive way. *) - + Lemma Zgcdn_ok_before_fibonacci : forall n a b, 0 < a < b -> a < fibonacci (S n) -> Zis_gcd a b (Zgcdn n a b). @@ -224,32 +224,32 @@ Open Scope Z_scope. replace (Zgcdn n (Zpos p) b) with (Zgcdn (S n) (Zpos p) b); auto. generalize (H2 H3); clear H2 H3; omega. Qed. - + (** 4) The proposed bound leads to a fibonacci number that is big enough. *) - + Lemma Zgcd_bound_fibonacci : forall a, 0 < a -> a < fibonacci (Zgcd_bound a). Proof. destruct a; [omega| | intro H; discriminate]. intros _. - induction p; [ | | compute; auto ]; + induction p; [ | | compute; auto ]; simpl Zgcd_bound in *; - rewrite plus_comm; simpl plus; + rewrite plus_comm; simpl plus; set (n:= (Psize p+Psize p)%nat) in *; simpl; assert (n <> O) by (unfold n; destruct p; simpl; auto). - + destruct n as [ |m]; [elim H; auto| ]. generalize (fibonacci_pos m); rewrite Zpos_xI; omega. destruct n as [ |m]; [elim H; auto| ]. generalize (fibonacci_pos m); rewrite Zpos_xO; omega. Qed. - + (* 5) the end: we glue everything together and take care of situations not corresponding to [0 + forall n a b, (Zgcd_bound a <= n)%nat -> Zis_gcd a b (Zgcdn n a b). Proof. destruct a; intros. @@ -261,7 +261,7 @@ Open Scope Z_scope. simpl Zgcd_bound in *. remember (Psize p+Psize p)%nat as m. assert (1 < m)%nat. - rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; + rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; auto with arith. destruct m as [ |m]; [inversion H0; auto| ]. destruct n as [ |n]; [inversion H; auto| ]. @@ -285,7 +285,7 @@ Open Scope Z_scope. simpl Zgcd_bound in *. remember (Psize p+Psize p)%nat as m. assert (1 < m)%nat. - rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; + rewrite Heqm; destruct p; simpl; rewrite 1? plus_comm; auto with arith. destruct m as [ |m]; [inversion H0; auto| ]. destruct n as [ |n]; [inversion H; auto| ]. @@ -307,7 +307,7 @@ Open Scope Z_scope. destruct n as [ |n]; [elimtype False; omega| ]. simpl; apply Zis_gcd_sym; apply Zis_gcd_0. Qed. - + Lemma Zgcd_is_gcd : forall a b, Zis_gcd a b (Zgcd_alt a b). Proof. diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v index e2b435abad..5459e693df 100644 --- a/theories/ZArith/Zhints.v +++ b/theories/ZArith/Zhints.v @@ -40,27 +40,27 @@ Require Import Wf_Z. (** No subgoal or smaller subgoals *) -Hint Resolve +Hint Resolve (** ** Reversible simplification lemmas (no loss of information) *) (** Should clearly be declared as hints *) - + (** Lemmas ending by eq *) Zsucc_eq_compat (* :(n,m:Z)`n = m`->`(Zs n) = (Zs m)` *) - + (** Lemmas ending by Zgt *) Zsucc_gt_compat (* :(n,m:Z)`m > n`->`(Zs m) > (Zs n)` *) Zgt_succ (* :(n:Z)`(Zs n) > n` *) Zorder.Zgt_pos_0 (* :(p:positive)`(POS p) > 0` *) Zplus_gt_compat_l (* :(n,m,p:Z)`n > m`->`p+n > p+m` *) Zplus_gt_compat_r (* :(n,m,p:Z)`n > m`->`n+p > m+p` *) - + (** Lemmas ending by Zlt *) Zlt_succ (* :(n:Z)`n < (Zs n)` *) Zsucc_lt_compat (* :(n,m:Z)`n < m`->`(Zs n) < (Zs m)` *) Zlt_pred (* :(n:Z)`(Zpred n) < n` *) Zplus_lt_compat_l (* :(n,m,p:Z)`n < m`->`p+n < p+m` *) Zplus_lt_compat_r (* :(n,m,p:Z)`n < m`->`n+p < m+p` *) - + (** Lemmas ending by Zle *) Zle_0_nat (* :(n:nat)`0 <= (inject_nat n)` *) Zorder.Zle_0_pos (* :(p:positive)`0 <= (POS p)` *) @@ -73,24 +73,24 @@ Hint Resolve Zplus_le_compat_l (* :(n,m,p:Z)`n <= m`->`p+n <= p+m` *) Zplus_le_compat_r (* :(a,b,c:Z)`a <= b`->`a+c <= b+c` *) Zabs_pos (* :(x:Z)`0 <= |x|` *) - + (** ** Irreversible simplification lemmas *) (** Probably to be declared as hints, when no other simplification is possible *) - + (** Lemmas ending by eq *) BinInt.Z_eq_mult (* :(x,y:Z)`y = 0`->`y*x = 0` *) Zplus_eq_compat (* :(n,m,p,q:Z)`n = m`->`p = q`->`n+p = m+q` *) - + (** Lemmas ending by Zge *) Zorder.Zmult_ge_compat_r (* :(a,b,c:Z)`a >= b`->`c >= 0`->`a*c >= b*c` *) Zorder.Zmult_ge_compat_l (* :(a,b,c:Z)`a >= b`->`c >= 0`->`c*a >= c*b` *) Zorder.Zmult_ge_compat (* : (a,b,c,d:Z)`a >= c`->`b >= d`->`c >= 0`->`d >= 0`->`a*b >= c*d` *) - + (** Lemmas ending by Zlt *) Zorder.Zmult_gt_0_compat (* :(a,b:Z)`a > 0`->`b > 0`->`a*b > 0` *) Zlt_lt_succ (* :(n,m:Z)`n < m`->`n < (Zs m)` *) - + (** Lemmas ending by Zle *) Zorder.Zmult_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x*y` *) Zorder.Zmult_le_compat_r (* :(a,b,c:Z)`a <= b`->`0 <= c`->`a*c <= b*c` *) @@ -98,9 +98,9 @@ Hint Resolve Zplus_le_0_compat (* :(x,y:Z)`0 <= x`->`0 <= y`->`0 <= x+y` *) Zle_le_succ (* :(x,y:Z)`x <= y`->`x <= (Zs y)` *) Zplus_le_compat (* :(n,m,p,q:Z)`n <= m`->`p <= q`->`n+p <= m+q` *) - + : zarith. - + (**********************************************************************) (** * Reversible lemmas relating operators *) (** Probably to be declared as hints but need to define precedences *) @@ -108,7 +108,7 @@ Hint Resolve (** ** Conversion between comparisons/predicates and arithmetic operators *) (** Lemmas ending by eq *) -(** +(** << Zegal_left: (x,y:Z)`x = y`->`x+(-y) = 0` Zabs_eq: (x:Z)`0 <= x`->`|x| = x` @@ -118,7 +118,7 @@ Zodd_div2: (x:Z)`x >= 0`->(Zodd x)->`x = 2*(Zdiv2 x)+1` *) (** Lemmas ending by Zgt *) -(** +(** << Zgt_left_rev: (x,y:Z)`x+(-y) > 0`->`x > y` Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0` @@ -126,7 +126,7 @@ Zgt_left_gt: (x,y:Z)`x > y`->`x+(-y) > 0` *) (** Lemmas ending by Zlt *) -(** +(** << Zlt_left_rev: (x,y:Z)`0 < y+(-x)`->`x < y` Zlt_left_lt: (x,y:Z)`x < y`->`0 < y+(-x)` @@ -135,7 +135,7 @@ Zlt_O_minus_lt: (n,m:Z)`0 < n-m`->`m < n` *) (** Lemmas ending by Zle *) -(** +(** << Zle_left: (x,y:Z)`x <= y`->`0 <= y+(-x)` Zle_left_rev: (x,y:Z)`0 <= y+(-x)`->`x <= y` @@ -148,35 +148,35 @@ Zgt_left: (x,y:Z)`x > y`->`0 <= x+(-1)+(-y)` (** ** Conversion between nat comparisons and Z comparisons *) (** Lemmas ending by eq *) -(** +(** << inj_eq: (x,y:nat)x=y->`(inject_nat x) = (inject_nat y)` >> *) (** Lemmas ending by Zge *) -(** +(** << inj_ge: (x,y:nat)(ge x y)->`(inject_nat x) >= (inject_nat y)` >> *) (** Lemmas ending by Zgt *) -(** +(** << inj_gt: (x,y:nat)(gt x y)->`(inject_nat x) > (inject_nat y)` >> *) (** Lemmas ending by Zlt *) -(** +(** << inj_lt: (x,y:nat)(lt x y)->`(inject_nat x) < (inject_nat y)` >> *) (** Lemmas ending by Zle *) -(** +(** << inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)` >> @@ -185,7 +185,7 @@ inj_le: (x,y:nat)(le x y)->`(inject_nat x) <= (inject_nat y)` (** ** Conversion between comparisons *) (** Lemmas ending by Zge *) -(** +(** << not_Zlt: (x,y:Z)~`x < y`->`x >= y` Zle_ge: (m,n:Z)`m <= n`->`n >= m` @@ -193,7 +193,7 @@ Zle_ge: (m,n:Z)`m <= n`->`n >= m` *) (** Lemmas ending by Zgt *) -(** +(** << Zle_gt_S: (n,p:Z)`n <= p`->`(Zs p) > n` not_Zle: (x,y:Z)~`x <= y`->`x > y` @@ -203,7 +203,7 @@ Zle_S_gt: (n,m:Z)`(Zs n) <= m`->`m > n` *) (** Lemmas ending by Zlt *) -(** +(** << not_Zge: (x,y:Z)~`x >= y`->`x < y` Zgt_lt: (m,n:Z)`m > n`->`n < m` @@ -212,7 +212,7 @@ Zle_lt_n_Sm: (n,m:Z)`n <= m`->`n < (Zs m)` *) (** Lemmas ending by Zle *) -(** +(** << Zlt_ZERO_pred_le_ZERO: (x:Z)`0 < x`->`0 <= (Zpred x)` not_Zgt: (x,y:Z)~`x > y`->`x <= y` @@ -230,7 +230,7 @@ Zle_refl: (n,m:Z)`n = m`->`n <= m` (** useful with clear precedences *) (** Lemmas ending by Zlt *) -(** +(** << Zlt_le_reg :(a,b,c,d:Z)`a < b`->`c <= d`->`a+c < b+d` Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d` @@ -240,21 +240,21 @@ Zle_lt_reg : (a,b,c,d:Z)`a <= b`->`c < d`->`a+c < b+d` (** ** What is decreasing here ? *) (** Lemmas ending by eq *) -(** +(** << Zplus_minus: (n,m,p:Z)`n = m+p`->`p = n-m` >> *) (** Lemmas ending by Zgt *) -(** +(** << Zgt_pred: (n,p:Z)`p > (Zs n)`->`(Zpred p) > n` >> *) (** Lemmas ending by Zlt *) -(** +(** << Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)` >> @@ -266,8 +266,8 @@ Zlt_pred: (n,p:Z)`(Zs n) < p`->`n < (Zpred p)` (** ** Bottom-up simplification: should be used *) (** Lemmas ending by eq *) -(** -<< +(** +<< Zeq_add_S: (n,m:Z)`(Zs n) = (Zs m)`->`n = m` Zsimpl_plus_l: (n,m,p:Z)`n+m = n+p`->`m = p` Zplus_unit_left: (n,m:Z)`n+0 = m`->`n = m` @@ -276,21 +276,21 @@ Zplus_unit_right: (n,m:Z)`n = m+0`->`n = m` *) (** Lemmas ending by Zgt *) -(** -<< +(** +<< Zsimpl_gt_plus_l: (n,m,p:Z)`p+n > p+m`->`n > m` Zsimpl_gt_plus_r: (n,m,p:Z)`n+p > m+p`->`n > m` -Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n` ->> +Zgt_S_n: (n,p:Z)`(Zs p) > (Zs n)`->`p > n` +>> *) (** Lemmas ending by Zlt *) -(** -<< +(** +<< Zsimpl_lt_plus_l: (n,m,p:Z)`p+n < p+m`->`n < m` Zsimpl_lt_plus_r: (n,m,p:Z)`n+p < m+p`->`n < m` -Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m` ->> +Zlt_S_n: (n,m:Z)`(Zs n) < (Zs m)`->`n < m` +>> *) (** Lemmas ending by Zle *) @@ -301,7 +301,7 @@ Zle_S_n: (n,m:Z)`(Zs m) <= (Zs n)`->`m <= n` >> *) (** ** Bottom-up irreversible (syntactic) simplification *) (** Lemmas ending by Zle *) -(** +(** << Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m` >> @@ -310,78 +310,78 @@ Zle_trans_S: (n,m:Z)`(Zs n) <= m`->`n <= m` (** ** Other unclearly simplifying lemmas *) (** Lemmas ending by Zeq *) -(** -<< -Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0` ->> +(** +<< +Zmult_eq: (x,y:Z)`x <> 0`->`y*x = 0`->`y = 0` +>> *) (* Lemmas ending by Zgt *) -(** -<< +(** +<< Zmult_gt: (x,y:Z)`x > 0`->`x*y > 0`->`y > 0` >> *) (* Lemmas ending by Zlt *) -(** -<< +(** +<< pZmult_lt: (x,y:Z)`x > 0`->`0 < y*x`->`0 < y` ->> +>> *) (* Lemmas ending by Zle *) -(** -<< +(** +<< Zmult_le: (x,y:Z)`x > 0`->`0 <= y*x`->`0 <= y` OMEGA1: (x,y:Z)`x = y`->`0 <= x`->`0 <= y` ->> +>> *) (**********************************************************************) (** * Irreversible lemmas with meta-variables *) -(** To be used by EAuto *) +(** To be used by EAuto *) (* Hints Immediate *) (** Lemmas ending by eq *) -(** -<< +(** +<< Zle_antisym: (n,m:Z)`n <= m`->`m <= n`->`n = m` >> *) (** Lemmas ending by Zge *) -(** -<< +(** +<< Zge_trans: (n,m,p:Z)`n >= m`->`m >= p`->`n >= p` ->> +>> *) (** Lemmas ending by Zgt *) -(** -<< +(** +<< Zgt_trans: (n,m,p:Z)`n > m`->`m > p`->`n > p` Zgt_trans_S: (n,m,p:Z)`(Zs n) > m`->`m > p`->`n > p` Zle_gt_trans: (n,m,p:Z)`m <= n`->`m > p`->`n > p` Zgt_le_trans: (n,m,p:Z)`n > m`->`p <= m`->`n > p` ->> +>> *) (** Lemmas ending by Zlt *) -(** -<< +(** +<< Zlt_trans: (n,m,p:Z)`n < m`->`m < p`->`n < p` Zlt_le_trans: (n,m,p:Z)`n < m`->`m <= p`->`n < p` Zle_lt_trans: (n,m,p:Z)`n <= m`->`m < p`->`n < p` ->> +>> *) (** Lemmas ending by Zle *) -(** -<< +(** +<< Zle_trans: (n,m,p:Z)`n <= m`->`m <= p`->`n <= p` ->> +>> *) diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v index 68e9c77337..70a959c2a3 100644 --- a/theories/ZArith/Zlogarithm.v +++ b/theories/ZArith/Zlogarithm.v @@ -9,7 +9,7 @@ (*i $Id$ i*) (**********************************************************************) -(** The integer logarithms with base 2. +(** The integer logarithms with base 2. There are three logarithms, depending on the rounding of the real 2-based logarithm: @@ -27,7 +27,7 @@ Require Import Zpower. Open Local Scope Z_scope. Section Log_pos. (* Log of positive integers *) - + (** First we build [log_inf] and [log_sup] *) Fixpoint log_inf (p:positive) : Z := @@ -43,12 +43,12 @@ Section Log_pos. (* Log of positive integers *) | xO n => Zsucc (log_sup n) (* 2n *) | xI n => Zsucc (Zsucc (log_inf n)) (* 2n+1 *) end. - + Hint Unfold log_inf log_sup. - - (** Then we give the specifications of [log_inf] and [log_sup] + + (** Then we give the specifications of [log_inf] and [log_sup] and prove their validity *) - + Hint Resolve Zle_trans: zarith. Theorem log_inf_correct : @@ -100,11 +100,11 @@ Section Log_pos. (* Log of positive integers *) [ left; simpl in |- *; rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0)); - rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); + rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); auto | right; simpl in |- *; rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); - rewrite BinInt.Zpos_xO; unfold Zsucc in |- *; + rewrite BinInt.Zpos_xO; unfold Zsucc in |- *; omega ] | left; auto ]. Qed. @@ -141,7 +141,7 @@ Section Log_pos. (* Log of positive integers *) | xI xH => 2 | xO y => Zsucc (log_near y) | xI y => Zsucc (log_near y) - end. + end. Theorem log_near_correct1 : forall p:positive, 0 <= log_near p. Proof. @@ -186,7 +186,7 @@ End Log_pos. Section divers. (** Number of significative digits. *) - + Definition N_digits (x:Z) := match x with | Zpos p => log_inf p diff --git a/theories/ZArith/Zmax.v b/theories/ZArith/Zmax.v index 59fcfa4947..413b685a27 100644 --- a/theories/ZArith/Zmax.v +++ b/theories/ZArith/Zmax.v @@ -30,15 +30,15 @@ Proof. intros n m P H1 H2; unfold Zmax in |- *; case (n ?= m); auto with arith. Qed. -Lemma Zmax_case_strong : forall (n m:Z) (P:Z -> Type), +Lemma Zmax_case_strong : forall (n m:Z) (P:Z -> Type), (m<=n -> P n) -> (n<=m -> P m) -> P (Zmax n m). Proof. intros n m P H1 H2; unfold Zmax, Zle, Zge in *. rewrite <- (Zcompare_antisym n m) in H1. - destruct (n ?= m); (apply H1|| apply H2); discriminate. + destruct (n ?= m); (apply H1|| apply H2); discriminate. Qed. -Lemma Zmax_spec : forall x y:Z, +Lemma Zmax_spec : forall x y:Z, x >= y /\ Zmax x y = x \/ x < y /\ Zmax x y = y. Proof. @@ -90,13 +90,13 @@ Qed. Lemma Zmax_comm : forall n m:Z, Zmax n m = Zmax m n. Proof. - intros; do 2 apply Zmax_case_strong; intros; + intros; do 2 apply Zmax_case_strong; intros; apply Zle_antisym; auto with zarith. Qed. Lemma Zmax_assoc : forall n m p:Z, Zmax n (Zmax m p) = Zmax (Zmax n m) p. Proof. - intros n m p; repeat apply Zmax_case_strong; intros; + intros n m p; repeat apply Zmax_case_strong; intros; reflexivity || (try apply Zle_antisym); eauto with zarith. Qed. @@ -114,7 +114,7 @@ Qed. (** * Operations preserving max *) -Lemma Zsucc_max_distr : +Lemma Zsucc_max_distr : forall n m:Z, Zsucc (Zmax n m) = Zmax (Zsucc n) (Zsucc m). Proof. intros n m; unfold Zmax in |- *; rewrite (Zcompare_succ_compat n m); diff --git a/theories/ZArith/Zmin.v b/theories/ZArith/Zmin.v index beb91a738b..fa454fa96e 100644 --- a/theories/ZArith/Zmin.v +++ b/theories/ZArith/Zmin.v @@ -30,12 +30,12 @@ Unboxed Definition Zmin (n m:Z) := (** * Characterization of the minimum on binary integer numbers *) -Lemma Zmin_case_strong : forall (n m:Z) (P:Z -> Type), +Lemma Zmin_case_strong : forall (n m:Z) (P:Z -> Type), (n<=m -> P n) -> (m<=n -> P m) -> P (Zmin n m). Proof. intros n m P H1 H2; unfold Zmin, Zle, Zge in *. rewrite <- (Zcompare_antisym n m) in H2. - destruct (n ?= m); (apply H1|| apply H2); discriminate. + destruct (n ?= m); (apply H1|| apply H2); discriminate. Qed. Lemma Zmin_case : forall (n m:Z) (P:Z -> Type), P n -> P m -> P (Zmin n m). @@ -43,7 +43,7 @@ Proof. intros n m P H1 H2; unfold Zmin in |- *; case (n ?= m); auto with arith. Qed. -Lemma Zmin_spec : forall x y:Z, +Lemma Zmin_spec : forall x y:Z, x <= y /\ Zmin x y = x \/ x > y /\ Zmin x y = y. Proof. @@ -93,7 +93,7 @@ Qed. Lemma Zmin_assoc : forall n m p:Z, Zmin n (Zmin m p) = Zmin (Zmin n m) p. Proof. - intros n m p; repeat apply Zmin_case_strong; intros; + intros n m p; repeat apply Zmin_case_strong; intros; reflexivity || (try apply Zle_antisym); eauto with zarith. Qed. @@ -118,7 +118,7 @@ Qed. (** * Operations preserving min *) -Lemma Zsucc_min_distr : +Lemma Zsucc_min_distr : forall n m:Z, Zsucc (Zmin n m) = Zmin (Zsucc n) (Zsucc m). Proof. intros n m; unfold Zmin in |- *; rewrite (Zcompare_succ_compat n m); diff --git a/theories/ZArith/Zminmax.v b/theories/ZArith/Zminmax.v index 6ea02a4839..83dceb84bd 100644 --- a/theories/ZArith/Zminmax.v +++ b/theories/ZArith/Zminmax.v @@ -18,32 +18,32 @@ Open Local Scope Z_scope. Lemma Zmin_max_absorption_r_r : forall n m, Zmax n (Zmin n m) = n. Proof. - intros; apply Zmin_case_strong; intro; apply Zmax_case_strong; intro; + intros; apply Zmin_case_strong; intro; apply Zmax_case_strong; intro; reflexivity || apply Zle_antisym; trivial. Qed. Lemma Zmax_min_absorption_r_r : forall n m, Zmin n (Zmax n m) = n. Proof. - intros; apply Zmax_case_strong; intro; apply Zmin_case_strong; intro; + intros; apply Zmax_case_strong; intro; apply Zmin_case_strong; intro; reflexivity || apply Zle_antisym; trivial. Qed. (** Distributivity *) -Lemma Zmax_min_distr_r : +Lemma Zmax_min_distr_r : forall n m p, Zmax n (Zmin m p) = Zmin (Zmax n m) (Zmax n p). Proof. intros. - repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; + repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; reflexivity || apply Zle_antisym; (assumption || eapply Zle_trans; eassumption). Qed. -Lemma Zmin_max_distr_r : +Lemma Zmin_max_distr_r : forall n m p, Zmin n (Zmax m p) = Zmax (Zmin n m) (Zmin n p). Proof. intros. - repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; + repeat apply Zmax_case_strong; repeat apply Zmin_case_strong; intros; reflexivity || apply Zle_antisym; (assumption || eapply Zle_trans; eassumption). Qed. diff --git a/theories/ZArith/Zmisc.v b/theories/ZArith/Zmisc.v index 34e76b8ac1..93ac74d544 100644 --- a/theories/ZArith/Zmisc.v +++ b/theories/ZArith/Zmisc.v @@ -37,14 +37,14 @@ Definition iter (n:Z) (A:Type) (f:A -> A) (x:A) := Theorem iter_nat_of_P : forall (p:positive) (A:Type) (f:A -> A) (x:A), iter_pos p A f x = iter_nat (nat_of_P p) A f x. -Proof. +Proof. intro n; induction n as [p H| p H| ]; [ intros; simpl in |- *; rewrite (H A f x); - rewrite (H A f (iter_nat (nat_of_P p) A f x)); + rewrite (H A f (iter_nat (nat_of_P p) A f x)); rewrite (ZL6 p); symmetry in |- *; apply f_equal with (f := f); apply iter_nat_plus | intros; unfold nat_of_P in |- *; simpl in |- *; rewrite (H A f x); - rewrite (H A f (iter_nat (nat_of_P p) A f x)); + rewrite (H A f (iter_nat (nat_of_P p) A f x)); rewrite (ZL6 p); symmetry in |- *; apply iter_nat_plus | simpl in |- *; auto with arith ]. Qed. @@ -59,7 +59,7 @@ Qed. Theorem iter_pos_plus : forall (p q:positive) (A:Type) (f:A -> A) (x:A), iter_pos (p + q) A f x = iter_pos p A f (iter_pos q A f x). -Proof. +Proof. intros n m; intros. rewrite (iter_nat_of_P m A f x). rewrite (iter_nat_of_P n A f (iter_nat (nat_of_P m) A f x)). @@ -68,14 +68,14 @@ Proof. apply iter_nat_plus. Qed. -(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], +(** Preservation of invariants : if [f : A->A] preserves the invariant [Inv], then the iterates of [f] also preserve it. *) Theorem iter_nat_invariant : forall (n:nat) (A:Type) (f:A -> A) (Inv:A -> Prop), (forall x:A, Inv x -> Inv (f x)) -> forall x:A, Inv x -> Inv (iter_nat n A f x). -Proof. +Proof. simple induction n; intros; [ trivial with arith | simpl in |- *; apply H0 with (x := iter_nat n0 A f x); apply H; @@ -86,6 +86,6 @@ Theorem iter_pos_invariant : forall (p:positive) (A:Type) (f:A -> A) (Inv:A -> Prop), (forall x:A, Inv x -> Inv (f x)) -> forall x:A, Inv x -> Inv (iter_pos p A f x). -Proof. +Proof. intros; rewrite iter_nat_of_P; apply iter_nat_invariant; trivial with arith. Qed. diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index 5d3b201607..46b23fe63c 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -57,9 +57,9 @@ Proof. | discriminate H0 | discriminate H0 | simpl in H0; injection H0; - do 2 rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ; + do 2 rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ; intros E; rewrite E; auto with arith ]. -Qed. +Qed. Theorem inj_eq_rev : forall n m:nat, Z_of_nat n = Z_of_nat m -> n = m. Proof. @@ -169,7 +169,7 @@ Proof. Qed. (** Injection and usual operations *) - + Theorem inj_plus : forall n m:nat, Z_of_nat (n + m) = Z_of_nat n + Z_of_nat m. Proof. intro x; induction x as [| n H]; intro y; destruct y as [| m]; @@ -186,7 +186,7 @@ Proof. intro x; induction x as [| n H]; [ simpl in |- *; trivial with arith | intro y; rewrite inj_S; rewrite <- Zmult_succ_l_reverse; rewrite <- H; - rewrite <- inj_plus; simpl in |- *; rewrite plus_comm; + rewrite <- inj_plus; simpl in |- *; rewrite plus_comm; trivial with arith ]. Qed. @@ -195,17 +195,17 @@ Theorem inj_minus1 : Proof. intros x y H; apply (Zplus_reg_l (Z_of_nat y)); unfold Zminus in |- *; rewrite Zplus_permute; rewrite Zplus_opp_r; rewrite <- inj_plus; - rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r; + rewrite <- (le_plus_minus y x H); rewrite Zplus_0_r; trivial with arith. Qed. - + Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z_of_nat (n - m) = 0. Proof. intros x y H; rewrite not_le_minus_0; [ trivial with arith | apply gt_not_le; assumption ]. Qed. -Theorem inj_minus : forall n m:nat, +Theorem inj_minus : forall n m:nat, Z_of_nat (minus n m) = Zmax 0 (Z_of_nat n - Z_of_nat m). Proof. intros. @@ -225,7 +225,7 @@ Proof. unfold Zminus; rewrite H'; auto. Qed. -Theorem inj_min : forall n m:nat, +Theorem inj_min : forall n m:nat, Z_of_nat (min n m) = Zmin (Z_of_nat n) (Z_of_nat m). Proof. induction n; destruct m; try (compute; auto; fail). @@ -234,7 +234,7 @@ Proof. rewrite <- Zsucc_min_distr; f_equal; auto. Qed. -Theorem inj_max : forall n m:nat, +Theorem inj_max : forall n m:nat, Z_of_nat (max n m) = Zmax (Z_of_nat n) (Z_of_nat m). Proof. induction n; destruct m; try (compute; auto; fail). @@ -269,11 +269,11 @@ Proof. intros x; exists (Z_of_nat x); split; [ trivial with arith | rewrite Zmult_comm; rewrite Zmult_1_l; rewrite Zplus_0_r; - unfold Zle in |- *; elim x; intros; simpl in |- *; + unfold Zle in |- *; elim x; intros; simpl in |- *; discriminate ]. Qed. -Lemma Zpos_P_of_succ_nat : forall n:nat, +Lemma Zpos_P_of_succ_nat : forall n:nat, Zpos (P_of_succ_nat n) = Zsucc (Z_of_nat n). Proof. intros. diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index f6d73d7eba..dac4a69281 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -15,13 +15,13 @@ Require Import Zdiv. Require Import Wf_nat. Open Local Scope Z_scope. -(** This file contains some notions of number theory upon Z numbers: +(** This file contains some notions of number theory upon Z numbers: - a divisibility predicate [Zdivide] - a gcd predicate [gcd] - Euclid algorithm [euclid] - a relatively prime predicate [rel_prime] - a prime predicate [prime] - - an efficient [Zgcd] function + - an efficient [Zgcd] function *) (** * Divisibility *) @@ -171,7 +171,7 @@ Proof. rewrite H1 in H0; left; omega. rewrite H1 in H0; right; omega. Qed. - + Theorem Zdivide_trans: forall a b c, (a | b) -> (b | c) -> (a | c). Proof. intros a b c [d H1] [e H2]; exists (d * e); auto with zarith. @@ -220,7 +220,7 @@ Lemma Zdivide_dec : forall a b:Z, {(a | b)} + {~ (a | b)}. Proof. intros a b; elim (Ztrichotomy_inf a 0). (* a<0 *) - intros H; elim H; intros. + intros H; elim H; intros. case (Z_eq_dec (b mod - a) 0). left; apply Zdivide_opp_l_rev; apply Zmod_divide; auto with zarith. intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith. @@ -234,7 +234,7 @@ Proof. intro H1; right; intro; elim H1; apply Zdivide_mod; auto with zarith. Qed. -Theorem Zdivide_Zdiv_eq: forall a b : Z, +Theorem Zdivide_Zdiv_eq: forall a b : Z, 0 < a -> (a | b) -> b = a * (b / a). Proof. intros a b Hb Hc. @@ -242,7 +242,7 @@ Proof. rewrite (Zdivide_mod b a); auto with zarith. Qed. -Theorem Zdivide_Zdiv_eq_2: forall a b c : Z, +Theorem Zdivide_Zdiv_eq_2: forall a b c : Z, 0 < a -> (a | b) -> (c * b)/a = c * (b / a). Proof. intros a b c H1 H2. @@ -250,7 +250,7 @@ Proof. rewrite Hz; rewrite Zmult_assoc. repeat rewrite Z_div_mult; auto with zarith. Qed. - + Theorem Zdivide_Zabs_l: forall a b, (Zabs a | b) -> (a | b). Proof. intros a b [x H]; subst b. @@ -258,7 +258,7 @@ Proof. exists (- x); ring. exists x; ring. Qed. - + Theorem Zdivide_Zabs_inv_l: forall a b, (a | b) -> (Zabs a | b). Proof. intros a b [x H]; subst b. @@ -267,7 +267,7 @@ Proof. exists x; ring. Qed. -Theorem Zdivide_le: forall a b : Z, +Theorem Zdivide_le: forall a b : Z, 0 <= a -> 0 < b -> (a | b) -> a <= b. Proof. intros a b H1 H2 [q H3]; subst b. @@ -278,7 +278,7 @@ Proof. intros H4; subst q; omega. Qed. -Theorem Zdivide_Zdiv_lt_pos: forall a b : Z, +Theorem Zdivide_Zdiv_lt_pos: forall a b : Z, 1 < a -> 0 < b -> (a | b) -> 0 < b / a < b . Proof. intros a b H1 H2 H3; split. @@ -305,7 +305,7 @@ Proof. rewrite Zplus_0_l; rewrite Zmod_mod; auto with zarith. Qed. -Lemma Zmod_divide_minus: forall a b c : Z, 0 < b -> +Lemma Zmod_divide_minus: forall a b c : Z, 0 < b -> a mod b = c -> (b | a - c). Proof. intros a b c H H1; apply Zmod_divide; auto with zarith. @@ -315,7 +315,7 @@ Proof. subst; apply Z_mod_lt; auto with zarith. Qed. -Lemma Zdivide_mod_minus: forall a b c : Z, 0 <= c < b -> +Lemma Zdivide_mod_minus: forall a b c : Z, 0 <= c < b -> (b | a - c) -> a mod b = c. Proof. intros a b c (H1, H2) H3; assert (0 < b); try apply Zle_lt_trans with c; auto. @@ -326,9 +326,9 @@ Proof. Qed. (** * Greatest common divisor (gcd). *) - -(** There is no unicity of the gcd; hence we define the predicate [gcd a b d] - expressing that [d] is a gcd of [a] and [b]. + +(** There is no unicity of the gcd; hence we define the predicate [gcd a b d] + expressing that [d] is a gcd of [a] and [b]. (We show later that the [gcd] is actually unique if we discard its sign.) *) Inductive Zis_gcd (a b d:Z) : Prop := @@ -377,8 +377,8 @@ Proof. Qed. Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith. - -Theorem Zis_gcd_unique: forall a b c d : Z, + +Theorem Zis_gcd_unique: forall a b c d : Z, Zis_gcd a b c -> Zis_gcd a b d -> c = d \/ c = (- d). Proof. intros a b c d H1 H2. @@ -429,7 +429,7 @@ Section extended_euclid_algorithm. (** The recursive part of Euclid's algorithm uses well-founded recursion of non-negative integers. It maintains 6 integers [u1,u2,u3,v1,v2,v3] such that the following invariant holds: - [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)]. + [u1*a+u2*b=u3] and [v1*a+v2*b=v3] and [gcd(u2,v3)=gcd(a,b)]. *) Lemma euclid_rec : @@ -453,8 +453,8 @@ Section extended_euclid_algorithm. replace (u3 - q * x) with (u3 mod x). apply Z_mod_lt; omega. assert (xpos : x > 0). omega. - generalize (Z_div_mod_eq u3 x xpos). - unfold q in |- *. + generalize (Z_div_mod_eq u3 x xpos). + unfold q in |- *. intro eq; pattern u3 at 2 in |- *; rewrite eq; ring. apply (H (u3 - q * x) Hq (proj1 Hq) v1 v2 x (u1 - q * v1) (u2 - q * v2)). tauto. @@ -529,7 +529,7 @@ Proof. rewrite H6; rewrite H7; ring. ring. Qed. - + (** * Relative primality *) @@ -610,16 +610,16 @@ Proof. intros a b g; intros. assert (g <> 0). intro. - elim H1; intros. + elim H1; intros. elim H4; intros. rewrite H2 in H6; subst b; omega. unfold rel_prime in |- *. destruct H1. destruct H1 as (a',H1). destruct H3 as (b',H3). - replace (a/g) with a'; + replace (a/g) with a'; [|rewrite H1; rewrite Z_div_mult; auto with zarith]. - replace (b/g) with b'; + replace (b/g) with b'; [|rewrite H3; rewrite Z_div_mult; auto with zarith]. constructor. exists a'; auto with zarith. @@ -641,7 +641,7 @@ Proof. red; apply Zis_gcd_sym; auto with zarith. Qed. -Theorem rel_prime_div: forall p q r, +Theorem rel_prime_div: forall p q r, rel_prime p q -> (r | p) -> rel_prime r q. Proof. intros p q r H (u, H1); subst. @@ -668,7 +668,7 @@ Proof. exists 1; auto with zarith. Qed. -Theorem rel_prime_mod: forall p q, 0 < q -> +Theorem rel_prime_mod: forall p q, 0 < q -> rel_prime p q -> rel_prime (p mod q) q. Proof. intros p q H H0. @@ -681,7 +681,7 @@ Proof. pattern p at 3; rewrite (Z_div_mod_eq p q); try ring; auto with zarith. Qed. -Theorem rel_prime_mod_rev: forall p q, 0 < q -> +Theorem rel_prime_mod_rev: forall p q, 0 < q -> rel_prime (p mod q) q -> rel_prime p q. Proof. intros p q H H0. @@ -713,7 +713,7 @@ Proof. assert (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p). assert (Zabs a <= Zabs p). apply Zdivide_bounds; [ assumption | omega ]. - generalize H3. + generalize H3. pattern (Zabs a) in |- *; apply Zabs_ind; pattern (Zabs p) in |- *; apply Zabs_ind; intros; omega. intuition idtac. @@ -783,7 +783,7 @@ Proof. intros H1; absurd (1 < 1); auto with zarith. inversion H1; auto. Qed. - + Lemma prime_2: prime 2. Proof. apply prime_intro; auto with zarith. @@ -793,7 +793,7 @@ Proof. subst n; red; auto with zarith. apply Zis_gcd_intro; auto with zarith. Qed. - + Theorem prime_3: prime 3. Proof. apply prime_intro; auto with zarith. @@ -810,7 +810,7 @@ Proof. subst n; red; auto with zarith. apply Zis_gcd_intro; auto with zarith. Qed. - + Theorem prime_ge_2: forall p, prime p -> 2 <= p. Proof. intros p Hp; inversion Hp; auto with zarith. @@ -818,7 +818,7 @@ Qed. Definition prime' p := 1

~ (n|p)). -Theorem prime_alt: +Theorem prime_alt: forall p, prime' p <-> prime p. Proof. split; destruct 1; intros. @@ -846,7 +846,7 @@ Proof. apply Zis_gcd_intro; auto with zarith. apply H0; auto with zarith. Qed. - + Theorem square_not_prime: forall a, ~ prime (a * a). Proof. intros a Ha. @@ -862,10 +862,10 @@ Proof. exists b; auto. Qed. -Theorem prime_div_prime: forall p q, +Theorem prime_div_prime: forall p q, prime p -> prime q -> (p | q) -> p = q. Proof. - intros p q H H1 H2; + intros p q H H1 H2; assert (Hp: 0 < p); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. assert (Hq: 0 < q); try apply Zlt_le_trans with 2; try apply prime_ge_2; auto with zarith. case prime_divisors with (2 := H2); auto. @@ -876,10 +876,10 @@ Proof. Qed. -(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose +(** We could obtain a [Zgcd] function via Euclid algorithm. But we propose here a binary version of [Zgcd], faster and executable within Coq. - Algorithm: + Algorithm: gcd 0 b = b gcd a 0 = a @@ -887,23 +887,23 @@ Qed. gcd (2a+1) (2b) = gcd (2a+1) b gcd (2a) (2b+1) = gcd a (2b+1) gcd (2a+1) (2b+1) = gcd (b-a) (2*a+1) - or gcd (a-b) (2*b+1), depending on whether a 1 - | S n => - match a,b with - | xH, _ => 1 + | S n => + match a,b with + | xH, _ => 1 | _, xH => 1 | xO a, xO b => xO (Pgcdn n a b) | a, xO b => Pgcdn n a b | xO a, b => Pgcdn n a b - | xI a', xI b' => - match Pcompare a' b' Eq with + | xI a', xI b' => + match Pcompare a' b' Eq with | Eq => a | Lt => Pgcdn n (b'-a') a | Gt => Pgcdn n (a'-b') b @@ -917,7 +917,7 @@ Close Scope positive_scope. Definition Zgcd (a b : Z) : Z := match a,b with - | Z0, _ => Zabs b + | Z0, _ => Zabs b | _, Z0 => Zabs a | Zpos a, Zpos b => Zpos (Pgcd a b) | Zpos a, Zneg b => Zpos (Pgcd a b) @@ -930,8 +930,8 @@ Proof. unfold Zgcd; destruct a; destruct b; auto with zarith. Qed. -Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g -> - Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g. +Lemma Zis_gcd_even_odd : forall a b g, Zis_gcd (Zpos a) (Zpos (xI b)) g -> + Zis_gcd (Zpos (xO a)) (Zpos (xI b)) g. Proof. intros. destruct H. @@ -949,7 +949,7 @@ Proof. omega. Qed. -Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat -> +Lemma Pgcdn_correct : forall n a b, (Psize a + Psize b<=n)%nat -> Zis_gcd (Zpos a) (Zpos b) (Zpos (Pgcdn n a b)). Proof. intro n; pattern n; apply lt_wf_ind; clear n; intros. @@ -975,7 +975,7 @@ Proof. rewrite (Zpos_minus_morphism _ _ H1). assert (0 < Zpos a) by (compute; auto). omega. - omega. + omega. rewrite Zpos_xO; do 2 rewrite Zpos_xI. rewrite Zpos_minus_morphism; auto. omega. @@ -993,7 +993,7 @@ Proof. assert (0 < Zpos b) by (compute; auto). omega. rewrite ZC4; rewrite H1; auto. - omega. + omega. rewrite Zpos_xO; do 2 rewrite Zpos_xI. rewrite Zpos_minus_morphism; auto. omega. @@ -1060,7 +1060,7 @@ Proof. split; [apply Zgcd_is_gcd | apply Zgcd_is_pos]. Qed. -Theorem Zdivide_Zgcd: forall p q r : Z, +Theorem Zdivide_Zgcd: forall p q r : Z, (p | q) -> (p | r) -> (p | Zgcd q r). Proof. intros p q r H1 H2. @@ -1069,7 +1069,7 @@ Proof. inversion_clear H3; auto. Qed. -Theorem Zis_gcd_gcd: forall a b c : Z, +Theorem Zis_gcd_gcd: forall a b c : Z, 0 <= c -> Zis_gcd a b c -> Zgcd a b = c. Proof. intros a b c H1 H2. @@ -1101,7 +1101,7 @@ Proof. rewrite H1; ring. Qed. -Theorem Zgcd_div_swap0 : forall a b : Z, +Theorem Zgcd_div_swap0 : forall a b : Z, 0 < Zgcd a b -> 0 < b -> (a / Zgcd a b) * b = a * (b/Zgcd a b). @@ -1114,7 +1114,7 @@ Proof. rewrite <- Zdivide_Zdiv_eq; auto. Qed. -Theorem Zgcd_div_swap : forall a b c : Z, +Theorem Zgcd_div_swap : forall a b c : Z, 0 < Zgcd a b -> 0 < b -> (c * a) / Zgcd a b * b = c * a * (b/Zgcd a b). @@ -1165,7 +1165,7 @@ Proof. Qed. Hint Resolve Zgcd_0 Zgcd_1 : zarith. -Theorem Zgcd_1_rel_prime : forall a b, +Theorem Zgcd_1_rel_prime : forall a b, Zgcd a b = 1 <-> rel_prime a b. Proof. unfold rel_prime; split; intro H. @@ -1176,7 +1176,7 @@ Proof. generalize (Zgcd_is_pos a b); auto with zarith. Qed. -Definition rel_prime_dec: forall a b, +Definition rel_prime_dec: forall a b, { rel_prime a b }+{ ~ rel_prime a b }. Proof. intros a b; case (Z_eq_dec (Zgcd a b) 1); intros H1. @@ -1190,7 +1190,7 @@ Definition prime_dec_aux: { exists n, 1 < n < m /\ ~ rel_prime n p }. Proof. intros p m. - case (Z_lt_dec 1 m); intros H1; + case (Z_lt_dec 1 m); intros H1; [ | left; intros; elimtype False; omega ]. pattern m; apply natlike_rec; auto with zarith. left; intros; elimtype False; omega. @@ -1255,34 +1255,34 @@ Qed. Open Scope positive_scope. -Fixpoint Pggcdn (n: nat) (a b : positive) { struct n } : (positive*(positive*positive)) := - match n with +Fixpoint Pggcdn (n: nat) (a b : positive) { struct n } : (positive*(positive*positive)) := + match n with | O => (1,(a,b)) - | S n => - match a,b with - | xH, b => (1,(1,b)) + | S n => + match a,b with + | xH, b => (1,(1,b)) | a, xH => (1,(a,1)) - | xO a, xO b => - let (g,p) := Pggcdn n a b in + | xO a, xO b => + let (g,p) := Pggcdn n a b in (xO g,p) - | a, xO b => - let (g,p) := Pggcdn n a b in - let (aa,bb) := p in + | a, xO b => + let (g,p) := Pggcdn n a b in + let (aa,bb) := p in (g,(aa, xO bb)) - | xO a, b => - let (g,p) := Pggcdn n a b in - let (aa,bb) := p in + | xO a, b => + let (g,p) := Pggcdn n a b in + let (aa,bb) := p in (g,(xO aa, bb)) - | xI a', xI b' => - match Pcompare a' b' Eq with + | xI a', xI b' => + match Pcompare a' b' Eq with | Eq => (a,(1,1)) - | Lt => - let (g,p) := Pggcdn n (b'-a') a in - let (ba,aa) := p in + | Lt => + let (g,p) := Pggcdn n (b'-a') a in + let (ba,aa) := p in (g,(aa, aa + xO ba)) - | Gt => - let (g,p) := Pggcdn n (a'-b') b in - let (ab,bb) := p in + | Gt => + let (g,p) := Pggcdn n (a'-b') b in + let (ab,bb) := p in (g,(bb+xO ab, bb)) end end @@ -1294,28 +1294,28 @@ Open Scope Z_scope. Definition Zggcd (a b : Z) : Z*(Z*Z) := match a,b with - | Z0, _ => (Zabs b,(0, Zsgn b)) + | Z0, _ => (Zabs b,(0, Zsgn b)) | _, Z0 => (Zabs a,(Zsgn a, 0)) - | Zpos a, Zpos b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in + | Zpos a, Zpos b => + let (g,p) := Pggcd a b in + let (aa,bb) := p in (Zpos g, (Zpos aa, Zpos bb)) - | Zpos a, Zneg b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in + | Zpos a, Zneg b => + let (g,p) := Pggcd a b in + let (aa,bb) := p in (Zpos g, (Zpos aa, Zneg bb)) - | Zneg a, Zpos b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in + | Zneg a, Zpos b => + let (g,p) := Pggcd a b in + let (aa,bb) := p in (Zpos g, (Zneg aa, Zpos bb)) | Zneg a, Zneg b => - let (g,p) := Pggcd a b in - let (aa,bb) := p in + let (g,p) := Pggcd a b in + let (aa,bb) := p in (Zpos g, (Zneg aa, Zneg bb)) end. -Lemma Pggcdn_gcdn : forall n a b, +Lemma Pggcdn_gcdn : forall n a b, fst (Pggcdn n a b) = Pgcdn n a b. Proof. induction n. @@ -1336,15 +1336,15 @@ Qed. Lemma Zggcd_gcd : forall a b, fst (Zggcd a b) = Zgcd a b. Proof. - destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd; + destruct a; destruct b; simpl; auto; rewrite <- Pggcd_gcd; destruct (Pggcd p p0) as (g,(aa,bb)); simpl; auto. Qed. Open Scope positive_scope. -Lemma Pggcdn_correct_divisors : forall n a b, - let (g,p) := Pggcdn n a b in - let (aa,bb):=p in +Lemma Pggcdn_correct_divisors : forall n a b, + let (g,p) := Pggcdn n a b in + let (aa,bb):=p in (a=g*aa) /\ (b=g*bb). Proof. induction n. @@ -1371,7 +1371,7 @@ Proof. rewrite <- H1; rewrite <- H0. simpl; f_equal; symmetry. apply Pplus_minus; auto. - (* Then... *) + (* Then... *) generalize (IHn (xI a) b); destruct (Pggcdn n (xI a) b) as (g,(ab,bb)); simpl. intros (H0,H1); split; auto. rewrite Pmult_xO_permute_r; rewrite H1; auto. @@ -1382,9 +1382,9 @@ Proof. intros (H0,H1); split; subst; auto. Qed. -Lemma Pggcd_correct_divisors : forall a b, - let (g,p) := Pggcd a b in - let (aa,bb):=p in +Lemma Pggcd_correct_divisors : forall a b, + let (g,p) := Pggcd a b in + let (aa,bb):=p in (a=g*aa) /\ (b=g*bb). Proof. intros a b; exact (Pggcdn_correct_divisors (Psize a + Psize b)%nat a b). @@ -1392,17 +1392,17 @@ Qed. Close Scope positive_scope. -Lemma Zggcd_correct_divisors : forall a b, - let (g,p) := Zggcd a b in - let (aa,bb):=p in +Lemma Zggcd_correct_divisors : forall a b, + let (g,p) := Zggcd a b in + let (aa,bb):=p in (a=g*aa) /\ (b=g*bb). Proof. - destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto]; - generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb)); + destruct a; destruct b; simpl; auto; try solve [rewrite Pmult_comm; simpl; auto]; + generalize (Pggcd_correct_divisors p p0); destruct (Pggcd p p0) as (g,(aa,bb)); destruct 1; subst; auto. Qed. -Theorem Zggcd_opp: forall x y, +Theorem Zggcd_opp: forall x y, Zggcd (-x) y = let (p1,p) := Zggcd x y in let (p2,p3) := p in (p1,(-p2,p3)). diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 9ab0aadfd9..7aef3ea8e8 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -49,7 +49,7 @@ Proof. [ tauto | intros H3; right; unfold not in |- *; intros H4; elim H3; rewrite (H2 H4); intros H5; discriminate H5 ]. -Qed. +Qed. Theorem dec_Zne : forall n m:Z, decidable (Zne n m). Proof. @@ -79,7 +79,7 @@ Proof. intros x y; unfold decidable, Zge in |- *; elim (x ?= y); [ left; discriminate | right; unfold not in |- *; intros H; apply H; trivial with arith - | left; discriminate ]. + | left; discriminate ]. Qed. Theorem dec_Zlt : forall n m:Z, decidable (n < m). @@ -96,7 +96,7 @@ Proof. | unfold Zlt in |- *; intros H; elim H; intros H1; [ auto with arith | right; elim (Zcompare_Gt_Lt_antisym x y); auto with arith ] ]. -Qed. +Qed. (** * Relating strict and large orders *) @@ -180,7 +180,7 @@ Proof. intros x y. split. intro. apply Zgt_lt. assumption. intro. apply Zlt_gt. assumption. Qed. - + (** * Equivalence and order properties *) (** Reflexivity *) @@ -188,7 +188,7 @@ Qed. Lemma Zle_refl : forall n:Z, n <= n. Proof. intros n; unfold Zle in |- *; rewrite (Zcompare_refl n); discriminate. -Qed. +Qed. Lemma Zeq_le : forall n m:Z, n = m -> n <= m. Proof. @@ -201,7 +201,7 @@ Hint Resolve Zle_refl: zarith. Lemma Zle_antisym : forall n m:Z, n <= m -> m <= n -> n = m. Proof. - intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]. + intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]]. absurd (m > n); [ apply Zle_not_gt | apply Zlt_gt ]; assumption. assumption. absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption. @@ -399,7 +399,7 @@ Qed. Lemma Zgt_le_succ : forall n m:Z, m > n -> Zsucc n <= m. Proof. unfold Zgt, Zle in |- *; intros n p H; elim (Zcompare_Gt_not_Lt p n); - intros H1 H2; unfold not in |- *; intros H3; unfold not in H1; + intros H1 H2; unfold not in |- *; intros H3; unfold not in H1; apply H1; [ assumption | elim (Zcompare_Gt_Lt_antisym (n + 1) p); intros H4 H5; apply H4; exact H3 ]. @@ -477,9 +477,9 @@ Hint Resolve Zle_le_succ: zarith. Lemma Zgt_succ_pred : forall n m:Z, m > Zsucc n -> Zpred m > n. Proof. unfold Zgt, Zsucc, Zpred in |- *; intros n p H; - rewrite <- (fun x y => Zcompare_plus_compat x y 1); + rewrite <- (fun x y => Zcompare_plus_compat x y 1); rewrite (Zplus_comm p); rewrite Zplus_assoc; - rewrite (fun x => Zplus_comm x n); simpl in |- *; + rewrite (fun x => Zplus_comm x n); simpl in |- *; assumption. Qed. @@ -562,7 +562,7 @@ Proof. assert (Hle : m <= n). apply Zgt_succ_le; assumption. destruct (Zle_lt_or_eq _ _ Hle) as [Hlt| Heq]. - left; apply Zlt_gt; assumption. + left; apply Zlt_gt; assumption. right; assumption. Qed. @@ -679,7 +679,7 @@ Proof. rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial. Qed. -(** ** Multiplication *) +(** ** Multiplication *) (** Compatibility of multiplication by a positive wrt to order *) Lemma Zmult_le_compat_r : forall n m p:Z, n <= m -> 0 <= p -> n * p <= m * p. @@ -776,7 +776,7 @@ Proof. intros a b c d H0 H1 H2 H3. apply Zge_trans with (a * d). apply Zmult_ge_compat_l; trivial. - apply Zge_trans with c; trivial. + apply Zge_trans with c; trivial. apply Zmult_ge_compat_r; trivial. Qed. @@ -964,17 +964,17 @@ Qed. Lemma Zeq_plus_swap : forall n m p:Z, n + p = m <-> n = m - p. Proof. - intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry in |- *. rewrite Zplus_comm. + intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry in |- *. rewrite Zplus_comm. assumption. - intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse. + intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse. rewrite Zplus_opp_l. apply Zplus_0_r. Qed. Lemma Zlt_minus_simpl_swap : forall n m:Z, 0 < m -> n - m < n. Proof. intros n m H; apply Zplus_lt_reg_l with (p := m); rewrite Zplus_minus; - pattern n at 1 in |- *; rewrite <- (Zplus_0_r n); - rewrite (Zplus_comm m n); apply Zplus_lt_compat_l; + pattern n at 1 in |- *; rewrite <- (Zplus_0_r n); + rewrite (Zplus_comm m n); apply Zplus_lt_compat_l; assumption. Qed. @@ -992,8 +992,8 @@ Qed. Lemma Zle_minus_le_0 : forall n m:Z, m <= n -> 0 <= n - m. Proof. - intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m); - rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H. + intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m); + rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H. Qed. Lemma Zmult_lt_compat: @@ -1011,7 +1011,7 @@ Proof. rewrite <- H5; simpl; apply Zmult_lt_0_compat; auto with zarith. Qed. -Lemma Zmult_lt_compat2: +Lemma Zmult_lt_compat2: forall n m p q : Z, 0 < n <= p -> 0 < m < q -> n * m < p * q. Proof. intros n m p q (H1, H2) (H3, H4). diff --git a/theories/ZArith/Zpow_def.v b/theories/ZArith/Zpow_def.v index b0f372debc..620d6324f7 100644 --- a/theories/ZArith/Zpow_def.v +++ b/theories/ZArith/Zpow_def.v @@ -2,11 +2,11 @@ Require Import ZArith_base. Require Import Ring_theory. Open Local Scope Z_scope. - + (** [Zpower_pos z n] is the n-th power of [z] when [n] is an binary - integer (type [positive]) and [z] a signed integer (type [Z]) *) + integer (type [positive]) and [z] a signed integer (type [Z]) *) Definition Zpower_pos (z:Z) (n:positive) := iter_pos n Z (fun x:Z => z * x) 1. - + Definition Zpower (x y:Z) := match y with | Zpos p => Zpower_pos x p @@ -24,4 +24,4 @@ Proof. repeat rewrite Zmult_assoc;trivial. rewrite H;rewrite Zmult_1_r;trivial. Qed. - + diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index bf25de4d61..40917519e3 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -37,7 +37,7 @@ Proof. Qed. Lemma Zpower_pos_0_l: forall p, Zpower_pos 0 p = 0. -Proof. +Proof. induction p. change (xI p) with (1 + (xO p))%positive. rewrite Zpower_pos_is_exp, Zpower_pos_1_r; auto. @@ -133,7 +133,7 @@ Proof. apply Zle_ge; replace 0 with (0 * r1); try apply Zmult_le_compat_r; auto. Qed. -Theorem Zpower_le_monotone: forall a b c, +Theorem Zpower_le_monotone: forall a b c, 0 < a -> 0 <= b <= c -> a^b <= a^c. Proof. intros a b c H (H1, H2). @@ -145,7 +145,7 @@ Proof. apply Zlt_le_weak; apply Zpower_gt_0; auto with zarith. Qed. -Theorem Zpower_lt_monotone: forall a b c, +Theorem Zpower_lt_monotone: forall a b c, 1 < a -> 0 <= b < c -> a^b < a^c. Proof. intros a b c H (H1, H2). @@ -160,7 +160,7 @@ Proof. apply Zpower_le_monotone; auto with zarith. Qed. -Theorem Zpower_gt_1 : forall x y, +Theorem Zpower_gt_1 : forall x y, 1 < x -> 0 < y -> 1 < x^y. Proof. intros x y H1 H2. @@ -168,14 +168,14 @@ Proof. apply Zpower_lt_monotone; auto with zarith. Qed. -Theorem Zpower_ge_0: forall x y, 0 <= x -> 0 <= x^y. +Theorem Zpower_ge_0: forall x y, 0 <= x -> 0 <= x^y. Proof. intros x y; case y; auto with zarith. simpl ; auto with zarith. intros p H1; assert (H: 0 <= Zpos p); auto with zarith. generalize H; pattern (Zpos p); apply natlike_ind; auto with zarith. - intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith. - apply Zmult_le_0_compat; auto with zarith. + intros p1 H2 H3 _; unfold Zsucc; rewrite Zpower_exp; simpl; auto with zarith. + apply Zmult_le_0_compat; auto with zarith. generalize H1; case x; compute; intros; auto; try discriminate. Qed. @@ -195,7 +195,7 @@ Proof. destruct b;trivial;unfold Zgt in z;discriminate z. Qed. -Theorem Zmult_power: forall p q r, 0 <= r -> +Theorem Zmult_power: forall p q r, 0 <= r -> (p*q)^r = p^r * q^r. Proof. intros p q r H1; generalize H1; pattern r; apply natlike_ind; auto. @@ -206,7 +206,7 @@ Qed. Hint Resolve Zpower_ge_0 Zpower_gt_0: zarith. -Theorem Zpower_le_monotone3: forall a b c, +Theorem Zpower_le_monotone3: forall a b c, 0 <= c -> 0 <= a <= b -> a^c <= b^c. Proof. intros a b c H (H1, H2). @@ -216,7 +216,7 @@ Proof. apply Zle_trans with (a^x * b); auto with zarith. Qed. -Lemma Zpower_le_monotone_inv: forall a b c, +Lemma Zpower_le_monotone_inv: forall a b c, 1 < a -> 0 < b -> a^b <= a^c -> b <= c. Proof. intros a b c H H0 H1. @@ -227,14 +227,14 @@ Proof. apply Zpower_le_monotone;auto with zarith. apply Zpower_le_monotone3;auto with zarith. assert (c > 0). - destruct (Z_le_gt_dec 0 c);trivial. + destruct (Z_le_gt_dec 0 c);trivial. destruct (Zle_lt_or_eq _ _ z0);auto with zarith. rewrite <- H3 in H1;simpl in H1; elimtype False;omega. destruct c;try discriminate z0. simpl in H1. elimtype False;omega. assert (H4 := Zpower_lt_monotone a c b H). elimtype False;omega. Qed. -Theorem Zpower_nat_Zpower: forall p q, 0 <= q -> +Theorem Zpower_nat_Zpower: forall p q, 0 <= q -> p^q = Zpower_nat p (Zabs_nat q). Proof. intros p1 q1; case q1; simpl. @@ -262,7 +262,7 @@ Proof. intros; apply Zlt_le_weak; apply Zpower2_lt_lin; auto. Qed. -Lemma Zpower2_Psize : +Lemma Zpower2_Psize : forall n p, Zpos p < 2^(Z_of_nat n) <-> (Psize p <= n)%nat. Proof. induction n. @@ -311,14 +311,14 @@ Fixpoint Zpow_mod_pos (a: Z)(m: positive)(n : Z) {struct m} : Z := end end. -Definition Zpow_mod a m n := - match m with - | 0 => 1 - | Zpos p => Zpow_mod_pos a p n - | Zneg p => 0 +Definition Zpow_mod a m n := + match m with + | 0 => 1 + | Zpos p => Zpow_mod_pos a p n + | Zneg p => 0 end. -Theorem Zpow_mod_pos_correct: forall a m n, 0 < n -> +Theorem Zpow_mod_pos_correct: forall a m n, 0 < n -> Zpow_mod_pos a m n = (Zpower_pos a m) mod n. Proof. intros a m; elim m; simpl; auto. @@ -327,12 +327,12 @@ Proof. repeat rewrite Rec; auto. rewrite Zpower_pos_1_r. repeat rewrite (fun x => (Zmult_mod x a)); auto with zarith. - rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. + rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. case (Zpower_pos a p mod n); auto. intros p Rec n H1; rewrite <- Pplus_diag; auto. repeat rewrite Zpower_pos_is_exp; auto. repeat rewrite Rec; auto. - rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. + rewrite (Zmult_mod (Zpower_pos a p)); auto with zarith. case (Zpower_pos a p mod n); auto. unfold Zpower_pos; simpl; rewrite Zmult_1_r; auto with zarith. Qed. @@ -354,7 +354,7 @@ Proof. pattern p at 3; rewrite <- (Zpower_1_r p); rewrite <- Zpower_exp; try f_equal; auto with zarith. Qed. -Theorem rel_prime_Zpower_r: forall i p q, 0 < i -> +Theorem rel_prime_Zpower_r: forall i p q, 0 < i -> rel_prime p q -> rel_prime p (q^i). Proof. intros i p q Hi Hpq; generalize Hi; pattern i; apply natlike_ind; auto with zarith; clear i Hi. @@ -365,7 +365,7 @@ Proof. rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1. Qed. -Theorem rel_prime_Zpower: forall i j p q, 0 <= i -> 0 <= j -> +Theorem rel_prime_Zpower: forall i j p q, 0 <= i -> 0 <= j -> rel_prime p q -> rel_prime (p^i) (q^j). Proof. intros i j p q Hi; generalize Hi j p q; pattern i; apply natlike_ind; auto with zarith; clear i Hi j p q. @@ -379,7 +379,7 @@ Proof. rewrite Zpower_0_r; apply rel_prime_sym; apply rel_prime_1. Qed. -Theorem prime_power_prime: forall p q n, 0 <= n -> +Theorem prime_power_prime: forall p q n, 0 <= n -> prime p -> prime q -> (p | q^n) -> p = q. Proof. intros p q n Hn Hp Hq; pattern n; apply natlike_ind; auto; clear n Hn. @@ -442,15 +442,15 @@ Fixpoint Psquare (p: positive): positive := end. Definition Zsquare p := - match p with - | Z0 => Z0 - | Zpos p => Zpos (Psquare p) + match p with + | Z0 => Z0 + | Zpos p => Zpos (Psquare p) | Zneg p => Zpos (Psquare p) end. Theorem Psquare_correct: forall p, Psquare p = (p * p)%positive. Proof. - induction p; simpl; auto; f_equal; rewrite IHp. + induction p; simpl; auto; f_equal; rewrite IHp. apply trans_equal with (xO p + xO (p*p))%positive; auto. rewrite (Pplus_comm (xO p)); auto. rewrite Pmult_xI_permute_r; rewrite Pplus_assoc. diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index 7ee8b97667..508e6601c4 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -20,7 +20,7 @@ Infix "^" := Zpower : Z_scope. (** * Definition of powers over [Z]*) (** [Zpower_nat z n] is the n-th power of [z] when [n] is an unary - integer (type [nat]) and [z] a signed integer (type [Z]) *) + integer (type [nat]) and [z] a signed integer (type [Z]) *) Definition Zpower_nat (z:Z) (n:nat) := iter_nat n Z (fun x:Z => z * x) 1. @@ -83,12 +83,12 @@ Section Powers_of_2. (** For the powers of two, that will be widely used, a more direct calculus is possible. We will also prove some properties such as [(x:positive) x < 2^x] that are true for all integers bigger - than 2 but more difficult to prove and useless. *) + than 2 but more difficult to prove and useless. *) (** [shift n m] computes [2^n * m], or [m] shifted by [n] positions *) - Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z. - Definition shift_pos (n z:positive) := iter_pos n positive xO z. + Definition shift_nat (n:nat) (z:positive) := iter_nat n positive xO z. + Definition shift_pos (n z:positive) := iter_pos n positive xO z. Definition shift (n:Z) (z:positive) := match n with | Z0 => z @@ -130,7 +130,7 @@ Section Powers_of_2. rewrite (shift_nat_correct n). omega. Qed. - + (** Second we show that [two_power_pos] and [two_power_nat] are the same *) Lemma shift_pos_nat : forall p x:positive, shift_pos p x = shift_nat (nat_of_P p) x. @@ -181,12 +181,12 @@ Section Powers_of_2. apply Zpower_pos_is_exp. Qed. - (** The exponentiation [z -> 2^z] for [z] a signed integer. + (** The exponentiation [z -> 2^z] for [z] a signed integer. For convenience, we assume that [2^z = 0] for all [z < 0] We could also define a inductive type [Log_result] with 3 contructors [ Zero | Pos positive -> | minus_infty] but it's more complexe and not so useful. *) - + Definition two_p (x:Z) := match x with | Z0 => 1 @@ -227,7 +227,7 @@ Section Powers_of_2. Lemma two_p_S : forall x:Z, 0 <= x -> two_p (Zsucc x) = 2 * two_p x. Proof. - intros; unfold Zsucc in |- *. + intros; unfold Zsucc in |- *. rewrite (two_p_is_exp x 1 H (Zorder.Zle_0_pos 1)). apply Zmult_comm. Qed. @@ -247,10 +247,10 @@ Section Powers_of_2. | intro Hx0; rewrite <- Hx0; simpl in |- *; unfold Zlt in |- *; auto with zarith ] | assumption ]. - Qed. + Qed. Lemma Zlt_lt_double : forall x y:Z, 0 <= x < y -> x < 2 * y. - intros; omega. Qed. + intros; omega. Qed. End Powers_of_2. @@ -286,13 +286,13 @@ Section power_div_with_rest. let (qr, d) := iter_pos p _ Zdiv_rest_aux (x, 0, 1) in d = two_power_pos p. Proof. intros x p; rewrite (iter_nat_of_P p _ Zdiv_rest_aux (x, 0, 1)); - rewrite (two_power_pos_nat p); elim (nat_of_P p); + rewrite (two_power_pos_nat p); elim (nat_of_P p); simpl in |- *; [ trivial with zarith | intro n; rewrite (two_power_nat_S n); unfold Zdiv_rest_aux at 2 in |- *; - elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)); + elim (iter_nat n (Z * Z * Z) Zdiv_rest_aux (x, 0, 1)); destruct a; intros; apply f_equal with (f := fun z:Z => 2 * z); - assumption ]. + assumption ]. Qed. Lemma Zdiv_rest_correct2 : @@ -327,7 +327,7 @@ Section power_div_with_rest. apply f_equal with (f := fun z:Z => z + r); do 2 rewrite Zmult_plus_distr_l; rewrite Zmult_assoc; rewrite (Zmult_comm (Zneg p0) 2); rewrite <- Zplus_assoc; - apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z); + apply f_equal with (f := fun z:Z => 2 * Zneg p0 * d + z); omega | omega ] | rewrite BinInt.Zneg_xO; unfold Zminus in |- *; intro; elim H; intros; diff --git a/theories/ZArith/Zsqrt.v b/theories/ZArith/Zsqrt.v index a97750d77f..b845cf47a2 100644 --- a/theories/ZArith/Zsqrt.v +++ b/theories/ZArith/Zsqrt.v @@ -119,7 +119,7 @@ Definition Zsqrt : | Zneg p => fun h => False_rec - {s : Z & + {s : Z & {r : Z | Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}} (h (refl_equal Datatypes.Gt)) @@ -199,7 +199,7 @@ Qed. Theorem Zsqrt_le: forall p q, 0 <= p <= q -> Zsqrt_plain p <= Zsqrt_plain q. Proof. - intros p q [H1 H2]; case Zle_lt_or_eq with (1:=H2); clear H2; intros H2; + intros p q [H1 H2]; case Zle_lt_or_eq with (1:=H2); clear H2; intros H2; [ | subst q; auto with zarith]. case (Zle_or_lt (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3. assert (Hp: (0 <= Zsqrt_plain q)). diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index 650c797452..32d6de19a4 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -15,7 +15,7 @@ Open Local Scope Z_scope. (** Well-founded relations on Z. *) -(** We define the following family of relations on [Z x Z]: +(** We define the following family of relations on [Z x Z]: [x (Zwf c) y] iff [x < y & c <= y] *) diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index 5edf680133..6ebdcb50a9 100644 --- a/theories/ZArith/auxiliary.v +++ b/theories/ZArith/auxiliary.v @@ -25,7 +25,7 @@ Open Local Scope Z_scope. Theorem Zne_left : forall n m:Z, Zne n m -> Zne (n + - m) 0. Proof. intros x y; unfold Zne in |- *; unfold not in |- *; intros H1 H2; apply H1; - apply Zplus_reg_l with (- y); rewrite Zplus_opp_l; + apply Zplus_reg_l with (- y); rewrite Zplus_opp_l; rewrite Zplus_comm; trivial with arith. Qed. @@ -97,7 +97,7 @@ Proof. intros x y z H1 H2 H3; apply Zle_trans with (m := y * x); [ apply Zmult_gt_0_le_0_compat; assumption | pattern (y * x) at 1 in |- *; rewrite <- Zplus_0_r; - apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt; + apply Zplus_le_compat_l; apply Zlt_le_weak; apply Zgt_lt; assumption ]. Qed. diff --git a/tools/coq_makefile.ml4 b/tools/coq_makefile.ml4 index 8a39c383a2..486c8804f4 100644 --- a/tools/coq_makefile.ml4 +++ b/tools/coq_makefile.ml4 @@ -42,7 +42,7 @@ let rec print_list sep = function let list_iter_i f = let rec aux i = function [] -> () | a::l -> f i a; aux (i+1) l in aux 1 -let best_ocamlc = +let best_ocamlc = if Coq_config.best = "opt" then "ocamlc.opt" else "ocamlc" let best_ocamlopt = if Coq_config.best = "opt" then "ocamlopt.opt" else "ocamlopt" @@ -85,7 +85,7 @@ coq_makefile [subdirectory] .... [file.v] ... [file.ml] ... [-custom [-impredicative-set]: compile with option -impredicative-set of coq [-no-install]: build a makefile with no install target [-f file]: take the contents of file as arguments -[-o file]: output should go in file file +[-o file]: output should go in file file [-h]: print this usage summary [--help]: equivalent to [-h]\n"; exit 1 @@ -215,7 +215,7 @@ let clean sds sps = print "\trm -f $(CMOFILES) $(MLFILES:.ml=.cmi) $(MLFILES:.ml=.ml.d) $(MLFILES:.ml=.cmx) $(MLFILES:.ml=.o)\n"; print "\t- rm -rf html\n"; List.iter - (fun (file,_,_) -> + (fun (file,_,_) -> if not (is_genrule file) then (print "\t- rm -f "; print file; print "\n")) sps; @@ -233,8 +233,8 @@ let clean sds sps = print "\t@echo CAMLP4LIB =\t$(CAMLP4LIB)\n\n" let header_includes () = () - -let footer_includes () = + +let footer_includes () = if !some_vfile then print "-include $(VFILES:.v=.v.d)\n.SECONDARY: $(VFILES:.v=.v.d)\n\n"; if !some_mlfile then print "-include $(MLFILES:.ml=.ml.d)\n.SECONDARY: $(MLFILES:.ml=.ml.d)\n\n" @@ -267,7 +267,7 @@ let variables defs = let var_aux (v,def) = print v; print "="; print def; print "\n" in section "Variables definitions."; print "ZFLAGS=$(OCAMLLIBS) $(COQSRCLIBS) -I $(CAMLP4LIB)\n"; - if !opt = "-byte" then + if !opt = "-byte" then print "override OPT:=-byte\n" else print "OPT:=\n"; @@ -297,8 +297,8 @@ let parameters () = print "# This Makefile may take 3 arguments passed as environment variables:\n"; print "# - COQBIN to specify the directory where Coq binaries resides;\n"; print "# - CAMLBIN and CAMLP4BIN to give the path for the OCaml and Camlp4/5 binaries.\n"; - print "COQLIB:=$(shell $(COQBIN)coqtop -where | sed -e 's/\\\\/\\\\\\\\/g')\n"; - print "CAMLP4:=\"$(shell $(COQBIN)coqtop -config | awk -F = '/CAMLP4=/{print $$2}')\"\n"; + print "COQLIB:=$(shell $(COQBIN)coqtop -where | sed -e 's/\\\\/\\\\\\\\/g')\n"; + print "CAMLP4:=\"$(shell $(COQBIN)coqtop -config | awk -F = '/CAMLP4=/{print $$2}')\"\n"; print "ifndef CAMLP4BIN\n CAMLP4BIN:=$(CAMLBIN)\nendif\n\n"; print "CAMLP4LIB:=$(shell $(CAMLP4BIN)$(CAMLP4) -where)\n\n" @@ -329,7 +329,7 @@ let rec special = function | [] -> [] | Special (file,deps,com) :: r -> (file,deps,com) :: (special r) | _ :: r -> special r - + let custom sps = let pr_path (file,dependencies,com) = print file; print ": "; print dependencies; print "\n"; @@ -347,7 +347,7 @@ let subdirs sds = section "Special targets."; print ".PHONY: "; print_list " " - ("all" :: "opt" :: "byte" :: "archclean" :: "clean" :: "install" + ("all" :: "opt" :: "byte" :: "archclean" :: "clean" :: "install" :: "depend" :: "html" :: sds); print "\n\n" @@ -356,7 +356,7 @@ let rec split_arguments = function let (v,m,o,s),i,d = split_arguments r in ((canonize n::v,m,o,s),i,d) | ML n :: r -> let (v,m,o,s),i,d = split_arguments r in ((v,canonize n::m,o,s),i,d) - | Special (n,dep,c) :: r -> + | Special (n,dep,c) :: r -> let (v,m,o,s),i,d = split_arguments r in ((v,m,(n,dep,c)::o,s),i,d) | Subdir n :: r -> let (v,m,o,s),i,d = split_arguments r in ((v,m,o,n::s),i,d) @@ -364,7 +364,7 @@ let rec split_arguments = function let t,(i,r),d = split_arguments r in (t,((p,absolute_dir p)::i,r),d) | RInclude (p,l) :: r -> let t,(i,r),d = split_arguments r in (t,(i,(p,l,absolute_dir p)::r),d) - | Def (v,def) :: r -> + | Def (v,def) :: r -> let t,i,d = split_arguments r in (t,i,(v,def)::d) | [] -> ([],[],[],[]),([],[]),[] @@ -397,15 +397,15 @@ let main_targets vfiles mlfiles other_targets inc = if !some_mlfile then print "$(CMOFILES) "; if Coq_config.has_natdynlink && !some_mlfile then print "$(CMXSFILES) "; print_list "\\\n " other_targets; print "\n"; - if !some_vfile then + if !some_vfile then begin print "spec: $(VIFILES)\n\n"; print "gallina: $(GFILES)\n\n"; print "html: $(GLOBFILES) $(VFILES)\n"; - print "\t- mkdir html\n"; + print "\t- mkdir html\n"; print "\t$(COQDOC) -toc -html $(COQDOCLIBS) -d html $(VFILES)\n\n"; print "gallinahtml: $(GLOBFILES) $(VFILES)\n"; - print "\t- mkdir html\n"; + print "\t- mkdir html\n"; print "\t$(COQDOC) -toc -html -g $(COQDOCLIBS) -d html $(VFILES)\n\n"; print "all.ps: $(VFILES)\n"; print "\t$(COQDOC) -toc -ps $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $(VFILES)`\n\n"; @@ -425,20 +425,20 @@ let all_target (vfiles, mlfiles, sps, sds) inc = main_targets vfiles mlfiles other_targets inc; custom sps; subdirs sds - + let parse f = - let rec string = parser + let rec string = parser | [< '' ' | '\n' | '\t' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(string s) | [< >] -> "" - and string2 = parser + and string2 = parser | [< ''"' >] -> "" | [< 'c; s >] -> (String.make 1 c)^(string2 s) - and skip_comment = parser + and skip_comment = parser | [< ''\n'; s >] -> s | [< 'c; s >] -> skip_comment s | [< >] -> [< >] - and args = parser + and args = parser | [< '' ' | '\n' | '\t'; s >] -> args s | [< ''#'; s >] -> args (skip_comment s) | [< ''"'; str = string2; s >] -> ("" ^ str) :: args s @@ -451,13 +451,13 @@ let parse f = res let rec process_cmd_line = function - | [] -> + | [] -> some_file := !some_file or !some_mlfile or !some_vfile; [] - | ("-h"|"--help") :: _ -> + | ("-h"|"--help") :: _ -> usage () - | ("-no-opt"|"-byte") :: r -> + | ("-no-opt"|"-byte") :: r -> opt := "-byte"; process_cmd_line r - | ("-full"|"-opt") :: r -> + | ("-full"|"-opt") :: r -> opt := "-opt"; process_cmd_line r | "-impredicative-set" :: r -> impredicative_set := true; process_cmd_line r @@ -476,32 +476,32 @@ let rec process_cmd_line = function Include d :: (process_cmd_line r) | "-R" :: p :: l :: r -> RInclude (p,l) :: (process_cmd_line r) - | ("-I"|"-custom") :: _ -> + | ("-I"|"-custom") :: _ -> usage () - | "-f" :: file :: r -> + | "-f" :: file :: r -> make_name := file; process_cmd_line ((parse file)@r) - | ["-f"] -> + | ["-f"] -> usage () - | "-o" :: file :: r -> + | "-o" :: file :: r -> makefile_name := file; output_channel := (open_out file); (process_cmd_line r) - | v :: "=" :: def :: r -> + | v :: "=" :: def :: r -> Def (v,def) :: (process_cmd_line r) | f :: r -> if Filename.check_suffix f ".v" then begin - some_vfile := true; + some_vfile := true; V f :: (process_cmd_line r) end else if (Filename.check_suffix f ".ml") || (Filename.check_suffix f ".ml4") then begin - some_mlfile := true; + some_mlfile := true; ML f :: (process_cmd_line r) end else if (Filename.check_suffix f ".mli") then begin Printf.eprintf "Warning: no need for .mli files, skipped %s\n" f; process_cmd_line r end else Subdir f :: (process_cmd_line r) - + let banner () = print (Printf.sprintf "########################################################################## @@ -518,23 +518,23 @@ let warning () = print "# This Makefile has been automagically generated\n"; print "# Edit at your own risks !\n"; print "#\n# END OF WARNING\n\n" - + let print_list l = List.iter (fun x -> print x; print " ") l - + let command_line args = print "#\n# This Makefile was generated by the command line :\n"; print "# coq_makefile "; print_list args; print "\n#\n\n" - + let directories_deps l = - let print_dep f dep = + let print_dep f dep = if dep <> [] then begin print f; print ": "; print_list dep; print "\n" end in let rec iter ((dirs,before) as acc) = function - | [] -> + | [] -> () - | (Subdir d) :: l -> + | (Subdir d) :: l -> print_dep d before; iter (d :: dirs, d :: before) l | (ML f) :: l -> print_dep f dirs; iter (dirs, f :: before) l @@ -542,7 +542,7 @@ let directories_deps l = print_dep f dirs; iter (dirs, f :: before) l | (Special (f,_,_)) :: l -> print_dep f dirs; iter (dirs, f :: before) l - | _ :: l -> + | _ :: l -> iter acc l in iter ([],[]) l @@ -560,7 +560,7 @@ let warn_install_at_root_directory (vfiles,mlfiles,_,_) (inc_i,inc_r) = if not !no_install && List.exists (fun f -> List.mem_assoc (Filename.dirname f) inc_top) files then - Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R %sis recommended\n" + Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R %sis recommended\n" (if inc_r_top = [] then "" else "with non trivial logical root ") let check_overlapping_include (inc_i,inc_r) = @@ -575,7 +575,7 @@ let check_overlapping_include (inc_i,inc_r) = Printf.eprintf "Warning: in options -R, %s and %s overlap\n" pdir pdir') l; List.iter (fun (pdir',abspdir') -> if is_prefix abspdir abspdir' or is_prefix abspdir' abspdir then - Printf.eprintf "Warning: in option -I, %s overlap with %s in option -R\n" pdir' pdir) inc_i + Printf.eprintf "Warning: in option -I, %s overlap with %s in option -R\n" pdir' pdir) inc_i in aux inc_r let do_makefile args = @@ -602,12 +602,12 @@ let do_makefile args = warning (); if not (!output_channel == stdout) then close_out !output_channel; exit 0 - + let main () = let args = if Array.length Sys.argv = 1 then usage (); List.tl (Array.to_list Sys.argv) in do_makefile args - + let _ = Printexc.catch main () diff --git a/tools/coq_tex.ml4 b/tools/coq_tex.ml4 index 30f55468b1..c46a187c56 100644 --- a/tools/coq_tex.ml4 +++ b/tools/coq_tex.ml4 @@ -12,7 +12,7 @@ * JCF, 16/1/98 * adapted from caml-tex (perl script written by Xavier Leroy) * - * Perl isn't as portable as it pretends to be, and is quite difficult + * Perl isn't as portable as it pretends to be, and is quite difficult * to read and maintain... Let us rewrite the stuff in Caml! *) let _ = @@ -64,10 +64,10 @@ let extract texfile inputv = outside () in try - output_string chan_out + output_string chan_out ("Set Printing Width " ^ (string_of_int !linelen) ^".\n"); outside () - with End_of_file -> + with End_of_file -> begin close_in chan_in; close_out chan_out end (* Second pass: insert the answers of Coq from [coq_output] into the @@ -89,11 +89,11 @@ let expos = Str.regexp "^" let tex_escaped s = let rec trans = parser - | [< s1 = (parser - | [< ''_'|'$'|'{'|'}'|'&'|'%'|'#' as c >] -> + | [< s1 = (parser + | [< ''_'|'$'|'{'|'}'|'&'|'%'|'#' as c >] -> "\\" ^ (String.make 1 c) - | [< ''\\' >] -> "{\\char'134}" - | [< ''^' >] -> "{\\char'136}" + | [< ''\\' >] -> "{\\char'134}" + | [< ''^' >] -> "{\\char'136}" | [< ''~' >] -> "{\\char'176}" | [< '' ' >] -> "~" | [< ''<' >] -> "{<}" @@ -101,7 +101,7 @@ let tex_escaped s = | [< 'c >] -> String.make 1 c); s2 = trans >] -> s1 ^ s2 | [< >] -> "" - in + in trans (Stream.of_string s) let encapsule sl c_out s = @@ -109,7 +109,7 @@ let encapsule sl c_out s = Printf.fprintf c_out "\\texttt{\\textit{%s}}\\\\\n" (tex_escaped s) else Printf.fprintf c_out "\\texttt{%s}\\\\\n" (tex_escaped s) - + let print_block c_out bl = List.iter (fun s -> if s="" then () else encapsule !slanted c_out s) bl @@ -138,7 +138,7 @@ let insert texfile coq_output result = let first = !last_read in first :: (read_lines ()) in (* we are just after \end{coq_...} block *) - let rec just_after () = + let rec just_after () = let s = input_line c_tex in if Str.string_match begin_coq_example s 0 then begin inside (Str.matched_group 1 s <> "example*") @@ -149,11 +149,11 @@ let insert texfile coq_output result = output_string c_out "\\end{flushleft}\n"; if !small then output_string c_out "\\end{small}\n"; if Str.string_match begin_coq_eval s 0 then - eval 0 + eval 0 else begin output_string c_out (s ^ "\n"); outside () - end + end end (* we are outside of a \begin{coq_...} ... \end{coq_...} block *) and outside () = @@ -173,7 +173,7 @@ let insert texfile coq_output result = (* we are inside a \begin{coq_example?} ... \end{coq_example?} block * show_answers tells what kind of block it is * k is the number of lines read until now *) - and inside show_answers show_questions k first_block = + and inside show_answers show_questions k first_block = let s = input_line c_tex in if Str.string_match end_coq_example s 0 then begin just_after () @@ -183,7 +183,7 @@ let insert texfile coq_output result = if show_questions then encapsule false c_out ("Coq < " ^ s); if has_match dot_end_line s then begin let bl = next_block (succ k) in - if !verbose then List.iter print_endline bl; + if !verbose then List.iter print_endline bl; if show_answers then print_block c_out bl; inside show_answers show_questions 0 false end else @@ -228,14 +228,14 @@ let one_file texfile = else if Filename.check_suffix texfile ".tex" then (Filename.chop_suffix texfile ".tex") ^ ".v.tex" else - texfile ^ ".v.tex" + texfile ^ ".v.tex" in try (* 1. extract Coq phrases *) extract texfile inputv; (* 2. run Coq on input *) let _ = Sys.command (Printf.sprintf "%s < %s > %s 2>&1" !image inputv - coq_output) + coq_output) in (* 3. insert Coq output into original file *) insert texfile coq_output result; @@ -250,7 +250,7 @@ let one_file texfile = * of all the files in the command line, one by one *) let files = ref [] - + let parse_cl () = Arg.parse [ "-o", Arg.String (fun s -> output_specified := true; output := s), diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 5faedf6828..9be50c62ca 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -45,7 +45,7 @@ let add_coqlib_known phys_dir log_dir f = Hashtbl.add coqlibKnown name () | _ -> () -let sort () = +let sort () = let seen = Hashtbl.create 97 in let rec loop file = let file = canonize file in @@ -57,8 +57,8 @@ let sort () = while true do match coq_action lb with | Require sl -> - List.iter - (fun s -> + List.iter + (fun s -> try loop (Hashtbl.find vKnown s) with Not_found -> ()) sl @@ -73,16 +73,16 @@ let sort () = List.iter (fun (name,_) -> loop name) !vAccu let (dep_tab : (string,string list) Hashtbl.t) = Hashtbl.create 151 - -let mL_dep_list b f = - try + +let mL_dep_list b f = + try Hashtbl.find dep_tab f with Not_found -> - let deja_vu = ref ([] : string list) in - try - let chan = open_in f in - let buf = Lexing.from_channel chan in - try + let deja_vu = ref ([] : string list) in + try + let chan = open_in f in + let buf = Lexing.from_channel chan in + try while true do let (Use_module str) = caml_action buf in if str = b then begin @@ -93,14 +93,14 @@ let mL_dep_list b f = if not (List.mem str !deja_vu) then addQueue deja_vu str done; [] with Fin_fichier -> begin - close_in chan; + close_in chan; let rl = List.rev !deja_vu in Hashtbl.add dep_tab f rl; rl end with Sys_error _ -> [] -let affiche_Declare f dcl = +let affiche_Declare f dcl = printf "\n*** In file %s: \n" f; printf "Declare ML Module"; List.iter (fun str -> printf " \"%s\"" str) dcl; @@ -115,7 +115,7 @@ let warning_Declare f dcl = eprintf ".\n"; flush stderr -let traite_Declare f = +let traite_Declare f = let decl_list = ref ([] : string list) in let rec treat = function | s :: ll -> @@ -133,15 +133,15 @@ let traite_Declare f = try let chan = open_in f in let buf = Lexing.from_channel chan in - begin try + begin try while true do let tok = coq_action buf in (match tok with - | Declare sl -> + | Declare sl -> decl_list := []; treat sl; decl_list := List.rev !decl_list; - if !option_D then + if !option_D then affiche_Declare f !decl_list else if !decl_list <> sl then warning_Declare f !decl_list diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 43395b0e9d..21fc66fc68 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -78,7 +78,7 @@ let addQueue q v = q := v :: !q let safe_hash_add clq q (k,v) = try let v2 = Hashtbl.find q k in - if v<>v2 then + if v<>v2 then let rec add_clash = function (k1,l1)::cltl when k=k1 -> (k1,v::l1)::cltl | cl::cltl -> cl::add_clash cltl @@ -88,7 +88,7 @@ let safe_hash_add clq q (k,v) = (** Files found in the loadpaths. For the ML files, the string is the basename without extension. - To allow ML source filename to be potentially capitalized, + To allow ML source filename to be potentially capitalized, we perform a double search. *) @@ -177,16 +177,16 @@ let depend_ML str = | None, None -> "", "" let traite_fichier_ML md ext = - try - let chan = open_in (md ^ ext) in - let buf = Lexing.from_channel chan in + try + let chan = open_in (md ^ ext) in + let buf = Lexing.from_channel chan in let deja_vu = ref [md] in let a_faire = ref "" in let a_faire_opt = ref "" in - begin try + begin try while true do let (Use_module str) = caml_action buf in - if List.mem str !deja_vu then + if List.mem str !deja_vu then () else begin addQueue deja_vu str; @@ -223,13 +223,13 @@ let canonize f = | (f,_) :: _ -> f | _ -> f -let traite_fichier_Coq verbose f = - try - let chan = open_in f in - let buf = Lexing.from_channel chan in +let traite_fichier_Coq verbose f = + try + let chan = open_in f in + let buf = Lexing.from_channel chan in let deja_vu_v = ref ([]: string list list) and deja_vu_ml = ref ([] : string list) in - try + try while true do let tok = coq_action buf in match tok with @@ -240,18 +240,18 @@ let traite_fichier_Coq verbose f = try let file_str = safe_assoc verbose f str in printf " %s%s" (canonize file_str) !suffixe - with Not_found -> + with Not_found -> if verbose && not (Hashtbl.mem coqlibKnown str) then warning_module_notfound f str end) strl - | RequireString s -> + | RequireString s -> let str = Filename.basename s in if not (List.mem [str] !deja_vu_v) then begin addQueue deja_vu_v [str]; try let file_str = Hashtbl.find vKnown [str] in printf " %s%s" (canonize file_str) !suffixe - with Not_found -> + with Not_found -> if not (Hashtbl.mem coqlibKnown [str]) then warning_notfound f s end @@ -273,7 +273,7 @@ let traite_fichier_Coq verbose f = | None -> warning_declare f str end in List.iter decl sl - | Load str -> + | Load str -> let str = Filename.basename str in if not (List.mem [str] !deja_vu_v) then begin addQueue deja_vu_v [str]; @@ -285,11 +285,11 @@ let traite_fichier_Coq verbose f = done with Fin_fichier -> (); close_in chan - with Sys_error _ -> () + with Sys_error _ -> () let mL_dependencies () = - List.iter + List.iter (fun (name,ext,dirname) -> let fullname = file_name name dirname in let (dep,dep_opt) = traite_fichier_ML fullname ext in @@ -344,10 +344,10 @@ let add_known phys_dir log_dir f = | (basename,".mllib") -> add_mllib_known basename (Some phys_dir) | _ -> () -(* Visits all the directories under [dir], including [dir], +(* Visits all the directories under [dir], including [dir], or just [dir] if [recur=false] *) -let rec add_directory recur add_file phys_dir log_dir = +let rec add_directory recur add_file phys_dir log_dir = let dirh = opendir phys_dir in try while true do @@ -366,32 +366,32 @@ let rec add_directory recur add_file phys_dir log_dir = done with End_of_file -> closedir dirh -let add_dir add_file phys_dir log_dir = +let add_dir add_file phys_dir log_dir = try add_directory false add_file phys_dir log_dir with Unix_error _ -> () -let add_rec_dir add_file phys_dir log_dir = +let add_rec_dir add_file phys_dir log_dir = handle_unix_error (add_directory true add_file phys_dir) log_dir let rec treat_file old_dirname old_name = - let name = Filename.basename old_name + let name = Filename.basename old_name and new_dirname = Filename.dirname old_name in - let dirname = - match (old_dirname,new_dirname) with + let dirname = + match (old_dirname,new_dirname) with | (d, ".") -> d | (None,d) -> Some d - | (Some d1,d2) -> Some (d1//d2) + | (Some d1,d2) -> Some (d1//d2) in let complete_name = file_name name dirname in - match try (stat complete_name).st_kind with _ -> S_BLK with + match try (stat complete_name).st_kind with _ -> S_BLK with | S_DIR -> - (if name.[0] <> '.' then + (if name.[0] <> '.' then let dir=opendir complete_name in - let newdirname = - match dirname with + let newdirname = + match dirname with | None -> name - | Some d -> d//name + | Some d -> d//name in - try + try while true do treat_file (Some newdirname) (readdir dir) done with End_of_file -> closedir dir) | S_REG -> diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index 3c7d09e1fa..b13c16bad9 100755 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -7,26 +7,26 @@ (************************************************************************) (*i $Id$ i*) - + { - open Filename + open Filename open Lexing - + type mL_token = Use_module of string type spec = bool - - type coq_token = + + type coq_token = | Require of string list list | RequireString of string | Declare of string list | Load of string let comment_depth = ref 0 - + exception Fin_fichier - + let module_current_name = ref [] let module_names = ref [] let ml_module_name = ref "" @@ -62,10 +62,10 @@ rule coq_action = parse | "\"" { string lexbuf; coq_action lexbuf} | "(*" (* "*)" *) - { comment_depth := 1; comment lexbuf; coq_action lexbuf } - | eof - { raise Fin_fichier} - | _ + { comment_depth := 1; comment lexbuf; coq_action lexbuf } + | eof + { raise Fin_fichier} + | _ { coq_action lexbuf } and caml_action = parse @@ -132,7 +132,7 @@ and comment = parse | "'" '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { comment lexbuf } | eof - { raise Fin_fichier } + { raise Fin_fichier } | _ { comment lexbuf } and string = parse @@ -157,7 +157,7 @@ and load_file = parse Load (if check_suffix f ".v" then chop_suffix f ".v" else f) } | coq_ident { let s = lexeme lexbuf in skip_to_dot lexbuf; Load s } - | eof + | eof { raise Fin_fichier } | _ { load_file lexbuf } @@ -196,7 +196,7 @@ and opened_file_fields = parse { module_current_name := field_name (Lexing.lexeme lexbuf) :: !module_current_name; opened_file_fields lexbuf } - | coq_ident { module_names := + | coq_ident { module_names := List.rev !module_current_name :: !module_names; module_current_name := [Lexing.lexeme lexbuf]; opened_file_fields lexbuf } @@ -211,10 +211,10 @@ and modules = parse | "(*" (* "*)" *) { comment_depth := 1; comment lexbuf; modules lexbuf } | '"' [^'"']* '"' - { let lex = (Lexing.lexeme lexbuf) in + { let lex = (Lexing.lexeme lexbuf) in let str = String.sub lex 1 (String.length lex - 2) in mllist := str :: !mllist; modules lexbuf} - | _ { (Declare (List.rev !mllist)) } + | _ { (Declare (List.rev !mllist)) } and qual_id = parse | '.' [^ '.' '(' '['] { diff --git a/tools/coqdoc/alpha.ml b/tools/coqdoc/alpha.ml index aef17031d4..fe26e0086c 100644 --- a/tools/coqdoc/alpha.ml +++ b/tools/coqdoc/alpha.ml @@ -32,10 +32,10 @@ let compare_char c1 c2 = match norm_char c1, norm_char c2 with | _, 'A'..'Z' -> 1 | c1, c2 -> compare c1 c2 -let compare_string s1 s2 = +let compare_string s1 s2 = let n1 = String.length s1 in let n2 = String.length s2 in - let rec cmp i = + let rec cmp i = if i == n1 || i == n2 then n1 - n2 else diff --git a/tools/coqdoc/cdglobals.ml b/tools/coqdoc/cdglobals.ml index 2ee90820f3..4994a12803 100644 --- a/tools/coqdoc/cdglobals.ml +++ b/tools/coqdoc/cdglobals.ml @@ -37,7 +37,7 @@ type glob_source_t = | DotGlob | GlobFile of string -let glob_source = ref DotGlob +let glob_source = ref DotGlob let header_trailer = ref true let header_file = ref "" diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index d9ed862972..22d81d6f54 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -16,7 +16,7 @@ open Lexing (* A list function we need *) - let rec take n ls = + let rec take n ls = if n = 0 then [] else match ls with | [] -> [] @@ -25,7 +25,7 @@ (* count the number of spaces at the beginning of a string *) let count_spaces s = let n = String.length s in - let rec count c i = + let rec count c i = if i == n then c,i else match s.[i] with | '\t' -> count (c + (8 - (c mod 8))) (i + 1) | ' ' -> count (c + 1) (i + 1) @@ -47,10 +47,10 @@ if l <= r then String.sub s l (r-l+1) else s let sec_title s = - let rec count lev i = - if s.[i] = '*' then - count (succ lev) (succ i) - else + let rec count lev i = + if s.[i] = '*' then + count (succ lev) (succ i) + else let t = String.sub s i (String.length s - i) in lev, cut_head_tail_spaces t in @@ -88,14 +88,14 @@ let state_stack = Stack.create () - let save_state () = + let save_state () = Stack.push { st_gallina = !Cdglobals.gallina; st_light = !Cdglobals.light } state_stack let restore_state () = let s = Stack.pop state_stack in Cdglobals.gallina := s.st_gallina; Cdglobals.light := s.st_light - + let without_ref r f x = save_state (); r := false; f x; restore_state () let without_gallina = without_ref Cdglobals.gallina @@ -127,16 +127,16 @@ if is_section s then begin incr sections_to_close; true end else if is_end s then begin - if !sections_to_close > 0 then begin - decr sections_to_close; true - end else + if !sections_to_close > 0 then begin + decr sections_to_close; true + end else false end else true (* for item lists *) - type list_compare = - | Before + type list_compare = + | Before | StartLevel of int | InLevel of int * bool @@ -147,16 +147,16 @@ let find_level levels cur_indent = match levels with | [] -> Before - | (l::ls) -> + | (l::ls) -> if cur_indent < l then Before - else + else (* cur_indent will never be less than the head of the list *) - let rec findind ls n = + let rec findind ls n = match ls with | [] -> InLevel (n,true) | (l :: []) -> if cur_indent = l then StartLevel n else InLevel (n,true) - | (l1 :: l2 :: ls) -> + | (l1 :: l2 :: ls) -> if cur_indent = l1 then StartLevel n else if cur_indent < l2 then InLevel (n,false) else findind (l2 :: ls) (n+1) @@ -171,16 +171,16 @@ let check_start_list str = let n_dashes = count_dashes str in let (n_spaces,_) = count_spaces str in - if n_dashes >= 4 then + if n_dashes >= 4 then Rule - else + else if n_dashes = 1 then List n_spaces else Neither (* examine a string for subtitleness *) - let subtitle m s = + let subtitle m s = match Str.split_delim (Str.regexp ":") s with | [] -> false | (name::_) -> @@ -194,7 +194,7 @@ let token_buffer = Buffer.create 1024 - let token_re = + let token_re = Str.regexp "[ \t]*(\\*\\*[ \t]+printing[ \t]+\\([^ \t]+\\)" let printing_token_re = Str.regexp @@ -205,8 +205,8 @@ if Str.string_match token_re toks 0 then let tok = Str.matched_group 1 toks in if Str.string_match printing_token_re pps 0 then - let pp = - (try Some (Str.matched_group 3 pps) with _ -> + let pp = + (try Some (Str.matched_group 3 pps) with _ -> try Some (Str.matched_group 4 pps) with _ -> None), (try Some (Str.matched_group 6 pps) with _ -> None) in @@ -214,8 +214,8 @@ with _ -> () - let remove_token_re = - Str.regexp + let remove_token_re = + Str.regexp "[ \t]*(\\*\\*[ \t]+remove[ \t]+printing[ \t]+\\([^ \t]+\\)[ \t]*\\*)" let remove_printing_token toks = @@ -234,7 +234,7 @@ else String.sub s 1 (String.length s - 3) - let symbol lexbuf s = Output.symbol s + let symbol lexbuf s = Output.symbol s } @@ -244,41 +244,41 @@ let space = [' ' '\t'] let space_nl = [' ' '\t' '\n' '\r'] let nl = "\r\n" | '\n' -let firstchar = - ['A'-'Z' 'a'-'z' '_' - (* iso 8859-1 accents *) +let firstchar = + ['A'-'Z' 'a'-'z' '_' + (* iso 8859-1 accents *) '\192'-'\214' '\216'-'\246' '\248'-'\255' ] | (* *) '\194' '\185' | - (* utf-8 latin 1 supplement *) + (* utf-8 latin 1 supplement *) '\195' ['\128'-'\191'] | - (* utf-8 letterlike symbols *) + (* utf-8 letterlike symbols *) '\206' ('\160' | [ '\177'-'\183'] | '\187') | '\226' ('\130' [ '\128'-'\137' ] (* subscripts *) | '\129' [ '\176'-'\187' ] (* superscripts *) | '\132' ['\128'-'\191'] | '\133' ['\128'-'\143']) -let identchar = +let identchar = firstchar | ['\'' '0'-'9' '@' ] let id = firstchar identchar* let pfx_id = (id '.')* -let identifier = +let identifier = id | pfx_id id (* This misses unicode stuff, and it adds "[" and "]". It's only an approximation of idents - used for detecting whether an underscore is part of an identifier or meant to indicate emphasis *) -let nonidentchar = +let nonidentchar = [^ 'A'-'Z' 'a'-'z' '_' '[' ']' - (* iso 8859-1 accents *) + (* iso 8859-1 accents *) '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9' '@' ] let symbolchar_symbol_no_brackets = ['!' '$' '%' '&' '*' '+' ',' '^' '#' '\\' '/' '-' '<' '>' '|' ':' '?' '=' '~' ] | - (* utf-8 symbols *) + (* utf-8 symbols *) '\226' ['\134'-'\143' '\152'-'\155' '\164'-'\165' '\168'-'\171'] _ -let symbolchar_no_brackets = symbolchar_symbol_no_brackets | +let symbolchar_no_brackets = symbolchar_symbol_no_brackets | [ '@' '{' '}' '(' ')' 'A'-'Z' 'a'-'z' '_'] let symbolchar = symbolchar_no_brackets | '[' | ']' let token_no_brackets = symbolchar_symbol_no_brackets symbolchar_no_brackets* @@ -287,17 +287,17 @@ let printing_token = (token | id)+ (* tokens with balanced brackets *) let token_brackets = - ( token_no_brackets ('[' token_no_brackets? ']')* + ( token_no_brackets ('[' token_no_brackets? ']')* | token_no_brackets? ('[' token_no_brackets? ']')+ ) token_no_brackets? -let thm_token = - "Theorem" - | "Lemma" - | "Fact" - | "Remark" - | "Corollary" - | "Proposition" +let thm_token = + "Theorem" + | "Lemma" + | "Fact" + | "Remark" + | "Corollary" + | "Proposition" | "Property" | "Goal" @@ -305,18 +305,18 @@ let prf_token = "Next" space+ "Obligation" | "Proof" (space* "." | space+ "with") -let def_token = - "Definition" - | "Let" +let def_token = + "Definition" + | "Let" | "Class" | "SubClass" | "Example" - | "Local" - | "Fixpoint" - | "Boxed" - | "CoFixpoint" - | "Record" - | "Structure" + | "Local" + | "Fixpoint" + | "Boxed" + | "CoFixpoint" + | "Record" + | "Structure" | "Scheme" | "Inductive" | "CoInductive" @@ -324,15 +324,15 @@ let def_token = | "Instance" | "Global" space+ "Instance" -let decl_token = - "Hypothesis" - | "Hypotheses" - | "Parameter" - | "Axiom" 's'? +let decl_token = + "Hypothesis" + | "Hypotheses" + | "Parameter" + | "Axiom" 's'? | "Conjecture" let gallina_ext = - "Module" + "Module" | "Include" space+ "Type" | "Include" | "Declare" space+ "Module" @@ -352,7 +352,7 @@ let gallina_ext = | ("Hypothesis" | "Hypotheses") | "End" -let commands = +let commands = "Pwd" | "Cd" | "Drop" @@ -378,9 +378,9 @@ let commands = let end_kw = "Qed" | "Defined" | "Save" | "Admitted" | "Abort" -let extraction = +let extraction = "Extraction" - | "Recursive" space+ "Extraction" + | "Recursive" space+ "Extraction" | "Extract" let gallina_kw = thm_token | def_token | decl_token | gallina_ext | commands | extraction @@ -397,7 +397,7 @@ let gallina_kw_to_hide = | "Require" | "Import" | "Export" - | "Load" + | "Load" | "Hint" | "Open" | "Close" @@ -406,7 +406,7 @@ let gallina_kw_to_hide = | "Opaque" | ("Declare" space+ ("Morphism" | "Step") ) | ("Set" | "Unset") space+ "Printing" space+ "Coercions" - | "Declare" space+ ("Left" | "Right") space+ "Step" + | "Declare" space+ ("Left" | "Right") space+ "Step" let section = "*" | "**" | "***" | "****" @@ -430,12 +430,12 @@ rule coq_bol = parse | space* nl+ { if not (!in_proof <> None && (!Cdglobals.gallina || !Cdglobals.light)) then Output.empty_line_of_code (); coq_bol lexbuf } | space* "(**" space_nl - { Output.end_coq (); Output.start_doc (); + { Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in - Output.end_doc (); Output.start_coq (); + Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } | space* "Comments" space_nl - { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); + { Output.end_coq (); Output.start_doc (); comments lexbuf; Output.end_doc (); Output.start_coq (); coq lexbuf } | space* begin_hide { skip_hide lexbuf; coq_bol lexbuf } @@ -445,63 +445,63 @@ rule coq_bol = parse { end_show (); coq_bol lexbuf } | space* gallina_kw_to_hide { let s = lexeme lexbuf in - if !Cdglobals.light && section_or_end s then + if !Cdglobals.light && section_or_end s then let eol = skip_to_dot lexbuf in if eol then (coq_bol lexbuf) else coq lexbuf - else + else begin let nbsp,isp = count_spaces s in - Output.indentation nbsp; + Output.indentation nbsp; let s = String.sub s isp (String.length s - isp) in - Output.ident s (lexeme_start lexbuf + isp); - let eol = body lexbuf in + Output.ident s (lexeme_start lexbuf + isp); + let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf end } | space* thm_token - { let s = lexeme lexbuf in + { let s = lexeme lexbuf in let nbsp,isp = count_spaces s in let s = String.sub s isp (String.length s - isp) in Output.indentation nbsp; - Output.ident s (lexeme_start lexbuf + isp); + Output.ident s (lexeme_start lexbuf + isp); let eol = body lexbuf in in_proof := Some eol; if eol then coq_bol lexbuf else coq lexbuf } | space* prf_token { in_proof := Some true; - let eol = - if not !Cdglobals.gallina then - begin backtrack lexbuf; body_bol lexbuf end - else + let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body_bol lexbuf end + else let s = lexeme lexbuf in if s.[String.length s - 1] = '.' then false else skip_to_dot lexbuf in if eol then coq_bol lexbuf else coq lexbuf } - | space* end_kw { - let eol = - if not (!in_proof <> None && !Cdglobals.gallina) then - begin backtrack lexbuf; body_bol lexbuf end + | space* end_kw { + let eol = + if not (!in_proof <> None && !Cdglobals.gallina) then + begin backtrack lexbuf; body_bol lexbuf end else skip_to_dot lexbuf in in_proof := None; if eol then coq_bol lexbuf else coq lexbuf } | space* gallina_kw - { + { in_proof := None; - let s = lexeme lexbuf in + let s = lexeme lexbuf in let nbsp,isp = count_spaces s in let s = String.sub s isp (String.length s - isp) in Output.indentation nbsp; - Output.ident s (lexeme_start lexbuf + isp); + Output.ident s (lexeme_start lexbuf + isp); let eol= body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space* prog_kw - { + { in_proof := None; - let s = lexeme lexbuf in + let s = lexeme lexbuf in let nbsp,isp = count_spaces s in Output.indentation nbsp; let s = String.sub s isp (String.length s - isp) in - Output.ident s (lexeme_start lexbuf + isp); + Output.ident s (lexeme_start lexbuf + isp); let eol= body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } @@ -511,56 +511,56 @@ rule coq_bol = parse add_printing_token tok s; coq_bol lexbuf } | space* "(**" space+ "printing" space+ - { eprintf "warning: bad 'printing' command at character %d\n" + { eprintf "warning: bad 'printing' command at character %d\n" (lexeme_start lexbuf); flush stderr; comment_level := 1; ignore (comment lexbuf); coq_bol lexbuf } - | space* "(**" space+ "remove" space+ "printing" space+ + | space* "(**" space+ "remove" space+ "printing" space+ (identifier | token) space* "*)" { remove_printing_token (lexeme lexbuf); coq_bol lexbuf } | space* "(**" space+ "remove" space+ "printing" space+ - { eprintf "warning: bad 'remove printing' command at character %d\n" + { eprintf "warning: bad 'remove printing' command at character %d\n" (lexeme_start lexbuf); flush stderr; comment_level := 1; ignore (comment lexbuf); coq_bol lexbuf } | space* "(*" - { comment_level := 1; + { comment_level := 1; if !Cdglobals.parse_comments then begin - let s = lexeme lexbuf in + let s = lexeme lexbuf in let nbsp,isp = count_spaces s in Output.indentation nbsp; Output.start_comment (); end; let eol = comment lexbuf in if eol then coq_bol lexbuf else coq lexbuf } - | eof + | eof { () } | _ - { let eol = - if not !Cdglobals.gallina then - begin backtrack lexbuf; body_bol lexbuf end - else - skip_to_dot lexbuf + { let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body_bol lexbuf end + else + skip_to_dot lexbuf in if eol then coq_bol lexbuf else coq lexbuf } (*s Scanning Coq elsewhere *) and coq = parse - | nl + | nl { if not (!in_proof <> None && !Cdglobals.gallina) then Output.line_break(); coq_bol lexbuf } | "(**" space_nl - { Output.end_coq (); Output.start_doc (); + { Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in - Output.end_doc (); Output.start_coq (); + Output.end_doc (); Output.start_coq (); if eol then coq_bol lexbuf else coq lexbuf } | "(*" { comment_level := 1; if !Cdglobals.parse_comments then begin - let s = lexeme lexbuf in + let s = lexeme lexbuf in let nbsp,isp = count_spaces s in Output.indentation nbsp; Output.start_comment (); @@ -571,66 +571,66 @@ and coq = parse } | nl+ space* "]]" { if not !formatted then begin symbol lexbuf (lexeme lexbuf); coq lexbuf end } - | eof + | eof { () } | gallina_kw_to_hide { let s = lexeme lexbuf in - if !Cdglobals.light && section_or_end s then - begin + if !Cdglobals.light && section_or_end s then + begin let eol = skip_to_dot lexbuf in - if eol then coq_bol lexbuf else coq lexbuf - end - else + if eol then coq_bol lexbuf else coq lexbuf + end + else begin - Output.ident s (lexeme_start lexbuf); - let eol=body lexbuf in + Output.ident s (lexeme_start lexbuf); + let eol=body lexbuf in if eol then coq_bol lexbuf else coq lexbuf end } | prf_token - { let eol = - if not !Cdglobals.gallina then - begin backtrack lexbuf; body_bol lexbuf end - else + { let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body_bol lexbuf end + else let s = lexeme lexbuf in - let eol = + let eol = if s.[String.length s - 1] = '.' then false else skip_to_dot lexbuf in eol in if eol then coq_bol lexbuf else coq lexbuf } - | end_kw { - let eol = - if not !Cdglobals.gallina then - begin backtrack lexbuf; body lexbuf end - else + | end_kw { + let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body lexbuf end + else let eol = skip_to_dot lexbuf in - if !in_proof <> Some true && eol then + if !in_proof <> Some true && eol then Output.line_break (); eol in in_proof := None; if eol then coq_bol lexbuf else coq lexbuf } | gallina_kw - { let s = lexeme lexbuf in - Output.ident s (lexeme_start lexbuf); + { let s = lexeme lexbuf in + Output.ident s (lexeme_start lexbuf); let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | prog_kw - { let s = lexeme lexbuf in - Output.ident s (lexeme_start lexbuf); + { let s = lexeme lexbuf in + Output.ident s (lexeme_start lexbuf); let eol = body lexbuf in if eol then coq_bol lexbuf else coq lexbuf } | space+ { Output.char ' '; coq lexbuf } - | eof + | eof { () } - | _ { let eol = - if not !Cdglobals.gallina then - begin backtrack lexbuf; body lexbuf end - else + | _ { let eol = + if not !Cdglobals.gallina then + begin backtrack lexbuf; body lexbuf end + else skip_to_dot lexbuf - in + in if eol then coq_bol lexbuf else coq lexbuf} - + (*s Scanning documentation, at beginning of line *) and doc_bol = parse @@ -650,7 +650,7 @@ and doc_bol = parse production and the begin list production fire eliminates extra vertical whitespace. *) let buf' = lexeme lexbuf in - let buf = + let buf = let bufs = Str.split_delim (Str.regexp "['\n']") buf' in match bufs with | (_ :: s :: []) -> s @@ -672,12 +672,12 @@ and doc_bol = parse } | "<<" space* { Output.start_verbatim (); verbatim lexbuf; doc_bol lexbuf } - | eof + | eof { true } | '_' - { Output.start_emph (); + { Output.start_emph (); doc None lexbuf } - | _ + | _ { backtrack lexbuf; doc None lexbuf } (*s Scanning lists - using whitespace *) @@ -687,7 +687,7 @@ and doc_list_bol indents = parse match find_level indents n_spaces with | Before -> backtrack lexbuf; doc_bol lexbuf | StartLevel n -> Output.item n; doc (Some (take n indents)) lexbuf - | InLevel (n,true) -> + | InLevel (n,true) -> let items = List.length indents in Output.item (items+1); doc (Some (List.append indents [n_spaces])) lexbuf @@ -695,13 +695,13 @@ and doc_list_bol indents = parse backtrack lexbuf; doc_bol lexbuf } | "<<" space* - { Output.start_verbatim (); - verbatim lexbuf; + { Output.start_verbatim (); + verbatim lexbuf; doc_list_bol indents lexbuf } | "[[" nl { formatted := true; Output.paragraph (); - Output.start_inline_coq (); + Output.start_inline_coq (); ignore(body_bol lexbuf); Output.end_inline_coq (); formatted := false; @@ -714,7 +714,7 @@ and doc_list_bol indents = parse doc_list_bol indents lexbuf } | space* nl space* _ { let buf' = lexeme lexbuf in - let buf = + let buf = let bufs = Str.split_delim (Str.regexp "['\n']") buf' in match bufs with | (_ :: s :: []) -> s @@ -723,7 +723,7 @@ and doc_list_bol indents = parse exit 1 in let (n_spaces,_) = count_spaces buf in - match find_level indents n_spaces with + match find_level indents n_spaces with | InLevel _ -> Output.paragraph (); backtrack_past_newline lexbuf; @@ -741,15 +741,15 @@ and doc_list_bol indents = parse backtrack_past_newline lexbuf; doc_list_bol indents lexbuf end - | Before -> Output.stop_item (); - backtrack_past_newline lexbuf; + | Before -> Output.stop_item (); + backtrack_past_newline lexbuf; doc_bol lexbuf } - | space* _ + | space* _ { let (n_spaces,_) = count_spaces (lexeme lexbuf) in - match find_level indents n_spaces with - | Before -> Output.stop_item (); backtrack lexbuf; + match find_level indents n_spaces with + | Before -> Output.stop_item (); backtrack lexbuf; doc_bol lexbuf | StartLevel n -> Output.reach_item_level (n-1); @@ -764,20 +764,20 @@ and doc_list_bol indents = parse (*s Scanning documentation elsewhere *) and doc indents = parse | nl - { Output.char '\n'; - match indents with - | Some ls -> doc_list_bol ls lexbuf + { Output.char '\n'; + match indents with + | Some ls -> doc_list_bol ls lexbuf | None -> doc_bol lexbuf } | "[[" nl { if !Cdglobals.plain_comments then (Output.char '['; Output.char '['; doc indents lexbuf) - else (formatted := true; + else (formatted := true; Output.line_break (); Output.start_inline_coq (); - let eol = body_bol lexbuf in + let eol = body_bol lexbuf in Output.end_inline_coq (); formatted := false; if eol then - match indents with - | Some ls -> doc_list_bol ls lexbuf + match indents with + | Some ls -> doc_list_bol ls lexbuf | None -> doc_bol lexbuf else doc indents lexbuf)} | "[]" @@ -804,7 +804,7 @@ and doc indents = parse else (Output.start_latex_math (); escaped_math_latex lexbuf); doc indents lexbuf } | "$$" - { if !Cdglobals.plain_comments then Output.char '$'; + { if !Cdglobals.plain_comments then Output.char '$'; Output.char '$'; doc indents lexbuf } | "%" { if !Cdglobals.plain_comments then Output.char '%' @@ -822,16 +822,16 @@ and doc indents = parse { List.iter (fun x -> Output.char (lexeme_char lexbuf x)) [0;1;2]; doc indents lexbuf} | nonidentchar '_' - { Output.char (lexeme_char lexbuf 0); - Output.start_emph (); + { Output.char (lexeme_char lexbuf 0); + Output.start_emph (); doc indents lexbuf } | '_' nonidentchar - { Output.stop_emph (); + { Output.stop_emph (); Output.char (lexeme_char lexbuf 1); doc indents lexbuf } - | eof + | eof { false } - | _ + | _ { Output.char (lexeme_char lexbuf 0); doc indents lexbuf } (*s Various escapings *) @@ -865,7 +865,7 @@ and verbatim = parse and escaped_coq = parse | "]" - { decr brackets; + { decr brackets; if !brackets > 0 then begin Output.char ']'; escaped_coq lexbuf end } | "[" { incr brackets; Output.char '['; escaped_coq lexbuf } @@ -880,15 +880,15 @@ and escaped_coq = parse symbol lexbuf s; escaped_coq lexbuf } | (identifier '.')* identifier { Output.ident (lexeme lexbuf) (lexeme_start lexbuf); escaped_coq lexbuf } - | _ + | _ { Output.char (lexeme_char lexbuf 0); escaped_coq lexbuf } (*s Coq "Comments" command. *) and comments = parse - | space_nl+ + | space_nl+ { Output.char ' '; comments lexbuf } - | '"' [^ '"']* '"' + | '"' [^ '"']* '"' { let s = lexeme lexbuf in let s = String.sub s 1 (String.length s - 2) in ignore (doc None (from_string s)); comments lexbuf } @@ -896,9 +896,9 @@ and comments = parse { escaped_coq (from_string (lexeme lexbuf)); comments lexbuf } | "." (space_nl | eof) { () } - | eof + | eof { () } - | _ + | _ { Output.char (lexeme_char lexbuf 0); comments lexbuf } (*s Skip comments *) @@ -908,10 +908,10 @@ and comment = parse if !Cdglobals.parse_comments then Output.start_comment (); comment lexbuf } | "*)" space* nl { - if !Cdglobals.parse_comments then + if !Cdglobals.parse_comments then (Output.end_comment (); Output.line_break ()); decr comment_level; if !comment_level > 0 then comment lexbuf else true } - | "*)" { + | "*)" { if !Cdglobals.parse_comments then (Output.end_comment ()); decr comment_level; if !comment_level > 0 then comment lexbuf else false } | "[" { @@ -934,18 +934,18 @@ and comment = parse else (Output.start_latex_math (); escaped_math_latex lexbuf); comment lexbuf } | "$$" - { if !Cdglobals.parse_comments - then + { if !Cdglobals.parse_comments + then (if !Cdglobals.plain_comments then Output.char '$'; Output.char '$'); doc None lexbuf } | "%" { if !Cdglobals.parse_comments - then + then if !Cdglobals.plain_comments then Output.char '%' else escaped_latex lexbuf; comment lexbuf } | "%%" - { if !Cdglobals.parse_comments - then + { if !Cdglobals.parse_comments + then (if !Cdglobals.plain_comments then Output.char '%'; Output.char '%'); comment lexbuf } | "#" @@ -954,8 +954,8 @@ and comment = parse if !Cdglobals.plain_comments then Output.char '$' else escaped_html lexbuf; comment lexbuf } | "##" - { if !Cdglobals.parse_comments - then + { if !Cdglobals.parse_comments + then (if !Cdglobals.plain_comments then Output.char '#'; Output.char '#'); comment lexbuf } | eof { false } @@ -966,7 +966,7 @@ and comment = parse then Output.line_break (); comment lexbuf } | _ { if !Cdglobals.parse_comments then Output.char (lexeme_char lexbuf 0); comment lexbuf } - + and skip_to_dot = parse | '.' space* nl { true } | eof | '.' space+ { false } @@ -981,68 +981,68 @@ and body_bol = parse and body = parse | nl {Output.line_break(); body_bol lexbuf} | nl+ space* "]]" space* nl - { if not !formatted then - begin - symbol lexbuf (lexeme lexbuf); - body lexbuf - end - else + { if not !formatted then + begin + symbol lexbuf (lexeme lexbuf); + body lexbuf + end + else begin Output.paragraph (); true end } | "]]" space* nl - { if not !formatted then - begin - symbol lexbuf (lexeme lexbuf); - body lexbuf - end - else + { if not !formatted then + begin + symbol lexbuf (lexeme lexbuf); + body lexbuf + end + else begin Output.paragraph (); true end } | eof { false } - | '.' space* nl | '.' space* eof - { Output.char '.'; Output.line_break(); - if not !formatted then true else body_bol lexbuf } + | '.' space* nl | '.' space* eof + { Output.char '.'; Output.line_break(); + if not !formatted then true else body_bol lexbuf } | '.' space* nl "]]" space* nl { Output.char '.'; if not !formatted then begin - eprintf "Error: stray ]] at %d\n" (lexeme_start lexbuf); + eprintf "Error: stray ]] at %d\n" (lexeme_start lexbuf); flush stderr; exit 1 end - else + else begin Output.paragraph (); true end } - | '.' space+ { Output.char '.'; Output.char ' '; + | '.' space+ { Output.char '.'; Output.char ' '; if not !formatted then false else body lexbuf } | '"' { Output.char '"'; ignore(notation lexbuf); body lexbuf } | "(**" space_nl - { Output.end_coq (); Output.start_doc (); + { Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in - Output.end_doc (); Output.start_coq (); + Output.end_doc (); Output.start_coq (); if eol then body_bol lexbuf else body lexbuf } - | "(*" { comment_level := 1; + | "(*" { comment_level := 1; if !Cdglobals.parse_comments then Output.start_comment (); - let eol = comment lexbuf in - if eol + let eol = comment lexbuf in + if eol then begin if not !Cdglobals.parse_comments then Output.line_break(); body_bol lexbuf end else body lexbuf } - | identifier - { let s = lexeme lexbuf in - Output.ident s (lexeme_start lexbuf); + | identifier + { let s = lexeme lexbuf in + Output.ident s (lexeme_start lexbuf); body lexbuf } | token_no_brackets { let s = lexeme lexbuf in symbol lexbuf s; body lexbuf } - | _ { let c = lexeme_char lexbuf 0 in - Output.char c; + | _ { let c = lexeme_char lexbuf 0 in + Output.char c; body lexbuf } and notation_bol = parse @@ -1056,8 +1056,8 @@ and notation = parse | token { let s = lexeme lexbuf in symbol lexbuf s; notation lexbuf } - | _ { let c = lexeme_char lexbuf 0 in - Output.char c; + | _ { let c = lexeme_char lexbuf 0 in + Output.char c; notation lexbuf } and skip_hide = parse @@ -1067,18 +1067,18 @@ and skip_hide = parse (*s Reading token pretty-print *) and printing_token_body = parse - | "*)" nl? | eof - { let s = Buffer.contents token_buffer in + | "*)" nl? | eof + { let s = Buffer.contents token_buffer in Buffer.clear token_buffer; s } - | _ { Buffer.add_string token_buffer (lexeme lexbuf); + | _ { Buffer.add_string token_buffer (lexeme lexbuf); printing_token_body lexbuf } (*s A small scanner to support the chapter subtitle feature *) and st_start m = parse | "(*" "*"+ space+ "*" space+ { st_modname m lexbuf } - | _ + | _ { None } and st_modname m = parse @@ -1088,20 +1088,20 @@ and st_modname m = parse else None } - | _ + | _ { None } and st_subtitle = parse | [^ '\n']* '\n' { let st = lexeme lexbuf in - let i = try Str.search_forward (Str.regexp "\\**)") st 0 with - Not_found -> + let i = try Str.search_forward (Str.regexp "\\**)") st 0 with + Not_found -> (eprintf "unterminated comment at beginning of file\n"; exit 1) in Some (cut_head_tail_spaces (String.sub st 0 i)) } - | _ + | _ { None } (*s Applying the scanners to files *) diff --git a/tools/coqdoc/index.mli b/tools/coqdoc/index.mli index bfb57dad28..f8a8730d08 100644 --- a/tools/coqdoc/index.mli +++ b/tools/coqdoc/index.mli @@ -12,7 +12,7 @@ open Cdglobals type loc = int -type entry_type = +type entry_type = | Library | Module | Definition @@ -33,7 +33,7 @@ type entry_type = val type_name : entry_type -> string -type index_entry = +type index_entry = | Def of string * entry_type | Ref of coq_module * string * entry_type | Mod of coq_module * string @@ -58,14 +58,14 @@ val read_glob : string -> coq_module (*s Indexes *) -type 'a index = { +type 'a index = { idx_name : string; idx_entries : (char * (string * 'a) list) list; idx_size : int } val current_library : string ref -val all_entries : unit -> +val all_entries : unit -> (coq_module * entry_type) index * (entry_type * coq_module index) list diff --git a/tools/coqdoc/index.mll b/tools/coqdoc/index.mll index 62ae42c1ad..a39450986c 100644 --- a/tools/coqdoc/index.mll +++ b/tools/coqdoc/index.mll @@ -12,14 +12,14 @@ { open Filename -open Lexing +open Lexing open Printf open Cdglobals type loc = int -type entry_type = +type entry_type = | Library | Module | Definition @@ -38,7 +38,7 @@ type entry_type = | Notation | Section -type index_entry = +type index_entry = | Def of string * entry_type | Ref of coq_module * string * entry_type | Mod of coq_module * string @@ -47,45 +47,45 @@ let current_type : entry_type ref = ref Library let current_library = ref "" (** refers to the file being parsed *) -(** [deftable] stores only definitions and is used to interpolate idents +(** [deftable] stores only definitions and is used to interpolate idents inside comments, which are not globalized otherwise. *) let deftable = Hashtbl.create 97 (** [reftable] stores references and definitions *) let reftable = Hashtbl.create 97 - + let full_ident sp id = - if sp <> "<>" then - if id <> "<>" then - sp ^ "." ^ id - else sp - else if id <> "<>" - then id + if sp <> "<>" then + if id <> "<>" then + sp ^ "." ^ id + else sp + else if id <> "<>" + then id else "" - -let add_def loc ty sp id = + +let add_def loc ty sp id = Hashtbl.add reftable (!current_library, loc) (Def (full_ident sp id, ty)); Hashtbl.add deftable id (Ref (!current_library, full_ident sp id, ty)) - -let add_ref m loc m' sp id ty = + +let add_ref m loc m' sp id ty = if Hashtbl.mem reftable (m, loc) then () else Hashtbl.add reftable (m, loc) (Ref (m', full_ident sp id, ty)); let idx = if id = "<>" then m' else id in if Hashtbl.mem deftable idx then () - else Hashtbl.add deftable idx (Ref (m', full_ident sp id, ty)) - -let add_mod m loc m' id = + else Hashtbl.add deftable idx (Ref (m', full_ident sp id, ty)) + +let add_mod m loc m' id = Hashtbl.add reftable (m, loc) (Mod (m', id)); Hashtbl.add deftable m (Mod (m', id)) - + let find m l = Hashtbl.find reftable (m, l) - + let find_string m s = Hashtbl.find deftable s - -(*s Manipulating path prefixes *) -type stack = string list +(*s Manipulating path prefixes *) + +type stack = string list let rec string_of_stack st = match st with @@ -102,11 +102,11 @@ let init_stack () = module_stack := empty_stack; section_stack := empty_stack let push st p = st := p::!st -let pop st = - match !st with +let pop st = + match !st with | [] -> () | _::tl -> st := tl - + let head st = match st with | [] -> "" @@ -124,22 +124,22 @@ let end_block id = else () -let make_fullid id = +let make_fullid id = (** prepends the current module path to an id *) let path = string_of_stack !module_stack in if String.length path > 0 then path ^ "." ^ id - else + else id (* Coq modules *) -let split_sp s = +let split_sp s = try let i = String.rindex s '.' in String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1) - with + with Not_found -> "", s let modules = Hashtbl.create 97 @@ -155,7 +155,7 @@ type module_kind = Local | Coqlib | Unknown let coq_module m = String.length m >= 4 && String.sub m 0 4 = "Coq." let find_module m = - if Hashtbl.mem local_modules m then + if Hashtbl.mem local_modules m then Local else if coq_module m then Coqlib @@ -165,42 +165,42 @@ let find_module m = (* Building indexes *) -type 'a index = { +type 'a index = { idx_name : string; idx_entries : (char * (string * 'a) list) list; idx_size : int } - -let map f i = - { i with idx_entries = - List.map - (fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l)) + +let map f i = + { i with idx_entries = + List.map + (fun (c,l) -> (c, List.map (fun (s,x) -> (s,f s x)) l)) i.idx_entries } let compare_entries (s1,_) (s2,_) = Alpha.compare_string s1 s2 let sort_entries el = let t = Hashtbl.create 97 in - List.iter + List.iter (fun c -> Hashtbl.add t c []) - ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M'; 'N'; - 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; '_']; - List.iter - (fun ((s,_) as e) -> - let c = Alpha.norm_char s.[0] in + ['A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M'; 'N'; + 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z'; '_']; + List.iter + (fun ((s,_) as e) -> + let c = Alpha.norm_char s.[0] in let l = try Hashtbl.find t c with Not_found -> [] in - Hashtbl.replace t c (e :: l)) + Hashtbl.replace t c (e :: l)) el; let res = ref [] in - Hashtbl.iter + Hashtbl.iter (fun c l -> res := (c, List.sort compare_entries l) :: !res) t; List.sort (fun (c1,_) (c2,_) -> Alpha.compare_char c1 c2) !res - + let index_size = List.fold_left (fun s (_,l) -> s + List.length l) 0 - + let hashtbl_elements h = Hashtbl.fold (fun x y l -> (x,y)::l) h [] - + let type_name = function - | Library -> + | Library -> let ln = !lib_name in if ln <> "" then String.lowercase ln else "library" | Module -> "module" @@ -228,31 +228,31 @@ let all_entries () = let l = try Hashtbl.find bt t with Not_found -> [] in Hashtbl.replace bt t ((s,m) :: l) in - let classify (m,_) e = match e with + let classify (m,_) e = match e with | Def (s,t) -> add_g s m t; add_bt t s m | Ref _ | Mod _ -> () in Hashtbl.iter classify reftable; Hashtbl.iter (fun id m -> add_g id m Library; add_bt Library id m) modules; - { idx_name = "global"; - idx_entries = sort_entries !gl; + { idx_name = "global"; + idx_entries = sort_entries !gl; idx_size = List.length !gl }, - Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t; - idx_entries = sort_entries e; + Hashtbl.fold (fun t e l -> (t, { idx_name = type_name t; + idx_entries = sort_entries e; idx_size = List.length e }) :: l) bt [] - + } (*s Shortcuts for regular expressions. *) let digit = ['0'-'9'] let num = digit+ -let space = +let space = [' ' '\010' '\013' '\009' '\012'] -let firstchar = +let firstchar = ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255'] -let identchar = - ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' +let identchar = + ['$' 'A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] let id = firstchar identchar* let pfx_id = (id '.')* @@ -260,15 +260,15 @@ let ident = id | pfx_id id let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" let end_hide = "(*" space* "end" space+ "hide" space* "*)" - + (*s Indexing entry point. *) - + rule traverse = parse | ("Program" space+)? "Definition" space { current_type := Definition; index_ident lexbuf; traverse lexbuf } | "Tactic" space+ "Definition" space { current_type := TacticDefinition; index_ident lexbuf; traverse lexbuf } - | ("Axiom" | "Parameter") space + | ("Axiom" | "Parameter") space { current_type := Axiom; index_ident lexbuf; traverse lexbuf } | ("Program" space+)? "Fixpoint" space { current_type := Definition; index_ident lexbuf; fixpoint lexbuf; @@ -278,7 +278,7 @@ rule traverse = parse | "Obligation" space num ("of" ident)? { current_type := Lemma; index_ident lexbuf; traverse lexbuf } | "Inductive" space - { current_type := Inductive; + { current_type := Inductive; index_ident lexbuf; inductive lexbuf; traverse lexbuf } | "Record" space { current_type := Inductive; index_ident lexbuf; traverse lexbuf } @@ -288,40 +288,40 @@ rule traverse = parse | "Variable" 's'? space { current_type := Variable; index_idents lexbuf; traverse lexbuf } ***i*) - | "Require" (space+ ("Export"|"Import"))? + | "Require" (space+ ("Export"|"Import"))? { module_refs lexbuf; traverse lexbuf } - | "End" space+ + | "End" space+ { end_ident lexbuf; traverse lexbuf } - | begin_hide + | begin_hide { skip_hide lexbuf; traverse lexbuf } - | "(*" + | "(*" { comment lexbuf; traverse lexbuf } | '"' { string lexbuf; traverse lexbuf } - | eof + | eof { () } - | _ + | _ { traverse lexbuf } (*s Index one identifier. *) and index_ident = parse - | space+ + | space+ { index_ident lexbuf } - | ident - { let fullid = + | ident + { let fullid = let id = lexeme lexbuf in match !current_type with | Definition | Inductive - | Constructor + | Constructor | Lemma -> make_fullid id - | _ -> id - in + | _ -> id + in add_def (lexeme_start lexbuf) !current_type "" fullid } - | eof + | eof { () } - | _ + | _ { () } (*s Index identifiers separated by blanks and/or commas. *) @@ -329,42 +329,42 @@ and index_ident = parse and index_idents = parse | space+ | ',' { index_idents lexbuf } - | ident + | ident { add_def (lexeme_start lexbuf) !current_type "" (lexeme lexbuf); index_idents lexbuf } - | eof + | eof { () } | _ { skip_until_point lexbuf } - + (*s Index identifiers in an inductive definition (types and constructors). *) - + and inductive = parse - | '|' | ":=" space* '|'? + | '|' | ":=" space* '|'? { current_type := Constructor; index_ident lexbuf; inductive lexbuf } | "with" space { current_type := Inductive; index_ident lexbuf; inductive lexbuf } - | '.' + | '.' { () } - | eof + | eof { () } - | _ + | _ { inductive lexbuf } - + (*s Index identifiers in a Fixpoint declaration. *) - + and fixpoint = parse | "with" space { index_ident lexbuf; fixpoint lexbuf } - | '.' + | '.' { () } - | eof + | eof { () } - | _ + | _ { fixpoint lexbuf } - + (*s Skip a possibly nested comment. *) - + and comment = parse | "*)" { () } | "(*" { comment lexbuf; comment lexbuf } @@ -373,19 +373,19 @@ and comment = parse | _ { comment lexbuf } (*s Skip a constant string. *) - + and string = parse | '"' { () } | eof { eprintf " *** Unterminated string while indexing" } | _ { string lexbuf } (*s Skip everything until the next dot. *) - + and skip_until_point = parse | '.' { () } | eof { () } | _ { skip_until_point lexbuf } - + (*s Skip everything until [(* end hide *)] *) and skip_hide = parse @@ -393,13 +393,13 @@ and skip_hide = parse | _ { skip_hide lexbuf } and end_ident = parse - | space+ + | space+ { end_ident lexbuf } - | ident + | ident { let id = lexeme lexbuf in end_block id } - | eof + | eof { () } - | _ + | _ { () } and module_ident = parse @@ -419,19 +419,19 @@ and module_ident = parse (*s parse module names *) and module_refs = parse - | space+ + | space+ { module_refs lexbuf } - | ident + | ident { let id = lexeme lexbuf in (try add_mod !current_library (lexeme_start lexbuf) (Hashtbl.find modules id) id with Not_found -> () - ); + ); module_refs lexbuf } - | eof + | eof { () } - | _ + | _ { () } { @@ -455,8 +455,8 @@ and module_refs = parse | "tac" -> TacticDefinition | "sec" -> Section | s -> raise (Invalid_argument ("type_of_string:" ^ s)) - - let read_glob f = + + let read_glob f = let c = open_in f in let cur_mod = ref "" in try @@ -465,7 +465,7 @@ and module_refs = parse let n = String.length s in if n > 0 then begin match s.[0] with - | 'F' -> + | 'F' -> cur_mod := String.sub s 1 (n - 1); current_library := !cur_mod | 'R' -> @@ -474,16 +474,16 @@ and module_refs = parse (fun loc lib_dp sp id ty -> add_ref !cur_mod loc lib_dp sp id (type_of_string ty)) with _ -> ()) - | _ -> + | _ -> try Scanf.sscanf s "%s %d %s %s" (fun ty loc sp id -> add_def loc (type_of_string ty) sp id) with Scanf.Scan_failure _ -> () end done; assert false - with End_of_file -> + with End_of_file -> close_in c; !cur_mod - - let scan_file f m = + + let scan_file f m = init_stack (); current_library := m; let c = open_in f in let lb = from_channel c in diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 3c4c9a6566..d2b66f9939 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -54,7 +54,7 @@ let usage () = prerr_endline " --files-from read file names to process in "; prerr_endline " --glob-from read globalization information from "; prerr_endline " --quiet quiet mode (default)"; - prerr_endline " --verbose verbose mode"; + prerr_endline " --verbose verbose mode"; prerr_endline " --no-externals no links to Coq standard library"; prerr_endline " --coqlib set URL for Coq standard library"; prerr_endline (" (default is " ^ Coq_config.wwwstdlib ^ ")"); @@ -80,20 +80,20 @@ let obsolete s = (*s \textbf{Banner.} Always printed. Notice that it is printed on error output, so that when the output of [coqdoc] is redirected this header - is not (unless both standard and error outputs are redirected, of + is not (unless both standard and error outputs are redirected, of course). *) let banner () = eprintf "This is coqdoc version %s, compiled on %s\n" Coq_config.version Coq_config.compile_date; flush stderr - -let target_full_name f = + +let target_full_name f = match !Cdglobals.target_language with | HTML -> f ^ ".html" | Raw -> f ^ ".txt" | _ -> f ^ ".tex" - + (*s \textbf{Separation of files.} Files given on the command line are separated according to their type, which is determined by their suffix. Coq files have suffixe \verb!.v! or \verb!.g! and \LaTeX\ @@ -106,7 +106,7 @@ let check_if_file_exists f = end -(*s Manipulations of paths and path aliases *) +(*s Manipulations of paths and path aliases *) let normalize_path p = (* We use the Unix subsystem to normalize a physical path (relative @@ -117,7 +117,7 @@ let normalize_path p = let orig = Sys.getcwd () in Sys.chdir p; let res = Sys.getcwd () in - Sys.chdir orig; + Sys.chdir orig; res let normalize_filename f = @@ -127,22 +127,22 @@ let normalize_filename f = (* [paths] maps a physical path to a name *) let paths = ref [] - -let add_path dir name = + +let add_path dir name = (* if dir is relative we add both the relative and absolute name *) let p = normalize_path dir in paths := (p,name) :: !paths - + (* turn A/B/C into A.B.C *) let name_of_path = Str.global_replace (Str.regexp "/") ".";; -let coq_module filename = +let coq_module filename = let bfname = Filename.chop_extension filename in let nfname = normalize_filename bfname in - let rec change_prefix map f = + let rec change_prefix map f = match map with - | [] -> - (* There is no prefix alias; + | [] -> + (* There is no prefix alias; we just cut the name wrt current working directory *) let cwd = Sys.getcwd () in let exp = Str.regexp (Str.quote (cwd ^ "/")) in @@ -166,10 +166,10 @@ let what_file f = Vernac_file (f, coq_module f) else if Filename.check_suffix f ".tex" then Latex_file f - else + else (eprintf "\ncoqdoc: don't know what to do with %s\n" f; exit 1) - -(*s \textbf{Reading file names from a file.} + +(*s \textbf{Reading file names from a file.} * File names may be given * in a file instead of being given on the command * line. [(files_from_file f)] returns the list of file names contained @@ -187,7 +187,7 @@ let files_from_file f = | ' ' | '\t' | '\n' -> if Buffer.length buf > 0 then l := (Buffer.contents buf) :: !l; Buffer.clear buf - | c -> + | c -> Buffer.add_char buf c done; [] with End_of_file -> @@ -202,9 +202,9 @@ let files_from_file f = eprintf "\ncoqdoc: cannot read from file %s (%s)\n" f s; exit 1 end - + (*s \textbf{Parsing of the command line.} *) - + let dvi = ref false let ps = ref false let pdf = ref false @@ -214,7 +214,7 @@ let parse () = let add_file f = files := f :: !files in let rec parse_rec = function | [] -> () - + | ("-nopreamble" | "--nopreamble" | "--no-preamble" | "-bodyonly" | "--bodyonly" | "--body-only") :: rem -> header_trailer := false; parse_rec rem @@ -244,11 +244,11 @@ let parse () = out_to := StdOut; parse_rec rem | ("-o" | "--output") :: f :: rem -> out_to := File (Filename.basename f); output_dir := Filename.dirname f; parse_rec rem - | ("-o" | "--output") :: [] -> + | ("-o" | "--output") :: [] -> usage () | ("-d" | "--directory") :: dir :: rem -> output_dir := dir; parse_rec rem - | ("-d" | "--directory") :: [] -> + | ("-d" | "--directory") :: [] -> usage () | ("-s" | "--short") :: rem -> short := true; parse_rec rem @@ -293,8 +293,8 @@ let parse () = | ("-toc-depth" | "--toc-depth") :: [] -> usage () | ("-toc-depth" | "--toc-depth") :: ds :: rem -> - let d = try int_of_string ds with - Failure _ -> + let d = try int_of_string ds with + Failure _ -> (eprintf "--toc-depth must be followed by an integer"; exit 1) in @@ -314,32 +314,32 @@ let parse () = Cdglobals.set_latin1 (); parse_rec rem | ("-utf8" | "--utf8") :: rem -> Cdglobals.set_utf8 (); parse_rec rem - + | ("-q" | "-quiet" | "--quiet") :: rem -> quiet := true; parse_rec rem | ("-v" | "-verbose" | "--verbose") :: rem -> quiet := false; parse_rec rem - + | ("-h" | "-help" | "-?" | "--help") :: rem -> banner (); usage () | ("-V" | "-version" | "--version") :: _ -> banner (); exit 0 - | ("-vernac-file" | "--vernac-file") :: f :: rem -> + | ("-vernac-file" | "--vernac-file") :: f :: rem -> check_if_file_exists f; add_file (Vernac_file (f, coq_module f)); parse_rec rem | ("-vernac-file" | "--vernac-file") :: [] -> usage () - | ("-tex-file" | "--tex-file") :: f :: rem -> + | ("-tex-file" | "--tex-file") :: f :: rem -> add_file (Latex_file f); parse_rec rem | ("-tex-file" | "--tex-file") :: [] -> usage () | ("-files" | "--files" | "--files-from") :: f :: rem -> - List.iter (fun f -> add_file (what_file f)) (files_from_file f); + List.iter (fun f -> add_file (what_file f)) (files_from_file f); parse_rec rem | ("-files" | "--files") :: [] -> usage () - | "-R" :: path :: log :: rem -> + | "-R" :: path :: log :: rem -> add_path path log; parse_rec rem | "-R" :: ([] | [_]) -> usage () @@ -359,16 +359,16 @@ let parse () = Cdglobals.coqlib_path := d; parse_rec rem | ("--coqlib_path" | "-coqlib_path") :: [] -> usage () - | f :: rem -> + | f :: rem -> add_file (what_file f); parse_rec rem - in + in parse_rec (List.tl (Array.to_list Sys.argv)); Output.initialize (); List.rev !files - + (*s The following function produces the output. The default output is - the \LaTeX\ document: in that case, we just call [Web.produce_document]. + the \LaTeX\ document: in that case, we just call [Web.produce_document]. If option \verb!-dvi!, \verb!-ps! or \verb!-html! is invoked, then we make calls to \verb!latex! or \verb!dvips! or \verb!pdflatex! accordingly. *) @@ -390,9 +390,9 @@ let clean_temp_files basefile = remove (basefile ^ ".pdf"); remove (basefile ^ ".haux"); remove (basefile ^ ".html") - + let clean_and_exit file res = clean_temp_files file; exit res - + let cat file = let c = open_in file in try @@ -401,7 +401,7 @@ let cat file = close_in c let copy src dst = - let cin = open_in src + let cin = open_in src and cout = open_out dst in try while true do Pervasives.output_char cout (input_char cin) done @@ -413,7 +413,7 @@ let copy src dst = let gen_one_file l = let file = function - | Vernac_file (f,m) -> + | Vernac_file (f,m) -> let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in Output.set_module m sub; Cpretty.coq_file f m @@ -424,57 +424,57 @@ let gen_one_file l = List.iter file l; if !index then Output.make_index(); if (!header_trailer) then Output.trailer () - + let gen_mult_files l = let file = function - | Vernac_file (f,m) -> + | Vernac_file (f,m) -> let sub = if !lib_subtitles then Cpretty.detect_subtitle f m else None in let hf = target_full_name m in Output.set_module m sub; open_out_file hf; - if (!header_trailer) then Output.header (); - Cpretty.coq_file f m; + if (!header_trailer) then Output.header (); + Cpretty.coq_file f m; if (!header_trailer) then Output.trailer (); close_out_file() | Latex_file _ -> () in List.iter file l; if (!index && !target_language=HTML) then begin - if (!multi_index) then Output.make_multi_index (); - open_out_file (!index_name^".html"); + if (!multi_index) then Output.make_multi_index (); + open_out_file (!index_name^".html"); page_title := (if !title <> "" then !title else "Index"); - if (!header_trailer) then Output.header (); - Output.make_index (); + if (!header_trailer) then Output.header (); + Output.make_index (); if (!header_trailer) then Output.trailer (); close_out_file() end; if (!toc && !target_language=HTML) then begin - open_out_file "toc.html"; + open_out_file "toc.html"; page_title := (if !title <> "" then !title else "Table of contents"); if (!header_trailer) then Output.header (); if !title <> "" then printf "

%s

\n" !title; - Output.make_toc (); + Output.make_toc (); if (!header_trailer) then Output.trailer (); close_out_file() - end + end (* Rq: pour latex et texmacs, une toc ou un index séparé n'a pas de sens... *) let read_glob x = match x with - | Vernac_file (f,m) -> + | Vernac_file (f,m) -> let glob = (Filename.chop_extension f) ^ ".glob" in (try Vernac_file (f, Index.read_glob glob) - with e -> + with e -> eprintf "Warning: file %s cannot be used; links will not be available: %s\n" glob (Printexc.to_string e); x) | Latex_file _ -> x let index_module = function - | Vernac_file (f,m) -> + | Vernac_file (f,m) -> Index.add_module m | Latex_file _ -> () - + let produce_document l = (if !target_language=HTML then let src = (Filename.concat !Cdglobals.coqlib_path "/tools/coqdoc/coqdoc.css") in @@ -482,8 +482,8 @@ let produce_document l = if (Sys.file_exists src) then (copy src dst) else eprintf "Warning: file %s does not exist\n" src); (if !target_language=LaTeX then let src = (Filename.concat !Cdglobals.coqlib_path "/tools/coqdoc/coqdoc.sty") in - let dst = if !output_dir <> "" then - Filename.concat !output_dir "coqdoc.sty" + let dst = if !output_dir <> "" then + Filename.concat !output_dir "coqdoc.sty" else "coqdoc.sty" in if Sys.file_exists src then copy src dst else eprintf "Warning: file %s does not exist\n" src); (match !Cdglobals.glob_source with @@ -492,7 +492,7 @@ let produce_document l = | GlobFile f -> ignore (Index.read_glob f)); List.iter index_module l; match !out_to with - | StdOut -> + | StdOut -> Cdglobals.out_channel := stdout; gen_one_file l | File f -> @@ -501,11 +501,11 @@ let produce_document l = close_out_file() | MultFiles -> gen_mult_files l - + let produce_output fl = - if not (!dvi || !ps || !pdf) then + if not (!dvi || !ps || !pdf) then produce_document fl - else + else begin let texfile = Filename.temp_file "coqdoc" ".tex" in let basefile = Filename.chop_suffix texfile ".tex" in @@ -513,52 +513,52 @@ let produce_output fl = out_to := File texfile; output_dir := (Filename.dirname texfile); produce_document fl; - + let latexexe = if !pdf then "pdflatex" else "latex" in - let latexcmd = + let latexcmd = let file = Filename.basename texfile in - let file = - if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file + let file = + if !quiet then sprintf "'\\nonstopmode\\input{%s}'" file else file in sprintf "%s %s && %s %s 1>&2 %s" latexexe file latexexe file (if !quiet then "> /dev/null" else "") in let res = locally (Filename.dirname texfile) Sys.command latexcmd in if res <> 0 then begin - eprintf "Couldn't run LaTeX successfully\n"; + eprintf "Couldn't run LaTeX successfully\n"; clean_and_exit basefile res end; - + let dvifile = basefile ^ ".dvi" in - if !dvi then + if !dvi then begin match final_out_to with | MultFiles | StdOut -> cat dvifile | File f -> copy dvifile f end; let pdffile = basefile ^ ".pdf" in - if !pdf then + if !pdf then begin match final_out_to with | MultFiles | StdOut -> cat pdffile | File f -> copy pdffile f end; if !ps then begin - let psfile = basefile ^ ".ps" + let psfile = basefile ^ ".ps" in - let command = - sprintf "dvips %s -o %s %s" dvifile psfile + let command = + sprintf "dvips %s -o %s %s" dvifile psfile (if !quiet then "> /dev/null 2>&1" else "") in let res = Sys.command command in if res <> 0 then begin - eprintf "Couldn't run dvips successfully\n"; + eprintf "Couldn't run dvips successfully\n"; clean_and_exit basefile res end; match final_out_to with | MultFiles | StdOut -> cat psfile | File f -> copy psfile f end; - + clean_temp_files basefile end @@ -570,5 +570,5 @@ let main () = let files = parse () in if not !quiet then banner (); if files <> [] then produce_output files - + let _ = Printexc.catch main () diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 302cbffce8..0c5e9ff295 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -25,26 +25,26 @@ let sprintf = Printf.sprintf (*s Coq keywords *) -let build_table l = +let build_table l = let h = Hashtbl.create 101 in List.iter (fun key ->Hashtbl.add h key ()) l; function s -> try Hashtbl.find h s; true with Not_found -> false -let is_keyword = +let is_keyword = build_table [ "AddPath"; "Axiom"; "Abort"; "Boxed"; "Chapter"; "Check"; "Coercion"; "CoFixpoint"; - "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example"; + "CoInductive"; "Corollary"; "Defined"; "Definition"; "End"; "Eval"; "Example"; "Export"; "Fact"; "Fix"; "Fixpoint"; "Global"; "Grammar"; "Goal"; "Hint"; - "Hypothesis"; "Hypotheses"; - "Resolve"; "Unfold"; "Immediate"; "Extern"; "Implicit"; "Import"; "Inductive"; - "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; + "Hypothesis"; "Hypotheses"; + "Resolve"; "Unfold"; "Immediate"; "Extern"; "Implicit"; "Import"; "Inductive"; + "Infix"; "Lemma"; "Let"; "Load"; "Local"; "Ltac"; "Module"; "Module Type"; "Declare Module"; "Include"; "Mutual"; "Parameter"; "Parameters"; "Print"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; - "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; + "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context"; "Notation"; "Reserved Notation"; "Tactic Notation"; - "Delimit"; "Bind"; "Open"; "Scope"; + "Delimit"; "Bind"; "Open"; "Scope"; "Boxed"; "Unboxed"; "Inline"; "Implicit Arguments"; "Add"; "Strict"; "Typeclasses"; "Instance"; "Global Instance"; "Class"; "Instantiation"; @@ -54,13 +54,13 @@ let is_keyword = "Obligation"; "Obligations"; "Solve"; "using"; "Next Obligation"; "Next"; "Program Instance"; "Equations"; "Equations_nocomp"; (*i (* coq terms *) *) - "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "dest"; "fun"; + "forall"; "match"; "as"; "in"; "return"; "with"; "end"; "let"; "dest"; "fun"; "if"; "then"; "else"; "Prop"; "Set"; "Type"; ":="; "where"; "struct"; "wf"; "measure"; (* Ltac *) "before"; "after" ] -let is_tactic = +let is_tactic = build_table [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection"; "elimtype"; "progress"; "setoid_rewrite"; @@ -81,14 +81,14 @@ let current_module : (string * string option) ref = ref ("",None) let get_module withsub = let (m,sub) = !current_module in - if withsub then - match sub with + if withsub then + match sub with | None -> m | Some sub -> m ^ ": " ^ sub else m -let set_module m sub = current_module := (m,sub); +let set_module m sub = current_module := (m,sub); page_title := get_module true (*s Common to both LaTeX and HTML *) @@ -102,15 +102,15 @@ let token_pp = Hashtbl.create 97 let add_printing_token = Hashtbl.replace token_pp -let find_printing_token tok = +let find_printing_token tok = try Hashtbl.find token_pp tok with Not_found -> None, None let remove_printing_token = Hashtbl.remove token_pp (* predefined pretty-prints *) -let initialize () = +let initialize () = let if_utf8 = if !Cdglobals.utf8 then fun x -> Some x else fun _ -> None in - List.iter + List.iter (fun (s,l,l') -> Hashtbl.add token_pp s (Some l, l')) [ "*" , "\\ensuremath{\\times}", if_utf8 "×"; "|", "\\ensuremath{|}", None; @@ -136,7 +136,7 @@ let initialize () = (*s Table of contents *) -type toc_entry = +type toc_entry = | Toc_library of string * string option | Toc_section of int * (unit -> unit) * string @@ -172,7 +172,7 @@ module Latex = struct Queue.iter (fun s -> printf "%s\n" s) preamble; printf "\\begin{document}\n" end; - output_string + output_string "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n"; output_string "%% This file has been automatically generated with the command\n"; @@ -188,19 +188,19 @@ module Latex = struct end let char c = match c with - | '\\' -> + | '\\' -> printf "\\symbol{92}" - | '$' | '#' | '%' | '&' | '{' | '}' | '_' -> + | '$' | '#' | '%' | '&' | '{' | '}' | '_' -> output_char '\\'; output_char c - | '^' | '~' -> + | '^' | '~' -> output_char '\\'; output_char c; printf "{}" - | _ -> + | _ -> output_char c let label_char c = match c with | '\\' | '$' | '#' | '%' | '&' | '{' | '}' | '_' | '^' | '~' -> () - | _ -> + | _ -> output_char c let latex_char = output_char @@ -215,10 +215,10 @@ module Latex = struct let label_ident s = for i = 0 to String.length s - 1 do label_char s.[i] done - let start_module () = + let start_module () = let ln = !lib_name in if not !short then begin - printf "\\coqlibrary{"; + printf "\\coqlibrary{"; label_ident (get_module false); printf "}{"; if ln <> "" then printf "%s " ln; @@ -235,22 +235,22 @@ module Latex = struct let stop_verbatim () = printf "\\end{verbatim}\n" - let indentation n = - if n == 0 then + let indentation n = + if n == 0 then printf "\\coqdocnoindent\n" else let space = 0.5 *. (float n) in printf "\\coqdocindent{%2.2fem}\n" space let with_latex_printing f tok = - try + try (match Hashtbl.find token_pp tok with | Some s, _ -> output_string s | _ -> f tok) - with Not_found -> + with Not_found -> f tok - let module_ref m s = + let module_ref m s = printf "\\moduleid{%s}{" m; raw_ident s; printf "}" (*i match find_module m with @@ -278,16 +278,16 @@ module Latex = struct printf "\\coq%s{" (type_name ty); label_ident (m ^ "." ^ id); printf "}{"; raw_ident s; printf "}" let reference s = function - | Def (fullid,typ) -> + | Def (fullid,typ) -> defref (get_module false) fullid typ s | Mod (m,s') when s = s' -> module_ref m s - | Ref (m,fullid,typ) -> + | Ref (m,fullid,typ) -> ident_ref m fullid typ s | Mod _ -> printf "\\coqdocvar{"; raw_ident s; printf "}" - - let ident s loc = + + let ident s loc = if is_keyword s then begin printf "\\coqdockw{"; raw_ident s; printf "}" end else begin @@ -298,7 +298,7 @@ module Latex = struct if is_tactic s then begin printf "\\coqdoctac{"; raw_ident s; printf "}" end else begin - if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) + if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) then try reference s (Index.find_string (get_module false) s) with _ -> (printf "\\coqdocvar{"; raw_ident s; printf "}") @@ -307,19 +307,19 @@ module Latex = struct end end - let ident s l = + let ident s l = if !in_title then ( printf "\\texorpdfstring{\\protect"; with_latex_printing (fun s -> ident s l) s; printf "}{"; raw_ident s; printf "}") else with_latex_printing (fun s -> ident s l) s - + let symbol s = with_latex_printing raw_ident s let proofbox () = printf "\\ensuremath{\\Box}" - let rec reach_item_level n = + let rec reach_item_level n = if !item_level < n then begin printf "\n\\begin{itemize}\n\\item "; incr item_level; reach_item_level n @@ -397,14 +397,14 @@ end (*s HTML output *) module Html = struct - + let header () = if !header_trailer then if !header_file_spec then let cin = Pervasives.open_in !header_file in - try - while true do - let s = Pervasives.input_line cin in + try + while true do + let s = Pervasives.input_line cin in printf "%s\n" s done with End_of_file -> Pervasives.close_in cin @@ -421,14 +421,14 @@ module Html = struct end let trailer () = - if !index && (get_module false) <> "Index" then + if !index && (get_module false) <> "Index" then printf "\n\n
\n
Index" !index_name; - if !header_trailer then + if !header_trailer then if !footer_file_spec then let cin = Pervasives.open_in !footer_file in - try - while true do - let s = Pervasives.input_line cin in + try + while true do + let s = Pervasives.input_line cin in printf "%s\n" s done with End_of_file -> Pervasives.close_in cin @@ -439,7 +439,7 @@ module Html = struct printf "
\n\n\n\n\n" end - let start_module () = + let start_module () = let ln = !lib_name in if not !short then begin let (m,sub) = !current_module in @@ -454,7 +454,7 @@ module Html = struct let line_break () = printf "
\n" - let empty_line_of_code () = + let empty_line_of_code () = printf "\n
\n" let char = function @@ -477,7 +477,7 @@ module Html = struct let start_verbatim () = printf "
"
   let stop_verbatim () = printf "
\n" - let module_ref m s = + let module_ref m s = match find_module m with | Local -> printf "" m; raw_ident s; printf "" @@ -491,56 +491,56 @@ module Html = struct match find_module m with | Local -> printf "" m fid; - printf "" typ; + printf "" typ; raw_ident s; printf "" | Coqlib when !externals -> let m = Filename.concat !coqlib m in printf "" m fid; - printf "" typ; + printf "" typ; raw_ident s; printf "" | Coqlib | Unknown -> printf "" typ; raw_ident s; printf "" - - let reference s r = + + let reference s r = match r with - | Def (fullid,ty) -> - printf "" fullid; - printf "" (type_name ty); + | Def (fullid,ty) -> + printf "" fullid; + printf "" (type_name ty); raw_ident s; printf "" | Mod (m,s') when s = s' -> module_ref m s - | Ref (m,fullid,ty) -> + | Ref (m,fullid,ty) -> ident_ref m fullid (type_name ty) s | Mod _ -> printf ""; raw_ident s ; printf "" - let ident s loc = + let ident s loc = if is_keyword s then begin - printf ""; - raw_ident s; + printf ""; + raw_ident s; printf "" - end else + end else begin try reference s (Index.find (get_module false) loc) with Not_found -> if is_tactic s then (printf ""; raw_ident s; printf "") else - if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) + if !Cdglobals.interpolate && !in_doc (* always a var otherwise *) then try reference s (Index.find_string (get_module false) s) with _ -> (printf ""; raw_ident s ; printf "") else (printf ""; raw_ident s ; printf "") end - + let with_html_printing f tok = - try + try (match Hashtbl.find token_pp tok with | _, Some s -> output_string s | _ -> f tok) - with Not_found -> + with Not_found -> f tok let ident s l = @@ -551,7 +551,7 @@ module Html = struct let proofbox () = printf "☐" - let rec reach_item_level n = + let rec reach_item_level n = if !item_level < n then begin printf "
    \n
  • "; incr item_level; reach_item_level n @@ -576,11 +576,11 @@ module Html = struct printf "\n
    \n" let end_doc () = in_doc := false; - stop_item (); + stop_item (); if not !raw_comments then printf "\n
    \n" let start_emph () = printf "" - + let stop_emph () = printf "" let start_comment () = printf "(*" @@ -620,19 +620,19 @@ module Html = struct if l <> [] then begin let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in printf "

    %c %s

    \n" idx c c cat; - List.iter - (fun (id,(text,link)) -> + List.iter + (fun (id,(text,link)) -> printf "%s %s
    \n" link id text) l; printf "

    " end - + let all_letters i = List.iter (letter_index false i.idx_name) i.idx_entries (* Construction d'une liste des index (1 index global, puis 1 index par catégorie) *) let format_global_index = - Index.map - (fun s (m,t) -> + Index.map + (fun s (m,t) -> if t = Library then let ln = !lib_name in if ln <> "" then @@ -647,16 +647,16 @@ module Html = struct | Library, idx -> Index.map (fun id m -> "", m ^ ".html") idx | (t,idx) -> - Index.map - (fun s m -> + Index.map + (fun s m -> let text = sprintf "[in %s]" m m in (text, sprintf "%s.html#%s" m s)) idx (* Impression de la table d'index *) let print_index_table_item i = printf "\n%s Index\n" (String.capitalize i.idx_name); - List.iter - (fun (c,l) -> + List.iter + (fun (c,l) -> if l <> [] then printf "%c\n" (index_ref i c) c else @@ -666,11 +666,11 @@ module Html = struct printf "(%d %s)\n" n (if n > 1 then "entries" else "entry"); printf "\n" - let print_index_table idxl = + let print_index_table idxl = printf "\n"; List.iter print_index_table_item idxl; printf "
    \n" - + let make_one_multi_index prt_tbl i = (* Attn: make_one_multi_index créé un nouveau fichier... *) let idx = i.idx_name in @@ -685,16 +685,16 @@ module Html = struct in List.iter one_letter i.idx_entries - let make_multi_index () = - let all_index = + let make_multi_index () = + let all_index = let glob,bt = Index.all_entries () in (format_global_index glob) :: (List.map format_bytype_index bt) in let print_table () = print_index_table all_index in List.iter (make_one_multi_index print_table) all_index - + let make_index () = - let all_index = + let all_index = let glob,bt = Index.all_entries () in (format_global_index glob) :: (List.map format_bytype_index bt) in @@ -708,16 +708,16 @@ module Html = struct set_module "Index" None; if !title <> "" then printf "

    %s

    \n" !title; print_table (); - if not (!multi_index) then + if not (!multi_index) then begin List.iter print_one_index all_index; printf "
    "; print_table () end - - let make_toc () = + + let make_toc () = let ln = !lib_name in let make_toc_entry = function - | Toc_library (m,sub) -> + | Toc_library (m,sub) -> stop_item (); let ms = match sub with | None -> m | Some s -> m ^ ": " ^ s in if ln = "" then @@ -725,14 +725,14 @@ module Html = struct else printf "

    %s %s

    \n" m ln ms | Toc_section (n, f, r) -> - item n; + item n; printf "" r; f (); printf "\n" in printf "
    \n"; Queue.iter make_toc_entry toc_q; stop_item (); printf "
    \n" - + end @@ -742,15 +742,15 @@ module TeXmacs = struct (*s Latex preamble *) - let (preamble : string Queue.t) = + let (preamble : string Queue.t) = in_doc := false; Queue.create () let push_in_preamble s = Queue.add s preamble let header () = - output_string + output_string "(*i This file has been automatically generated with the command \n"; - output_string + output_string " "; Array.iter (fun s -> printf "%s " s) Sys.argv; printf " *)\n" let trailer () = () @@ -785,7 +785,7 @@ module TeXmacs = struct let indentation n = () - let ident_true s = + let ident_true s = if is_keyword s then begin printf "" end else begin @@ -793,8 +793,8 @@ module TeXmacs = struct end let ident s _ = if !in_doc then ident_true s else raw_ident s - - let symbol_true s = + + let symbol_true s = let ensuremath x = printf ">" x in match s with | "*" -> ensuremath "times" @@ -815,7 +815,7 @@ module TeXmacs = struct let proofbox () = printf "QED" - let rec reach_item_level n = + let rec reach_item_level n = if !item_level < n then begin printf "\n<\\itemize>\n"; incr item_level; reach_item_level n @@ -857,7 +857,7 @@ module TeXmacs = struct let section lev f = stop_item (); - printf "<"; output_string (section_kind lev); printf "|"; + printf "<"; output_string (section_kind lev); printf "|"; f (); printf ">\n\n" let rule () = @@ -897,7 +897,7 @@ module Raw = struct let label_char c = match c with | '\\' | '$' | '#' | '%' | '&' | '{' | '}' | '_' | '^' | '~' -> () - | _ -> + | _ -> output_char c let latex_char = output_char @@ -919,7 +919,7 @@ module Raw = struct let stop_verbatim () = () - let indentation n = + let indentation n = for i = 1 to n do printf " " done let ident s loc = raw_ident s @@ -947,15 +947,15 @@ module Raw = struct let start_code () = end_doc (); start_coq () let end_code () = end_coq (); start_doc () - let section_kind = + let section_kind = function | 1 -> "* " | 2 -> "** " | 3 -> "*** " | 4 -> "**** " - | _ -> assert false + | _ -> assert false - let section lev f = + let section lev f = output_string (section_kind lev); f () @@ -972,7 +972,7 @@ module Raw = struct let make_multi_index () = () let make_index () = () - let make_toc () = () + let make_toc () = () end @@ -980,7 +980,7 @@ end (*s Generic output *) -let select f1 f2 f3 f4 x = +let select f1 f2 f3 f4 x = match !target_language with LaTeX -> f1 x | HTML -> f2 x | TeXmacs -> f3 x | Raw -> f4 x let push_in_preamble = Latex.push_in_preamble @@ -988,7 +988,7 @@ let push_in_preamble = Latex.push_in_preamble let header = select Latex.header Html.header TeXmacs.header Raw.header let trailer = select Latex.trailer Html.trailer TeXmacs.trailer Raw.trailer -let start_module = +let start_module = select Latex.start_module Html.start_module TeXmacs.start_module Raw.start_module let start_doc = select Latex.start_doc Html.start_doc TeXmacs.start_doc Raw.start_doc @@ -1001,17 +1001,17 @@ let start_coq = select Latex.start_coq Html.start_coq TeXmacs.start_coq Raw.star let end_coq = select Latex.end_coq Html.end_coq TeXmacs.end_coq Raw.end_coq let start_code = select Latex.start_code Html.start_code TeXmacs.start_code Raw.start_code -let end_code = select Latex.end_code Html.end_code TeXmacs.end_code Raw.end_code +let end_code = select Latex.end_code Html.end_code TeXmacs.end_code Raw.end_code -let start_inline_coq = +let start_inline_coq = select Latex.start_inline_coq Html.start_inline_coq TeXmacs.start_inline_coq Raw.start_inline_coq -let end_inline_coq = +let end_inline_coq = select Latex.end_inline_coq Html.end_inline_coq TeXmacs.end_inline_coq Raw.end_inline_coq let indentation = select Latex.indentation Html.indentation TeXmacs.indentation Raw.indentation let paragraph = select Latex.paragraph Html.paragraph TeXmacs.paragraph Raw.paragraph let line_break = select Latex.line_break Html.line_break TeXmacs.line_break Raw.line_break -let empty_line_of_code = select +let empty_line_of_code = select Latex.empty_line_of_code Html.empty_line_of_code TeXmacs.empty_line_of_code Raw.empty_line_of_code let section = select Latex.section Html.section TeXmacs.section Raw.section @@ -1027,10 +1027,10 @@ let symbol = select Latex.symbol Html.symbol TeXmacs.symbol Raw.symbol let proofbox = select Latex.proofbox Html.proofbox TeXmacs.proofbox Raw.proofbox let latex_char = select Latex.latex_char Html.latex_char TeXmacs.latex_char Raw.latex_char -let latex_string = +let latex_string = select Latex.latex_string Html.latex_string TeXmacs.latex_string Raw.latex_string let html_char = select Latex.html_char Html.html_char TeXmacs.html_char Raw.html_char -let html_string = +let html_string = select Latex.html_string Html.html_string TeXmacs.html_string Raw.html_string let start_emph = @@ -1038,16 +1038,16 @@ let start_emph = let stop_emph = select Latex.stop_emph Html.stop_emph TeXmacs.stop_emph Raw.stop_emph -let start_latex_math = +let start_latex_math = select Latex.start_latex_math Html.start_latex_math TeXmacs.start_latex_math Raw.start_latex_math -let stop_latex_math = +let stop_latex_math = select Latex.stop_latex_math Html.stop_latex_math TeXmacs.stop_latex_math Raw.stop_latex_math -let start_verbatim = +let start_verbatim = select Latex.start_verbatim Html.start_verbatim TeXmacs.start_verbatim Raw.start_verbatim -let stop_verbatim = +let stop_verbatim = select Latex.stop_verbatim Html.stop_verbatim TeXmacs.stop_verbatim Raw.stop_verbatim -let verbatim_char = +let verbatim_char = select output_char Html.char TeXmacs.char Raw.char let hard_verbatim_char = output_char diff --git a/tools/coqwc.mll b/tools/coqwc.mll index 9c0019342e..f3646a8a1f 100644 --- a/tools/coqwc.mll +++ b/tools/coqwc.mll @@ -11,10 +11,10 @@ (*i $Id$ i*) -(*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source. +(*s {\bf coqwc.} Counts the lines of spec, proof and comments in a Coq source. It assumes the files to be lexically well-formed. *) -(*i*){ +(*i*){ open Printf open Lexing open Filename @@ -40,8 +40,8 @@ let tplines = ref 0 let tdlines = ref 0 let update_totals () = - tslines := !tslines + !slines; - tplines := !tplines + !plines; + tslines := !tslines + !slines; + tplines := !tplines + !plines; tdlines := !tdlines + !dlines (*s The following booleans indicate whether we have seen spec, proof or @@ -53,12 +53,12 @@ let seen_proof = ref false let seen_comment = ref false let newline () = - if !seen_spec then incr slines; - if !seen_proof then incr plines; - if !seen_comment then incr dlines; + if !seen_spec then incr slines; + if !seen_proof then incr plines; + if !seen_comment then incr dlines; seen_spec := false; seen_proof := false; seen_comment := false -let reset_counters () = +let reset_counters () = seen_spec := false; seen_proof := false; seen_comment := false; slines := 0; plines := 0; dlines := 0 @@ -83,7 +83,7 @@ let print_totals () = print_line !tslines !tplines !tdlines (Some "total") (*i*)}(*i*) (*s Shortcuts for regular expressions. The [rcs] regular expression - is used to skip the CVS infos possibly contained in some comments, + is used to skip the CVS infos possibly contained in some comments, in order not to consider it as documentation. *) let space = [' ' '\t' '\r'] @@ -96,7 +96,7 @@ let rcs_keyword = let rcs = "\036" rcs_keyword [^ '$']* "\036" let stars = "(*" '*'* "*)" let dot = '.' (' ' | '\t' | '\n' | '\r' | eof) -let proof_start = +let proof_start = "Theorem" | "Lemma" | "Fact" | "Remark" | "Goal" | "Correctness" | "Obligation" | "Next" let proof_end = ("Save" | "Qed" | "Defined" | "Abort" | "Admitted") [^'.']* '.' @@ -105,10 +105,10 @@ let proof_end = rule spec = parse | "(*" { comment lexbuf; spec lexbuf } - | '"' { let n = string lexbuf in slines := !slines + n; + | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; spec lexbuf } | '\n' { newline (); spec lexbuf } - | space+ | stars + | space+ | stars { spec lexbuf } | proof_start space { seen_spec := true; spec_to_dot lexbuf; proof lexbuf } @@ -118,7 +118,7 @@ rule spec = parse { seen_spec := true; definition lexbuf } | "Program"? "Fixpoint" space { seen_spec := true; definition lexbuf } - | character | _ + | character | _ { seen_spec := true; spec lexbuf } | eof { () } @@ -126,29 +126,29 @@ rule spec = parse and spec_to_dot = parse | "(*" { comment lexbuf; spec_to_dot lexbuf } - | '"' { let n = string lexbuf in slines := !slines + n; + | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; spec_to_dot lexbuf } | '\n' { newline (); spec_to_dot lexbuf } | dot { () } - | space+ | stars + | space+ | stars { spec_to_dot lexbuf } - | character | _ + | character | _ { seen_spec := true; spec_to_dot lexbuf } | eof { () } -(*s [definition] scans a definition; passes to [proof] is the body is +(*s [definition] scans a definition; passes to [proof] is the body is absent, and to [spec] otherwise *) and definition = parse | "(*" { comment lexbuf; definition lexbuf } - | '"' { let n = string lexbuf in slines := !slines + n; + | '"' { let n = string lexbuf in slines := !slines + n; seen_spec := true; definition lexbuf } | '\n' { newline (); definition lexbuf } | ":=" { seen_spec := true; spec lexbuf } | dot { proof lexbuf } - | space+ | stars + | space+ | stars { definition lexbuf } - | character | _ + | character | _ { seen_spec := true; definition lexbuf } | eof { () } @@ -156,30 +156,30 @@ and definition = parse and proof = parse | "(*" { comment lexbuf; proof lexbuf } - | '"' { let n = string lexbuf in plines := !plines + n; + | '"' { let n = string lexbuf in plines := !plines + n; seen_proof := true; proof lexbuf } - | space+ | stars + | space+ | stars { proof lexbuf } | '\n' { newline (); proof lexbuf } - | "Proof" space* '.' + | "Proof" space* '.' { seen_proof := true; proof lexbuf } | "Proof" space { proof_term lexbuf } | proof_end { seen_proof := true; spec lexbuf } - | character | _ + | character | _ { seen_proof := true; proof lexbuf } | eof { () } and proof_term = parse | "(*" { comment lexbuf; proof_term lexbuf } - | '"' { let n = string lexbuf in plines := !plines + n; + | '"' { let n = string lexbuf in plines := !plines + n; seen_proof := true; proof_term lexbuf } - | space+ | stars + | space+ | stars { proof_term lexbuf } | '\n' { newline (); proof_term lexbuf } | dot { spec lexbuf } - | character | _ + | character | _ { seen_proof := true; proof_term lexbuf } | eof { () } @@ -188,12 +188,12 @@ and proof_term = parse and comment = parse | "(*" { comment lexbuf; comment lexbuf } | "*)" { () } - | '"' { let n = string lexbuf in dlines := !dlines + n; + | '"' { let n = string lexbuf in dlines := !dlines + n; seen_comment := true; comment lexbuf } | '\n' { newline (); comment lexbuf } | space+ | stars { comment lexbuf } - | character | _ + | character | _ { seen_comment := true; comment lexbuf } | eof { () } @@ -212,9 +212,9 @@ and string = parse It stops whenever it encounters an empty line or any character outside a comment. In this last case, it correctly resets the lexer position on that character (decreasing [lex_curr_pos] by 1). *) - + and read_header = parse - | "(*" { skip_comment lexbuf; skip_until_nl lexbuf; + | "(*" { skip_comment lexbuf; skip_until_nl lexbuf; read_header lexbuf } | "\n" { () } | space+ { read_header lexbuf } @@ -250,9 +250,9 @@ let process_file f = print_file (Some f); update_totals () with - | Sys_error "Is a directory" -> + | Sys_error "Is a directory" -> flush stdout; eprintf "coqwc: %s: Is a directory\n" f; flush stderr - | Sys_error s -> + | Sys_error s -> flush stdout; eprintf "coqwc: %s\n" s; flush stderr (*s Parsing of the command line. *) @@ -269,9 +269,9 @@ let usage () = let rec parse = function | [] -> [] | ("-h" | "-?" | "-help" | "--help") :: _ -> usage () - | ("-s" | "--spec-only") :: args -> + | ("-s" | "--spec-only") :: args -> proof_only := false; spec_only := true; parse args - | ("-r" | "--proof-only") :: args -> + | ("-r" | "--proof-only") :: args -> spec_only := false; proof_only := true; parse args | ("-p" | "--percentage") :: args -> percentage := true; parse args | ("-e" | "--header") :: args -> skip_header := false; parse args @@ -281,7 +281,7 @@ let rec parse = function let main () = let files = parse (List.tl (Array.to_list Sys.argv)) in - if not (!spec_only || !proof_only) then + if not (!spec_only || !proof_only) then printf " spec proof comments\n"; match files with | [] -> process_channel stdin; print_file None diff --git a/tools/gallina.ml b/tools/gallina.ml index 8b39442073..8ba9ae1049 100644 --- a/tools/gallina.ml +++ b/tools/gallina.ml @@ -16,29 +16,29 @@ let option_moins = ref false let option_stdout = ref false -let traite_fichier f = - try - let chan_in = open_in (f^".v") in +let traite_fichier f = + try + let chan_in = open_in (f^".v") in let buf = Lexing.from_channel chan_in in if not !option_stdout then chan_out := open_out (f ^ ".g"); - try + try while true do Gallina_lexer.action buf done - with Fin_fichier -> begin + with Fin_fichier -> begin flush !chan_out; close_in chan_in; if not !option_stdout then close_out !chan_out end - with Sys_error _ -> - () + with Sys_error _ -> + () let traite_stdin () = try let buf = Lexing.from_channel stdin in - try + try while true do Gallina_lexer.action buf done - with Fin_fichier -> + with Fin_fichier -> flush !chan_out - with Sys_error _ -> + with Sys_error _ -> () let gallina () = @@ -52,7 +52,7 @@ let gallina () = | "-" -> option_moins := true | "-stdout" -> option_stdout := true | "-nocomments" -> comments := false - | f -> + | f -> if Filename.check_suffix f ".v" then vfiles := (Filename.chop_suffix f ".v") :: !vfiles in diff --git a/tools/gallina_lexer.mll b/tools/gallina_lexer.mll index b47a04b2c1..6d35d83972 100644 --- a/tools/gallina_lexer.mll +++ b/tools/gallina_lexer.mll @@ -17,7 +17,7 @@ let cRcpt = ref 0 let comments = ref true let print s = output_string !chan_out s - + exception Fin_fichier } @@ -26,17 +26,17 @@ let space = [' ' '\t' '\n' '\r'] let enddot = '.' (' ' | '\t' | '\n' | '\r' | eof) rule action = parse - | "Theorem" space { print "Theorem "; body lexbuf; + | "Theorem" space { print "Theorem "; body lexbuf; cRcpt := 1; action lexbuf } - | "Lemma" space { print "Lemma "; body lexbuf; + | "Lemma" space { print "Lemma "; body lexbuf; cRcpt := 1; action lexbuf } - | "Fact" space { print "Fact "; body lexbuf; + | "Fact" space { print "Fact "; body lexbuf; cRcpt := 1; action lexbuf } - | "Remark" space { print "Remark "; body lexbuf; + | "Remark" space { print "Remark "; body lexbuf; cRcpt := 1; action lexbuf } - | "Goal" space { print "Goal "; body lexbuf; + | "Goal" space { print "Goal "; body lexbuf; cRcpt := 1; action lexbuf } - | "Correctness" space { print "Correctness "; body_pgm lexbuf; + | "Correctness" space { print "Correctness "; body_pgm lexbuf; cRcpt := 1; action lexbuf } | "Definition" space { print "Definition "; body_def lexbuf; cRcpt := 1; action lexbuf } @@ -55,7 +55,7 @@ rule action = parse | _ { print (Lexing.lexeme lexbuf); cRcpt := 0; action lexbuf } and comment = parse - | "(*" { (if !comments then print "(*"); + | "(*" { (if !comments then print "(*"); comment_depth := succ !comment_depth; comment lexbuf } | "*)" { (if !comments then print "*)"); comment_depth := pred !comment_depth; @@ -63,15 +63,15 @@ and comment = parse | "*)" [' ''\t']*'\n' { (if !comments then print (Lexing.lexeme lexbuf)); comment_depth := pred !comment_depth; if !comment_depth > 0 then comment lexbuf } - | eof { raise Fin_fichier } - | _ { (if !comments then print (Lexing.lexeme lexbuf)); + | eof { raise Fin_fichier } + | _ { (if !comments then print (Lexing.lexeme lexbuf)); comment lexbuf } and skip_comment = parse | "(*" { comment_depth := succ !comment_depth; skip_comment lexbuf } | "*)" { comment_depth := pred !comment_depth; if !comment_depth > 0 then skip_comment lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { skip_comment lexbuf } and body_def = parse @@ -83,14 +83,14 @@ and body = parse | ":=" { print ".\n"; skip_proof lexbuf } | "(*" { print "(*"; comment_depth := 1; comment lexbuf; body lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf); body lexbuf } and body_pgm = parse | enddot { print ".\n"; skip_proof lexbuf } | "(*" { print "(*"; comment_depth := 1; comment lexbuf; body_pgm lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf); body_pgm lexbuf } and skip_until_point = parse @@ -98,13 +98,13 @@ and skip_until_point = parse | enddot { end_of_line lexbuf } | "(*" { comment_depth := 1; skip_comment lexbuf; skip_until_point lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { skip_until_point lexbuf } and end_of_line = parse | [' ' '\t' ]* { end_of_line lexbuf } | '\n' { () } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { print (Lexing.lexeme lexbuf) } and skip_proof = parse @@ -124,5 +124,5 @@ and skip_proof = parse | "Proof" [' ' '\t']* '.' { skip_proof lexbuf } | "(*" { comment_depth := 1; skip_comment lexbuf; skip_proof lexbuf } - | eof { raise Fin_fichier } + | eof { raise Fin_fichier } | _ { skip_proof lexbuf } diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 5ddf2b7055..3e025b0320 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -30,7 +30,7 @@ open Ind_tables (* boolean equality *) -let quick_chop n l = +let quick_chop n l = let rec kick_last = function | t::[] -> [] | t::q -> t::(kick_last q) @@ -39,20 +39,20 @@ and aux = function | (0,l') -> l' | (n,h::t) -> aux (n-1,t) | _ -> failwith "quick_chop" - in + in if n > (List.length l) then failwith "quick_chop args" else kick_last (aux (n,l) ) -let rec deconstruct_type t = +let rec deconstruct_type t = let l,r = decompose_prod t in (List.map (fun (_,b) -> b) (List.rev l))@[r] -let subst_in_constr (_,subst,(ind,const)) = +let subst_in_constr (_,subst,(ind,const)) = let ind' = (subst_kn subst (fst ind)),(snd ind) and const' = subst_mps subst const in ind',const' -exception EqNotFound of string +exception EqNotFound of string exception EqUnknown of string let dl = dummy_loc @@ -62,28 +62,28 @@ let bb = constr_of_global Coqlib.glob_bool let andb_prop = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb_prop -let andb_true_intro = fun _ -> - (Coqlib.build_bool_type()).Coqlib.andb_true_intro +let andb_true_intro = fun _ -> + (Coqlib.build_bool_type()).Coqlib.andb_true_intro -let tt = constr_of_global Coqlib.glob_true +let tt = constr_of_global Coqlib.glob_true let ff = constr_of_global Coqlib.glob_false -let eq = constr_of_global Coqlib.glob_eq +let eq = constr_of_global Coqlib.glob_eq -let sumbool = Coqlib.build_coq_sumbool +let sumbool = Coqlib.build_coq_sumbool -let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb +let andb = fun _ -> (Coqlib.build_bool_type()).Coqlib.andb (* reconstruct the inductive with the correct deBruijn indexes *) -let mkFullInd ind n = +let mkFullInd ind n = let mib = Global.lookup_mind (fst ind) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in (* params context divided *) - let lnonparrec,lnamesparrec = + let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - if nparrec > 0 + if nparrec > 0 then mkApp (mkInd ind, Array.of_list(extended_rel_list (nparrec+n) lnamesparrec)) else mkInd ind @@ -99,33 +99,33 @@ let make_eq_scheme sp = let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in (* params context divided *) - let lnonparrec,lnamesparrec = + let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in (* predef coq's boolean type *) (* rec name *) let rec_name i =(string_of_id (Array.get mib.mind_packets i).mind_typename)^ - "_eqrec" + "_eqrec" in (* construct the "fun A B ... N, eqA eqB eqC ... N => fixpoint" part *) let create_input c = - let myArrow u v = mkArrow u (lift 1 v) + let myArrow u v = mkArrow u (lift 1 v) and eqName = function | Name s -> id_of_string ("eq_"^(string_of_id s)) - | Anonymous -> id_of_string "eq_A" + | Anonymous -> id_of_string "eq_A" in let ext_rel_list = extended_rel_list 0 lnamesparrec in let lift_cnt = ref 0 in - let eqs_typ = List.map (fun aa -> - let a = lift !lift_cnt aa in - incr lift_cnt; - myArrow a (myArrow a bb) + let eqs_typ = List.map (fun aa -> + let a = lift !lift_cnt aa in + incr lift_cnt; + myArrow a (myArrow a bb) ) ext_rel_list in let eq_input = List.fold_left2 ( fun a b (n,_,_) -> (* mkLambda(n,b,a) ) *) (* here I leave the Naming thingy so that the type of the function is more readable for the user *) - mkNamedLambda (eqName n) b a ) + mkNamedLambda (eqName n) b a ) c (List.rev eqs_typ) lnamesparrec in List.fold_left (fun a (n,_,t) ->(* mkLambda(n,t,a)) eq_input rel_list *) @@ -134,83 +134,83 @@ let make_eq_scheme sp = (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec in - let make_one_eq cur = - let ind = sp,cur in + let make_one_eq cur = + let ind = sp,cur in (* current inductive we are working on *) - let cur_packet = mib.mind_packets.(snd ind) in + let cur_packet = mib.mind_packets.(snd ind) in (* Inductive toto : [rettyp] := *) let rettyp = Inductive.type_of_inductive env (mib,cur_packet) in - (* split rettyp in a list without the non rec params and the last -> + (* split rettyp in a list without the non rec params and the last -> e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *) let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in (* give a type A, this function tries to find the equality on A declared previously *) (* nlist = the number of args (A , B , ... ) eqA = the deBruijn index of the first eq param - ndx = how much to translate due to the 2nd Case + ndx = how much to translate due to the 2nd Case *) - let compute_A_equality rel_list nlist eqA ndx t = + let compute_A_equality rel_list nlist eqA ndx t = let lifti = ndx in let rec aux c a = match c with | Rel x -> mkRel (x-nlist+ndx) - | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))) - | Cast (x,_,_) -> aux (kind_of_term x) a - | App (x,newa) -> aux (kind_of_term x) newa + | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))) + | Cast (x,_,_) -> aux (kind_of_term x) a + | App (x,newa) -> aux (kind_of_term x) newa | Ind (sp',i) -> if sp=sp' then mkRel(eqA-nlist-i+nb_ind-1) - else ( try - let eq = find_eq_scheme (sp',i) - and eqa = Array.map - (fun x -> aux (kind_of_term x) [||] ) a + else ( try + let eq = find_eq_scheme (sp',i) + and eqa = Array.map + (fun x -> aux (kind_of_term x) [||] ) a in - let args = Array.append - (Array.map (fun x->lift lifti x) a) eqa - in if args = [||] then eq - else mkApp (eq,Array.append + let args = Array.append + (Array.map (fun x->lift lifti x) a) eqa + in if args = [||] then eq + else mkApp (eq,Array.append (Array.map (fun x->lift lifti x) a) eqa) with Not_found -> raise(EqNotFound (string_of_kn sp')) ) | Sort _ -> raise (EqUnknown "Sort" ) | Prod _ -> raise (EqUnknown "Prod" ) - | Lambda _-> raise (EqUnknown "Lambda") + | Lambda _-> raise (EqUnknown "Lambda") | LetIn _ -> raise (EqUnknown "LetIn") - | Const kn -> let mp,dir,lbl= repr_con kn in + | Const kn -> let mp,dir,lbl= repr_con kn in mkConst (make_con mp dir ( - mk_label ("eq_"^(string_of_label lbl)))) + mk_label ("eq_"^(string_of_label lbl)))) | Construct _ -> raise (EqUnknown "Construct") | Case _ -> raise (EqUnknown "Case") | CoFix _ -> raise (EqUnknown "CoFix") - | Fix _ -> raise (EqUnknown "Fix") - | Meta _ -> raise (EqUnknown "Meta") + | Fix _ -> raise (EqUnknown "Fix") + | Meta _ -> raise (EqUnknown "Meta") | Evar _ -> raise (EqUnknown "Evar") in aux t [||] in (* construct the predicate for the Case part*) - let do_predicate rel_list n = - List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) + let do_predicate rel_list n = + List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) (mkLambda (Anonymous, mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), - bb)) - (List.rev rettyp_l) in + bb)) + (List.rev rettyp_l) in (* make_one_eq *) - (* do the [| C1 ... => match Y with ... end - ... + (* do the [| C1 ... => match Y with ... end + ... Cn => match Y with ... end |] part *) let ci = make_case_info env ind MatchStyle in let constrs n = get_constructors env (make_ind_family (ind, extended_rel_list (n+nb_ind-1) mib.mind_params_ctxt)) in let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in - let ar = Array.create n ff in + let ar = Array.create n ff in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in let ar2 = Array.create n ff in let constrsj = constrs (3+nparrec+nb_cstr_args) in for j=0 to n-1 do - if (i=j) then + if (i=j) then ar2.(j) <- let cc = (match nb_cstr_args with | 0 -> tt - | _ -> let eqs = Array.make nb_cstr_args tt in + | _ -> let eqs = Array.make nb_cstr_args tt in for ndx = 0 to nb_cstr_args-1 do let _,_,cc = List.nth constrsi.(i).cs_args ndx in let eqA = compute_A_equality rel_list @@ -218,53 +218,53 @@ let make_eq_scheme sp = (nparrec+3+2*nb_cstr_args) (nb_cstr_args+ndx+1) (kind_of_term cc) - in - Array.set eqs ndx + in + Array.set eqs ndx (mkApp (eqA, [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] )) - done; - Array.fold_left - (fun a b -> mkApp (andb(),[|b;a|])) - (eqs.(0)) + done; + Array.fold_left + (fun a b -> mkApp (andb(),[|b;a|])) + (eqs.(0)) (Array.sub eqs 1 (nb_cstr_args - 1)) ) in (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) cc - (constrsj.(j).cs_args) - ) + (constrsj.(j).cs_args) + ) else ar2.(j) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) ff (constrsj.(j).cs_args) ) done; - ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) + ar.(i) <- (List.fold_left (fun a (p,q,r) -> mkLambda (p,r,a)) (mkCase (ci,do_predicate rel_list nb_cstr_args, mkVar (id_of_string "Y") ,ar2)) - (constrsi.(i).cs_args)) + (constrsi.(i).cs_args)) done; mkNamedLambda (id_of_string "X") (mkFullInd ind (nb_ind-1+1)) ( mkNamedLambda (id_of_string "Y") (mkFullInd ind (nb_ind-1+2)) ( - mkCase (ci, do_predicate rel_list 0,mkVar (id_of_string "X"),ar))) + mkCase (ci, do_predicate rel_list 0,mkVar (id_of_string "X"),ar))) in (* make_eq_scheme *) try - let names = Array.make nb_ind Anonymous and - types = Array.make nb_ind mkSet and + let names = Array.make nb_ind Anonymous and + types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet and - res = Array.make nb_ind mkSet in + res = Array.make nb_ind mkSet in for i=0 to (nb_ind-1) do names.(i) <- Name (id_of_string (rec_name i)); - types.(i) <- mkArrow (mkFullInd (sp,i) 0) + types.(i) <- mkArrow (mkFullInd (sp,i) 0) (mkArrow (mkFullInd (sp,i) 1) bb); cores.(i) <- make_one_eq i - done; - if (string_of_mp (modpath sp ))="Coq.Init.Logic" + done; + if (string_of_mp (modpath sp ))="Coq.Init.Logic" then print_string "Logic time, do nothing.\n" else ( - for i=0 to (nb_ind-1) do + for i=0 to (nb_ind-1) do let cpack = Array.get mib.mind_packets i in if check_eq_scheme (sp,i) then message ("Boolean equality is already defined on "^ - (string_of_id cpack.mind_typename)^".") + (string_of_id cpack.mind_typename)^".") else ( let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in res.(i) <- create_input fix @@ -272,7 +272,7 @@ let make_eq_scheme sp = done; ); res - with + with | EqUnknown s -> error ("Type unexpected ("^s^ ") during boolean eq computation, please report.") | EqNotFound s -> error ("Boolean equality on "^s^ @@ -283,32 +283,32 @@ let make_eq_scheme sp = (* This function tryies to get the [inductive] between a constr the constr should be Ind i or App(Ind i,[|args|]) *) -let destruct_ind c = +let destruct_ind c = try let u,v = destApp c in let indc = destInd u in indc,v with _-> let indc = destInd c in indc,[||] -(* - In the followind, avoid is the list of names to avoid. +(* + In the followind, avoid is the list of names to avoid. If the args of the Inductive type are A1 ... An - then avoid should be + then avoid should be [| lb_An ... lb _A1 (resp. bl_An ... bl_A1) eq_An .... eq_A1 An ... A1 |] so from Ai we can find the the correct eq_Ai bl_ai or lb_ai *) (* used in the leib -> bool side*) -let do_replace_lb aavoid narg gls p q = +let do_replace_lb aavoid narg gls p q = let avoid = Array.of_list aavoid in - let do_arg v offset = - try + let do_arg v offset = + try let x = narg*offset in - let s = destVar v in + let s = destVar v in let n = Array.length avoid in - let rec find i = - if avoid.(n-i) = s then avoid.(n-i-x) - else (if i + in let lb_type_of_p = + try find_lb_proof u + with Not_found -> (* spiwack: the format of this error message should probably be improved. *) - let err_msg = msg_with Format.str_formatter + let err_msg = msg_with Format.str_formatter (str "Leibniz->boolean:" ++ - str "You have to declare the" ++ + str "You have to declare the" ++ str "decidability over " ++ - Printer.pr_constr type_of_pq ++ + Printer.pr_constr type_of_pq ++ str " first."); Format.flush_str_formatter () in error err_msg - in let lb_args = Array.append (Array.append + in let lb_args = Array.append (Array.append (Array.map (fun x -> x) v) (Array.map (fun x -> do_arg x 1) v)) (Array.map (fun x -> do_arg x 2) v) - in let app = if lb_args = [||] - then lb_type_of_p else mkApp (lb_type_of_p,lb_args) + in let app = if lb_args = [||] + then lb_type_of_p else mkApp (lb_type_of_p,lb_args) in [Equality.replace p q ; apply app ; Auto.default_auto] (* used in the bool -> leib side *) -let do_replace_bl ind gls aavoid narg lft rgt = - let avoid = Array.of_list aavoid in - let do_arg v offset = - try +let do_replace_bl ind gls aavoid narg lft rgt = + let avoid = Array.of_list aavoid in + let do_arg v offset = + try let x = narg*offset in - let s = destVar v in + let s = destVar v in let n = Array.length avoid in - let rec find i = - if avoid.(n-i) = s then avoid.(n-i-x) - else (if i let tt1 = pf_type_of gls t1 in if t1=t2 then aux q1 q2 else ( - let u,v = try destruct_ind tt1 + let u,v = try destruct_ind tt1 (* trick so that the good sequence is returned*) with _ -> ind,[||] - in if u = ind + in if u = ind then (Equality.replace t1 t2)::(Auto.default_auto)::(aux q1 q2) else ( - let bl_t1 = - try find_bl_proof u - with Not_found -> + let bl_t1 = + try find_bl_proof u + with Not_found -> (* spiwack: the format of this error message should probably be improved. *) - let err_msg = msg_with Format.str_formatter + let err_msg = msg_with Format.str_formatter (str "boolean->Leibniz:" ++ - str "You have to declare the" ++ + str "You have to declare the" ++ str "decidability over " ++ - Printer.pr_constr tt1 ++ + Printer.pr_constr tt1 ++ str " first."); Format.flush_str_formatter () in error err_msg - in let bl_args = - Array.append (Array.append + in let bl_args = + Array.append (Array.append (Array.map (fun x -> x) v) (Array.map (fun x -> do_arg x 1) v)) (Array.map (fun x -> do_arg x 2) v ) - in - let app = if bl_args = [||] - then bl_t1 else mkApp (bl_t1,bl_args) - in - (Equality.replace_by t1 t2 + in + let app = if bl_args = [||] + then bl_t1 else mkApp (bl_t1,bl_args) + in + (Equality.replace_by t1 t2 (tclTHEN (apply app) (Auto.default_auto)))::(aux q1 q2) ) ) | ([],[]) -> [] | _ -> error "Both side of the equality must have the same arity." in - let (ind1,ca1) = try destApp lft with + let (ind1,ca1) = try destApp lft with _ -> error "replace failed." and (ind2,ca2) = try destApp rgt with _ -> error "replace failed." in let (sp1,i1) = try destInd ind1 with - _ -> (try fst (destConstruct ind1) with _ -> + _ -> (try fst (destConstruct ind1) with _ -> error "The expected type is an inductive one.") and (sp2,i2) = try destInd ind2 with _ -> (try fst (destConstruct ind2) with _ -> @@ -427,14 +427,14 @@ let do_replace_bl ind gls aavoid narg lft rgt = in if (sp1 <> sp2) || (i1 <> i2) then (error "Eq should be on the same type") - else (aux (Array.to_list ca1) (Array.to_list ca2)) + else (aux (Array.to_list ca1) (Array.to_list ca2)) -(* +(* create, from a list of ids [i1,i2,...,in] the list [(in,eq_in,in_bl,in_al),,...,(i1,eq_i1,i1_bl_i1_al )] *) -let list_id l = List.fold_left ( fun a (n,_,t) -> let s' = - match n with +let list_id l = List.fold_left ( fun a (n,_,t) -> let s' = + match n with Name s -> string_of_id s | Anonymous -> "A" in (id_of_string s',id_of_string ("eq_"^s'), @@ -445,61 +445,61 @@ let list_id l = List.fold_left ( fun a (n,_,t) -> let s' = (* build the right eq_I A B.. N eq_A .. eq_N *) -let eqI ind l = +let eqI ind l = let list_id = list_id l in let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@ (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) - and e = try find_eq_scheme ind with - Not_found -> error + and e = try find_eq_scheme ind with + Not_found -> error ("The boolean equality on "^(string_of_kn (fst ind))^" is needed."); in (if eA = [||] then e else mkApp(e,eA)) -let compute_bl_goal ind lnamesparrec nparrec = +let compute_bl_goal ind lnamesparrec nparrec = let eqI = eqI ind lnamesparrec in - let list_id = list_id lnamesparrec in + let list_id = list_id lnamesparrec in let create_input c = let x = id_of_string "x" and y = id_of_string "y" in let bl_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( - mkArrow + mkArrow ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) )) - ) list_id in + ) list_id in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> mkNamedProd sbl b a - ) c (List.rev list_id) (List.rev bl_typ) in + ) c (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a - ) bl_input (List.rev list_id) (List.rev eqs_typ) in + ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec - in + in let n = id_of_string "n" and m = id_of_string "m" in create_input ( mkNamedProd n (mkFullInd ind nparrec) ( mkNamedProd m (mkFullInd ind (nparrec+1)) ( - mkArrow + mkArrow (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) (mkApp(eq,[|mkFullInd ind (nparrec+3);mkVar n;mkVar m|])) ))) - -let compute_bl_tact ind lnamesparrec nparrec = + +let compute_bl_tact ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let avoid = ref [] in let gsig = top_goal_of_pftreestate (Pfedit.get_pftreestate()) in - let first_intros = + let first_intros = ( List.map (fun (s,_,_,_) -> s ) list_id ) @ ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @ - ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) - in + ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) + in let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in @@ -526,7 +526,7 @@ let compute_bl_tact ind lnamesparrec nparrec = None; intro_using freshz; intros; - tclTRY ( + tclTRY ( tclORELSE reflexivity (Equality.discr_tac false None) ); simpl_in_hyp (freshz,InHyp); @@ -537,9 +537,9 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). tclTHENSEQ [ simple_apply_in freshz (andb_prop()); fun gl -> - let fresht = fresh_id (!avoid) (id_of_string "Z") gsig + let fresht = fresh_id (!avoid) (id_of_string "Z") gsig in - avoid := fresht::(!avoid); + avoid := fresht::(!avoid); (new_destruct false [Tacexpr.ElimOnConstr ((mkVar freshz,Rawterm.NoBindings))] None @@ -548,30 +548,30 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). dl,Genarg.IntroIdentifier freshz]])) None) gl ]); (* - Ci a1 ... an = Ci b1 ... bn + Ci a1 ... an = Ci b1 ... bn replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto *) fun gls-> let gl = (gls.Evd.it).Evd.evar_concl in match (kind_of_term gl) with - | App (c,ca) -> ( + | App (c,ca) -> ( match (kind_of_term c) with - | Ind (i1,i2) -> + | Ind (i1,i2) -> if(string_of_label (label i1) = "eq") then ( tclTHENSEQ ((do_replace_bl ind gls (!avoid) nparrec (ca.(2)) (ca.(1)))@[Auto.default_auto]) gls ) - else + else (error "Failure while solving Boolean->Leibniz.") | _ -> error "Failure while solving Boolean->Leibniz." ) | _ -> error "Failure while solving Boolean->Leibniz." - + ] ) -let compute_lb_goal ind lnamesparrec nparrec = +let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eqI = eqI ind lnamesparrec in let create_input c = @@ -580,43 +580,43 @@ let compute_lb_goal ind lnamesparrec nparrec = let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( - mkArrow + mkArrow ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) )) - ) list_id in + ) list_id in let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> mkNamedProd slb b a - ) c (List.rev list_id) (List.rev lb_typ) in + ) c (List.rev list_id) (List.rev lb_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a - ) lb_input (List.rev list_id) (List.rev eqs_typ) in + ) lb_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec - in + in let n = id_of_string "n" and m = id_of_string "m" in create_input ( mkNamedProd n (mkFullInd ind nparrec) ( mkNamedProd m (mkFullInd ind (nparrec+1)) ( - mkArrow + mkArrow (mkApp(eq,[|mkFullInd ind (nparrec+2);mkVar n;mkVar m|])) (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) ))) -let compute_lb_tact ind lnamesparrec nparrec = +let compute_lb_tact ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let avoid = ref [] in let gsig = top_goal_of_pftreestate (Pfedit.get_pftreestate()) in - let first_intros = + let first_intros = ( List.map (fun (s,_,_,_) -> s ) list_id ) @ ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ - ( List.map (fun (_,_,_,slb) -> slb) list_id ) - in + ( List.map (fun (_,_,_,slb) -> slb) list_id ) + in let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in @@ -630,20 +630,20 @@ let compute_lb_tact ind lnamesparrec nparrec = Pfedit.by ( tclTHENSEQ [ intros_using fresh_first_intros; intro_using freshn ; - new_induct false [Tacexpr.ElimOnConstr - ((mkVar freshn),Rawterm.NoBindings)] + new_induct false [Tacexpr.ElimOnConstr + ((mkVar freshn),Rawterm.NoBindings)] None (None,None) None; intro_using freshm; - new_destruct false [Tacexpr.ElimOnConstr + new_destruct false [Tacexpr.ElimOnConstr ((mkVar freshm),Rawterm.NoBindings)] None (None,None) None; intro_using freshz; intros; - tclTRY ( + tclTRY ( tclORELSE reflexivity (Equality.discr_tac false None) ); Equality.inj [] false (mkVar freshz,Rawterm.NoBindings); @@ -657,21 +657,21 @@ let compute_lb_tact ind lnamesparrec nparrec = (* assume the goal to be eq (eq_type ...) = true *) match (kind_of_term gl) with | App(c,ca) -> (match (kind_of_term ca.(1)) with - | App(c',ca') -> + | App(c',ca') -> let n = Array.length ca' in - tclTHENSEQ (do_replace_lb (!avoid) - nparrec gls + tclTHENSEQ (do_replace_lb (!avoid) + nparrec gls ca'.(n-2) ca'.(n-1)) gls - | _ -> error - "Failure while solving Leibniz->Boolean." + | _ -> error + "Failure while solving Leibniz->Boolean." ) - | _ -> error - "Failure while solving Leibniz->Boolean." + | _ -> error + "Failure while solving Leibniz->Boolean." ] ) (* {n=m}+{n<>m} part *) -let compute_dec_goal ind lnamesparrec nparrec = +let compute_dec_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let create_input c = let x = id_of_string "x" and @@ -679,37 +679,37 @@ let compute_dec_goal ind lnamesparrec nparrec = let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( - mkArrow + mkArrow ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) )) - ) list_id in + ) list_id in let bl_typ = List.map (fun (s,seq,_,_) -> mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( - mkArrow + mkArrow ( mkApp(eq,[|bb;mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt|])) ( mkApp(eq,[|mkVar s;mkVar x;mkVar y|])) )) - ) list_id in + ) list_id in let lb_input = List.fold_left2 ( fun a (s,_,_,slb) b -> mkNamedProd slb b a - ) c (List.rev list_id) (List.rev lb_typ) in + ) c (List.rev list_id) (List.rev lb_typ) in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> mkNamedProd sbl b a - ) lb_input (List.rev list_id) (List.rev bl_typ) in + ) lb_input (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,bb)) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a - ) bl_input (List.rev list_id) (List.rev eqs_typ) in + ) bl_input (List.rev list_id) (List.rev eqs_typ) in List.fold_left (fun a (n,_,t) -> mkNamedProd (match n with Name s -> s | Anonymous -> id_of_string "A") t a) eq_input lnamesparrec - in + in let n = id_of_string "n" and m = id_of_string "m" in let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in @@ -721,26 +721,26 @@ let compute_dec_goal ind lnamesparrec nparrec = ) ) -let compute_dec_tact ind lnamesparrec nparrec = +let compute_dec_tact ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eqI = eqI ind lnamesparrec in let avoid = ref [] in let gsig = top_goal_of_pftreestate (Pfedit.get_pftreestate()) in let eqtrue x = mkApp(eq,[|bb;x;tt|]) in let eqfalse x = mkApp(eq,[|bb;x;ff|]) in - let first_intros = + let first_intros = ( List.map (fun (s,_,_,_) -> s ) list_id ) @ ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @ - ( List.map (fun (_,_,_,slb) -> slb) list_id ) - in + ( List.map (fun (_,_,_,slb) -> slb) list_id ) + in let fresh_first_intros = List.map ( fun s -> let fresh = fresh_id (!avoid) s gsig in avoid := fresh::(!avoid); fresh ) first_intros in let freshn = fresh_id (!avoid) (id_of_string "n") gsig in let freshm = avoid := freshn::(!avoid); fresh_id (!avoid) (id_of_string "m") gsig in - let freshH = avoid := freshm::(!avoid); + let freshH = avoid := freshm::(!avoid); fresh_id (!avoid) (id_of_string "H") gsig in let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in avoid := freshH::(!avoid); @@ -749,9 +749,9 @@ let compute_dec_tact ind lnamesparrec nparrec = intros_using [freshn;freshm]; assert_tac (Name freshH) ( mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) - ) ]); + ) ]); (*we do this so we don't have to prove the same goal twice *) - Pfedit.by ( tclTHEN + Pfedit.by ( tclTHEN (new_destruct false [Tacexpr.ElimOnConstr (eqbnm,Rawterm.NoBindings)] None @@ -762,8 +762,8 @@ let compute_dec_tact ind lnamesparrec nparrec = Pfedit.by ( let freshH2 = fresh_id (!avoid) (id_of_string "H") gsig in avoid := freshH2::(!avoid); - new_destruct false [Tacexpr.ElimOnConstr - ((mkVar freshH),Rawterm.NoBindings)] + new_destruct false [Tacexpr.ElimOnConstr + ((mkVar freshH),Rawterm.NoBindings)] None (None,Some (dl,Genarg.IntroOrAndPattern [ [dl,Genarg.IntroAnonymous]; @@ -782,7 +782,7 @@ let compute_dec_tact ind lnamesparrec nparrec = " equality is required.") in - (* left *) + (* left *) Pfedit.by ( tclTHENSEQ [ simplest_left; apply (mkApp(blI,Array.map(fun x->mkVar x) xargs)); Auto.default_auto @@ -794,20 +794,20 @@ let compute_dec_tact ind lnamesparrec nparrec = unfold_constr (Lazy.force Coqlib.coq_not_ref); intro; Equality.subst_all; - assert_tac (Name freshH3) + assert_tac (Name freshH3) (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|])) ]); - Pfedit.by + Pfedit.by (tclTHENSEQ [apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs)); Auto.default_auto ]); Pfedit.by (Equality.general_rewrite_bindings_in true all_occurrences - (List.hd !avoid) + (List.hd !avoid) ((mkVar (List.hd (List.tl !avoid))), Rawterm.NoBindings ) true); Pfedit.by (Equality.discr_tac false None) - + diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli index b8fa1710e0..291ce7bb14 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -14,14 +14,14 @@ open Sign val subst_in_constr : (object_name*substitution*(inductive*constr)) - -> (inductive*constr) + -> (inductive*constr) val compute_bl_goal : inductive -> rel_context -> int -> types -val compute_bl_tact : inductive -> rel_context -> int -> unit -val compute_lb_goal : inductive -> rel_context -> int -> types -val compute_lb_tact : inductive -> rel_context -> int -> unit +val compute_bl_tact : inductive -> rel_context -> int -> unit +val compute_lb_goal : inductive -> rel_context -> int -> types +val compute_lb_tact : inductive -> rel_context -> int -> unit val compute_dec_goal : inductive -> rel_context -> int -> types -val compute_dec_tact : inductive -> rel_context -> int -> unit +val compute_dec_tact : inductive -> rel_context -> int -> unit val make_eq_scheme :mutual_inductive -> types array diff --git a/toplevel/autoinstance.ml b/toplevel/autoinstance.ml index 4946ee9330..cc174ebace 100644 --- a/toplevel/autoinstance.ml +++ b/toplevel/autoinstance.ml @@ -18,7 +18,7 @@ open Sign open Libnames (*i*) -(*s +(*s * Automatic detection of (some) record instances *) @@ -30,25 +30,25 @@ type signature = global_reference * evar list * evar_map type instance_decl_function = global_reference -> rel_context -> constr list -> unit -(* +(* * Search algorithm - *) + *) -let rec subst_evar evar def n c = +let rec subst_evar evar def n c = match kind_of_term c with | Evar (e,_) when e=evar -> lift n def | _ -> map_constr_with_binders (fun n->n+1) (subst_evar evar def) n c -let subst_evar_in_evm evar def evm = +let subst_evar_in_evm evar def evm = Evd.fold - (fun ev evi acc -> - let evar_body = match evi.evar_body with + (fun ev evi acc -> + let evar_body = match evi.evar_body with | Evd.Evar_empty -> Evd.Evar_empty | Evd.Evar_defined c -> Evd.Evar_defined (subst_evar evar def 0 c) in let evar_concl = subst_evar evar def 0 evi.evar_concl in Evd.add acc ev {evi with evar_body=evar_body; evar_concl=evar_concl} ) evm empty - + (* Tries to define ev by c in evd. Fails if ev := c1 and c1 /= c ev : * T1, c : T2 and T1 /= T2. Defines recursively all evars instantiated * by this definition. *) @@ -59,7 +59,7 @@ let rec safe_define evm ev c = let evi = (Evd.find evm ev) in let define_subst evm sigma = Util.Intmap.fold - ( fun ev (e,c) evm -> + ( fun ev (e,c) evm -> match kind_of_term c with Evar (i,_) when i=ev -> evm | _ -> safe_define evm ev (lift (-List.length e) c) ) sigma evm in @@ -72,7 +72,7 @@ let rec safe_define evm ev c = let evm = subst_evar_in_evm ev c evm in define_subst (Evd.define ev c evm) (Termops.filtering [] Reduction.CUMUL t u) -let add_gen_ctx (cl,gen,evm) ctx : signature * constr list = +let add_gen_ctx (cl,gen,evm) ctx : signature * constr list = let rec really_new_evar () = let ev = Evarutil.new_untyped_evar() in if Evd.is_evar evm ev then really_new_evar() else ev in @@ -104,7 +104,7 @@ let complete_evar (cl,gen,evm:signature) (ev,evi) (k:signature -> unit) = (* msgnl(str"cherche "++pr_constr ev_typ++str" pour "++Util.pr_int ev);*) let substs = ref SubstSet.empty in try List.iter - ( fun (gr,(pat,_),s) -> + ( fun (gr,(pat,_),s) -> let (_,genl,_) = Termops.decompose_prod_letin pat in let genl = List.map (fun (_,_,t) -> t) genl in let ((cl,gen,evm),argl) = add_gen_ctx (cl,gen,evm) genl in @@ -146,7 +146,7 @@ let complete_with_evars_permut (cl,gen,evm:signature) evl c (k:signature -> unit ( fun (ctx,ev) -> let tyl = List.map (fun (_,_,t) -> t) ctx in let ((cl,gen,evm),argl) = add_gen_ctx (cl,gen,evm) tyl in - let def = applistc c argl in + let def = applistc c argl in (* msgnl(str"trouvé def ?"++Util.pr_int ev++str" := "++pr_constr def++str " dans "++pr_evar_defs evm);*) try if not (Evd.is_defined evm ev) then @@ -155,8 +155,8 @@ let complete_with_evars_permut (cl,gen,evm:signature) evl c (k:signature -> unit with Termops.CannotFilter -> () ) evl in aux evm - -let new_inst_no = + +let new_inst_no = let cnt = ref 0 in fun () -> incr cnt; string_of_int !cnt @@ -172,7 +172,7 @@ let new_instance_message ident typ def = open Entries -let rec deep_refresh_universes c = +let rec deep_refresh_universes c = match kind_of_term c with | Sort (Type _) -> Termops.new_Type() | _ -> map_constr deep_refresh_universes c @@ -182,23 +182,23 @@ let declare_record_instance gr ctx params = let def = it_mkLambda_or_LetIn (applistc (constr_of_global gr) params) ctx in let def = deep_refresh_universes def in let ce = { const_entry_body=def; const_entry_type=None; - const_entry_opaque=false; const_entry_boxed=false } in - let cst = Declare.declare_constant ident + const_entry_opaque=false; const_entry_boxed=false } in + let cst = Declare.declare_constant ident (DefinitionEntry ce,Decl_kinds.IsDefinition Decl_kinds.StructureComponent) in new_instance_message ident (Typeops.type_of_constant (Global.env()) cst) def -let declare_class_instance gr ctx params = +let declare_class_instance gr ctx params = let ident = make_instance_ident gr in let cl = Typeclasses.class_info gr in let (def,typ) = Typeclasses.instance_constructor cl params in let (def,typ) = it_mkLambda_or_LetIn def ctx, it_mkProd_or_LetIn typ ctx in let def = deep_refresh_universes def in let typ = deep_refresh_universes typ in - let ce = Entries.DefinitionEntry + let ce = Entries.DefinitionEntry { const_entry_type=Some typ; const_entry_body=def; - const_entry_opaque=false; const_entry_boxed=false } in + const_entry_opaque=false; const_entry_boxed=false } in try - let cst = Declare.declare_constant ident + let cst = Declare.declare_constant ident (ce,Decl_kinds.IsDefinition Decl_kinds.Instance) in Typeclasses.add_instance (Typeclasses.new_instance cl (Some 100) true cst); new_instance_message ident typ def @@ -217,16 +217,16 @@ let complete_signature_with_def gr deftyp (k:instance_decl_function -> signature ('a * 'b * Term.constr) list * Evd.evar) Gmapl.t ref) = ref Gmapl.empty in iter_under_prod - ( fun ctx typ -> + ( fun ctx typ -> List.iter - (fun ((cl,ev,evm),_,_) -> + (fun ((cl,ev,evm),_,_) -> (* msgnl(pr_global gr++str" : "++pr_constr typ++str" matche ?"++Util.pr_int ev++str " dans "++pr_evar_defs evm);*) smap := Gmapl.add (cl,evm) (ctx,ev) !smap) (Recordops.methods_matching typ) ) [] deftyp; - Gmapl.iter - ( fun (cl,evm) evl -> - let f = if Typeclasses.is_class cl then + Gmapl.iter + ( fun (cl,evm) evl -> + let f = if Typeclasses.is_class cl then declare_class_instance else declare_record_instance in complete_with_evars_permut (cl,[],evm) evl gr_c (fun sign -> complete_signature (k f) sign) @@ -239,15 +239,15 @@ let complete_signature_with_def gr deftyp (k:instance_decl_function -> signature let evar_definition evi = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c - -let gen_sort_topo l evm = + +let gen_sort_topo l evm = let iter_evar f ev = let rec aux c = match kind_of_term c with Evar (e,_) -> f e | _ -> iter_constr aux c in aux (Evd.evar_concl (Evd.find evm ev)); if Evd.is_defined evm ev then aux (evar_definition (Evd.find evm ev)) in - let r = ref [] in + let r = ref [] in let rec dfs ev = iter_evar dfs ev; if not(List.mem ev !r) then r := ev::!r in List.iter dfs l; List.rev !r @@ -258,15 +258,15 @@ let declare_instance (k:global_reference -> rel_context -> constr list -> unit) let evm = Evarutil.nf_evars evm in let gen = gen_sort_topo gen evm in let (evm,gen) = List.fold_right - (fun ev (evm,gen) -> - if Evd.is_defined evm ev - then Evd.remove evm ev,gen + (fun ev (evm,gen) -> + if Evd.is_defined evm ev + then Evd.remove evm ev,gen else evm,(ev::gen)) gen (evm,[]) in (* msgnl(str"instance complète : ["++Util.prlist_with_sep (fun _ -> str";") Util.pr_int gen++str"] : "++spc()++pr_evar_defs evm);*) let ngen = List.length gen in let (_,ctx,evm) = List.fold_left - ( fun (i,ctx,evm) ev -> + ( fun (i,ctx,evm) ev -> let ctx = (Anonymous,None,lift (-i) (Evd.evar_concl(Evd.find evm ev)))::ctx in let evm = subst_evar_in_evm ev (mkRel i) (Evd.remove evm ev) in (i-1,ctx,evm) @@ -277,7 +277,7 @@ let declare_instance (k:global_reference -> rel_context -> constr list -> unit) let autoinstance_opt = ref true let search_declaration gr = - if !autoinstance_opt && + if !autoinstance_opt && not (Lib.is_modtype()) then let deftyp = Global.type_of_global gr in complete_signature_with_def gr deftyp declare_instance @@ -301,7 +301,7 @@ let begin_autoinstance () = if not !autoinstance_opt then ( autoinstance_opt := true; ) - + let end_autoinstance () = if !autoinstance_opt then ( autoinstance_opt := false; diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index f9a3364301..dfedc178fb 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -17,9 +17,9 @@ open Indrec open Lexer let print_loc loc = - if loc = dummy_loc then + if loc = dummy_loc then (str"") - else + else let loc = unloc loc in (int (fst loc) ++ str"-" ++ int (snd loc)) @@ -31,43 +31,43 @@ let where s = (* assumption : explain_sys_exn does NOT end with a 'FNL anymore! *) let rec explain_exn_default_aux anomaly_string report_fn = function - | Stream.Failure -> + | Stream.Failure -> hov 0 (anomaly_string () ++ str "uncaught Stream.Failure.") - | Stream.Error txt -> + | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | Token.Error txt -> + | Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") - | Sys_error msg -> + | Sys_error msg -> hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report_fn ()) - | UserError(s,pps) -> + | UserError(s,pps) -> hov 0 (str "Error: " ++ where s ++ pps) - | Out_of_memory -> + | Out_of_memory -> hov 0 (str "Out of memory.") - | Stack_overflow -> + | Stack_overflow -> hov 0 (str "Stack overflow.") | Timeout -> hov 0 (str "Timeout!") - | Anomaly (s,pps) -> + | Anomaly (s,pps) -> hov 0 (anomaly_string () ++ where s ++ pps ++ report_fn ()) | Match_failure(filename,pos1,pos2) -> - hov 0 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ + hov 0 (anomaly_string () ++ str "Match failure in file " ++ str (guill filename) ++ if Sys.ocaml_version = "3.06" then - (str " from character " ++ int pos1 ++ + (str " from character " ++ int pos1 ++ str " to " ++ int pos2) else (str " at line " ++ int pos1 ++ str " character " ++ int pos2) ++ report_fn ()) - | Not_found -> + | Not_found -> hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report_fn ()) - | Failure s -> + | Failure s -> hov 0 (anomaly_string () ++ str "uncaught exception Failure " ++ str (guill s) ++ report_fn ()) - | Invalid_argument s -> + | Invalid_argument s -> hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report_fn ()) - | Sys.Break -> + | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") | Univ.UniverseInconsistency (o,u,v) -> - let msg = + let msg = if !Constrextern.print_universes then spc() ++ str "(cannot enforce" ++ spc() ++ Univ.pr_uni u ++ spc() ++ str (match o with Univ.Lt -> "<" | Univ.Le -> "<=" | Univ.Eq -> "=") @@ -75,60 +75,60 @@ let rec explain_exn_default_aux anomaly_string report_fn = function else mt() in hov 0 (str "Error: Universe inconsistency" ++ msg ++ str ".") - | TypeError(ctx,te) -> + | TypeError(ctx,te) -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_type_error ctx te) | PretypeError(ctx,te) -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_pretype_error ctx te) | Typeclasses_errors.TypeClassError(env, te) -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_typeclass_error env te) - | InductiveError e -> + | InductiveError e -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_inductive_error e) - | RecursionSchemeError e -> + | RecursionSchemeError e -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_recursion_scheme_error e) | Proof_type.LtacLocated (_,(Refiner.FailError (i,s) as exc)) when Lazy.force s <> mt () -> explain_exn_default_aux anomaly_string report_fn exc | Proof_type.LtacLocated (s,exc) -> hov 0 (Himsg.explain_ltac_call_trace s ++ fnl () ++ explain_exn_default_aux anomaly_string report_fn exc) - | Cases.PatternMatchingError (env,e) -> + | Cases.PatternMatchingError (env,e) -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_pattern_matching_error env e) - | Tacred.ReductionTacticError e -> + | Tacred.ReductionTacticError e -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_reduction_tactic_error e) - | Logic.RefinerError e -> + | Logic.RefinerError e -> hov 0 (str "Error:" ++ spc () ++ Himsg.explain_refiner_error e) | Nametab.GlobalizationError q -> hov 0 (str "Error:" ++ spc () ++ str "The reference" ++ spc () ++ Libnames.pr_qualid q ++ - spc () ++ str "was not found" ++ + spc () ++ str "was not found" ++ spc () ++ str "in the current" ++ spc () ++ str "environment.") | Nametab.GlobalizationConstantError q -> hov 0 (str "Error:" ++ spc () ++ - str "No constant of this name:" ++ spc () ++ + str "No constant of this name:" ++ spc () ++ Libnames.pr_qualid q ++ str ".") | Refiner.FailError (i,s) -> - hov 0 (str "Error: Tactic failure" ++ + hov 0 (str "Error: Tactic failure" ++ (if Lazy.force s <> mt() then str ":" ++ Lazy.force s else mt ()) ++ if i=0 then str "." else str " (level " ++ int i ++ str").") | Stdpp.Exc_located (loc,exc) -> hov 0 ((if loc = dummy_loc then (mt ()) else (str"At location " ++ print_loc loc ++ str":" ++ fnl ())) ++ explain_exn_default_aux anomaly_string report_fn exc) - | Lexer.Error Illegal_character -> + | Lexer.Error Illegal_character -> hov 0 (str "Syntax error: Illegal character.") - | Lexer.Error Unterminated_comment -> + | Lexer.Error Unterminated_comment -> hov 0 (str "Syntax error: Unterminated comment.") - | Lexer.Error Unterminated_string -> + | Lexer.Error Unterminated_string -> hov 0 (str "Syntax error: Unterminated string.") - | Lexer.Error Undefined_token -> + | Lexer.Error Undefined_token -> hov 0 (str "Syntax error: Undefined token.") - | Lexer.Error (Bad_token s) -> + | Lexer.Error (Bad_token s) -> hov 0 (str "Syntax error: Bad token" ++ spc () ++ str s ++ str ".") | Assert_failure (s,b,e) -> hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ - (if s <> "" then + (if s <> "" then if Sys.ocaml_version = "3.06" then - (str ("(file \"" ^ s ^ "\", characters ") ++ + (str ("(file \"" ^ s ^ "\", characters ") ++ int b ++ str "-" ++ int e ++ str ")") else (str ("(file \"" ^ s ^ "\", line ") ++ int b ++ @@ -138,7 +138,7 @@ let rec explain_exn_default_aux anomaly_string report_fn = function (mt ())) ++ report_fn ()) | reraise -> - hov 0 (anomaly_string () ++ str "Uncaught exception " ++ + hov 0 (anomaly_string () ++ str "Uncaught exception " ++ str (Printexc.to_string reraise) ++ report_fn ()) let anomaly_string () = str "Anomaly: " diff --git a/toplevel/class.ml b/toplevel/class.ml index 11c5bf398d..3a35887431 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -50,7 +50,7 @@ let explain_coercion_error g = function | NotAFunction -> (Printer.pr_global g ++ str" is not a function") | NoSource (Some cl) -> - (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " + (str "Cannot recognize " ++ pr_class cl ++ str " as a source class of " ++ Printer.pr_global g) | NoSource None -> (str ": cannot find the source class of " ++ Printer.pr_global g) @@ -91,24 +91,24 @@ let check_target clt = function (* condition d'heritage uniforme *) -let uniform_cond nargs lt = +let uniform_cond nargs lt = let rec aux = function | (0,[]) -> true | (n,t::l) -> (strip_outer_cast t = mkRel n) & (aux ((n-1),l)) | _ -> false - in + in aux (nargs,lt) let class_of_global = function | ConstRef sp -> CL_CONST sp | IndRef sp -> CL_IND sp | VarRef id -> CL_SECVAR id - | ConstructRef _ as c -> + | ConstructRef _ as c -> errorlabstrm "class_of_global" - (str "Constructors, such as " ++ Printer.pr_global c ++ + (str "Constructors, such as " ++ Printer.pr_global c ++ str ", cannot be used as a class.") -(* +(* lp est la liste (inverse'e) des arguments de la coercion ids est le nom de la classe source sps_opt est le sp de la classe source dans le cas des structures @@ -127,13 +127,13 @@ let get_source lp source = match lp with | [] -> raise Not_found | t1::_ -> find_class_type (Global.env()) Evd.empty t1 - in + in (cl1,lv1,1) | Some cl -> let rec aux = function | [] -> raise Not_found | t1::lt -> - try + try let cl1,lv1 = find_class_type (Global.env()) Evd.empty t1 in if cl = cl1 then cl1,lv1,(List.length lt+1) else raise Not_found @@ -141,20 +141,20 @@ let get_source lp source = in aux (List.rev lp) let get_target t ind = - if (ind > 1) then + if (ind > 1) then CL_FUN - else + else fst (find_class_type (Global.env()) Evd.empty t) -let prods_of t = +let prods_of t = let rec aux acc d = match kind_of_term d with | Prod (_,c1,c2) -> aux (c1::acc) c2 | Cast (c,_,_) -> aux acc c | _ -> (d,acc) - in + in aux [] t -let strength_of_cl = function +let strength_of_cl = function | CL_CONST kn -> Global | CL_SECVAR id -> Local | _ -> Global @@ -200,7 +200,7 @@ let build_id_coercion idf_opt source = lams in (* juste pour verification *) - let _ = + let _ = if not (Reductionops.is_conv_leq env Evd.empty (Typing.type_of env Evd.empty val_f) typ_f) @@ -229,7 +229,7 @@ let check_source = function | Some (CL_FUN|CL_SORT as s) -> raise (CoercionError (ForbiddenSourceClass s)) | _ -> () -(* +(* nom de la fonction coercion strength de f nom de la classe source (optionnel) @@ -248,7 +248,7 @@ let add_new_coercion_core coef stre source target isid = let llp = List.length lp in if llp = 0 then raise (CoercionError NotAFunction); let (cls,lvs,ind) = - try + try get_source lp source with Not_found -> raise (CoercionError (NoSource source)) @@ -258,7 +258,7 @@ let add_new_coercion_core coef stre source target isid = raise (CoercionError NotUniform); let clt = try - get_target tg ind + get_target tg ind with Not_found -> raise (CoercionError NoTarget) in @@ -291,7 +291,7 @@ let try_add_new_identity_coercion id stre ~source ~target = let try_add_new_coercion_with_source ref stre ~source = try_add_new_coercion_core ref stre (Some source) None false -let add_coercion_hook stre ref = +let add_coercion_hook stre ref = try_add_new_coercion ref stre; Flags.if_verbose message (string_of_qualid (shortest_qualid_of_global Idset.empty ref) diff --git a/toplevel/class.mli b/toplevel/class.mli index 3bbc2f043b..3398e3fab5 100644 --- a/toplevel/class.mli +++ b/toplevel/class.mli @@ -22,7 +22,7 @@ open Nametab (* [try_add_new_coercion_with_target ref s src tg] declares [ref] as a coercion from [src] to [tg] *) -val try_add_new_coercion_with_target : global_reference -> locality -> +val try_add_new_coercion_with_target : global_reference -> locality -> source:cl_typ -> target:cl_typ -> unit (* [try_add_new_coercion ref s] declares [ref], assumed to be of type diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 2eeb8a7de6..50bcf589b1 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -35,13 +35,13 @@ open Entries let typeclasses_db = "typeclass_instances" let _ = - Typeclasses.register_add_instance_hint + Typeclasses.register_add_instance_hint (fun inst pri -> - Flags.silently (fun () -> - Auto.add_hints false [typeclasses_db] + Flags.silently (fun () -> + Auto.add_hints false [typeclasses_db] (Auto.HintsResolveEntry [pri, false, mkConst inst])) ()) - + let declare_instance_cst glob con = let instance = Typeops.type_of_constant (Global.env ()) con in let _, r = decompose_prod_assum instance in @@ -50,13 +50,13 @@ let declare_instance_cst glob con = | None -> errorlabstrm "" (Pp.strbrk "Constant does not build instances of a declared type class.") let declare_instance glob idl = - let con = + let con = try (match global (Ident idl) with | ConstRef x -> x | _ -> raise Not_found) with _ -> error "Instance definition not found." in declare_instance_cst glob con - + let mismatched_params env n m = mismatched_ctx_inst env Parameters n m let mismatched_props env n m = mismatched_ctx_inst env Properties n m @@ -68,18 +68,18 @@ let interp_type_evars evdref env ?(impls=([],[])) typ = let typ' = intern_gen true ~impls !evdref env typ in let imps = Implicit_quantifiers.implicits_of_rawterm typ' in imps, Pretyping.Default.understand_tcc_evars evdref env Pretyping.IsType typ' - + (* Declare everything in the parameters as implicit, and the class instance as well *) open Topconstr - + let type_ctx_instance evars env ctx inst subst = - let (s, _) = + let (s, _) = List.fold_left2 (fun (subst, instctx) (na, b, t) ce -> let t' = substl subst t in - let c' = - match b with + let c' = + match b with | None -> interp_casted_constr_evars evars env ce t' | Some b -> substl subst b in @@ -93,25 +93,25 @@ let refine_ref = ref (fun _ -> assert(false)) let id_of_class cl = match cl.cl_impl with | ConstRef kn -> let _,_,l = repr_con kn in id_of_label l - | IndRef (kn,i) -> + | IndRef (kn,i) -> let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in mip.(0).Declarations.mind_typename | _ -> assert false - + open Pp let ($$) g f = fun x -> g (f x) - -let instance_hook k pri global imps ?hook cst = + +let instance_hook k pri global imps ?hook cst = let inst = Typeclasses.new_instance k pri global cst in Impargs.maybe_declare_manual_implicits false (ConstRef cst) ~enriching:false imps; Typeclasses.add_instance inst; (match hook with Some h -> h cst | None -> ()) let declare_instance_constant k pri global imps ?hook id term termtype = - let cdecl = + let cdecl = let kind = IsDefinition Instance in - let entry = + let entry = { const_entry_body = term; const_entry_type = Some termtype; const_entry_opaque = false; @@ -127,13 +127,13 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) ?(tac:Proof_type.tactic option) ?(hook:(Names.constant -> unit) option) pri = let env = Global.env() in let evars = ref Evd.empty in - let tclass = + let tclass = match bk with | Implicit -> Implicit_quantifiers.implicit_application Idset.empty ~allow_partial:false - (fun avoid (clname, (id, _, t)) -> - match clname with - | Some (cl, b) -> + (fun avoid (clname, (id, _, t)) -> + match clname with + | Some (cl, b) -> let t = CHole (Util.dummy_loc, None) in t, avoid | None -> failwith ("new instance: under-applied typeclass")) @@ -141,21 +141,21 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) | Explicit -> cl in let tclass = if generalize then CGeneralization (dummy_loc, Implicit, Some AbsPi, tclass) else tclass in - let k, ctx', imps, subst = + let k, ctx', imps, subst = let c = Command.generalize_constr_expr tclass ctx in let imps, c' = interp_type_evars evars env c in let ctx, c = decompose_prod_assum c' in let cl, args = Typeclasses.dest_class_app (push_rel_context ctx env) c in cl, ctx, imps, List.rev args in - let id = + let id = match snd instid with - Name id -> + Name id -> let sp = Lib.make_path id in if Nametab.exists_cci sp then errorlabstrm "new_instance" (Nameops.pr_id id ++ Pp.str " already exists."); id - | Anonymous -> + | Anonymous -> let i = Nameops.add_suffix (id_of_class k) "_instance_0" in Termops.next_global_ident_away false i (Termops.ids_of_context env) in @@ -167,7 +167,7 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) if Lib.is_modtype () then begin let _, ty_constr = instance_constructor k (List.rev subst) in - let termtype = + let termtype = let t = it_mkProd_or_LetIn ty_constr ctx' in Evarutil.nf_isevar !evars t in @@ -178,49 +178,49 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) end else begin - let props = + let props = match props with - | CRecord (loc, _, fs) -> - if List.length fs > List.length k.cl_props then + | CRecord (loc, _, fs) -> + if List.length fs > List.length k.cl_props then mismatched_props env' (List.map snd fs) k.cl_props; fs - | _ -> - if List.length k.cl_props <> 1 then + | _ -> + if List.length k.cl_props <> 1 then errorlabstrm "new_instance" (Pp.str "Expected a definition for the instance body") else [(dummy_loc, Nameops.out_name (pi1 (List.hd k.cl_props))), props] in - let subst = - match k.cl_props with - | [(na,b,ty)] -> - let term = match props with [] -> CHole (Util.dummy_loc, None) + let subst = + match k.cl_props with + | [(na,b,ty)] -> + let term = match props with [] -> CHole (Util.dummy_loc, None) | [(_,f)] -> f | _ -> assert false in let ty' = substl subst ty in let c = interp_casted_constr_evars evars env' term ty' in c :: subst | _ -> - let props, rest = + let props, rest = List.fold_left - (fun (props, rest) (id,b,_) -> - try + (fun (props, rest) (id,b,_) -> + try let ((loc, mid), c) = List.find (fun ((_,id'), c) -> Name id' = id) rest in let rest' = List.filter (fun ((_,id'), c) -> Name id' <> id) rest in Option.iter (fun x -> Dumpglob.add_glob loc (ConstRef x)) (List.assoc mid k.cl_projs); c :: props, rest' - with Not_found -> + with Not_found -> (CHole (Util.dummy_loc, None) :: props), rest) ([], props) k.cl_props in - if rest <> [] then + if rest <> [] then unbound_method env' k.cl_impl (fst (List.hd rest)) else type_ctx_instance evars env' k.cl_props props subst in - let subst = List.fold_left2 + let subst = List.fold_left2 (fun subst' s (_, b, _) -> if b = None then s :: subst' else subst') [] subst (k.cl_props @ snd k.cl_context) in let app, ty_constr = instance_constructor k subst in - let termtype = + let termtype = let t = it_mkProd_or_LetIn ty_constr ctx' in Evarutil.nf_isevar !evars t in @@ -235,10 +235,10 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) evars := Typeclasses.resolve_typeclasses ~onlyargs:true ~fail:true env !evars; let kind = Decl_kinds.Global, Decl_kinds.DefinitionBody Decl_kinds.Instance in Flags.silently (fun () -> - Command.start_proof id kind termtype + Command.start_proof id kind termtype (fun _ -> function ConstRef cst -> instance_hook k pri global imps ?hook cst | _ -> assert false); - if props <> [] then + if props <> [] then Pfedit.by (* (Refiner.tclTHEN (Refiner.tclEVARS !evars) *) (!refine_ref (evm, term)); (match tac with Some tac -> Pfedit.by tac | None -> ())) (); @@ -248,8 +248,8 @@ let new_instance ?(global=false) ctx (instid, bk, cl) props ?(generalize=true) end let named_of_rel_context l = - let acc, ctx = - List.fold_right + let acc, ctx = + List.fold_right (fun (na, b, t) (subst, ctx) -> let id = match na with Anonymous -> raise (Invalid_argument "named_of_rel_context") | Name id -> id in let d = (id, Option.map (substl subst) b, substl subst t) in @@ -272,11 +272,11 @@ let context ?(hook=fun _ -> ()) l = let fullctx = Evarutil.nf_rel_context_evar !evars fullctx in let ce t = Evarutil.check_evars env Evd.empty !evars t in List.iter (fun (n, b, t) -> Option.iter ce b; ce t) fullctx; - let ctx = try named_of_rel_context fullctx with _ -> + let ctx = try named_of_rel_context fullctx with _ -> error "Anonymous variables not allowed in contexts." in - List.iter (function (id,_,t) -> - if Lib.is_modtype () then + List.iter (function (id,_,t) -> + if Lib.is_modtype () then let cst = Declare.declare_internal_constant id (ParameterEntry (t,false), IsAssumption Logical) in @@ -286,8 +286,8 @@ let context ?(hook=fun _ -> ()) l = hook (ConstRef cst) | None -> () else ( - let impl = List.exists (fun (x,_) -> - match x with ExplByPos (_, Some id') -> id = id' | _ -> false) impls + let impl = List.exists (fun (x,_) -> + match x with ExplByPos (_, Some id') -> id = id' | _ -> false) impls in Command.declare_one_assumption false (Local (* global *), Definitional) t [] impl (* implicit *) false (* inline *) (dummy_loc, id); diff --git a/toplevel/classes.mli b/toplevel/classes.mli index c79eccab84..7a8e9a9235 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -43,8 +43,8 @@ val declare_instance_constant : Term.constr -> (* body *) Term.types -> (* type *) Names.identifier - -val new_instance : + +val new_instance : ?global:bool -> (* Not global by default. *) local_binder list -> typeclass_constraint -> @@ -59,9 +59,9 @@ val new_instance : val id_of_class : typeclass -> identifier -(* Context command *) +(* Context command *) -val context : ?hook:(Libnames.global_reference -> unit) -> +val context : ?hook:(Libnames.global_reference -> unit) -> local_binder list -> unit (* Forward ref for refine *) diff --git a/toplevel/command.ml b/toplevel/command.ml index 1da86712d1..735e1ff27b 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -94,7 +94,7 @@ let definition_message id = let constant_entry_of_com (bl,com,comtypopt,opacity,boxed) = let env = Global.env() in match comtypopt with - None -> + None -> let b = abstract_constr_expr com bl in let b, imps = interp_constr_evars_impls env b in imps, @@ -121,7 +121,7 @@ let red_constant_entry bl ce = function | None -> ce | Some red -> let body = ce.const_entry_body in - { ce with const_entry_body = + { ce with const_entry_body = under_binders (Global.env()) (fst (reduction_of_red_expr red)) (local_binders_length bl) body } @@ -150,9 +150,9 @@ let declare_definition ident (local,boxed,dok) bl red_option c typopt hook = SectionLocalDef(ce'.const_entry_body,ce'.const_entry_type,false) in let _ = declare_variable ident (Lib.cwd(),c,IsDefinition Definition) in definition_message ident; - if Pfedit.refining () then - Flags.if_verbose msg_warning - (str"Local definition " ++ pr_id ident ++ + if Pfedit.refining () then + Flags.if_verbose msg_warning + (str"Local definition " ++ pr_id ident ++ str" is not visible from current goals"); VarRef ident | (Global|Local) -> @@ -172,12 +172,12 @@ let assumption_message id = let declare_one_assumption is_coe (local,kind) c imps impl nl (_,ident) = let r = match local with | Local when Lib.sections_are_opened () -> - let _ = - declare_variable ident + let _ = + declare_variable ident (Lib.cwd(), SectionLocalAssum (c,impl), IsAssumption kind) in assumption_message ident; - if is_verbose () & Pfedit.refining () then - msgerrnl (str"Warning: Variable " ++ pr_id ident ++ + if is_verbose () & Pfedit.refining () then + msgerrnl (str"Warning: Variable " ++ pr_id ident ++ str" is not visible from current goals"); VarRef ident | (Global|Local) -> @@ -197,7 +197,7 @@ let declare_assumption_hook = ref ignore let set_declare_assumption_hook = (:=) declare_assumption_hook let declare_assumption idl is_coe k bl c impl nl = - if not (Pfedit.refining ()) then + if not (Pfedit.refining ()) then let c = generalize_constr_expr c bl in let env = Global.env () in let c', imps = interp_type_evars_impls env c in @@ -213,12 +213,12 @@ open Indrec open Inductiveops -let non_type_eliminations = +let non_type_eliminations = [ (InProp,elimination_suffix InProp); (InSet,elimination_suffix InSet) ] let declare_one_elimination ind = - let (mib,mip) = Global.lookup_inductive ind in + let (mib,mip) = Global.lookup_inductive ind in let mindstr = string_of_id mip.mind_typename in let declare s c t = let id = id_of_string s in @@ -227,7 +227,7 @@ let declare_one_elimination ind = { const_entry_body = c; const_entry_type = t; const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() }, + const_entry_boxed = Flags.boxed_definitions() }, Decl_kinds.IsDefinition Definition) in definition_message id; kn @@ -235,13 +235,13 @@ let declare_one_elimination ind = let env = Global.env () in let sigma = Evd.empty in let elim_scheme = Indrec.build_indrec env sigma ind in - let npars = + let npars = (* if a constructor of [ind] contains a recursive call, the scheme is generalized only wrt recursively uniform parameters *) - if (Inductiveops.mis_is_recursive_subset [snd ind] mip.mind_recargs) - then + if (Inductiveops.mis_is_recursive_subset [snd ind] mip.mind_recargs) + then mib.mind_nparams_rec - else + else mib.mind_nparams in let make_elim s = Indrec.instantiate_indrec_scheme s npars elim_scheme in let kelim = elim_sorts (mib,mip) in @@ -253,22 +253,22 @@ let declare_one_elimination ind = let cte = declare (mindstr^(Indrec.elimination_suffix InType)) elim None in let c = mkConst cte in let t = type_of_constant (Global.env()) cte in - List.iter (fun (sort,suff) -> - let (t',c') = + List.iter (fun (sort,suff) -> + let (t',c') = Indrec.instantiate_type_indrec_scheme (new_sort_in_family sort) npars c t in let _ = declare (mindstr^suff) c' (Some t') in ()) non_type_eliminations else (* Impredicative or logical inductive definition *) List.iter - (fun (sort,suff) -> + (fun (sort,suff) -> if List.mem sort kelim then let elim = make_elim (new_sort_in_family sort) in let _ = declare (mindstr^suff) elim None in ()) non_type_eliminations (* bool eq declaration flag && eq dec declaration flag *) -let eq_flag = ref false +let eq_flag = ref false let _ = declare_bool_option { optsync = true; @@ -278,14 +278,14 @@ let _ = optwrite = (fun b -> eq_flag := b) } (* boolean equality *) -let (inScheme,_) = - declare_object {(default_object "EQSCHEME") with - cache_function = Ind_tables.cache_scheme; - load_function = (fun _ -> Ind_tables.cache_scheme); - subst_function = Auto_ind_decl.subst_in_constr; - export_function = Ind_tables.export_scheme } - -let declare_eq_scheme sp = +let (inScheme,_) = + declare_object {(default_object "EQSCHEME") with + cache_function = Ind_tables.cache_scheme; + load_function = (fun _ -> Ind_tables.cache_scheme); + subst_function = Auto_ind_decl.subst_in_constr; + export_function = Ind_tables.export_scheme } + +let declare_eq_scheme sp = let mib = Global.lookup_mind sp in let nb_ind = Array.length mib.mind_packets in let eq_array = Auto_ind_decl.make_eq_scheme sp in @@ -297,7 +297,7 @@ let declare_eq_scheme sp = let cst_entry = {const_entry_body = eq_array.(i); const_entry_type = None; const_entry_opaque = false; - const_entry_boxed = Flags.boxed_definitions() } + const_entry_boxed = Flags.boxed_definitions() } in let cst_decl = (DefinitionEntry cst_entry),(IsDefinition Definition) in @@ -305,7 +305,7 @@ let declare_eq_scheme sp = Lib.add_anonymous_leaf (inScheme ((sp,i),mkConst cst)); definition_message nam done - with Not_found -> + with Not_found -> error "Your type contains Parameters without a boolean equality." (* decidability of eq *) @@ -349,7 +349,7 @@ let adjust_guardness_conditions const = List.map (fun c -> interval 0 (List.length ((lam_assum c)))) (Array.to_list fixdefs) in - let indexes = search_guard dummy_loc (Global.env()) possible_indexes fixdecls in + let indexes = search_guard dummy_loc (Global.env()) possible_indexes fixdecls in { const with const_entry_body = mkFix ((indexes,0),fixdecls) } | c -> const @@ -380,12 +380,12 @@ let save_named opacity = let const = { const with const_entry_opaque = opacity } in save id const do_guard persistence hook -let make_eq_decidability ind = +let make_eq_decidability ind = (* fetching data *) let mib = Global.lookup_mind (fst ind) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in - let lnonparrec,lnamesparrec = + let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let proof_name = (string_of_id( Array.get mib.mind_packets (snd ind)).mind_typename)^"_eq_dec" in @@ -399,24 +399,24 @@ let make_eq_decidability ind = else ( start_proof (id_of_string bl_name) (Global,Proof Theorem) - (Auto_ind_decl.compute_bl_goal ind lnamesparrec nparrec) + (Auto_ind_decl.compute_bl_goal ind lnamesparrec nparrec) (fun _ _ -> ()); Auto_ind_decl.compute_bl_tact ind lnamesparrec nparrec; - save_named true; - Lib.add_anonymous_leaf + save_named true; + Lib.add_anonymous_leaf (inBoolLeib (ind,mkConst (Lib.make_con (id_of_string bl_name)))) (* definition_message (id_of_string bl_name) *) ); - if Ind_tables.check_lb_proof ind + if Ind_tables.check_lb_proof ind then (message (lb_name^" is already declared.")) else ( start_proof (id_of_string lb_name) - (Global,Proof Theorem) + (Global,Proof Theorem) (Auto_ind_decl.compute_lb_goal ind lnamesparrec nparrec) ( fun _ _ -> ()); Auto_ind_decl.compute_lb_tact ind lnamesparrec nparrec; save_named true; - Lib.add_anonymous_leaf + Lib.add_anonymous_leaf (inLeibBool (ind,mkConst (Lib.make_con (id_of_string lb_name)))) (* definition_message (id_of_string lb_name) *) ); @@ -424,12 +424,12 @@ let make_eq_decidability ind = then (message (proof_name^" is already declared.")) else ( start_proof (id_of_string proof_name) - (Global,Proof Theorem) + (Global,Proof Theorem) (Auto_ind_decl.compute_dec_goal ind lnamesparrec nparrec) ( fun _ _ -> ()); Auto_ind_decl.compute_dec_tact ind lnamesparrec nparrec; save_named true; - Lib.add_anonymous_leaf + Lib.add_anonymous_leaf (inDec (ind,mkConst (Lib.make_con (id_of_string proof_name)))) (* definition_message (id_of_string proof_name) *) ) @@ -444,7 +444,7 @@ let declare_eliminations sp = declare_one_elimination (sp,i); try if (!eq_flag) then (make_eq_decidability (sp,i)) - with _ -> + with _ -> Pfedit.delete_current_proof(); message "Error while computing decidability scheme. Please report." done; @@ -455,9 +455,9 @@ let declare_eliminations sp = let compute_interning_datas env ty l nal typl impll = let mk_interning_data na typ impls = let idl, impl = - let impl = + let impl = compute_implicits_with_manual env typ (is_implicit_args ()) impls - in + in let sub_impl,_ = list_chop (List.length l) impl in let sub_impl' = List.filter is_status_implicit sub_impl in (List.map name_of_implicit sub_impl', impl) @@ -465,15 +465,15 @@ let compute_interning_datas env ty l nal typl impll = (na, (ty, idl, impl, compute_arguments_scope typ)) in (l, list_map3 mk_interning_data nal typl impll) - - (* temporary open scopes during interpretation of mutual families - so that locally defined notations are available + + (* temporary open scopes during interpretation of mutual families + so that locally defined notations are available *) let open_temp_scopes = function | None -> () | Some sc -> if not (Notation.scope_is_open sc) then Notation.open_close_scope (false,true,sc) - + let declare_interning_data (_,impls) (df,c,scope) = silently (Metasyntax.add_notation_interpretation df impls c) scope @@ -512,7 +512,7 @@ let mk_mltype_data evdref env assums arity indname = (is_ml_type,indname,assums) let prepare_param = function - | (na,None,t) -> out_name na, LocalAssum t + | (na,None,t) -> out_name na, LocalAssum t | (na,Some b,_) -> out_name na, LocalDef b let interp_ind_arity evdref env ind = @@ -526,12 +526,12 @@ let interp_cstrs evdref env impls mldata arity ind = let ctyps'', cimpls = List.split (List.map (interp_type_evars_impls ~evdref env ~impls) ctyps') in (cnames, ctyps'', cimpls) -let interp_mutual paramsl indl notations finite = +let interp_mutual paramsl indl notations finite = check_all_names_different indl; let env0 = Global.env() in let evdref = ref Evd.empty in - let (env_params, ctx_params), userimpls = - interp_context_evars ~fail_anonymous:false evdref env0 paramsl + let (env_params, ctx_params), userimpls = + interp_context_evars ~fail_anonymous:false evdref env0 paramsl in let indnames = List.map (fun ind -> ind.ind_name) indl in @@ -552,7 +552,7 @@ let interp_mutual paramsl indl notations finite = let mldatas = List.map2 (mk_mltype_data evdref env_params params) arities indnames in let constructors = - States.with_state_protection (fun () -> + States.with_state_protection (fun () -> (* Temporary declaration of notations and scopes *) List.iter (fun ((_,_,sc) as x ) -> declare_interning_data impls x; @@ -574,7 +574,7 @@ let interp_mutual paramsl indl notations finite = List.iter (fun (_,ctyps,_) -> List.iter (check_evars env_ar_params Evd.empty evd) ctyps) constructors; - + (* Build the inductive entries *) let entries = list_map3 (fun ind arity (cnames,ctypes,cimpls) -> { mind_entry_typename = ind.ind_name; @@ -582,17 +582,17 @@ let interp_mutual paramsl indl notations finite = mind_entry_consnames = cnames; mind_entry_lc = ctypes }) indl arities constructors in - let impls = + let impls = let len = List.length ctx_params in List.map2 (fun indimpls (_,_,cimpls) -> - indimpls, List.map (fun impls -> + indimpls, List.map (fun impls -> userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors in (* Build the mutual inductive entry *) { mind_entry_params = List.map prepare_param ctx_params; - mind_entry_record = false; - mind_entry_finite = finite; - mind_entry_inds = entries }, + mind_entry_record = false; + mind_entry_finite = finite; + mind_entry_inds = entries }, impls let eq_constr_expr c1 c2 = @@ -622,13 +622,13 @@ let extract_params indl = match paramsl with | [] -> anomaly "empty list of inductive types" | params::paramsl -> - if not (List.for_all (eq_local_binders params) paramsl) then error + if not (List.for_all (eq_local_binders params) paramsl) then error "Parameters should be syntactically the same for each inductive type."; params let prepare_inductive ntnl indl = let indl = - List.map (fun ((_,indname),_,ar,lc) -> { + List.map (fun ((_,indname),_,ar,lc) -> { ind_name = indname; ind_arity = Option.cata (fun x -> x) (CSort (dummy_loc, Rawterm.RType None)) ar; ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc @@ -638,7 +638,7 @@ let prepare_inductive ntnl indl = let elim_flag = ref true let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "automatic declaration of eliminations"; optkey = ["Elimination";"Schemes"]; @@ -647,13 +647,13 @@ let _ = let declare_mutual_with_eliminations isrecord mie impls = let names = List.map (fun e -> e.mind_entry_typename) mie.mind_entry_inds in - let (_,kn) = declare_mind isrecord mie in - list_iter_i (fun i (indimpls, constrimpls) -> + let (_,kn) = declare_mind isrecord mie in + list_iter_i (fun i (indimpls, constrimpls) -> let ind = (kn,i) in Autoinstance.search_declaration (IndRef ind); maybe_declare_manual_implicits false (IndRef ind) indimpls; list_iter_i - (fun j impls -> + (fun j impls -> (* Autoinstance.search_declaration (ConstructRef (ind,j));*) maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls) constrimpls) @@ -677,7 +677,7 @@ let build_mutual l finite = (* 3c| Fixpoints and co-fixpoints *) -let pr_rank = function +let pr_rank = function | 0 -> str "1st" | 1 -> str "2nd" | 2 -> str "3rd" @@ -686,12 +686,12 @@ let pr_rank = function let recursive_message indexes = function | [] -> anomaly "no recursive definition" | [id] -> pr_id id ++ str " is recursively defined" ++ - (match indexes with + (match indexes with | Some [|i|] -> str " (decreasing on "++pr_rank i++str " argument)" | _ -> mt ()) | l -> hov 0 (prlist_with_sep pr_coma pr_id l ++ spc () ++ str "are recursively defined" ++ - match indexes with + match indexes with | Some a -> spc () ++ str "(decreasing respectively on " ++ prlist_with_sep pr_coma pr_rank (Array.to_list a) ++ str " arguments)" @@ -703,7 +703,7 @@ let corecursive_message _ = function | l -> hov 0 (prlist_with_sep pr_coma pr_id l ++ spc () ++ str "are corecursively defined") -let recursive_message isfix = +let recursive_message isfix = if isfix=Fixpoint then recursive_message else corecursive_message (* An (unoptimized) function that maps preorders to partial orders... @@ -728,11 +728,11 @@ let rec partial_order = function | (z, Inr zge) when List.mem x zge -> (z, Inr (list_union zge xge')) | r -> r) res in (x,Inr xge')::res - | y::xge -> - let rec link y = + | y::xge -> + let rec link y = try match List.assoc y res with | Inl z -> link z - | Inr yge -> + | Inr yge -> if List.mem x yge then let res = List.remove_assoc y res in let res = List.map (function @@ -748,13 +748,13 @@ let rec partial_order = function browse res (list_add_set y (list_union xge' yge)) xge with Not_found -> browse res (list_add_set y xge') xge in link y - in browse (partial_order rest) [] xge + in browse (partial_order rest) [] xge let non_full_mutual_message x xge y yge kind rest = - let reason = - if List.mem x yge then + let reason = + if List.mem x yge then string_of_id y^" depends on "^string_of_id x^" but not conversely" - else if List.mem y xge then + else if List.mem y xge then string_of_id x^" depends on "^string_of_id y^" but not conversely" else string_of_id y^" and "^string_of_id x^" are not mutually dependent" in @@ -768,7 +768,7 @@ let non_full_mutual_message x xge y yge kind rest = let check_mutuality env kind fixl = let names = List.map fst fixl in let preorder = - List.map (fun (id,def) -> + List.map (fun (id,def) -> (id, List.filter (fun id' -> id<>id' & occur_var env id' def) names)) fixl in let po = partial_order preorder in @@ -813,7 +813,7 @@ let declare_fix boxed kind f def t imps = Autoinstance.search_declaration (ConstRef kn); maybe_declare_manual_implicits false gr imps; gr - + let prepare_recursive_declaration fixnames fixtypes fixdefs = let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in let names = List.map (fun id -> Name id) fixnames in @@ -821,7 +821,7 @@ let prepare_recursive_declaration fixnames fixtypes fixdefs = (* Jump over let-bindings. *) -let rel_index n ctx = +let rel_index n ctx = list_index0 (Name n) (List.rev_map pi1 (List.filter (fun x -> pi2 x = None) ctx)) let rec unfold f b = @@ -830,16 +830,16 @@ let rec unfold f b = | None -> [] let compute_possible_guardness_evidences (n,_) (_, fixctx) fixtype = - match n with + match n with | Some (loc, n) -> [rel_index n fixctx] - | None -> + | None -> (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, - but doing it properly involves delta-reduction, and it finally - doesn't seem to worth the effort (except for huge mutual + but doing it properly involves delta-reduction, and it finally + doesn't seem to worth the effort (except for huge mutual fixpoints ?) *) let len = List.length fixctx in - unfold (function x when x = len -> None + unfold (function x when x = len -> None | n -> Some (n, succ n)) 0 let interp_recursive fixkind l boxed = @@ -862,8 +862,8 @@ let interp_recursive fixkind l boxed = let notations = List.fold_right Option.List.cons ntnl [] in (* Interp bodies with rollback because temp use of notations/implicit *) - let fixdefs = - States.with_state_protection (fun () -> + let fixdefs = + States.with_state_protection (fun () -> List.iter (fun ((_,_,sc) as x) -> declare_interning_data impls x; open_temp_scopes sc @@ -882,12 +882,12 @@ let interp_recursive fixkind l boxed = (* Build the fix declaration block *) let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in - let indexes, fixdecls = + let indexes, fixdecls = match fixkind with | IsFixpoint wfl -> - let possible_indexes = + let possible_indexes = list_map3 compute_possible_guardness_evidences wfl fixctxs fixtypes in - let indexes = search_guard dummy_loc env possible_indexes fixdecls in + let indexes = search_guard dummy_loc env possible_indexes fixdecls in Some indexes, list_map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 l | IsCoFixpoint -> None, list_map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 l @@ -902,30 +902,30 @@ let interp_recursive fixkind l boxed = let build_recursive l b = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in - let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> + let fixl = List.map (fun (((_,id),_,bl,typ,def),ntn) -> ({fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ},ntn)) l in interp_recursive (IsFixpoint g) fixl b let build_corecursive l b = - let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> + let fixl = List.map (fun (((_,id),bl,typ,def),ntn) -> ({fix_name = id; fix_binders = bl; fix_body = def; fix_type = typ},ntn)) l in interp_recursive IsCoFixpoint fixl b (* 3d| Schemes *) -let rec split_scheme l = +let rec split_scheme l = let env = Global.env() in match l with | [] -> [],[] - | (Some id,t)::q -> let l1,l2 = split_scheme q in + | (Some id,t)::q -> let l1,l2 = split_scheme q in ( match t with | InductionScheme (x,y,z) -> ((id,x,y,z)::l1),l2 | EqualityScheme x -> l1,(x::l2) ) (* if no name has been provided, we build one from the types of the ind -requested +requested *) | (None,t)::q -> let l1,l2 = split_scheme q in @@ -963,7 +963,7 @@ in ) -let build_induction_scheme lnamedepindsort = +let build_induction_scheme lnamedepindsort = let lrecnames = List.map (fun ((_,f),_,_,_) -> f) lnamedepindsort and sigma = Evd.empty and env0 = Global.env() in @@ -972,10 +972,10 @@ let build_induction_scheme lnamedepindsort = (fun (_,dep,indid,sort) -> let ind = smart_global_inductive indid in let (mib,mip) = Global.lookup_inductive ind in - (ind,mib,mip,dep,interp_elimination_sort sort)) + (ind,mib,mip,dep,interp_elimination_sort sort)) lnamedepindsort in - let listdecl = Indrec.build_mutual_indrec env0 sigma lrecspec in + let listdecl = Indrec.build_mutual_indrec env0 sigma lrecspec in let rec declare decl fi lrecref = let decltype = Retyping.get_type_of env0 Evd.empty decl in let decltype = refresh_universes decltype in @@ -985,41 +985,41 @@ let build_induction_scheme lnamedepindsort = const_entry_boxed = Flags.boxed_definitions() } in let kn = declare_constant fi (DefinitionEntry ce, IsDefinition Scheme) in ConstRef kn :: lrecref - in + in let _ = List.fold_right2 declare listdecl lrecnames [] in if_verbose ppnl (recursive_message Fixpoint None lrecnames) -let build_scheme l = +let build_scheme l = let ischeme,escheme = split_scheme l in (* we want 1 kind of scheme at a time so we check if the user tried to declare different schemes at once *) - if (ischeme <> []) && (escheme <> []) + if (ischeme <> []) && (escheme <> []) then error "Do not declare equality and induction scheme at the same time." else ( if ischeme <> [] then build_induction_scheme ischeme; - List.iter ( fun indname -> + List.iter ( fun indname -> let ind = smart_global_inductive indname in declare_eq_scheme (fst ind); try - make_eq_decidability ind - with _ -> + make_eq_decidability ind + with _ -> Pfedit.delete_current_proof(); message "Error while computing decidability scheme. Please report." ) escheme ) - -let list_split_rev_at index l = + +let list_split_rev_at index l = let rec aux i acc = function hd :: tl when i = index -> acc, tl | hd :: tl -> aux (succ i) (hd :: acc) tl | [] -> failwith "list_split_when: Invalid argument" in aux 0 [] l -let fold_left' f = function +let fold_left' f = function [] -> raise (Invalid_argument "fold_right'") | hd :: tl -> List.fold_left f hd tl - + let build_combined_scheme name schemes = let env = Global.env () in (* let nschemes = List.length schemes in *) @@ -1027,17 +1027,17 @@ let build_combined_scheme name schemes = let (ctx, arity) = decompose_prod ty in let (_, last) = List.hd ctx in match kind_of_term last with - | App (ind, args) -> + | App (ind, args) -> let ind = destInd ind in let (_,spec) = Inductive.lookup_mind_specif env ind in ctx, ind, spec.mind_nrealargs | _ -> ctx, destInd last, 0 in - let defs = - List.map (fun x -> + let defs = + List.map (fun x -> let refe = Ident x in let qualid = qualid_of_reference refe in - let cst = try Nametab.locate_constant (snd qualid) + let cst = try Nametab.locate_constant (snd qualid) with Not_found -> error ((string_of_qualid (snd qualid))^" is not declared.") in let ty = Typeops.type_of_constant env cst in @@ -1050,18 +1050,18 @@ let build_combined_scheme name schemes = let prods = nb_prod t - (nargs + 1) in let coqand = Coqlib.build_coq_and () and coqconj = Coqlib.build_coq_conj () in let relargs = rel_vect 0 prods in - let concls = List.rev_map - (fun (_, cst, t) -> + let concls = List.rev_map + (fun (_, cst, t) -> mkApp(mkConst cst, relargs), snd (decompose_prod_n prods t)) defs in - let concl_bod, concl_typ = + let concl_bod, concl_typ = fold_left' - (fun (accb, acct) (cst, x) -> + (fun (accb, acct) (cst, x) -> mkApp (coqconj, [| x; acct; cst; accb |]), mkApp (coqand, [| x; acct |])) concls in - let ctx, _ = - list_split_rev_at prods + let ctx, _ = + list_split_rev_at prods (List.rev_map (fun (x, y) -> x, None, y) ctx) in let typ = it_mkProd_wo_LetIn concl_typ ctx in let body = it_mkLambda_or_LetIn concl_bod ctx in @@ -1076,9 +1076,9 @@ let build_combined_scheme name schemes = (* 4.1| Support for mutually proved theorems *) let retrieve_first_recthm = function - | VarRef id -> + | VarRef id -> (pi2 (Global.lookup_named id),variable_opacity id) - | ConstRef cst -> + | ConstRef cst -> let {const_body=body;const_opaque=opaq} = Global.lookup_constant cst in (Option.map Declarations.force body,opaq) | _ -> assert false @@ -1094,7 +1094,7 @@ let compute_proof_name = function | None -> let rec next avoid id = let id = next_global_ident_away false id avoid in - if Nametab.exists_cci (Lib.make_path id) then next (id::avoid) id + if Nametab.exists_cci (Lib.make_path id) then next (id::avoid) id else id in next (Pfedit.get_all_proof_names ()) default_thm_id @@ -1124,7 +1124,7 @@ let save_remaining_recthms (local,kind) body opaq i (id,(t_i,imps)) = let c = SectionLocalDef (body_i, Some t_i, opaq) in let _ = declare_variable id (Lib.cwd(), c, k) in (Local,VarRef id,imps) - | Global -> + | Global -> let const = { const_entry_body = body_i; const_entry_type = Some t_i; @@ -1138,7 +1138,7 @@ let look_for_mutual_statements thms = (* More than one statement: we look for a common inductive hyp or a *) (* common coinductive conclusion *) let n = List.length thms in - let inds = List.map (fun (id,(t,_) as x) -> + let inds = List.map (fun (id,(t,_) as x) -> let (hyps,ccl) = decompose_prod_assum t in let whnf_hyp_hds = map_rel_context_in_env (fun env c -> fst (whd_betadeltaiota_stack env Evd.empty c)) @@ -1169,7 +1169,7 @@ let look_for_mutual_statements thms = (* (degenerated cartesian product since there is at most one coind ccl) *) let same_indccl = list_cartesians_filter (fun hyp oks -> - if List.for_all (of_same_mutind hyp) oks + if List.for_all (of_same_mutind hyp) oks then Some (hyp::oks) else None) [] ind_ccls in let ordered_same_indccl = List.filter (list_for_all_i (fun i ((kn,j),_,_) -> i=j) 0) same_indccl in @@ -1183,7 +1183,7 @@ let look_for_mutual_statements thms = | indccl::rest, _ -> assert (rest=[]); (* One occ. of common coind ccls and no common inductive hyps *) - if common_same_indhyp <> [] then + if common_same_indhyp <> [] then if_verbose warning "Assuming mutual coinductive statements."; flush_all (); indccl, true @@ -1271,6 +1271,6 @@ let admit () = let get_current_context () = try Pfedit.get_current_goal_context () - with e when Logic.catchable_exception e -> + with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) diff --git a/toplevel/command.mli b/toplevel/command.mli index d648fc10e0..14cfef6b20 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -40,17 +40,17 @@ val declare_definition : identifier -> definition_kind -> local_binder list -> red_expr option -> constr_expr -> constr_expr option -> declaration_hook -> unit -val syntax_definition : identifier -> identifier list * constr_expr -> +val syntax_definition : identifier -> identifier list * constr_expr -> bool -> bool -> unit val declare_one_assumption : coercion_flag -> assumption_kind -> Term.types -> Impargs.manual_explicitation list -> bool (* implicit *) -> bool (* inline *) -> Names.variable located -> unit - + val set_declare_assumption_hook : (types -> unit) -> unit val declare_assumption : identifier located list -> - coercion_flag -> assumption_kind -> local_binder list -> constr_expr -> + coercion_flag -> assumption_kind -> local_binder list -> constr_expr -> bool -> bool -> unit val open_temp_scopes : Topconstr.scope_name option -> unit @@ -58,7 +58,7 @@ val open_temp_scopes : Topconstr.scope_name option -> unit val declare_interning_data : 'a * Constrintern.implicits_env -> string * Topconstr.constr_expr * Topconstr.scope_name option -> unit -val compute_interning_datas : Environ.env -> Constrintern.var_internalisation_type -> +val compute_interning_datas : Environ.env -> Constrintern.var_internalisation_type -> 'a list -> 'b list -> Term.types list ->Impargs.manual_explicitation list list -> 'a list * @@ -69,11 +69,11 @@ val compute_interning_datas : Environ.env -> Constrintern.var_internalisation_ty val check_mutuality : Environ.env -> definition_object_kind -> (identifier * types) list -> unit -val build_mutual : ((lident * local_binder list * constr_expr option * constructor_expr list) * +val build_mutual : ((lident * local_binder list * constr_expr option * constructor_expr list) * decl_notation) list -> bool -> unit val declare_mutual_with_eliminations : - bool -> Entries.mutual_inductive_entry -> + bool -> Entries.mutual_inductive_entry -> (Impargs.manual_explicitation list * Impargs.manual_explicitation list list) list -> mutual_inductive @@ -91,7 +91,7 @@ type fixpoint_expr = { val recursive_message : definition_object_kind -> int array option -> identifier list -> Pp.std_ppcmds - + val declare_fix : bool -> definition_object_kind -> identifier -> constr -> types -> Impargs.manual_explicitation list -> global_reference @@ -113,7 +113,7 @@ val set_start_hook : (types -> unit) -> unit val start_proof : identifier -> goal_kind -> types -> ?init_tac:Proof_type.tactic -> ?compute_guard:bool -> declaration_hook -> unit -val start_proof_com : goal_kind -> +val start_proof_com : goal_kind -> (lident option * (local_binder list * constr_expr)) list -> declaration_hook -> unit diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 729db2d02a..4007a96bb7 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -32,7 +32,7 @@ let load_rcfile() = if !load_rc then try if !rcfile_specified then - if file_readable_p !rcfile then + if file_readable_p !rcfile then Vernac.load_vernac false !rcfile else raise (Sys_error ("Cannot read rcfile: "^ !rcfile)) else if file_readable_p (!rcfile^"."^Coq_config.version) then @@ -48,7 +48,7 @@ let load_rcfile() = with e -> (msgnl (str"Load of rcfile failed."); raise e) - else + else Flags.if_verbose msgnl (str"Skipping rcfile loading.") (* Puts dir in the path of ML and in the LoadPath *) @@ -64,24 +64,24 @@ let push_rec_include (s, alias) = includes := (s,alias,true) :: !includes (* The list of all theories in the standard library /!\ order does matter *) let theories_dirs_map = [ "theories/Unicode", "Unicode" ; - "theories/Classes", "Classes" ; - "theories/Program", "Program" ; - "theories/FSets", "FSets" ; - "theories/Reals", "Reals" ; - "theories/Strings", "Strings" ; - "theories/Sorting", "Sorting" ; - "theories/Setoids", "Setoids" ; - "theories/Sets", "Sets" ; - "theories/Lists", "Lists" ; - "theories/Wellfounded", "Wellfounded" ; - "theories/Relations", "Relations" ; - "theories/Numbers", "Numbers" ; - "theories/QArith", "QArith" ; - "theories/NArith", "NArith" ; - "theories/ZArith", "ZArith" ; - "theories/Arith", "Arith" ; - "theories/Bool", "Bool" ; - "theories/Logic", "Logic" ; + "theories/Classes", "Classes" ; + "theories/Program", "Program" ; + "theories/FSets", "FSets" ; + "theories/Reals", "Reals" ; + "theories/Strings", "Strings" ; + "theories/Sorting", "Sorting" ; + "theories/Setoids", "Setoids" ; + "theories/Sets", "Sets" ; + "theories/Lists", "Lists" ; + "theories/Wellfounded", "Wellfounded" ; + "theories/Relations", "Relations" ; + "theories/Numbers", "Numbers" ; + "theories/QArith", "QArith" ; + "theories/NArith", "NArith" ; + "theories/ZArith", "ZArith" ; + "theories/Arith", "Arith" ; + "theories/Bool", "Bool" ; + "theories/Logic", "Logic" ; "theories/Init", "Init" ] @@ -91,24 +91,24 @@ let init_load_path () = let user_contrib = coqlib/"user-contrib" in let dirs = ["states";"plugins"] in (* first user-contrib *) - if Sys.file_exists user_contrib then + if Sys.file_exists user_contrib then Mltop.add_rec_path user_contrib Nameops.default_root_prefix; (* then states, theories and dev *) List.iter (fun s -> coq_add_rec_path (coqlib/s)) dirs; (* developer specific directory to open *) if Coq_config.local then coq_add_path (coqlib/"dev") "dev"; (* then standard library *) - List.iter - (fun (s,alias) -> Mltop.add_rec_path (coqlib/s) (Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root])) + List.iter + (fun (s,alias) -> Mltop.add_rec_path (coqlib/s) (Names.make_dirpath [Names.id_of_string alias; Nameops.coq_root])) theories_dirs_map; (* then current directory *) Mltop.add_path "." Nameops.default_root_prefix; (* additional loadpath, given with -I -include -R options *) - List.iter + List.iter (fun (s,alias,reci) -> if reci then Mltop.add_rec_path s alias else Mltop.add_path s alias) (List.rev !includes) - + let init_library_roots () = includes := [] @@ -116,11 +116,11 @@ let init_library_roots () = find the "include" file in the *source* directory *) let init_ocaml_path () = let coqsrc = Coq_config.coqsrc in - let add_subdir dl = - Mltop.add_ml_dir (List.fold_left (/) coqsrc dl) + let add_subdir dl = + Mltop.add_ml_dir (List.fold_left (/) coqsrc dl) in - Mltop.add_ml_dir (Envars.coqlib ()); + Mltop.add_ml_dir (Envars.coqlib ()); List.iter add_subdir - [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; + [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ]; [ "tactics" ]; [ "toplevel" ]; [ "translate" ]; [ "ide" ] ] diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index a699e528b0..d66e975fcf 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -21,7 +21,7 @@ open Coqinit let get_version_date () = try - let coqlib = Envars.coqlib () in + let coqlib = Envars.coqlib () in let ch = open_in (Filename.concat coqlib "revision") in let ver = input_line ch in let rev = input_line ch in @@ -37,7 +37,7 @@ let output_context = ref false let memory_stat = ref false -let print_memory_stat () = +let print_memory_stat () = if !memory_stat then Format.printf "total heap size = %d kbytes\n" (heap_size_kb ()) @@ -47,7 +47,7 @@ let engagement = ref None let set_engagement c = engagement := Some c let engage () = match !engagement with Some c -> Global.set_engagement c | None -> () - + let set_batch_mode () = batch_mode := true let toplevel_default_name = make_dirpath [id_of_string "Top"] @@ -76,7 +76,7 @@ let set_include d p = let p = dirpath_of_string p in push_include (d,p) let set_rec_include d p = - let p = dirpath_of_string p in + let p = dirpath_of_string p in push_rec_include(d,p) let load_vernacular_list = ref ([] : (string * bool) list) @@ -84,7 +84,7 @@ let add_load_vernacular verb s = load_vernacular_list := ((make_suffix s ".v"),verb) :: !load_vernacular_list let load_vernacular () = List.iter - (fun (s,b) -> + (fun (s,b) -> if Flags.do_beautify () then with_option beautify_file (Vernac.load_vernac b) s else @@ -93,7 +93,7 @@ let load_vernacular () = let load_vernacular_obj = ref ([] : string list) let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj -let load_vernac_obj () = +let load_vernac_obj () = List.iter (fun f -> Library.require_library_from_file None f None) (List.rev !load_vernacular_obj) @@ -106,7 +106,7 @@ let require () = let compile_list = ref ([] : (bool * string) list) let add_compile verbose s = set_batch_mode (); - Flags.make_silent true; + Flags.make_silent true; compile_list := (verbose,s) :: !compile_list let compile_files () = let init_state = States.freeze() in @@ -142,11 +142,11 @@ let re_exec is_ide = if (is_native && s = "byte") || ((not is_native) && s = "opt") then begin let s = if s = "" then if is_native then "opt" else "byte" else s in - let newprog = + let newprog = let dir = Filename.dirname prog in let coqtop = if is_ide then "coqide." else "coqtop." in let com = coqtop ^ s ^ Coq_config.exec_extension in - if dir <> "." then Filename.concat dir com else com + if dir <> "." then Filename.concat dir com else com in Sys.argv.(0) <- newprog; Unix.handle_unix_error (Unix.execvp newprog) Sys.argv @@ -189,12 +189,12 @@ let parse_args is_ide = let glob_opt = ref false in let rec parse = function | [] -> () - | "-with-geoproof" :: s :: rem -> + | "-with-geoproof" :: s :: rem -> if s = "yes" then Coq_config.with_geoproof := true else if s = "no" then Coq_config.with_geoproof := false else usage (); parse rem - | "-impredicative-set" :: rem -> + | "-impredicative-set" :: rem -> set_engagement Declarations.ImpredicativeSet; parse rem | ("-I"|"-include") :: d :: "-as" :: p :: rem -> set_include d p; parse rem @@ -221,13 +221,13 @@ let parse_args is_ide = | "-full" :: rem -> warning "option -full deprecated\n"; parse rem | "-batch" :: rem -> set_batch_mode (); parse rem - | "-boot" :: rem -> boot := true; no_load_rc (); parse rem + | "-boot" :: rem -> boot := true; no_load_rc (); parse rem | "-quality" :: rem -> term_quality := true; no_load_rc (); parse rem | "-outputstate" :: s :: rem -> set_outputstate s; parse rem | "-outputstate" :: [] -> usage () | "-nois" :: rem -> set_inputstate ""; parse rem - + | ("-inputstate"|"-is") :: s :: rem -> set_inputstate s; parse rem | ("-inputstate"|"-is") :: [] -> usage () @@ -237,11 +237,11 @@ let parse_args is_ide = | "-load-ml-source" :: f :: rem -> Mltop.dir_ml_use f; parse rem | "-load-ml-source" :: [] -> usage () - | ("-load-vernac-source"|"-l") :: f :: rem -> + | ("-load-vernac-source"|"-l") :: f :: rem -> add_load_vernacular false f; parse rem | ("-load-vernac-source"|"-l") :: [] -> usage () - | ("-load-vernac-source-verbose"|"-lv") :: f :: rem -> + | ("-load-vernac-source-verbose"|"-lv") :: f :: rem -> add_load_vernacular true f; parse rem | ("-load-vernac-source-verbose"|"-lv") :: [] -> usage () @@ -278,9 +278,9 @@ let parse_args is_ide = | "-vm" :: rem -> use_vm := true; parse rem | "-emacs" :: rem -> Flags.print_emacs := true; Pp.make_pp_emacs(); parse rem - | "-emacs-U" :: rem -> Flags.print_emacs := true; + | "-emacs-U" :: rem -> Flags.print_emacs := true; Flags.print_emacs_safechar := true; Pp.make_pp_emacs(); parse rem - + | "-unicode" :: rem -> Flags.unicode_syntax := true; parse rem | "-coqlib" :: d :: rem -> Flags.coqlib_spec:=true; Flags.coqlib:=d; parse rem @@ -302,7 +302,7 @@ let parse_args is_ide = | "-user" :: u :: rem -> set_rcuser u; parse rem | "-user" :: [] -> usage () - | "-notactics" :: rem -> + | "-notactics" :: rem -> warning "Obsolete option \"-notactics\"."; remove_top_ml (); parse rem @@ -320,7 +320,7 @@ let parse_args is_ide = | "-no-hash-consing" :: rem -> Flags.hash_cons_proofs := false; parse rem - | s :: rem -> + | s :: rem -> if is_ide then begin ide_args := s :: !ide_args; parse rem @@ -330,7 +330,7 @@ let parse_args is_ide = in try parse (List.tl (Array.to_list Sys.argv)) - with + with | UserError(_,s) as e -> begin try Stream.empty s; exit 1 @@ -368,10 +368,10 @@ let init is_ide = exit 1 end; if !batch_mode then - (flush_all(); + (flush_all(); if !output_context then Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ()); - Profile.print_profile (); + Profile.print_profile (); exit 0); Lib.declare_initial_state () diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 6f3edf57f4..87f4bdeb55 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -9,14 +9,14 @@ (*i $Id$ i*) (* The Coq main module. The following function [start] will parse the - command line, print the banner, initialize the load path, load the input + command line, print the banner, initialize the load path, load the input state, load the files given on the command line, load the ressource file, produce the output state if any, and finally will launch [Toplevel.loop]. *) val start : unit -> unit -(* [init_ide] is to be used by the Coq IDE. - It does everything [start] does, except launching the toplevel loop. +(* [init_ide] is to be used by the Coq IDE. + It does everything [start] does, except launching the toplevel loop. It returns the list of Coq files given on the command line. *) val init_ide : unit -> string list diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index dfed4a3be1..4c21e49154 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -36,26 +36,26 @@ let detype_param = function *) let abstract_inductive hyps nparams inds = - let ntyp = List.length inds in + let ntyp = List.length inds in let nhyp = named_context_length hyps in let args = instance_from_named_context (List.rev hyps) in let subs = list_tabulate (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) ntyp in let inds' = List.map - (function (tname,arity,cnames,lc) -> + (function (tname,arity,cnames,lc) -> let lc' = List.map (substl subs) lc in let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in (tname,arity',cnames,lc'')) inds in let nparams' = nparams + Array.length args in -(* To be sure to be the same as before, should probably be moved to process_inductive *) - let params' = let (_,arity,_,_) = List.hd inds' in +(* To be sure to be the same as before, should probably be moved to process_inductive *) + let params' = let (_,arity,_,_) = List.hd inds' in let (params,_) = decompose_prod_n_assum nparams' arity in List.map detype_param params in - let ind'' = - List.map + let ind'' = + List.map (fun (a,arity,c,lc) -> let _, short_arity = decompose_prod_n_assum nparams' arity in let shortlc = @@ -70,7 +70,7 @@ let abstract_inductive hyps nparams inds = let process_inductive sechyps modlist mib = let nparams = mib.mind_nparams in - let inds = + let inds = array_map_to_list (fun mip -> let arity = expmod_constr modlist (Termops.refresh_universes_strict (Inductive.type_of_inductive (Global.env()) (mib,mip))) in diff --git a/toplevel/discharge.mli b/toplevel/discharge.mli index c8af4d1dab..c6496cd4b0 100644 --- a/toplevel/discharge.mli +++ b/toplevel/discharge.mli @@ -13,5 +13,5 @@ open Cooking open Declarations open Entries -val process_inductive : +val process_inductive : named_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index b005aedf61..99e228dd46 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -369,17 +369,17 @@ let explain_typeclass_resolution env evi k = match k with | GoalEvar | InternalHole | ImplicitArg _ -> (match Typeclasses.class_of_constr evi.evar_concl with - | Some c -> + | Some c -> let env = Evd.evar_env evi in - fnl () ++ str "Could not find an instance for " ++ - pr_lconstr_env env evi.evar_concl ++ + fnl () ++ str "Could not find an instance for " ++ + pr_lconstr_env env evi.evar_concl ++ pr_ne_context_of (str " in environment:"++ fnl ()) (str ".") env | None -> mt()) | _ -> mt() - + let explain_unsolvable_implicit env evi k explain = - str "Cannot infer " ++ explain_hole_kind env (Some evi) k ++ - explain_unsolvability explain ++ str "." ++ + str "Cannot infer " ++ explain_hole_kind env (Some evi) k ++ + explain_unsolvability explain ++ str "." ++ explain_typeclass_resolution env evi k let explain_var_not_found env id = @@ -418,7 +418,7 @@ let explain_refiner_cannot_generalize env ty = let explain_no_occurrence_found env c id = str "Found no subterm matching " ++ pr_lconstr_env env c ++ - str " in " ++ + str " in " ++ (match id with | Some id -> pr_id id | None -> str"the current goal") ++ str "." @@ -431,9 +431,9 @@ let explain_cannot_unify_binding_type env m n = let explain_cannot_find_well_typed_abstraction env p l = str "Abstracting over the " ++ - str (plural (List.length l) "term") ++ spc () ++ + str (plural (List.length l) "term") ++ spc () ++ hov 0 (pr_enum (pr_lconstr_env env) l) ++ spc () ++ - str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++ + str "leads to a term" ++ spc () ++ pr_lconstr_env env p ++ spc () ++ str "which is ill-typed." let explain_type_error env err = @@ -490,24 +490,24 @@ let explain_pretype_error env err = | CannotFindWellTypedAbstraction (p,l) -> explain_cannot_find_well_typed_abstraction env p l - + (* Typeclass errors *) let explain_not_a_class env c = pr_constr_env env c ++ str" is not a declared type class." let explain_unbound_method env cid id = - str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ str"of class" ++ spc () ++ + str "Unbound method name " ++ Nameops.pr_id (snd id) ++ spc () ++ str"of class" ++ spc () ++ pr_global cid ++ str "." -let pr_constr_exprs exprs = - hv 0 (List.fold_right +let pr_constr_exprs exprs = + hv 0 (List.fold_right (fun d pps -> ws 2 ++ Ppconstr.pr_constr_expr d ++ pps) exprs (mt ())) let explain_no_instance env (_,id) l = str "No instance found for class " ++ Nameops.pr_id id ++ spc () ++ - str "applied to arguments" ++ spc () ++ + str "applied to arguments" ++ spc () ++ prlist_with_sep pr_spc (pr_lconstr_env env) l let pr_constraints printenv env evm = @@ -516,14 +516,14 @@ let pr_constraints printenv env evm = if List.for_all (fun (ev', evi') -> eq_named_context_val evi.evar_hyps evi'.evar_hyps) l then - let pe = pr_ne_context_of (str "In environment:") (mt ()) + let pe = pr_ne_context_of (str "In environment:") (mt ()) (reset_with_named_context evi.evar_hyps env) in (if printenv then pe ++ fnl () else mt ()) ++ - prlist_with_sep (fun () -> fnl ()) + prlist_with_sep (fun () -> fnl ()) (fun (ev, evi) -> str(string_of_existential ev)++ str " == " ++ pr_constr evi.evar_concl) l else pr_evar_defs evm - + let explain_unsatisfiable_constraints env evd constr = let evm = Evarutil.nf_evars evd in let undef = Evd.undefined_evars evm in @@ -531,26 +531,26 @@ let explain_unsatisfiable_constraints env evd constr = | None -> str"Unable to satisfy the following constraints:" ++ fnl() ++ pr_constraints true env evm - | Some (ev, k) -> + | Some (ev, k) -> explain_unsolvable_implicit env (Evd.find evm ev) k None ++ fnl () ++ if List.length (Evd.to_list undef) > 1 then - str"With the following constraints:" ++ fnl() ++ + str"With the following constraints:" ++ fnl() ++ pr_constraints false env (Evd.remove undef ev) else mt () - -let explain_mismatched_contexts env c i j = + +let explain_mismatched_contexts env c i j = str"Mismatched contexts while declaring instance: " ++ brk (1,1) ++ - hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env j) ++ fnl () ++ brk (1,1) ++ + hov 1 (str"Expected:" ++ brk (1, 1) ++ pr_rel_context env j) ++ fnl () ++ brk (1,1) ++ hov 1 (str"Found:" ++ brk (1, 1) ++ pr_constr_exprs i) -let explain_typeclass_error env err = +let explain_typeclass_error env err = match err with | NotAClass c -> explain_not_a_class env c | UnboundMethod (cid, id) -> explain_unbound_method env cid id | NoInstance (id, l) -> explain_no_instance env id l | UnsatisfiableConstraints (evd, c) -> explain_unsatisfiable_constraints env evd c | MismatchedContextInstance (c, i, j) -> explain_mismatched_contexts env c i j - + (* Refiner errors *) let explain_refiner_bad_type arg ty conclty = @@ -560,7 +560,7 @@ let explain_refiner_bad_type arg ty conclty = str "instead of" ++ brk(1,1) ++ pr_lconstr conclty ++ str "." let explain_refiner_unresolved_bindings l = - str "Unable to find an instance for the " ++ + str "Unable to find an instance for the " ++ str (plural (List.length l) "variable") ++ spc () ++ prlist_with_sep pr_coma pr_name l ++ str"." @@ -584,9 +584,9 @@ let explain_non_linear_proof c = spc () ++ str "because a metavariable has several occurrences." let explain_meta_in_type c = - str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++ + str "In refiner, a meta appears in the type " ++ brk(1,1) ++ pr_lconstr c ++ str " of another meta" - + let explain_refiner_error = function | BadType (arg,ty,conclty) -> explain_refiner_bad_type arg ty conclty | UnresolvedBindings t -> explain_refiner_unresolved_bindings t @@ -615,9 +615,9 @@ let error_ill_formed_constructor env id c v nparams nargs = let pv = pr_lconstr_env env v in let atomic = (nb_prod c = 0) in str "The type of constructor" ++ brk(1,1) ++ pr_id id ++ brk(1,1) ++ - str "is not valid;" ++ brk(1,1) ++ - strbrk (if atomic then "it must be " else "its conclusion must be ") ++ - pv ++ + str "is not valid;" ++ brk(1,1) ++ + strbrk (if atomic then "it must be " else "its conclusion must be ") ++ + pv ++ (* warning: because of implicit arguments it is difficult to say which parameters must be explicitly given *) (if nparams<>0 then @@ -663,7 +663,7 @@ let error_large_non_prop_inductive_not_in_type () = let error_not_allowed_case_analysis isrec kind i = str (if isrec then "Induction" else "Case analysis") ++ - strbrk " on sort " ++ pr_sort kind ++ + strbrk " on sort " ++ pr_sort kind ++ strbrk " is not allowed for inductive definition " ++ pr_inductive (Global.env()) i ++ str "." @@ -801,7 +801,7 @@ let explain_ltac_call_trace (nrep,last,trace,loc) = | Proof_type.LtacNotationCall s -> quote (str s) | Proof_type.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) | Proof_type.LtacVarCall (id,t) -> - quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ + quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" | Proof_type.LtacAtomCall (te,otac) -> quote (Pptactic.pr_glob_tactic (Global.env()) @@ -821,7 +821,7 @@ let explain_ltac_call_trace (nrep,last,trace,loc) = (if unboundvars <> [] or vars <> [] then strbrk " (with " ++ prlist_with_sep pr_coma - (fun (id,c) -> + (fun (id,c) -> pr_id id ++ str ":=" ++ Printer.pr_lconstr c) (List.rev vars @ unboundvars) ++ str ")" else mt())) ++ @@ -832,7 +832,7 @@ let explain_ltac_call_trace (nrep,last,trace,loc) = let kind_of_last_call = match list_last calls with | (_,Proof_type.LtacConstrInterp _) -> ", last term evaluation failed." | _ -> ", last call failed." in - hov 0 (str "In nested Ltac calls to " ++ + hov 0 (str "In nested Ltac calls to " ++ pr_enum pr_call calls ++ strbrk kind_of_last_call) else mt () diff --git a/toplevel/himsg.mli b/toplevel/himsg.mli index 8cc179e810..848fec79c2 100644 --- a/toplevel/himsg.mli +++ b/toplevel/himsg.mli @@ -29,7 +29,7 @@ val explain_pretype_error : env -> pretype_error -> std_ppcmds val explain_inductive_error : inductive_error -> std_ppcmds -val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds +val explain_typeclass_error : env -> typeclass_error -> Pp.std_ppcmds val explain_recursion_scheme_error : recursion_scheme_error -> std_ppcmds @@ -41,6 +41,6 @@ val explain_pattern_matching_error : val explain_reduction_tactic_error : Tacred.reduction_tactic_error -> std_ppcmds -val explain_ltac_call_trace : +val explain_ltac_call_trace : int * Proof_type.ltac_call_kind * Proof_type.ltac_trace * Util.loc -> std_ppcmds diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 5df33d4593..49c8ce7155 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -11,9 +11,9 @@ open Names open Mod_subst -let eq_scheme_map = ref Indmap.empty +let eq_scheme_map = ref Indmap.empty -let cache_scheme (_,(ind,const)) = +let cache_scheme (_,(ind,const)) = eq_scheme_map := Indmap.add ind const (!eq_scheme_map) let export_scheme obj = @@ -26,10 +26,10 @@ let _ = Summary.declare_summary "eqscheme" Summary.unfreeze_function = (fun fs -> eq_scheme_map := fs); Summary.init_function = (fun () -> eq_scheme_map := Indmap.empty) } -let find_eq_scheme ind = +let find_eq_scheme ind = Indmap.find ind !eq_scheme_map -let check_eq_scheme ind = +let check_eq_scheme ind = Indmap.mem ind !eq_scheme_map let bl_map = ref Indmap.empty @@ -37,13 +37,13 @@ let lb_map = ref Indmap.empty let dec_map = ref Indmap.empty -let cache_bl (_,(ind,const)) = +let cache_bl (_,(ind,const)) = bl_map := Indmap.add ind const (!bl_map) -let cache_lb (_,(ind,const)) = +let cache_lb (_,(ind,const)) = lb_map := Indmap.add ind const (!lb_map) -let cache_dec (_,(ind,const)) = +let cache_dec (_,(ind,const)) = dec_map := Indmap.add ind const (!dec_map) let export_bool_leib obj = @@ -62,7 +62,7 @@ let _ = Summary.declare_summary "bl_proof" Summary.unfreeze_function = (fun fs -> bl_map := fs); Summary.init_function = (fun () -> bl_map := Indmap.empty) } -let find_bl_proof ind = +let find_bl_proof ind = Indmap.find ind !bl_map let check_bl_proof ind = @@ -73,7 +73,7 @@ let _ = Summary.declare_summary "lb_proof" Summary.unfreeze_function = (fun fs -> lb_map := fs); Summary.init_function = (fun () -> lb_map := Indmap.empty) } -let find_lb_proof ind = +let find_lb_proof ind = Indmap.find ind !lb_map let check_lb_proof ind = @@ -84,7 +84,7 @@ let _ = Summary.declare_summary "eq_dec_proof" Summary.unfreeze_function = (fun fs -> dec_map := fs); Summary.init_function = (fun () -> dec_map := Indmap.empty) } -let find_eq_dec_proof ind = +let find_eq_dec_proof ind = Indmap.find ind !dec_map let check_dec_proof ind = diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli index 2edb294f99..a97c2daaa5 100644 --- a/toplevel/ind_tables.mli +++ b/toplevel/ind_tables.mli @@ -19,9 +19,9 @@ val export_scheme : (Indmap.key*constr) -> (Indmap.key*constr) option val find_eq_scheme : Indmap.key -> constr val check_eq_scheme : Indmap.key -> bool -val cache_bl: (object_name*(Indmap.key*constr)) -> unit -val cache_lb: (object_name*(Indmap.key*constr)) -> unit -val cache_dec : (object_name*(Indmap.key*constr)) -> unit +val cache_bl: (object_name*(Indmap.key*constr)) -> unit +val cache_lb: (object_name*(Indmap.key*constr)) -> unit +val cache_dec : (object_name*(Indmap.key*constr)) -> unit val export_bool_leib : (Indmap.key*constr) -> (Indmap.key*constr) option val export_leib_bool : (Indmap.key*constr) -> (Indmap.key*constr) option @@ -31,9 +31,9 @@ val find_bl_proof : Indmap.key -> constr val find_lb_proof : Indmap.key -> constr val find_eq_dec_proof : Indmap.key -> constr -val check_bl_proof: Indmap.key -> bool -val check_lb_proof: Indmap.key -> bool -val check_dec_proof: Indmap.key -> bool +val check_bl_proof: Indmap.key -> bool +val check_lb_proof: Indmap.key -> bool +val check_dec_proof: Indmap.key -> bool diff --git a/toplevel/libtypes.ml b/toplevel/libtypes.ml index c999c0609a..fa636989a7 100644 --- a/toplevel/libtypes.ml +++ b/toplevel/libtypes.ml @@ -10,21 +10,21 @@ open Term open Summary open Libobject -(* +(* * Module construction *) - -let reduce c = Reductionops.head_unfold_under_prod + +let reduce c = Reductionops.head_unfold_under_prod (Auto.Hint_db.transparent_state (Auto.searchtable_map "typeclass_instances")) (Global.env()) Evd.empty c -module TypeDnet = Term_dnet.Make(struct +module TypeDnet = Term_dnet.Make(struct type t = Libnames.global_reference let compare = Pervasives.compare let subst s gr = fst (Libnames.subst_global s gr) let constr_of = Global.type_of_global end) - (struct let reduce = reduce + (struct let reduce = reduce let direction = false end) type result = Libnames.global_reference * (constr*existential_key) * Termops.subst @@ -36,18 +36,18 @@ let defined_types = ref TypeDnet.empty * Bookeeping & States *) -let freeze () = +let freeze () = (!all_types,!defined_types) -let unfreeze (lt,dt) = - all_types := lt; +let unfreeze (lt,dt) = + all_types := lt; defined_types := dt -let init () = - all_types := TypeDnet.empty; +let init () = + all_types := TypeDnet.empty; defined_types := TypeDnet.empty -let _ = +let _ = declare_summary "type-library-state" { freeze_function = freeze; unfreeze_function = unfreeze; @@ -56,7 +56,7 @@ let _ = let load (_,d) = (* Profile.print_logical_stats !all_types; Profile.print_logical_stats d;*) - all_types := TypeDnet.union d !all_types + all_types := TypeDnet.union d !all_types let subst s t = TypeDnet.subst s t (* @@ -66,18 +66,18 @@ let subst a b = Profile.profile2 subst_key TypeDnet.subst a b let load_key = Profile.declare_profile "load" let load a = Profile.profile1 load_key load a *) -let (input,output) = +let (input,output) = declare_object { (default_object "LIBTYPES") with load_function = (fun _ -> load); subst_function = (fun (_,s,t) -> subst s t); export_function = (fun x -> Some x); - classify_function = (fun x -> Substitute x) + classify_function = (fun x -> Substitute x) } let update () = Lib.add_anonymous_leaf (input !defined_types) -(* +(* * Search interface *) @@ -93,12 +93,12 @@ let add typ gr = let add_key = Profile.declare_profile "add" let add a b = Profile.profile1 add_key add a b *) - -(* - * Hooks declaration + +(* + * Hooks declaration *) -let _ = Declare.add_cache_hook +let _ = Declare.add_cache_hook ( fun sp -> let gr = Nametab.global_of_path sp in let ty = Global.type_of_global gr in diff --git a/toplevel/libtypes.mli b/toplevel/libtypes.mli index be5e9312a2..d57ecb9483 100644 --- a/toplevel/libtypes.mli +++ b/toplevel/libtypes.mli @@ -12,8 +12,8 @@ open Term (*i*) -(* - * Persistent library of all declared object, +(* + * Persistent library of all declared object, * indexed by their types (uses Dnets) *) @@ -24,7 +24,7 @@ type result = Libnames.global_reference * (constr*existential_key) * Termops.sub (* this is the reduction function used in the indexing process *) val reduce : types -> types -(* The different types of search available. +(* The different types of search available. * See term_dnet.mli for more explanations *) val search_pattern : types -> result list val search_concl : types -> result list diff --git a/toplevel/line_oriented_parser.ml b/toplevel/line_oriented_parser.ml index 9f5d72c5a3..a9dcff3e70 100644 --- a/toplevel/line_oriented_parser.ml +++ b/toplevel/line_oriented_parser.ml @@ -12,7 +12,7 @@ let line_oriented_channel_to_option stop_string input_channel = let count = ref 0 in let buff = ref "" in let current_length = ref 0 in - fun i -> + fun i -> if (i - !count) >= !current_length then begin count := !count + !current_length + 1; buff := input_line input_channel; diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 9912f32812..288f1850ea 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -115,14 +115,14 @@ let print_grammar = function Gram.Entry.print Pcoq.Constr.operconstr; | "pattern" -> Gram.Entry.print Pcoq.Constr.pattern - | "tactic" -> + | "tactic" -> msgnl (str "Entry tactic_expr is"); Gram.Entry.print Pcoq.Tactic.tactic_expr; msgnl (str "Entry binder_tactic is"); Gram.Entry.print Pcoq.Tactic.binder_tactic; msgnl (str "Entry simple_tactic is"); Gram.Entry.print Pcoq.Tactic.simple_tactic; - | "vernac" -> + | "vernac" -> msgnl (str "Entry vernac is"); Gram.Entry.print Pcoq.Vernac_.vernac; msgnl (str "Entry command is"); @@ -174,7 +174,7 @@ let parse_format (loc,str) = (* Parse " // " *) | '/' when i <= String.length str & str.[i+1] = '/' -> (* We forget the useless n spaces... *) - push_token (UnpCut PpFnl) + push_token (UnpCut PpFnl) (parse_token (close_quotation (i+2))) (* Parse " .. / .. " *) | '/' when i <= String.length str -> @@ -244,10 +244,10 @@ let split_notation_string str = let push_token beg i l = if beg = i then l else let s = String.sub str beg (i - beg) in - String s :: l + String s :: l in let push_whitespace beg i l = - if beg = i then l else WhiteSpace (i-beg) :: l + if beg = i then l else WhiteSpace (i-beg) :: l in let rec loop beg i = if i < String.length str then @@ -271,9 +271,9 @@ let split_notation_string str = (* Interpret notations with a recursive component *) let rec find_pattern xl = function - | Break n as x :: l, Break n' :: l' when n=n' -> + | Break n as x :: l, Break n' :: l' when n=n' -> find_pattern (x::xl) (l,l') - | Terminal s as x :: l, Terminal s' :: l' when s = s' -> + | Terminal s as x :: l, Terminal s' :: l' when s = s' -> find_pattern (x::xl) (l,l') | [NonTerminal x], NonTerminal x' :: l' -> (x,x',xl),l' @@ -281,7 +281,7 @@ let rec find_pattern xl = function error ("The token "^s^" occurs on one side of \"..\" but not on the other side.") | [NonTerminal _], Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") - | ((SProdList _ | NonTerminal _) :: _ | []), _ -> + | ((SProdList _ | NonTerminal _) :: _ | []), _ -> error ("The special symbol \"..\" must occur in a configuration of the form\n\"x symbs .. symbs y\".") let rec interp_list_parser hd = function @@ -293,7 +293,7 @@ let rec interp_list_parser hd = function (* remove the second copy of it afterwards *) (y,x)::yl, x::xl, SProdList (x,sl) :: tl'' | (Terminal _ | Break _) as s :: tl -> - if hd = [] then + if hd = [] then let yl,xl,tl' = interp_list_parser [] tl in yl, xl, s :: tl' else @@ -328,7 +328,7 @@ let rec raw_analyze_notation_tokens = function | WhiteSpace n :: sl -> Break n :: raw_analyze_notation_tokens sl -let is_numeral symbs = +let is_numeral symbs = match List.filter (function Break _ -> false | _ -> true) symbs with | ([Terminal "-"; Terminal x] | [Terminal x]) -> (try let _ = Bigint.of_string x in true with _ -> false) @@ -363,10 +363,10 @@ let remove_extravars extrarecvars (vars,recvars) = error "Two end variables of a recursive notation are not in the same scope." else - List.remove_assoc x l) + List.remove_assoc x l) extrarecvars (List.remove_assoc ldots_var vars) in (vars,recvars) - + (**********************************************************************) (* Build pretty-printing rules *) @@ -457,7 +457,7 @@ let make_hunks etyps symbols from = else if is_operator s then if ws = CanBreak then UnpTerminal (" "^s) :: add_break 1 (make NoBreak prods) - else + else UnpTerminal s :: add_break 1 (make NoBreak prods) else if is_ident_tail s.[String.length s - 1] then let sep = if is_prod_ident (List.hd prods) then "" else " " in @@ -502,14 +502,14 @@ let error_format () = error "The format does not match the notation." let rec split_format_at_ldots hd = function | UnpTerminal s :: fmt when s = string_of_id ldots_var -> List.rev hd, fmt - | u :: fmt -> + | u :: fmt -> check_no_ldots_in_box u; split_format_at_ldots (u::hd) fmt | [] -> raise Exit and check_no_ldots_in_box = function | UnpBox (_,fmt) -> - (try + (try let _ = split_format_at_ldots [] fmt in error ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse.") with Exit -> ()) @@ -533,7 +533,7 @@ let read_recursive_format sl fmt = let slfmt, fmt = get_head fmt in slfmt, get_tail (slfmt, fmt) -let hunks_of_format (from,(vars,typs)) symfmt = +let hunks_of_format (from,(vars,typs)) symfmt = let rec aux = function | symbs, (UnpTerminal s' as u) :: fmt when s' = String.make (String.length s') ' ' -> @@ -545,7 +545,7 @@ let hunks_of_format (from,(vars,typs)) symfmt = let i = list_index s vars in let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l - | symbs, UnpBox (a,b) :: fmt -> + | symbs, UnpBox (a,b) :: fmt -> let symbs', b' = aux (symbs,b) in let symbs', l = aux (symbs',fmt) in symbs', UnpBox (a,b') :: l @@ -605,7 +605,7 @@ let make_production etyps symbols = l | SProdList (x,sl) -> let sl = List.flatten - (List.map (function Terminal s -> [terminal s] + (List.map (function Terminal s -> [terminal s] | Break _ -> [] | _ -> anomaly "Found a non terminal token in recursive notation separator") sl) in let y = match List.assoc x etyps with @@ -624,7 +624,7 @@ let rec find_symbols c_current c_next c_last = function (id, prec) :: (find_symbols c_next c_next c_last sl) | Terminal s :: sl -> find_symbols c_next c_next c_last sl | Break n :: sl -> find_symbols c_current c_next c_last sl - | SProdList (x,_) :: sl' -> + | SProdList (x,_) :: sl' -> (x,c_next)::(find_symbols c_next c_next c_last sl') let border = function @@ -654,13 +654,13 @@ let pr_level ntn (from,args) = let error_incompatible_level ntn oldprec prec = errorlabstrm "" - (str ("Notation "^ntn^" is already defined") ++ spc() ++ - pr_level ntn oldprec ++ - spc() ++ str "while it is now required to be" ++ spc() ++ + (str ("Notation "^ntn^" is already defined") ++ spc() ++ + pr_level ntn oldprec ++ + spc() ++ str "while it is now required to be" ++ spc() ++ pr_level ntn prec ++ str ".") let cache_one_syntax_extension (prec,ntn,gr,pp) = - try + try let oldprec = Notation.level_of_notation ntn in if prec <> oldprec then error_incompatible_level ntn oldprec prec with Not_found -> @@ -738,13 +738,13 @@ let check_infix_modifiers modifiers = if t <> [] then error "Explicit entry level or type unexpected in infix notation." -let no_syntax_modifiers modifiers = +let no_syntax_modifiers modifiers = modifiers = [] or modifiers = [SetOnlyParsing] (* Compute precedences from modifiers (or find default ones) *) let set_entry_type etyps (x,typ) = - let typ = try + let typ = try match List.assoc x etyps, typ with | ETConstr (n,()), (_,BorderProd (left,_)) -> ETConstr (n,BorderProd (left,None)) @@ -754,7 +754,7 @@ let set_entry_type etyps (x,typ) = with Not_found -> ETConstr typ in (x,typ) -let check_rule_productivity l = +let check_rule_productivity l = if List.for_all (function NonTerminal _ -> true | _ -> false) l then error "A notation must include at least one symbol."; if (match l with SProdList _ :: _ -> true | _ -> false) then @@ -770,8 +770,8 @@ let find_precedence lev etyps symbols = (try match List.assoc x etyps with | ETConstr _ -> error "The level of the leftmost non-terminal cannot be changed." - | ETName | ETBigint | ETReference -> - if lev = None then + | ETName | ETBigint | ETReference -> + if lev = None then Flags.if_verbose msgnl (str "Setting notation at level 0.") else if lev <> Some 0 then @@ -782,13 +782,13 @@ let find_precedence lev etyps symbols = error "Need an explicit level." else Option.get lev | ETConstrList _ -> assert false (* internally used in grammar only *) - with Not_found -> + with Not_found -> if lev = None then error "A left-recursive notation must have an explicit level." else Option.get lev) | Terminal _ ::l when (match list_last symbols with Terminal _ -> true |_ -> false) - -> + -> if lev = None then (Flags.if_verbose msgnl (str "Setting notation at level 0."); 0) else Option.get lev @@ -798,18 +798,18 @@ let find_precedence lev etyps symbols = let check_curly_brackets_notation_exists () = try let _ = Notation.level_of_notation "{ _ }" in () - with Not_found -> + with Not_found -> error "Notations involving patterns of the form \"{ _ }\" are treated \n\ specially and require that the notation \"{ _ }\" is already reserved." (* Remove patterns of the form "{ _ }", unless it is the "{ _ }" notation *) -let remove_curly_brackets l = +let remove_curly_brackets l = let rec next = function | Break _ :: l -> next l | l -> l in let rec aux deb = function | [] -> [] - | Terminal "{" as t1 :: l -> + | Terminal "{" as t1 :: l -> (match next l with | NonTerminal _ as x :: l' as l0 -> (match next l' with @@ -898,17 +898,17 @@ let contract_notation ntn = if i <= String.length ntn - 5 then let ntn' = if String.sub ntn i 5 = "{ _ }" then - String.sub ntn 0 i ^ "_" ^ + String.sub ntn 0 i ^ "_" ^ String.sub ntn (i+5) (String.length ntn -i-5) else ntn in - aux ntn' (i+1) + aux ntn' (i+1) else ntn in aux ntn 0 exception NoSyntaxRule let recover_syntax ntn = - try + try let prec = Notation.level_of_notation ntn in let pprule,_ = Notation.find_notation_printing_rule ntn in let gr = Egrammar.recover_notation_grammar ntn prec in @@ -926,7 +926,7 @@ let recover_notation_syntax rawntn = (**********************************************************************) (* Main entry point for building parsing and printing rules *) - + let make_pa_rule (n,typs,symbols,_) ntn = let assoc = recompute_assoc typs in let prod = make_production typs symbols in @@ -1035,12 +1035,12 @@ let cache_scope_command o = open_scope_command 1 o let subst_scope_command (_,subst,(scope,o as x)) = match o with - | ScopeClasses cl -> + | ScopeClasses cl -> let cl' = Classops.subst_cl_typ subst cl in if cl'==cl then x else scope, ScopeClasses cl' | _ -> x -let (inScopeCommand,outScopeCommand) = +let (inScopeCommand,outScopeCommand) = declare_object {(default_object "DELIMITERS") with cache_function = cache_scope_command; open_function = open_scope_command; @@ -1052,5 +1052,5 @@ let (inScopeCommand,outScopeCommand) = let add_delimiters scope key = Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key)) -let add_class_scope scope cl = +let add_class_scope scope cl = Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl)) diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index d9f70610b2..53822b4735 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -23,7 +23,7 @@ val add_token_obj : string -> unit (* Adding a tactic notation in the environment *) -val add_tactic_notation : +val add_tactic_notation : int * grammar_tactic_prod_item_expr list * raw_tactic_expr -> unit (* Adding a (constr) notation in the environment*) @@ -46,7 +46,7 @@ val add_notation_interpretation : string -> Constrintern.implicits_env -> (* Add only the parsing/printing rule of a notation *) -val add_syntax_extension : +val add_syntax_extension : locality_flag -> (string * syntax_modifier list) -> unit (* Print the Camlp4 state of a grammar *) diff --git a/toplevel/mltop.ml4 b/toplevel/mltop.ml4 index c390c7c52a..e33363f3ac 100644 --- a/toplevel/mltop.ml4 +++ b/toplevel/mltop.ml4 @@ -25,12 +25,12 @@ open Vernacinterp (* Code to hook Coq into the ML toplevel -- depends on having the objective-caml compiler mostly visible. The functions implemented here are: \begin{itemize} - \item [dir_ml_load name]: Loads the ML module fname from the current ML - path. + \item [dir_ml_load name]: Loads the ML module fname from the current ML + path. \item [dir_ml_use]: Directive #use of Ocaml toplevel \item [add_ml_dir]: Directive #directory of Ocaml toplevel \end{itemize} - + How to build an ML module interface with these functions. The idea is that the ML directory path is like the Coq directory path. So we can maintain the two in parallel. @@ -53,13 +53,13 @@ let keep_copy_mlpath path = coq_mlpath_copy := path :: List.filter filter !coq_mlpath_copy (* If there is a toplevel under Coq *) -type toplevel = { +type toplevel = { load_obj : string -> unit; use_file : string -> unit; add_dir : string -> unit; ml_loop : unit -> unit } -(* Determines the behaviour of Coq with respect to ML files (compiled +(* Determines the behaviour of Coq with respect to ML files (compiled or not) *) type kind_load = | WithTop of toplevel @@ -93,7 +93,7 @@ let ocaml_toploop () = | _ -> () (* Dynamic loading of .cmo/.cma *) -let dir_ml_load s = +let dir_ml_load s = match !load with | WithTop t -> (try t.load_obj s @@ -133,7 +133,7 @@ let add_ml_dir s = | _ -> () (* For Rec Add ML Path *) -let add_rec_ml_dir dir = +let add_rec_ml_dir dir = List.iter (fun (lp,_) -> add_ml_dir lp) (all_subdirs dir) (* Adding files to Coq and ML loadpath *) @@ -149,8 +149,8 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = let convert_string d = try Names.id_of_string d - with _ -> - if_verbose warning + with _ -> + if_verbose warning ("Directory "^d^" cannot be used as a Coq identifier (skipped)"); flush_all (); failwith "caught" @@ -169,14 +169,14 @@ let add_rec_path ~unix_path:dir ~coq_root:coq_dirpath = else msg_warning (str ("Cannot open " ^ dir)) -(* convertit un nom quelconque en nom de fichier ou de module *) +(* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = let base = if Filename.check_suffix name ".cmo" then Filename.chop_suffix name ".cmo" - else + else name - in + in String.capitalize base let get_ml_object_suffix name = @@ -227,7 +227,7 @@ let file_of_name name = let stdlib_use_plugins = Coq_config.has_natdynlink (* [known_loaded_module] contains the names of the loaded ML modules - * (linked or loaded with load_object). It is used not to load a + * (linked or loaded with load_object). It is used not to load a * module twice. It is NOT the list of ML modules Coq knows. *) type ml_module_object = { mnames : string list } @@ -264,13 +264,13 @@ let unfreeze_ml_modules x = if has_dynlink then let fname = file_of_name mname in load_object mname fname - else + else errorlabstrm "Mltop.unfreeze_ml_modules" (str"Loading of ML object file forbidden in a native Coq."); add_loaded_module mname) x -let _ = +let _ = Summary.declare_summary "ML-MODULES" { Summary.freeze_function = (fun () -> List.rev (get_loaded_modules())); Summary.unfreeze_function = (fun x -> unfreeze_ml_modules x); @@ -318,7 +318,7 @@ let print_ml_path () = hv 0 (prlist_with_sep pr_fnl pr_str l)) (* Printing of loaded ML modules *) - + let print_ml_modules () = let l = get_loaded_modules () in pp (str"Loaded ML Modules: " ++ pr_vertical_list pr_str l) diff --git a/toplevel/mltop.mli b/toplevel/mltop.mli index 715355635e..2b5de5708e 100644 --- a/toplevel/mltop.mli +++ b/toplevel/mltop.mli @@ -8,9 +8,9 @@ (*i $Id$ i*) -(* If there is a toplevel under Coq, it is described by the following +(* If there is a toplevel under Coq, it is described by the following record. *) -type toplevel = { +type toplevel = { load_obj : string -> unit; use_file : string -> unit; add_dir : string -> unit; diff --git a/toplevel/protectedtoplevel.ml b/toplevel/protectedtoplevel.ml index db5a5c4c51..ad1beb5534 100644 --- a/toplevel/protectedtoplevel.ml +++ b/toplevel/protectedtoplevel.ml @@ -27,7 +27,7 @@ open Vernacexpr let break_happened = ref false -(* Before outputing any data, output_results makes sure that no interrupt +(* Before outputing any data, output_results makes sure that no interrupt is going to disturb the process. *) let output_results_nl stream = let _ = Sys.signal Sys.sigint @@ -36,7 +36,7 @@ let output_results_nl stream = msgnl stream let rearm_break () = - let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun _ -> raise Sys.Break)) in + let _ = Sys.signal Sys.sigint (Sys.Signal_handle(fun _ -> raise Sys.Break)) in () let check_break () = @@ -52,7 +52,7 @@ let global_request_id = ref 013 let acknowledge_command_ref = ref(fun request_id command_count opt_exn -> (fnl () ++ str "acknowledge command number " ++ - int request_id ++ fnl () ++ + int request_id ++ fnl () ++ str "successfully executed " ++ int command_count ++ fnl () ++ str "error message" ++ fnl () ++ (match opt_exn with @@ -76,7 +76,7 @@ let set_start_marker s = start_marker := s; start_length := String.length s; start_marker_buffer := String.make !start_length ' ' - + let set_end_marker s = end_marker := s @@ -89,7 +89,7 @@ let rec parse_one_command_group input_channel = String.blit this_line 0 !start_marker_buffer 0 !start_length; if !start_marker_buffer = !start_marker then let req_id_line = input_line input_channel in - begin + begin (try global_request_id := int_of_string req_id_line with @@ -114,7 +114,7 @@ let rec parse_one_command_group input_channel = None else let first_cmd_status = - try + try raw_do_vernac (Pcoq.Gram.parsable stream_tail); None @@ -126,17 +126,17 @@ let rec parse_one_command_group input_channel = let r = execute_n_commands 0 in (match r with None -> - output_results_nl + output_results_nl (acknowledge_command !global_request_id !count None) | Some(rank, e) -> - (match e with + (match e with | DuringCommandInterp(a,e1) | Stdpp.Exc_located (a,DuringSyntaxChecking e1) -> output_results_nl (acknowledge_command !global_request_id rank (Some e1)) - | e -> + | e -> output_results_nl (acknowledge_command !global_request_id rank (Some e)))); @@ -158,7 +158,7 @@ let protected_loop input_chan = looprec input_chan; end and looprec input_chan = - try + try while true do parse_one_command_group input_chan done with | Vernacexpr.Drop -> raise Vernacexpr.Drop diff --git a/toplevel/record.ml b/toplevel/record.ml index ef3ee50879..152ae5b706 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -39,13 +39,13 @@ let interp_evars evdref env ?(impls=([],[])) k typ = let mk_interning_data env na impls typ = let impl = Impargs.compute_implicits_with_manual env typ (Impargs.is_implicit_args()) impls in (na, (Constrintern.Method, [], impl, Notation.compute_arguments_scope typ)) - + let interp_fields_evars evars env nots l = List.fold_left2 (fun (env, uimpls, params, impls) no ((loc, i), b, t) -> let impl, t' = interp_evars evars env ~impls Pretyping.IsType t in let b' = Option.map (fun x -> snd (interp_evars evars env ~impls (Pretyping.OfType (Some t')) x)) b in - let impls = + let impls = match i with | Anonymous -> impls | Name na -> (fst impls, mk_interning_data env na impl t' :: snd impls) @@ -87,7 +87,7 @@ let typecheck_params_and_fields id t ps nots fs = let degenerate_decl (na,b,t) = let id = match na with | Name id -> id - | Anonymous -> anomaly "Unnamed record variable" in + | Anonymous -> anomaly "Unnamed record variable" in match b with | None -> (id, Entries.LocalAssum t) | Some b -> (id, Entries.LocalDef b) @@ -102,21 +102,21 @@ let warning_or_error coe indsp err = let s,have = if List.length projs > 1 then "s","were" else "","was" in (str(string_of_id fi) ++ strbrk" cannot be defined because the projection" ++ str s ++ spc () ++ - prlist_with_sep pr_coma pr_id projs ++ spc () ++ str have ++ + prlist_with_sep pr_coma pr_id projs ++ spc () ++ str have ++ strbrk " not defined.") | BadTypedProj (fi,ctx,te) -> match te with | ElimArity (_,_,_,_,Some (_,_,NonInformativeToInformative)) -> - (pr_id fi ++ + (pr_id fi ++ strbrk" cannot be defined because it is informative and " ++ Printer.pr_inductive (Global.env()) indsp ++ - strbrk " is not.") + strbrk " is not.") | ElimArity (_,_,_,_,Some (_,_,StrongEliminationOnNonSmallType)) -> - (pr_id fi ++ + (pr_id fi ++ strbrk" cannot be defined because it is large and " ++ Printer.pr_inductive (Global.env()) indsp ++ strbrk " is not.") - | _ -> + | _ -> (pr_id fi ++ strbrk " cannot be defined because it is not typable.") in if coe then errorlabstrm "structure" st; @@ -139,20 +139,20 @@ let subst_projection fid l c = let rec substrec depth c = match kind_of_term c with | Rel k -> (* We are in context [[params;fields;x:ind;...depth...]] *) - if k <= depth+1 then + if k <= depth+1 then c else if k-depth-1 <= lv then match List.nth l (k-depth-2) with | Projection t -> lift depth t | NoProjection (Name id) -> bad_projs := id :: !bad_projs; mkRel k | NoProjection Anonymous -> assert false - else + else mkRel (k-lv) | _ -> map_constr_with_binders succ substrec depth c in let c' = lift 1 c in (* to get [c] defined in ctxt [[params;fields;x:ind]] *) let c'' = substrec 0 c' in - if !bad_projs <> [] then + if !bad_projs <> [] then raise (NotDefinable (MissingProj (fid,List.rev !bad_projs))); c'' @@ -226,14 +226,14 @@ let declare_projections indsp ?(kind=StructureComponent) ?name coers fieldimpls in (kinds,sp_projs) let structure_signature ctx = - let rec deps_to_evar evm l = + let rec deps_to_evar evm l = match l with [] -> Evd.empty - | [(_,_,typ)] -> Evd.add evm (Evarutil.new_untyped_evar()) + | [(_,_,typ)] -> Evd.add evm (Evarutil.new_untyped_evar()) (Evd.make_evar Environ.empty_named_context_val typ) - | (_,_,typ)::tl -> + | (_,_,typ)::tl -> let ev = Evarutil.new_untyped_evar() in let evm = Evd.add evm ev (Evd.make_evar Environ.empty_named_context_val typ) in - let new_tl = Util.list_map_i + let new_tl = Util.list_map_i (fun pos (n,c,t) -> n,c, Termops.replace_term (mkRel pos) (mkEvar(ev,[||])) t) 1 tl in deps_to_evar evm new_tl in @@ -241,7 +241,7 @@ let structure_signature ctx = open Typeclasses -let declare_structure finite infer id idbuild paramimpls params arity fieldimpls fields +let declare_structure finite infer id idbuild paramimpls params arity fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in let args = extended_rel_list nfields params in @@ -257,7 +257,7 @@ let declare_structure finite infer id idbuild paramimpls params arity fieldimpls but isn't *) (* there is probably a way to push this to "declare_mutual" *) begin match finite with - | BiFinite -> + | BiFinite -> if dependent (mkRel (nparams+1)) (it_mkProd_or_LetIn mkProp fields) then error "Records declared with the keyword Record or Structure cannot be recursive. Maybe you meant to define an Inductive or CoInductive record." | _ -> () @@ -280,8 +280,8 @@ let declare_structure finite infer id idbuild paramimpls params arity fieldimpls let implicits_of_context ctx = list_map_i (fun i name -> - let explname = - match name with + let explname = + match name with | Name n -> Some n | Anonymous -> None in ExplByPos (i, explname), (true, true, true)) @@ -289,11 +289,11 @@ let implicits_of_context ctx = let typeclasses_db = "typeclass_instances" -let qualid_of_con c = +let qualid_of_con c = Qualid (dummy_loc, shortest_qualid_of_global Idset.empty (ConstRef c)) -let set_rigid c = - Auto.add_hints false [typeclasses_db] +let set_rigid c = + Auto.add_hints false [typeclasses_db] (Auto.HintsTransparencyEntry ([EvalConstRef c], false)) let declare_instance_cst glob con = @@ -305,7 +305,7 @@ let declare_instance_cst glob con = let declare_class finite def infer id idbuild paramimpls params arity fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = - let fieldimpls = + let fieldimpls = (* Make the class and all params implicits in the projections *) let ctx_impls = implicits_of_context params in let len = succ (List.length params) in @@ -323,19 +323,19 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls const_entry_boxed = false } in let cst = Declare.declare_constant (snd id) - (DefinitionEntry class_entry, IsDefinition Definition) + (DefinitionEntry class_entry, IsDefinition Definition) in let inst_type = appvectc (mkConst cst) (rel_vect 0 (List.length params)) in let proj_type = it_mkProd_or_LetIn (mkProd(Name (snd id), inst_type, lift 1 field)) params in let proj_body = it_mkLambda_or_LetIn (mkLambda (Name (snd id), inst_type, mkRel 1)) params in - let proj_entry = + let proj_entry = { const_entry_body = proj_body; const_entry_type = Some proj_type; const_entry_opaque = false; const_entry_boxed = false } in let proj_cst = Declare.declare_constant proj_name - (DefinitionEntry proj_entry, IsDefinition Definition) + (DefinitionEntry proj_entry, IsDefinition Definition) in let cref = ConstRef cst in Impargs.declare_manual_implicits false cref paramimpls; @@ -354,7 +354,7 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls (List.rev fields) (Recordops.lookup_projections ind)) in let ctx_context = - List.map (fun (na, b, t) -> + List.map (fun (na, b, t) -> match Typeclasses.class_of_constr t with | Some cl -> Some (cl.cl_impl, true) (*List.exists (fun (_, n) -> n = na) supnames)*) | None -> None) @@ -366,7 +366,7 @@ let declare_class finite def infer id idbuild paramimpls params arity fieldimpls cl_props = fields; cl_projs = projs } in - List.iter2 (fun p sub -> + List.iter2 (fun p sub -> if sub then match snd p with Some p -> declare_instance_cst true p | None -> ()) k.cl_projs coers; add_class k; impl @@ -381,7 +381,7 @@ let interp_and_check_sort sort = open Vernacexpr open Autoinstance -(* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean +(* [fs] corresponds to fields and [ps] to parameters; [coers] is a boolean list telling if the corresponding fields must me declared as coercion *) let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = let cfs,notations = List.split cfs in @@ -394,13 +394,13 @@ let definition_structure (kind,finite,infer,(is_coe,(loc,idstruc)),ps,cfs,idbuil if not (list_distinct allnames) then error "Two objects have the same name"; (* Now, younger decl in params and fields is on top *) let sc = interp_and_check_sort s in - let implpars, params, implfs, fields = + let implpars, params, implfs, fields = States.with_state_protection (fun () -> typecheck_params_and_fields idstruc sc ps notations fs) () in let sign = structure_signature (fields@params) in - match kind with + match kind with | Class def -> - let gr = declare_class finite def infer (loc,idstruc) idbuild + let gr = declare_class finite def infer (loc,idstruc) idbuild implpars params sc implfs fields is_coe coers sign in if infer then search_record declare_class_instance gr sign; gr diff --git a/toplevel/record.mli b/toplevel/record.mli index 0e23af5c0f..b9864f0837 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -24,11 +24,11 @@ open Libnames val declare_projections : inductive -> ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> - bool list -> manual_explicitation list list -> rel_context -> + bool list -> manual_explicitation list list -> rel_context -> (name * bool) list * constant option list -val declare_structure : Decl_kinds.recursivity_kind -> - bool (*infer?*) -> identifier -> identifier -> +val declare_structure : Decl_kinds.recursivity_kind -> + bool (*infer?*) -> identifier -> identifier -> manual_explicitation list -> rel_context -> (* params *) constr -> (* arity *) Impargs.manual_explicitation list list -> rel_context -> (* fields *) ?kind:Decl_kinds.definition_object_kind -> ?name:identifier -> @@ -39,5 +39,5 @@ val declare_structure : Decl_kinds.recursivity_kind -> val definition_structure : inductive_kind * Decl_kinds.recursivity_kind * bool(*infer?*)* lident with_coercion * local_binder list * - (local_decl_expr with_coercion with_notation) list * + (local_decl_expr with_coercion with_notation) list * identifier * constr_expr option -> global_reference diff --git a/toplevel/search.ml b/toplevel/search.ml index 66dc28e2d0..8457ef0202 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -49,8 +49,8 @@ let gen_crible refopt (fn : global_reference -> env -> constr -> unit) = let env = Global.env () in let crible_rec (sp,kn) lobj = match object_tag lobj with | "VARIABLE" -> - (try - let (id,_,typ) = Global.lookup_named (basename sp) in + (try + let (id,_,typ) = Global.lookup_named (basename sp) in if refopt = None || head_const typ = constr_of_global (Option.get refopt) then @@ -63,22 +63,22 @@ let gen_crible refopt (fn : global_reference -> env -> constr -> unit) = || head_const typ = constr_of_global (Option.get refopt) then fn (ConstRef cst) env typ - | "INDUCTIVE" -> - let mib = Global.lookup_mind kn in - (match refopt with + | "INDUCTIVE" -> + let mib = Global.lookup_mind kn in + (match refopt with | Some (IndRef ((kn',tyi) as ind)) when kn=kn' -> print_constructors ind fn env (Array.length (mib.mind_packets.(tyi).mind_user_lc)) | Some _ -> () | _ -> - Array.iteri + Array.iteri (fun i mip -> print_constructors (kn,i) fn env (Array.length mip.mind_user_lc)) mib.mind_packets) | _ -> () - in - try + in + try Declaremods.iter_all_segments crible_rec - with Not_found -> + with Not_found -> () let crible ref = gen_crible (Some ref) @@ -87,17 +87,17 @@ let crible ref = gen_crible (Some ref) exception No_full_path -let rec head c = +let rec head c = let c = strip_outer_cast c in match kind_of_term c with | Prod (_,_,c) -> head c | LetIn (_,_,_,c) -> head c | _ -> c - + let constr_to_full_path c = match kind_of_term c with | Const sp -> sp | _ -> raise No_full_path - + let xor a b = (a or b) & (not (a & b)) let plain_display ref a c = @@ -105,17 +105,17 @@ let plain_display ref a c = let pr = pr_global ref in msg (hov 2 (pr ++ str":" ++ spc () ++ pc) ++ fnl ()) -let filter_by_module (module_list:dir_path list) (accept:bool) +let filter_by_module (module_list:dir_path list) (accept:bool) (ref:global_reference) _ _ = try let sp = path_of_global ref in let sl = dirpath sp in let rec filter_aux = function | m :: tl -> (not (is_dirpath_prefix_of m sl)) && (filter_aux tl) - | [] -> true + | [] -> true in xor accept (filter_aux module_list) - with No_full_path -> + with No_full_path -> false let ref_eq = Libnames.encode_kn Coqlib.logic_module (id_of_string "eq"), 0 @@ -129,18 +129,18 @@ let mk_rewrite_pattern2 eq pattern = PApp (PRef eq, [| PMeta None; PMeta None; pattern |]) let pattern_filter pat _ a c = - try + try try - is_matching pat (head c) - with _ -> + is_matching pat (head c) + with _ -> is_matching pat (head (Typing.type_of (Global.env()) Evd.empty c)) - with UserError _ -> + with UserError _ -> false let filtered_search filter_function display_function ref = crible ref - (fun s a c -> if filter_function s a c then display_function s a c) + (fun s a c -> if filter_function s a c then display_function s a c) let rec id_from_pattern = function | PRef gr -> gr @@ -149,32 +149,32 @@ let rec id_from_pattern = function *) | PApp (p,_) -> id_from_pattern p | _ -> error "The pattern is not simple enough." - + let raw_pattern_search extra_filter display_function pat = let name = id_from_pattern pat in - filtered_search - (fun s a c -> (pattern_filter pat s a c) & extra_filter s a c) + filtered_search + (fun s a c -> (pattern_filter pat s a c) & extra_filter s a c) display_function name let raw_search_rewrite extra_filter display_function pattern = filtered_search (fun s a c -> ((pattern_filter (mk_rewrite_pattern1 gref_eq pattern) s a c) || - (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c)) + (pattern_filter (mk_rewrite_pattern2 gref_eq pattern) s a c)) && extra_filter s a c) display_function gref_eq let raw_search_by_head extra_filter display_function pattern = Util.todo "raw_search_by_head" -(* +(* * functions to use the new Libtypes facility *) let raw_search search_function extra_filter display_function pat = let env = Global.env() in - List.iter - (fun (gr,_,_) -> + List.iter + (fun (gr,_,_) -> let typ = Global.type_of_global gr in if extra_filter gr env typ then display_function gr env typ @@ -193,7 +193,7 @@ let filter_by_module_from_list = function | [], _ -> (fun _ _ _ -> true) | l, outside -> filter_by_module l (not outside) -let search_by_head pat inout = +let search_by_head pat inout = text_search_by_head (filter_by_module_from_list inout) pat let search_rewrite pat inout = @@ -204,7 +204,7 @@ let search_pattern pat inout = let gen_filtered_search filter_function display_function = gen_crible None - (fun s a c -> if filter_function s a c then display_function s a c) + (fun s a c -> if filter_function s a c then display_function s a c) (** SearchAbout *) @@ -221,10 +221,10 @@ let search_about_item (itemref,typ) = function let raw_search_about filter_modules display_function l = let filter ref' env typ = filter_modules ref' env typ && - List.for_all (fun (b,i) -> b = search_about_item (ref',typ) i) l && + List.for_all (fun (b,i) -> b = search_about_item (ref',typ) i) l && not (string_string_contains (name_of_reference ref') "_subproof") in gen_filtered_search filter display_function -let search_about ref inout = +let search_about ref inout = raw_search_about (filter_by_module_from_list inout) plain_display ref diff --git a/toplevel/search.mli b/toplevel/search.mli index 96163f7da0..cc764fbde1 100644 --- a/toplevel/search.mli +++ b/toplevel/search.mli @@ -25,7 +25,7 @@ type glob_search_about_item = val search_by_head : constr -> dir_path list * bool -> unit val search_rewrite : constr -> dir_path list * bool -> unit val search_pattern : constr -> dir_path list * bool -> unit -val search_about : +val search_about : (bool * glob_search_about_item) list -> dir_path list * bool -> unit (* The filtering function that is by standard search facilities. @@ -39,14 +39,14 @@ val filter_by_module_from_list : They are also used for pcoq. *) val gen_filtered_search : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> unit -val filtered_search : (global_reference -> env -> constr -> bool) -> +val filtered_search : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> global_reference -> unit val raw_pattern_search : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> constr_pattern -> unit val raw_search_rewrite : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> constr_pattern -> unit val raw_search_about : (global_reference -> env -> constr -> bool) -> - (global_reference -> env -> constr -> unit) -> + (global_reference -> env -> constr -> unit) -> (bool * glob_search_about_item) list -> unit val raw_search_by_head : (global_reference -> env -> constr -> bool) -> (global_reference -> env -> constr -> unit) -> constr_pattern -> unit diff --git a/toplevel/toplevel.ml b/toplevel/toplevel.ml index 54e491f906..d14acaab9c 100644 --- a/toplevel/toplevel.ml +++ b/toplevel/toplevel.ml @@ -20,7 +20,7 @@ open Protectedtoplevel (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) -type input_buffer = { +type input_buffer = { mutable prompt : unit -> string; mutable str : string; (* buffer of already read characters *) mutable len : int; (* number of chars in the buffer *) @@ -72,7 +72,7 @@ let prompt_char ic ibuf count = ibuf.str.[ibuf.len] <- c; ibuf.len <- ibuf.len + 1; Some c - with End_of_file -> + with End_of_file -> None (* Reinitialize the char stream (after a Drop) *) @@ -94,22 +94,22 @@ let get_bols_of_loc ibuf (bp,ep) = if b < 0 or e < b then anomaly "Bad location"; match lines with | ([],None) -> ([], Some (b,e)) - | (fl,oe) -> ((b,e)::fl, oe) + | (fl,oe) -> ((b,e)::fl, oe) in let rec lines_rec ba after = function | [] -> add_line (0,ba) after | ll::_ when ll <= bp -> add_line (ll,ba) after | ll::fl -> let nafter = if ll < ep then add_line (ll,ba) after else after in - lines_rec ll nafter fl + lines_rec ll nafter fl in let (fl,ll) = lines_rec ibuf.len ([],None) ibuf.bols in (fl,Option.get ll) let dotted_location (b,e) = - if e-b < 3 then + if e-b < 3 then ("", String.make (e-b) ' ') - else + else (String.make (e-b-1) '.', " ") let blanching_string s i n = @@ -127,11 +127,11 @@ let blanching_string s i n = let print_highlight_location ib loc = let (bp,ep) = unloc loc in - let bp = bp - ib.start + let bp = bp - ib.start and ep = ep - ib.start in let highlight_lines = match get_bols_of_loc ib (bp,ep) with - | ([],(bl,el)) -> + | ([],(bl,el)) -> (str"> " ++ str(String.sub ib.str bl (el-bl-1)) ++ fnl () ++ str"> " ++ str(blanching_string ib.str bl (bp-bl)) ++ str(String.make (ep-bp) '^')) @@ -144,9 +144,9 @@ let print_highlight_location ib loc = prlist (fun (bi,ei) -> (str"> " ++ str(String.sub ib.str bi (ei-bi)))) ml in let ln = (str"> " ++ str(String.sub ib.str bn (ep-bn)) ++ - str sn ++ str dn) in + str sn ++ str dn) in (l1 ++ li ++ ln) - in + in let loc = make_loc (bp,ep) in (str"Toplevel input, characters " ++ Cerrors.print_loc loc ++ str":" ++ fnl () ++ highlight_lines ++ fnl ()) @@ -184,7 +184,7 @@ let print_location_in_file s inlibrary fname loc = with e -> (close_in ic; hov 1 (errstrm ++ spc() ++ str"(invalid location):") ++ fnl ()) - + let print_command_location ib dloc = match dloc with | Some (bp,ep) -> @@ -198,10 +198,10 @@ let valid_loc dloc loc = | Some dloc -> let (bd,ed) = unloc dloc in let (b,e) = unloc loc in bd<=b & e<=ed | _ -> true - + let valid_buffer_loc ib dloc loc = - valid_loc dloc loc & - let (b,e) = unloc loc in b-ib.start >= 0 & e-ib.start < ib.len & b<=e + valid_loc dloc loc & + let (b,e) = unloc loc in b-ib.start >= 0 & e-ib.start < ib.len & b<=e (*s The Coq prompt is the name of the focused proof, if any, and "Coq" otherwise. We trap all exceptions to prevent the error message printing @@ -209,35 +209,35 @@ let valid_buffer_loc ib dloc loc = let make_prompt () = try (Names.string_of_id (Pfedit.get_current_proof_name ())) ^ " < " - with _ -> + with _ -> "Coq < " -(*let build_pending_list l = +(*let build_pending_list l = let pl = ref ">" in let l' = ref l in - let res = - while List.length !l' > 1 do + let res = + while List.length !l' > 1 do pl := !pl ^ "|" Names.string_of_id x; l':=List.tl !l' done in let last = try List.hd !l' with _ -> in "<"^l' -*) +*) (* the coq prompt added to the default one when in emacs mode The prompt contains the current state label [n] (for global backtracking) and the current proof state [p] (for proof backtracking) plus the list of open (nested) proofs (for proof aborting when backtracking). It looks like: - + "n |lem1|lem2|lem3| p < " *) let make_emacs_prompt() = let statnum = string_of_int (Lib.current_command_label ()) in let dpth = Pfedit.current_proof_depth() in let pending = Pfedit.get_all_proof_names() in - let pendingprompt = - List.fold_left + let pendingprompt = + List.fold_left (fun acc x -> acc ^ (if acc <> "" then "|" else "") ^ Names.string_of_id x) "" pending in let proof_info = if dpth >= 0 then string_of_int dpth else "0" in @@ -248,9 +248,9 @@ let make_emacs_prompt() = * initialized when a vernac command is immediately followed by "\n", * or after a Drop. *) let top_buffer = - let pr() = - emacs_prompt_startstring() - ^ make_prompt() + let pr() = + emacs_prompt_startstring() + ^ make_prompt() ^ make_emacs_prompt() ^ emacs_prompt_endstring() in @@ -263,7 +263,7 @@ let top_buffer = let set_prompt prompt = top_buffer.prompt - <- (fun () -> + <- (fun () -> emacs_prompt_startstring() ^ prompt () ^ emacs_prompt_endstring()) @@ -287,31 +287,31 @@ let print_toplevel_error exc = | DuringCommandInterp (loc,ie) | Stdpp.Exc_located (loc, DuringSyntaxChecking ie) -> if loc = dummy_loc then (None,ie) else (Some loc, ie) - | _ -> (None, exc) + | _ -> (None, exc) in let (locstrm,exc) = match exc with | Stdpp.Exc_located (loc, ie) -> if valid_buffer_loc top_buffer dloc loc then (print_highlight_location top_buffer loc, ie) - else + else ((mt ()) (* print_command_location top_buffer dloc *), ie) | Error_in_file (s, (inlibrary, fname, loc), ie) -> (print_location_in_file s inlibrary fname loc, ie) - | _ -> + | _ -> ((mt ()) (* print_command_location top_buffer dloc *), exc) in match exc with - | End_of_input -> + | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0 | Vernacexpr.Drop -> (* Last chance *) if Mltop.is_ocaml_top() then raise Vernacexpr.Drop; (str"Error: There is no ML toplevel." ++ fnl ()) | Vernacexpr.ProtectedLoop -> raise Vernacexpr.ProtectedLoop - | Vernacexpr.Quit -> + | Vernacexpr.Quit -> raise Vernacexpr.Quit - | _ -> + | _ -> (if is_pervasive_exn exc then (mt ()) else locstrm) ++ Cerrors.explain_exn exc @@ -321,14 +321,14 @@ let parse_to_dot = | ("", ".") -> () | ("EOI", "") -> raise End_of_input | _ -> dot st - in + in Gram.Entry.of_parser "Coqtoplevel.dot" dot - + (* We assume that when a lexer error occurs, at least one char was eaten *) let rec discard_to_dot () = - try + try Gram.Entry.parse parse_to_dot top_buffer.tokens - with Stdpp.Exc_located(_,Token.Error _) -> + with Stdpp.Exc_located(_,Token.Error _) -> discard_to_dot() @@ -336,14 +336,14 @@ let rec discard_to_dot () = * in encountered. *) let process_error = function - | DuringCommandInterp _ + | DuringCommandInterp _ | Stdpp.Exc_located (_,DuringSyntaxChecking _) as e -> e | e -> - if is_pervasive_exn e then + if is_pervasive_exn e then e - else - try - discard_to_dot (); e + else + try + discard_to_dot (); e with | End_of_input -> End_of_input | de -> if is_pervasive_exn de then de else e @@ -357,11 +357,11 @@ let do_vernac () = msgerrnl (mt ()); if !print_emacs then msgerr (str (top_buffer.prompt())); resynch_buffer top_buffer; - begin - try + begin + try raw_do_vernac top_buffer.tokens - with e -> - msgnl (print_toplevel_error (process_error e)) + with e -> + msgnl (print_toplevel_error (process_error e)) end; flush_all() @@ -386,7 +386,7 @@ let rec coq_switch b = protected_loop stdin with | Vernacexpr.Drop -> () - | Vernacexpr.ProtectedLoop -> + | Vernacexpr.ProtectedLoop -> Lib.declare_initial_state(); coq_switch false | End_of_input -> msgerrnl (mt ()); pp_flush(); exit 0 diff --git a/toplevel/toplevel.mli b/toplevel/toplevel.mli index 63a87201bf..3f2fa83adb 100644 --- a/toplevel/toplevel.mli +++ b/toplevel/toplevel.mli @@ -18,7 +18,7 @@ open Pcoq (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) -type input_buffer = { +type input_buffer = { mutable prompt : unit -> string; mutable str : string; (* buffer of already read characters *) mutable len : int; (* number of chars in the buffer *) diff --git a/toplevel/usage.ml b/toplevel/usage.ml index fcb14b2c64..257660481f 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -23,7 +23,7 @@ let print_usage_channel co command = " -I dir -as coqdir map physical dir to logical coqdir -I dir map directory dir to the empty logical path -include dir (idem) - -R dir -as coqdir recursively map physical dir to logical coqdir + -R dir -as coqdir recursively map physical dir to logical coqdir -R dir coqdir (idem) -top coqdir set the toplevel name to be coqdir instead of Top -notop r set the toplevel name to be the empty logical path @@ -35,10 +35,10 @@ let print_usage_channel co command = -outputstate f write state in file f.coq -compat X.Y provides compatibility support for Coq version X.Y - -load-ml-object f load ML object file f - -load-ml-source f load ML file f + -load-ml-object f load ML object file f + -load-ml-source f load ML file f -load-vernac-source f load Coq file f.v (Load f.) - -l f (idem) + -l f (idem) -load-vernac-source-verbose f load Coq file f.v (Load Verbose f.) -lv f (idem) -load-vernac-object f load Coq object file f.vo @@ -88,7 +88,7 @@ options are: (* Print the configuration information *) -let print_config () = +let print_config () = if Coq_config.local then Printf.printf "LOCAL=1\n" else Printf.printf "LOCAL=0\n"; Printf.printf "COQLIB=%s/\n" Coq_config.coqlib; Printf.printf "COQSRC=%s/\n" Coq_config.coqsrc; diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index ee962334ec..a14e8ad458 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -34,7 +34,7 @@ let raise_with_file file exc = match exc with | DuringCommandInterp(loc,e) | Stdpp.Exc_located (loc,DuringSyntaxChecking e) -> (loc,e) - | e -> (dummy_loc,e) + | e -> (dummy_loc,e) in let (inner,inex) = match re with @@ -43,7 +43,7 @@ let raise_with_file file exc = | Stdpp.Exc_located (loc, e) when loc <> dummy_loc -> ((false,file, loc), e) | _ -> ((false,file,cmdloc), re) - in + in raise (Error_in_file (file, inner, disable_drop inex)) let real_error = function @@ -68,7 +68,7 @@ let open_file_twice_if verbosely fname = (in_chan, longfname, (po, verb_ch)) let close_input in_chan (_,verb) = - try + try close_in in_chan; match verb with | Some verb_ch -> close_in verb_ch @@ -88,7 +88,7 @@ let verbose_phrase verbch loc = | _ -> () exception End_of_input - + let parse_phrase (po, verbch) = match Pcoq.Gram.Entry.parse Pcoq.main_entry po with | Some (loc,_ as com) -> verbose_phrase verbch loc; com @@ -133,7 +133,7 @@ let rec vernac_com interpfun (loc,com) = (* end translator state *) (* coqdoc state *) let cds = Dumpglob.coqdoc_freeze() in - if !Flags.beautify_file then + if !Flags.beautify_file then begin let _,f = find_file_in_path ~warn:(Flags.is_verbose()) (Library.get_load_paths ()) @@ -141,7 +141,7 @@ let rec vernac_com interpfun (loc,com) = chan_beautify := open_out (f^beautify_suffix); Pp.comments := [] end; - begin + begin try read_vernac_file verbosely (make_suffix fname ".v"); if !Flags.beautify_file then close_out !chan_beautify; @@ -149,7 +149,7 @@ let rec vernac_com interpfun (loc,com) = Lexer.restore_com_state cs; Pp.comments := cl; Dumpglob.coqdoc_unfreeze cds - with e -> + with e -> if !Flags.beautify_file then close_out !chan_beautify; chan_beautify := ch; Lexer.restore_com_state cs; @@ -157,7 +157,7 @@ let rec vernac_com interpfun (loc,com) = Dumpglob.coqdoc_unfreeze cds; raise e end - + | VernacList l -> List.iter (fun (_,v) -> interp v) l | VernacTime v -> @@ -185,11 +185,11 @@ let rec vernac_com interpfun (loc,com) = | v -> if not !just_parsing then interpfun v - in + in try if do_beautify () then pr_new_syntax loc (Some com); interp com - with e -> + with e -> Format.set_formatter_out_channel stdout; raise (DuringCommandInterp (loc, e)) @@ -199,10 +199,10 @@ and vernac interpfun input = and read_vernac_file verbosely s = Flags.make_warn verbosely; let interpfun = - if verbosely then + if verbosely then Vernacentries.interp - else - Flags.silently Vernacentries.interp + else + Flags.silently Vernacentries.interp in let (in_chan, fname, input) = open_file_twice_if verbosely s in try @@ -239,17 +239,17 @@ let set_xml_end_library f = xml_end_library := f let load_vernac verb file = chan_beautify := if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout; - try + try read_vernac_file verb file; if !Flags.beautify_file then close_out !chan_beautify; - with e -> + with e -> if !Flags.beautify_file then close_out !chan_beautify; raise_with_file file e (* Compile a vernac file (f is assumed without .v suffix) *) let compile verbosely f = let ldir,long_f_dot_v = Flags.verbosely Library.start_library f in - if Dumpglob.multi_dump () then + if Dumpglob.multi_dump () then Dumpglob.open_glob_file (f ^ ".glob"); Dumpglob.dump_string ("F" ^ Names.string_of_dirpath ldir ^ "\n"); if !Flags.xml_export then !xml_start_library (); diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index f1ea6fa443..4dff36e53e 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -41,6 +41,6 @@ val compile : bool -> string -> unit (* Interpret a vernac AST *) -val vernac_com : +val vernac_com : (Vernacexpr.vernac_expr -> unit) -> Util.loc * Vernacexpr.vernac_expr -> unit diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index be7c29babf..c97c24cd18 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -72,7 +72,7 @@ let show_proof () = msgnl (str"LOC: " ++ prlist_with_sep pr_spc pr_int (List.rev cursor) ++ fnl () ++ str"Subgoals" ++ fnl () ++ - prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++ + prlist (fun (mv,ty) -> Nameops.pr_meta mv ++ str" -> " ++ pr_ltype ty ++ fnl ()) meta_types ++ str"Proof: " ++ pr_lconstr (Evarutil.nf_evar evc pfterm)) @@ -90,7 +90,7 @@ let show_node () = str" " ++ hov 0 (prlist_with_sep pr_fnl pr_goal (List.map goal_of_proof spfl))))) - + let show_script () = let pts = get_pftreestate () in let pf = proof_of_pftreestate pts @@ -101,9 +101,9 @@ let show_thesis () = msgnl (anomaly "TODO" ) let show_top_evars () = - let pfts = get_pftreestate () in - let gls = top_goal_of_pftreestate pfts in - let sigma = project gls in + let pfts = get_pftreestate () in + let gls = top_goal_of_pftreestate pfts in + let sigma = project gls in msg (pr_evars_int 1 (Evarutil.non_instantiated sigma)) let show_prooftree () = @@ -120,38 +120,38 @@ let show_intro all = let pf = get_pftreestate() in let gl = nth_goal_of_pftreestate 1 pf in let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in - if all - then - let lid = Tactics.find_intro_names l gl in + if all + then + let lid = Tactics.find_intro_names l gl in msgnl (hov 0 (prlist_with_sep spc pr_id lid)) - else - try + else + try let n = list_last l in msgnl (pr_id (List.hd (Tactics.find_intro_names [n] gl))) with Failure "list_last" -> message "" -let id_of_name = function - | Names.Anonymous -> id_of_string "x" +let id_of_name = function + | Names.Anonymous -> id_of_string "x" | Names.Name x -> x (* Building of match expression *) (* From ide/coq.ml *) -let make_cases s = +let make_cases s = let qualified_name = Libnames.qualid_of_string s in let glob_ref = Nametab.locate qualified_name in match glob_ref with - | Libnames.IndRef i -> + | Libnames.IndRef i -> let {Declarations.mind_nparams = np} - , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr } + , {Declarations.mind_consnames = carr ; Declarations.mind_nf_lc = tarr } = Global.lookup_inductive i in - Util.array_fold_right2 - (fun n t l -> + Util.array_fold_right2 + (fun n t l -> let (al,_) = Term.decompose_prod t in let al,_ = Util.list_chop (List.length al - np) al in - let rec rename avoid = function + let rec rename avoid = function | [] -> [] - | (n,_)::l -> + | (n,_)::l -> let n' = Termops.next_global_ident_away true (id_of_name n) avoid in string_of_id n' :: rename (n'::avoid) l in let al' = rename [] (List.rev al) in @@ -160,18 +160,18 @@ let make_cases s = | _ -> raise Not_found -let show_match id = +let show_match id = try let s = string_of_id (snd id) in let patterns = make_cases s in - let cases = - List.fold_left - (fun acc x -> + let cases = + List.fold_left + (fun acc x -> match x with | [] -> assert false | [x] -> "| "^ x ^ " => \n" ^ acc - | x::l -> - "| (" ^ List.fold_left (fun acc s -> acc ^ " " ^ s) x l ^ ")" + | x::l -> + "| (" ^ List.fold_left (fun acc s -> acc ^ " " ^ s) x l ^ ")" ^ " => \n" ^ acc) "end" patterns in msg (str ("match # with\n" ^ cases)) @@ -196,7 +196,7 @@ let print_modules () = and loaded = Library.loaded_libraries () in let loaded_opened = list_intersect loaded opened and only_loaded = list_subtract loaded opened in - str"Loaded and imported library files: " ++ + str"Loaded and imported library files: " ++ pr_vertical_list pr_dirpath loaded_opened ++ fnl () ++ str"Loaded and not imported library files: " ++ pr_vertical_list pr_dirpath only_loaded @@ -213,7 +213,7 @@ let print_module r = with Not_found -> msgnl (str"Unknown Module " ++ pr_qualid qid) -let print_modtype r = +let print_modtype r = let (loc,qid) = qualid_of_reference r in try let kn = Nametab.locate_modtype qid in @@ -226,7 +226,7 @@ let dump_universes s = try Univ.dump_universes output (Global.universes ()); close_out output; - msgnl (str ("Universes written to file \""^s^"\".")) + msgnl (str ("Universes written to file \""^s^"\".")) with e -> close_out output; raise e @@ -237,7 +237,7 @@ let locate_file f = try let _,file = System.where_in_path ~warn:false (Library.get_load_paths ()) f in msgnl (str file) - with Not_found -> + with Not_found -> msgnl (hov 0 (str"Can't find file" ++ spc () ++ str f ++ spc () ++ str"on loadpath")) @@ -256,7 +256,7 @@ let msg_notfound_library loc qid = function strbrk "Cannot find a physical path bound to logical path " ++ pr_dirpath dir ++ str".") | Library.LibNotFound -> - msgnl (hov 0 + msgnl (hov 0 (strbrk "Unable to locate library " ++ pr_qualid qid ++ str".")) | e -> assert false @@ -265,18 +265,18 @@ let print_located_library r = try msg_found_library (Library.locate_qualified_library false qid) with e -> msg_notfound_library loc qid e -let print_located_module r = +let print_located_module r = let (loc,qid) = qualid_of_reference r in let msg = - try + try let dir = Nametab.full_name_module qid in str "Module " ++ pr_dirpath dir with Not_found -> (if fst (repr_qualid qid) = empty_dirpath then str "No module is referred to by basename " - else + else str "No module is referred to by name ") ++ pr_qualid qid - in msgnl msg + in msgnl msg let smart_global r = let gr = Smartlocate.smart_global r in @@ -290,7 +290,7 @@ let vernac_syntax_extension = Metasyntax.add_syntax_extension let vernac_delimiters = Metasyntax.add_delimiters -let vernac_bind_scope sc cll = +let vernac_bind_scope sc cll = List.iter (fun cl -> Metasyntax.add_class_scope sc (cl_of_qualid cl)) cll let vernac_open_close_scope = Notation.open_close_scope @@ -319,19 +319,19 @@ let vernac_definition (local,_,_ as k) (loc,id as lid) def hook = (str "Proof editing mode not supported in module types.") else let hook _ _ = () in - start_proof_and_print (local,DefinitionBody Definition) + start_proof_and_print (local,DefinitionBody Definition) [Some lid, (bl,t)] hook | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with | None -> None - | Some r -> + | Some r -> let (evc,env)= Command.get_current_context () in Some (interp_redexp env evc r) in declare_definition id k bl red_option c typ_opt hook) - + let vernac_start_proof kind l lettop hook = if Dumpglob.dump () then - List.iter (fun (id, _) -> + List.iter (fun (id, _) -> match id with | Some lid -> Dumpglob.dump_definition lid false "prf" | None -> ()) l; @@ -365,18 +365,18 @@ let vernac_exact_proof c = else errorlabstrm "Vernacentries.ExactProof" (strbrk "Command 'Proof ...' can only be used at the beginning of the proof.") - + let vernac_assumption kind l nl= let global = fst kind = Global in - List.iter (fun (is_coe,(idl,c)) -> + List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then - List.iter (fun lid -> - if global then Dumpglob.dump_definition lid false "ax" + List.iter (fun lid -> + if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl; declare_assumption idl is_coe kind [] c false nl) l - + let vernac_record k finite infer struc binders sort nameopt cfs = - let const = match nameopt with + let const = match nameopt with | None -> add_prefix "Build_" (snd (snd struc)) | Some (_,id as lid) -> Dumpglob.dump_definition lid false "constr"; id in @@ -387,11 +387,11 @@ let vernac_record k finite infer struc binders sort nameopt cfs = | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" | _ -> ()) cfs); ignore(Record.definition_structure (k,finite,infer,struc,binders,cfs,const,sort)) - -let vernac_inductive finite infer indl = + +let vernac_inductive finite infer indl = if Dumpglob.dump () then List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> - match cstrs with + match cstrs with | Constructors cstrs -> Dumpglob.dump_definition lid false "ind"; List.iter (fun (_, (lid, _)) -> @@ -399,28 +399,28 @@ let vernac_inductive finite infer indl = | _ -> () (* dumping is done by vernac_record (called below) *) ) indl; match indl with - | [ ( id , bl , c , b, RecordDecl (oc,fs) ), None ] -> + | [ ( id , bl , c , b, RecordDecl (oc,fs) ), None ] -> vernac_record (match b with Class true -> Class false | _ -> b) finite infer id bl c oc fs - | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> - let f = + | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> + let f = let (coe, ((loc, id), ce)) = l in ((coe, AssumExpr ((loc, Name id), ce)), None) in vernac_record (Class true) finite infer id bl c None [f] - | [ ( id , bl , c , Class true, _), _ ] -> + | [ ( id , bl , c , Class true, _), _ ] -> Util.error "Definitional classes must have a single method" | [ ( id , bl , c , Class false, Constructors _), _ ] -> Util.error "Inductive classes not supported" - | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> + | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> Util.error "where clause not supported for (co)inductive records" - | _ -> let unpack = function + | _ -> let unpack = function | ( (_, id) , bl , c , _ , Constructors l ) , ntn -> ( id , bl , c , l ) , ntn | _ -> Util.error "Cannot handle mutually (co)inductive records." in let indl = List.map unpack indl in Command.build_mutual indl (recursivity_flag_of_kind finite) -let vernac_fixpoint l b = +let vernac_fixpoint l b = if Dumpglob.dump () then List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; build_recursive l b @@ -438,13 +438,13 @@ let vernac_combined_scheme = build_combined_scheme (* Modules *) let vernac_import export refl = - let import ref = + let import ref = Library.import_module export (qualid_of_reference ref) in List.iter import refl; Lib.add_frozen_state () -let vernac_declare_module export (loc, id) binders_ast mty_ast_o = +let vernac_declare_module export (loc, id) binders_ast mty_ast_o = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then @@ -456,15 +456,15 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast_o = "Remove the \"Export\" and \"Import\" keywords from every functor " ^ "argument.") else (idl,ty)) binders_ast in - let mp = Declaremods.declare_module + let mp = Declaremods.declare_module Modintern.interp_modtype Modintern.interp_modexpr id binders_ast (Some mty_ast_o) None - in + in Dumpglob.dump_moddef loc mp "mod"; if_verbose message ("Module "^ string_of_id id ^" is declared"); Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export -let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = +let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = (* We check the state of the system (in section, in module type) and what module information is supplied *) if Lib.sections_are_opened () then @@ -478,10 +478,10 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = (idl,ty)::args, (List.map (fun (_,i) -> export,i)idl)@argsexport) binders_ast ([],[]) in let mp = Declaremods.start_module Modintern.interp_modtype export - id binders_ast mty_ast_o + id binders_ast mty_ast_o in Dumpglob.dump_moddef loc mp "mod"; - if_verbose message + if_verbose message ("Interactive Module "^ string_of_id id ^" started") ; List.iter (fun (export,id) -> @@ -496,12 +496,12 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_o = " the definition is interactive. Remove the \"Export\" and " ^ "\"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in - let mp = Declaremods.declare_module + let mp = Declaremods.declare_module Modintern.interp_modtype Modintern.interp_modexpr - id binders_ast mty_ast_o mexpr_ast_o + id binders_ast mty_ast_o mexpr_ast_o in Dumpglob.dump_moddef loc mp "mod"; - if_verbose message + if_verbose message ("Module "^ string_of_id id ^" is defined"); Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export @@ -515,7 +515,7 @@ let vernac_end_module export (loc,id as lid) = let vernac_declare_module_type (loc,id) binders_ast mty_ast_o = if Lib.sections_are_opened () then error "Modules and Module Types are not allowed inside sections."; - + match mty_ast_o with | None -> check_no_pending_proofs (); @@ -526,14 +526,14 @@ let vernac_declare_module_type (loc,id) binders_ast mty_ast_o = ([],[]) in let mp = Declaremods.start_modtype Modintern.interp_modtype id binders_ast in Dumpglob.dump_moddef loc mp "modtype"; - if_verbose message + if_verbose message ("Interactive Module Type "^ string_of_id id ^" started"); List.iter (fun (export,id) -> Option.iter (fun export -> vernac_import export [Ident (dummy_loc,id)]) export ) argsexport - + | Some base_mty -> let binders_ast = List.map (fun (export,idl,ty) -> @@ -542,23 +542,23 @@ let vernac_declare_module_type (loc,id) binders_ast mty_ast_o = " the definition is interactive. Remove the \"Export\" " ^ "and \"Import\" keywords from every functor argument.") else (idl,ty)) binders_ast in - let mp = Declaremods.declare_modtype Modintern.interp_modtype + let mp = Declaremods.declare_modtype Modintern.interp_modtype id binders_ast base_mty in Dumpglob.dump_moddef loc mp "modtype"; - if_verbose message + if_verbose message ("Module Type "^ string_of_id id ^" is defined") let vernac_end_modtype (loc,id) = let mp = Declaremods.end_modtype () in Dumpglob.dump_modref loc mp "modtype"; if_verbose message ("Module Type "^ string_of_id id ^" is defined") - + let vernac_include = function | CIMTE mty_ast -> Declaremods.declare_include Modintern.interp_modtype mty_ast false | CIME mexpr_ast -> Declaremods.declare_include Modintern.interp_modexpr mexpr_ast true - + (**********************) (* Gallina extensions *) @@ -570,7 +570,7 @@ let vernac_begin_section (_, id as lid) = Lib.open_section id let vernac_end_section (loc,_) = - Dumpglob.dump_reference loc + Dumpglob.dump_reference loc (string_of_dirpath (Lib.current_dirpath true)) "<>" "sec"; Lib.close_section () @@ -611,7 +611,7 @@ let vernac_identity_coercion stre id qids qidt = Class.try_add_new_identity_coercion id stre source target (* Type classes *) - + let vernac_instance glob sup inst props pri = Dumpglob.dump_constraint inst false "inst"; ignore(Classes.new_instance ~global:glob sup inst props pri) @@ -631,12 +631,12 @@ let vernac_solve n tcom b = error "Unknown command of the non proof-editing mode."; Decl_mode.check_not_proof_mode "Unknown proof instruction"; begin - if b then + if b then solve_nth n (Tacinterp.hide_interp tcom (get_end_tac ())) else solve_nth n (Tacinterp.hide_interp tcom None) end; - (* in case a strict subtree was completed, - go back to the top of the prooftree *) + (* in case a strict subtree was completed, + go back to the top of the prooftree *) if subtree_solved () then begin Flags.if_verbose msgnl (str "Subgoal proved"); make_focus 0; @@ -648,9 +648,9 @@ let vernac_solve n tcom b = (* A command which should be a tactic. It has been added by Christine to patch an error in the design of the proof machine, and enables to instantiate existential variables when - there are no more goals to solve. It cannot be a tactic since + there are no more goals to solve. It cannot be a tactic since all tactics fail if there are no further goals to prove. *) - + let vernac_solve_existential = instantiate_nth_evar_com let vernac_set_end_tac tac = @@ -662,9 +662,9 @@ let vernac_set_end_tac tac = (***********************) (* Proof Language Mode *) -let vernac_decl_proof () = +let vernac_decl_proof () = check_not_proof_mode "Already in Proof Mode"; - if tree_solved () then + if tree_solved () then error "Nothing left to prove here." else begin @@ -672,17 +672,17 @@ let vernac_decl_proof () = print_subgoals () end -let vernac_return () = +let vernac_return () = match get_current_mode () with Mode_tactic -> Decl_proof_instr.return_from_tactic_mode (); print_subgoals () - | Mode_proof -> + | Mode_proof -> error "\"return\" is only used after \"escape\"." - | Mode_none -> - error "There is no proof to end." + | Mode_none -> + error "There is no proof to end." -let vernac_proof_instr instr = +let vernac_proof_instr instr = Decl_proof_instr.proof_instr instr; print_subgoals () @@ -753,7 +753,7 @@ let vernac_backto n = Lib.reset_label n let vernac_declare_tactic_definition = Tacinterp.add_tacdef -let vernac_create_hintdb local id b = +let vernac_create_hintdb local id b = Auto.create_hint_db local id full_transparent_state b let vernac_hints local lb h = Auto.add_hints local lb (Auto.interp_hints h) @@ -761,12 +761,12 @@ let vernac_hints local lb h = Auto.add_hints local lb (Auto.interp_hints h) let vernac_syntactic_definition lid = Dumpglob.dump_definition lid false "syndef"; Command.syntax_definition (snd lid) - + let vernac_declare_implicits local r = function | Some imps -> Impargs.declare_manual_implicits local (smart_global r) ~enriching:false (List.map (fun (ex,b,f) -> ex, (b,true,f)) imps) - | None -> + | None -> Impargs.declare_implicits local (smart_global r) let vernac_reserve idl c = @@ -775,12 +775,12 @@ let vernac_reserve idl c = List.iter (fun id -> Reserve.declare_reserved_type id t) idl let make_silent_if_not_pcoq b = - if !pcoq <> None then + if !pcoq <> None then error "Turning on/off silent flag is not supported in Pcoq mode." else make_silent b let _ = - declare_bool_option + declare_bool_option { optsync = false; optname = "silent"; optkey = ["Silent"]; @@ -788,7 +788,7 @@ let _ = optwrite = make_silent_if_not_pcoq } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "implicit arguments"; optkey = ["Implicit";"Arguments"]; @@ -796,7 +796,7 @@ let _ = optwrite = Impargs.make_implicit_args } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "strict implicit arguments"; optkey = ["Strict";"Implicit"]; @@ -804,7 +804,7 @@ let _ = optwrite = Impargs.make_strict_implicit_args } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "strong strict implicit arguments"; optkey = ["Strongly";"Strict";"Implicit"]; @@ -812,7 +812,7 @@ let _ = optwrite = Impargs.make_strongly_strict_implicit_args } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "contextual implicit arguments"; optkey = ["Contextual";"Implicit"]; @@ -828,7 +828,7 @@ let _ = (* optwrite = Impargs.make_forceable_implicit_args } *) let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "implicit status of reversible patterns"; optkey = ["Reversible";"Pattern";"Implicit"]; @@ -836,7 +836,7 @@ let _ = optwrite = Impargs.make_reversible_pattern_implicit_args } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "maximal insertion of implicit"; optkey = ["Maximal";"Implicit";"Insertion"]; @@ -844,7 +844,7 @@ let _ = optwrite = Impargs.make_maximal_implicit_args } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "coercion printing"; optkey = ["Printing";"Coercions"]; @@ -852,14 +852,14 @@ let _ = optwrite = (fun b -> Constrextern.print_coercions := b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "printing of existential variable instances"; optkey = ["Printing";"Existential";"Instances"]; optread = (fun () -> !Constrextern.print_evar_arguments); optwrite = (:=) Constrextern.print_evar_arguments } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "implicit arguments printing"; optkey = ["Printing";"Implicit"]; @@ -867,7 +867,7 @@ let _ = optwrite = (fun b -> Constrextern.print_implicits := b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "implicit arguments defensive printing"; optkey = ["Printing";"Implicit";"Defensive"]; @@ -875,7 +875,7 @@ let _ = optwrite = (fun b -> Constrextern.print_implicits_defensive := b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "projection printing using dot notation"; optkey = ["Printing";"Projections"]; @@ -883,7 +883,7 @@ let _ = optwrite = (fun b -> Constrextern.print_projections := b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "notations printing"; optkey = ["Printing";"Notations"]; @@ -891,7 +891,7 @@ let _ = optwrite = (fun b -> Constrextern.print_no_symbol := not b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "raw printing"; optkey = ["Printing";"All"]; @@ -899,7 +899,7 @@ let _ = optwrite = (fun b -> Flags.raw_print := b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "use of virtual machine inside the kernel"; optkey = ["Virtual";"Machine"]; @@ -907,20 +907,20 @@ let _ = optwrite = (fun b -> Vconv.set_use_vm b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "use of boxed definitions"; optkey = ["Boxed";"Definitions"]; optread = Flags.boxed_definitions; - optwrite = (fun b -> Flags.set_boxed_definitions b) } + optwrite = (fun b -> Flags.set_boxed_definitions b) } let _ = - declare_bool_option + declare_bool_option { optsync = true; optname = "use of boxed values"; optkey = ["Boxed";"Values"]; optread = (fun _ -> not (Vm.transp_values ())); - optwrite = (fun b -> Vm.set_transp_values (not b)) } + optwrite = (fun b -> Vm.set_transp_values (not b)) } let _ = declare_int_option @@ -1061,7 +1061,7 @@ let vernac_print = function | PrintModuleType qid -> print_modtype qid | PrintMLLoadPath -> Mltop.print_ml_path () | PrintMLModules -> Mltop.print_ml_modules () - | PrintName qid -> + | PrintName qid -> if !pcoq <> None then (Option.get !pcoq).print_name qid else msg (print_name qid) | PrintGraph -> ppnl (Prettyp.print_graph()) @@ -1098,7 +1098,7 @@ let vernac_print = function let global_module r = let (loc,qid) = qualid_of_reference r in try Nametab.full_name_module qid - with Not_found -> + with Not_found -> user_err_loc (loc, "global_module", str "Module/section " ++ pr_qualid qid ++ str " not found.") @@ -1117,12 +1117,12 @@ let interp_search_about_item = function | SearchString (s,None) when is_ident s -> GlobSearchString s | SearchString (s,sc) -> - try + try let ref = Notation.interp_notation_as_global_reference dummy_loc (fun _ -> true) s sc in GlobSearchSubPattern (Pattern.PRef ref) - with UserError _ -> + with UserError _ -> error ("Unable to interp \""^s^"\" either as a reference or as an identifier component") @@ -1162,7 +1162,7 @@ let vernac_goal = function let unnamed_kind = Lemma (* Arbitrary *) in start_proof_com (Global, Proof unnamed_kind) [None,c] (fun _ _ ->()); print_subgoals () - end else + end else error "repeated Goal not permitted in refining mode." let vernac_abort = function @@ -1207,14 +1207,14 @@ let vernac_backtrack snum pnum naborts = Pp.flush_all(); (* there may be no proof in progress, even if no abort *) (try print_subgoals () with UserError _ -> ()) - + let vernac_focus gln = check_not_proof_mode "No focussing or Unfocussing in Proof Mode."; - match gln with + match gln with | None -> traverse_nth_goal 1; print_subgoals () | Some n -> traverse_nth_goal n; print_subgoals () - + (* Reset the focus to the top of the tree *) let vernac_unfocus () = check_not_proof_mode "No focussing or Unfocussing in Proof Mode."; @@ -1231,7 +1231,7 @@ let apply_subproof f occ = let evc = evc_of_pftreestate pts in let rec aux pts = function | [] -> pts - | (n::l) -> aux (Tacmach.traverse n pts) occ in + | (n::l) -> aux (Tacmach.traverse n pts) occ in let pts = aux pts (occ@[-1]) in let pf = proof_of_pftreestate pts in f evc (Global.named_context()) pf @@ -1270,14 +1270,14 @@ let vernac_check_guard () = let pts = get_pftreestate () in let pf = proof_of_pftreestate pts in let (pfterm,_) = extract_open_pftreestate pts in - let message = - try + let message = + try Inductiveops.control_only_guard (Evd.evar_env (goal_of_proof pf)) - pfterm; + pfterm; (str "The condition holds up to here") - with UserError(_,s) -> + with UserError(_,s) -> (str ("Condition violated: ") ++s) - in + in msgnl message let interp c = match c with @@ -1308,11 +1308,11 @@ let interp c = match c with | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l (* Modules *) - | VernacDeclareModule (export,lid,bl,mtyo) -> + | VernacDeclareModule (export,lid,bl,mtyo) -> vernac_declare_module export lid bl mtyo - | VernacDefineModule (export,lid,bl,mtyo,mexpro) -> + | VernacDefineModule (export,lid,bl,mtyo,mexpro) -> vernac_define_module export lid bl mtyo mexpro - | VernacDeclareModuleType (lid,bl,mtyo) -> + | VernacDeclareModuleType (lid,bl,mtyo) -> vernac_declare_module_type lid bl mtyo | VernacInclude (in_ast) -> vernac_include in_ast @@ -1340,7 +1340,7 @@ let interp c = match c with | VernacDeclProof -> vernac_decl_proof () | VernacReturn -> vernac_return () - | VernacProofInstr stp -> vernac_proof_instr stp + | VernacProofInstr stp -> vernac_proof_instr stp (* /MMode *) diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 300ff44f8e..44e8b7ab46 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -54,4 +54,4 @@ val abort_refine : ('a -> unit) -> 'a -> unit;; val interp : Vernacexpr.vernac_expr -> unit -val vernac_reset_name : identifier Util.located -> unit +val vernac_reset_name : identifier Util.located -> unit diff --git a/toplevel/vernacexpr.ml b/toplevel/vernacexpr.ml index 080acc7fcf..56fbd192bc 100644 --- a/toplevel/vernacexpr.ml +++ b/toplevel/vernacexpr.ml @@ -31,7 +31,7 @@ type lstring = string type lreference = reference type class_rawexpr = FunClass | SortClass | RefClass of reference or_by_notation - + type printable = | PrintTables | PrintFullContext @@ -164,7 +164,7 @@ type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list | RecordDecl of lident option * local_decl_expr with_coercion with_notation list type inductive_expr = - lident with_coercion * local_binder list * constr_expr option * inductive_kind * + lident with_coercion * local_binder list * constr_expr option * inductive_kind * constructor_list_or_record_decl_expr type module_binder = bool option * lident list * module_type_ast @@ -196,13 +196,13 @@ type vernac_expr = | VernacTime of vernac_expr | VernacTimeout of int * vernac_expr - (* Syntax *) + (* Syntax *) | VernacTacticNotation of int * grammar_tactic_prod_item_expr list * raw_tactic_expr | VernacSyntaxExtension of locality_flag * (lstring * syntax_modifier list) | VernacOpenCloseScope of (locality_flag * bool * scope_name) | VernacDelimiters of scope_name * lstring | VernacBindScope of scope_name * class_rawexpr list - | VernacArgumentsScope of locality_flag * reference or_by_notation * + | VernacArgumentsScope of locality_flag * reference or_by_notation * scope_name option list | VernacInfix of locality_flag * (lstring * syntax_modifier list) * constr_expr * scope_name option @@ -211,9 +211,9 @@ type vernac_expr = scope_name option (* Gallina *) - | VernacDefinition of definition_kind * lident * definition_expr * + | VernacDefinition of definition_kind * lident * definition_expr * declaration_hook - | VernacStartTheoremProof of theorem_kind * + | VernacStartTheoremProof of theorem_kind * (lident option * (local_binder list * constr_expr)) list * bool * declaration_hook | VernacEndProof of proof_end @@ -232,12 +232,12 @@ type vernac_expr = export_flag option * specif_flag option * lreference list | VernacImport of export_flag * lreference list | VernacCanonical of reference or_by_notation - | VernacCoercion of locality * reference or_by_notation * + | VernacCoercion of locality * reference or_by_notation * class_rawexpr * class_rawexpr - | VernacIdentityCoercion of locality * lident * + | VernacIdentityCoercion of locality * lident * class_rawexpr * class_rawexpr - (* Type classes *) + (* Type classes *) | VernacInstance of bool * (* global *) local_binder list * (* super *) @@ -246,16 +246,16 @@ type vernac_expr = int option (* Priority *) | VernacContext of local_binder list - + | VernacDeclareInstance of lident (* instance name *) (* Modules and Module Types *) - | VernacDeclareModule of bool option * lident * + | VernacDeclareModule of bool option * lident * module_binder list * (module_type_ast * bool) - | VernacDefineModule of bool option * lident * + | VernacDefineModule of bool option * lident * module_binder list * (module_type_ast * bool) option * module_ast option - | VernacDeclareModuleType of lident * + | VernacDeclareModuleType of lident * module_binder list * module_type_ast option | VernacInclude of include_ast @@ -297,7 +297,7 @@ type vernac_expr = | VernacHints of locality_flag * lstring list * hints_expr | VernacSyntacticDefinition of identifier located * (identifier list * constr_expr) * locality_flag * onlyparsing_flag - | VernacDeclareImplicits of locality_flag * reference or_by_notation * + | VernacDeclareImplicits of locality_flag * reference or_by_notation * (explicitation * bool * bool) list option | VernacReserve of lident list * constr_expr | VernacSetOpacity of @@ -345,7 +345,7 @@ and located_vernac_expr = loc * vernac_expr exception DuringSyntaxChecking of exn -let syntax_checking_error s = +let syntax_checking_error s = raise (DuringSyntaxChecking (UserError ("",Pp.str s))) (* Managing locality *) @@ -366,7 +366,7 @@ let use_locality_full () = r let use_locality () = - match use_locality_full () with Some true -> true | _ -> false + match use_locality_full () with Some true -> true | _ -> false let use_locality_exp () = local_of_bool (use_locality ()) @@ -374,16 +374,16 @@ let use_section_locality () = match use_locality_full () with Some b -> b | None -> Lib.sections_are_opened () let use_non_locality () = - match use_locality_full () with Some false -> false | _ -> true + match use_locality_full () with Some false -> false | _ -> true let enforce_locality () = let local = - match !locality_flag with + match !locality_flag with | Some false -> error "Cannot be simultaneously Local and Global." - | _ -> + | _ -> Flags.if_verbose - Pp.warning "Obsolete syntax: use \"Local\" as a prefix."; + Pp.warning "Obsolete syntax: use \"Local\" as a prefix."; true in locality_flag := None; local @@ -391,8 +391,8 @@ let enforce_locality () = let enforce_locality_exp () = local_of_bool (enforce_locality ()) let enforce_locality_of local = - let local = - match !locality_flag with + let local = + match !locality_flag with | Some false when local -> error "Cannot be simultaneously Local and Global." | Some true when local -> diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index 8520686d6d..211d20d39c 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -27,24 +27,24 @@ let vernac_tab = (string, Tacexpr.raw_generic_argument list -> unit -> unit) Hashtbl.t) let vinterp_add s f = - try + try Hashtbl.add vernac_tab s f with Failure _ -> errorlabstrm "vinterp_add" (str"Cannot add the vernac command " ++ str s ++ str" twice.") let overwriting_vinterp_add s f = - begin - try - let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s + begin + try + let _ = Hashtbl.find vernac_tab s in Hashtbl.remove vernac_tab s with Not_found -> () end; Hashtbl.add vernac_tab s f let vinterp_map s = - try + try Hashtbl.find vernac_tab s - with Not_found -> + with Not_found -> errorlabstrm "Vernac Interpreter" (str"Cannot find vernac command " ++ str s ++ str".") diff --git a/toplevel/vernacinterp.mli b/toplevel/vernacinterp.mli index 95c2f45d65..7adc74930e 100644 --- a/toplevel/vernacinterp.mli +++ b/toplevel/vernacinterp.mli @@ -13,11 +13,11 @@ open Tacexpr (*i*) (* Interpretation of extended vernac phrases. *) - + val disable_drop : exn -> exn val vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit -val overwriting_vinterp_add : +val overwriting_vinterp_add : string -> (raw_generic_argument list -> unit -> unit) -> unit val vinterp_init : unit -> unit diff --git a/toplevel/whelp.ml4 b/toplevel/whelp.ml4 index b7db4b431d..dac56e7d61 100644 --- a/toplevel/whelp.ml4 +++ b/toplevel/whelp.ml4 @@ -30,7 +30,7 @@ open Refiner open Tacmach open Syntax_def -(* Coq interface to the Whelp query engine developed at +(* Coq interface to the Whelp query engine developed at the University of Bologna *) let whelp_server_name = ref "http://mowgli.cs.unibo.it:58080" @@ -39,7 +39,7 @@ let getter_server_name = ref "http://mowgli.cs.unibo.it:58081" open Goptions let _ = - declare_string_option + declare_string_option { optsync = false; optname = "Whelp server"; optkey = ["Whelp";"Server"]; @@ -47,7 +47,7 @@ let _ = optwrite = (fun s -> whelp_server_name := s) } let _ = - declare_string_option + declare_string_option { optsync = false; optname = "Whelp getter"; optkey = ["Whelp";"Getter"]; @@ -61,7 +61,7 @@ let make_whelp_request req c = let b = Buffer.create 16 let url_char c = - if 'A' <= c & c <= 'Z' or 'a' <= c & c <= 'z' or + if 'A' <= c & c <= 'Z' or 'a' <= c & c <= 'z' or '0' <= c & c <= '9' or c ='.' then Buffer.add_char b c else Buffer.add_string b (Printf.sprintf "%%%2X" (Char.code c)) @@ -71,7 +71,7 @@ let url_string s = String.iter url_char s let rec url_list_with_sep sep f = function | [] -> () | [a] -> f a - | a::l -> f a; url_string sep; url_list_with_sep sep f l + | a::l -> f a; url_string sep; url_list_with_sep sep f l let url_id id = url_string (string_of_id id) @@ -81,10 +81,10 @@ let uri_of_dirpath dir = let error_whelp_unknown_reference ref = let qid = Nametab.shortest_qualid_of_global Idset.empty ref in errorlabstrm "" - (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++ + (strbrk "Definitions of the current session, like " ++ pr_qualid qid ++ strbrk ", are not supported in Whelp.") -let uri_of_repr_kn ref (mp,dir,l) = +let uri_of_repr_kn ref (mp,dir,l) = match mp with | MPfile sl -> uri_of_dirpath (id_of_label l :: repr_dirpath dir @ repr_dirpath sl) @@ -109,7 +109,7 @@ let uri_of_global ref = | VarRef id -> error ("Unknown Whelp reference: "^(string_of_id id)^".") | ConstRef cst -> uri_of_repr_kn ref (repr_con cst); url_string ".con" - | IndRef (kn,i) -> + | IndRef (kn,i) -> uri_of_repr_kn ref (repr_kn kn); uri_of_ind_pointer [1;i+1] | ConstructRef ((kn,i),j) -> uri_of_repr_kn ref (repr_kn kn); uri_of_ind_pointer [1;i+1;j] @@ -124,7 +124,7 @@ let uri_of_binding f (id,c) = url_id id; url_string "\\Assign "; f c let uri_params f = function | [] -> () - | l -> url_string "\\subst"; + | l -> url_string "\\subst"; url_bracket (url_list_with_sep ";" (uri_of_binding f)) l let get_discharged_hyp_names sp = List.map basename (get_discharged_hyps sp) @@ -151,7 +151,7 @@ let rec uri_of_constr c = | _ -> url_paren (fun () -> match c with | RApp (_,f,args) -> let inst,rest = merge (section_parameters f) args in - uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; + uri_of_constr f; url_char ' '; uri_params uri_of_constr inst; url_list_with_sep " " uri_of_constr rest | RLambda (_,na,k,ty,c) -> url_string "\\lambda "; url_of_name na; url_string ":"; @@ -170,7 +170,7 @@ let rec uri_of_constr c = error "Whelp does not support pattern-matching and (co-)fixpoint." | RVar _ | RRef _ | RHole _ | REvar _ | RSort _ | RCast (_,_, CastCoerce) -> anomaly "Written w/o parenthesis" - | RPatVar _ | RDynamic _ -> + | RPatVar _ | RDynamic _ -> anomaly "Found constructors not supported in constr") () let make_string f x = Buffer.reset b; f x; Buffer.contents b @@ -192,7 +192,7 @@ let whelp_constr_expr req c = let whelp_locate s = send_whelp "locate" s -let whelp_elim ind = +let whelp_elim ind = send_whelp "elim" (make_string uri_of_global (IndRef ind)) let on_goal f = @@ -215,13 +215,13 @@ VERNAC ARGUMENT EXTEND whelp_constr_request END VERNAC COMMAND EXTEND Whelp -| [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ] -| [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ] -| [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (Smartlocate.global_inductive_with_alias r) ] +| [ "Whelp" "Locate" string(s) ] -> [ whelp_locate s ] +| [ "Whelp" "Locate" preident(s) ] -> [ whelp_locate s ] +| [ "Whelp" "Elim" global(r) ] -> [ whelp_elim (Smartlocate.global_inductive_with_alias r) ] | [ "Whelp" whelp_constr_request(req) constr(c) ] -> [ whelp_constr_expr req c] END VERNAC COMMAND EXTEND WhelpHint -| [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ] -| [ "Whelp" "Hint" ] -> [ on_goal (whelp_constr "hint") ] +| [ "Whelp" "Hint" constr(c) ] -> [ whelp_constr_expr "hint" c ] +| [ "Whelp" "Hint" ] -> [ on_goal (whelp_constr "hint") ] END diff --git a/toplevel/whelp.mli b/toplevel/whelp.mli index 4ad615a621..2f1621a7af 100644 --- a/toplevel/whelp.mli +++ b/toplevel/whelp.mli @@ -8,7 +8,7 @@ (*i $Id$ i*) -(* Coq interface to the Whelp query engine developed at +(* Coq interface to the Whelp query engine developed at the University of Bologna *) open Names -- cgit v1.2.3