aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar glondu <glondu@85f007b7-540e-0410-9357-904b9bb8a0f7>2009-09-17 15:58:14 +0000
committerGravatar glondu <glondu@85f007b7-540e-0410-9357-904b9bb8a0f7>2009-09-17 15:58:14 +0000
commit61ccbc81a2f3b4662ed4a2bad9d07d2003dda3a2 (patch)
tree961cc88c714aa91a0276ea9fbf8bc53b2b9d5c28
parent6d3fbdf36c6a47b49c2a4b16f498972c93c07574 (diff)
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
-rw-r--r--checker/check.ml34
-rw-r--r--checker/check_stat.ml4
-rw-r--r--checker/checker.ml80
-rw-r--r--checker/closure.ml36
-rw-r--r--checker/closure.mli4
-rw-r--r--checker/declarations.ml170
-rw-r--r--checker/declarations.mli24
-rw-r--r--checker/environ.ml50
-rw-r--r--checker/indtypes.ml100
-rw-r--r--checker/inductive.ml146
-rw-r--r--checker/mod_checking.ml78
-rw-r--r--checker/modops.ml128
-rw-r--r--checker/modops.mli10
-rw-r--r--checker/reduction.ml40
-rw-r--r--checker/reduction.mli2
-rw-r--r--checker/safe_typing.ml24
-rw-r--r--checker/subtyping.ml102
-rw-r--r--checker/term.ml72
-rw-r--r--checker/type_errors.ml4
-rw-r--r--checker/type_errors.mli12
-rw-r--r--checker/typeops.ml62
-rw-r--r--dev/ocamlweb-doc/ast.ml4
-rw-r--r--dev/ocamlweb-doc/lex.mll4
-rw-r--r--dev/ocamlweb-doc/parse.ml2
-rw-r--r--dev/printers.mllib14
-rw-r--r--dev/top_printers.ml80
-rw-r--r--dev/vm_printers.ml18
-rw-r--r--doc/RecTutorial/RecTutorial.v202
-rw-r--r--doc/faq/interval_discr.v24
-rw-r--r--ide/command_windows.ml64
-rw-r--r--ide/config_lexer.mll8
-rw-r--r--ide/coq.ml124
-rw-r--r--ide/coq.mli8
-rw-r--r--ide/coq_commands.ml16
-rw-r--r--ide/coqide.ml1276
-rw-r--r--ide/coqide.mli2
-rw-r--r--ide/gtk_parsing.ml38
-rw-r--r--ide/highlight.mll54
-rw-r--r--ide/ideutils.ml122
-rw-r--r--ide/preferences.ml254
-rw-r--r--ide/tags.ml2
-rw-r--r--ide/typed_notebook.ml2
-rw-r--r--ide/undo.ml66
-rw-r--r--ide/undo_lablgtk_ge212.mli2
-rw-r--r--ide/undo_lablgtk_ge26.mli2
-rw-r--r--ide/undo_lablgtk_lt26.mli2
-rw-r--r--ide/utf8_convert.mll10
-rw-r--r--ide/utils/configwin.mli2
-rw-r--r--ide/utils/configwin_ihm.ml24
-rw-r--r--ide/utils/configwin_keys.ml50
-rw-r--r--ide/utils/configwin_types.ml6
-rw-r--r--ide/utils/editable_cells.ml92
-rw-r--r--ide/utils/okey.mli64
-rw-r--r--interp/constrextern.ml92
-rw-r--r--interp/constrextern.mli4
-rw-r--r--interp/constrintern.ml252
-rw-r--r--interp/constrintern.mli24
-rw-r--r--interp/coqlib.ml12
-rw-r--r--interp/dumpglob.ml36
-rw-r--r--interp/genarg.ml2
-rw-r--r--interp/genarg.mli22
-rw-r--r--interp/implicit_quantifiers.ml136
-rw-r--r--interp/interp.mllib6
-rw-r--r--interp/modintern.ml32
-rw-r--r--interp/modintern.mli2
-rw-r--r--interp/notation.ml68
-rw-r--r--interp/notation.mli20
-rw-r--r--interp/ppextend.ml2
-rw-r--r--interp/ppextend.mli2
-rw-r--r--interp/reserve.ml12
-rw-r--r--interp/smartlocate.ml4
-rw-r--r--interp/syntax_def.mli2
-rw-r--r--interp/topconstr.ml146
-rw-r--r--interp/topconstr.mli24
-rw-r--r--kernel/cbytecodes.ml60
-rw-r--r--kernel/cbytecodes.mli50
-rw-r--r--kernel/cbytegen.ml292
-rw-r--r--kernel/cbytegen.mli12
-rw-r--r--kernel/cemitcodes.ml52
-rw-r--r--kernel/cemitcodes.mli16
-rw-r--r--kernel/closure.ml30
-rw-r--r--kernel/closure.mli4
-rw-r--r--kernel/cooking.ml22
-rw-r--r--kernel/cooking.mli4
-rw-r--r--kernel/csymtable.ml68
-rw-r--r--kernel/csymtable.mli2
-rw-r--r--kernel/declarations.ml42
-rw-r--r--kernel/declarations.mli24
-rw-r--r--kernel/entries.ml8
-rw-r--r--kernel/entries.mli6
-rw-r--r--kernel/environ.ml194
-rw-r--r--kernel/environ.mli26
-rw-r--r--kernel/esubst.ml2
-rw-r--r--kernel/esubst.mli2
-rw-r--r--kernel/indtypes.ml142
-rw-r--r--kernel/inductive.ml160
-rw-r--r--kernel/inductive.mli2
-rw-r--r--kernel/mod_subst.ml132
-rw-r--r--kernel/mod_subst.mli14
-rw-r--r--kernel/mod_typing.ml144
-rw-r--r--kernel/mod_typing.mli2
-rw-r--r--kernel/modops.ml196
-rw-r--r--kernel/modops.mli24
-rw-r--r--kernel/names.ml48
-rw-r--r--kernel/names.mli12
-rw-r--r--kernel/pre_env.ml26
-rw-r--r--kernel/pre_env.mli14
-rw-r--r--kernel/reduction.ml50
-rw-r--r--kernel/reduction.mli6
-rw-r--r--kernel/retroknowledge.ml28
-rw-r--r--kernel/retroknowledge.mli38
-rw-r--r--kernel/safe_typing.ml200
-rw-r--r--kernel/safe_typing.mli30
-rw-r--r--kernel/subtyping.ml122
-rw-r--r--kernel/term.ml212
-rw-r--r--kernel/term.mli38
-rw-r--r--kernel/term_typing.ml20
-rw-r--r--kernel/term_typing.mli8
-rw-r--r--kernel/type_errors.ml4
-rw-r--r--kernel/type_errors.mli12
-rw-r--r--kernel/typeops.ml78
-rw-r--r--kernel/typeops.mli16
-rw-r--r--kernel/univ.ml122
-rw-r--r--kernel/univ.mli6
-rw-r--r--kernel/vconv.ml74
-rw-r--r--kernel/vm.ml172
-rw-r--r--kernel/vm.mli24
-rw-r--r--lib/bigint.ml26
-rw-r--r--lib/bstack.ml6
-rw-r--r--lib/compat.ml48
-rw-r--r--lib/dnet.ml58
-rw-r--r--lib/dnet.mli18
-rw-r--r--lib/dyn.ml2
-rw-r--r--lib/edit.ml16
-rw-r--r--lib/envars.ml50
-rw-r--r--lib/explore.ml18
-rw-r--r--lib/explore.mli8
-rw-r--r--lib/flags.ml4
-rw-r--r--lib/gmapl.ml2
-rw-r--r--lib/hashcons.ml6
-rw-r--r--lib/heap.ml54
-rw-r--r--lib/heap.mli20
-rw-r--r--lib/lib.mllib12
-rw-r--r--lib/option.ml28
-rw-r--r--lib/option.mli14
-rw-r--r--lib/pp.ml422
-rw-r--r--lib/pp.mli2
-rw-r--r--lib/pp_control.ml14
-rw-r--r--lib/pp_control.mli4
-rw-r--r--lib/predicate.ml2
-rw-r--r--lib/profile.ml54
-rw-r--r--lib/profile.mli6
-rw-r--r--lib/refutpat.ml42
-rw-r--r--lib/rtree.ml12
-rw-r--r--lib/rtree.mli4
-rw-r--r--lib/system.ml60
-rw-r--r--lib/system.mli8
-rw-r--r--lib/tlm.ml26
-rw-r--r--lib/util.ml340
-rw-r--r--lib/util.mli20
-rw-r--r--library/decl_kinds.ml2
-rw-r--r--library/decl_kinds.mli2
-rw-r--r--library/declare.ml16
-rw-r--r--library/declare.mli4
-rw-r--r--library/declaremods.ml334
-rw-r--r--library/declaremods.mli22
-rw-r--r--library/decls.ml2
-rw-r--r--library/decls.mli2
-rw-r--r--library/dischargedhypsmap.ml4
-rw-r--r--library/global.ml20
-rw-r--r--library/global.mli8
-rw-r--r--library/goptions.ml74
-rw-r--r--library/goptions.mli10
-rw-r--r--library/heads.ml22
-rw-r--r--library/impargs.ml96
-rw-r--r--library/impargs.mli8
-rw-r--r--library/lib.ml172
-rw-r--r--library/lib.mli12
-rw-r--r--library/libnames.ml30
-rw-r--r--library/libnames.mli8
-rw-r--r--library/libobject.ml50
-rw-r--r--library/libobject.mli20
-rw-r--r--library/library.ml80
-rw-r--r--library/library.mllib2
-rw-r--r--library/nameops.ml32
-rw-r--r--library/nametab.ml132
-rwxr-xr-xlibrary/nametab.mli22
-rw-r--r--library/states.ml4
-rw-r--r--library/states.mli4
-rw-r--r--library/summary.ml10
-rw-r--r--myocamlbuild.ml6
-rw-r--r--parsing/argextend.ml422
-rw-r--r--parsing/egrammar.ml32
-rw-r--r--parsing/egrammar.mli6
-rw-r--r--parsing/g_constr.ml480
-rw-r--r--parsing/g_decl_mode.ml496
-rw-r--r--parsing/g_ltac.ml422
-rw-r--r--parsing/g_prim.ml44
-rw-r--r--parsing/g_proofs.ml418
-rw-r--r--parsing/g_tactic.ml470
-rw-r--r--parsing/g_vernac.ml4182
-rw-r--r--parsing/g_xml.ml416
-rw-r--r--parsing/grammar.mllib6
-rw-r--r--parsing/lexer.ml464
-rw-r--r--parsing/pcoq.ml434
-rw-r--r--parsing/pcoq.mli22
-rw-r--r--parsing/ppconstr.ml76
-rw-r--r--parsing/ppconstr.mli18
-rw-r--r--parsing/ppdecl_proof.ml116
-rw-r--r--parsing/ppdecl_proof.mli2
-rw-r--r--parsing/pptactic.ml146
-rw-r--r--parsing/pptactic.mli16
-rw-r--r--parsing/ppvernac.ml196
-rw-r--r--parsing/ppvernac.mli2
-rw-r--r--parsing/prettyp.ml214
-rw-r--r--parsing/printer.ml118
-rw-r--r--parsing/printer.mli4
-rw-r--r--parsing/printmod.ml76
-rw-r--r--parsing/q_constr.ml434
-rw-r--r--parsing/q_coqast.ml446
-rw-r--r--parsing/q_util.ml42
-rw-r--r--parsing/tacextend.ml410
-rw-r--r--parsing/tactic_printer.ml72
-rw-r--r--parsing/vernacextend.ml42
-rw-r--r--plugins/cc/ccalgo.ml390
-rw-r--r--plugins/cc/ccalgo.mli62
-rw-r--r--plugins/cc/ccproof.ml56
-rw-r--r--plugins/cc/ccproof.mli8
-rw-r--r--plugins/cc/cctac.ml184
-rw-r--r--plugins/cc/cctac.mli2
-rw-r--r--plugins/cc/g_congruence.ml44
-rw-r--r--plugins/dp/Dp.v4
-rw-r--r--plugins/dp/dp.ml292
-rw-r--r--plugins/dp/dp_why.ml40
-rw-r--r--plugins/dp/dp_why.mli2
-rw-r--r--plugins/dp/dp_zenon.mll44
-rw-r--r--plugins/dp/fol.mli12
-rw-r--r--plugins/dp/g_dp.ml42
-rw-r--r--plugins/dp/test2.v6
-rw-r--r--plugins/dp/tests.v22
-rw-r--r--plugins/extraction/extraction.ml2
-rw-r--r--plugins/extraction/g_extraction.ml42
-rw-r--r--plugins/extraction/haskell.ml2
-rw-r--r--plugins/extraction/miniml.mli2
-rw-r--r--plugins/extraction/modutil.ml2
-rw-r--r--plugins/extraction/scheme.ml2
-rw-r--r--plugins/field/LegacyField_Compl.v4
-rw-r--r--plugins/field/LegacyField_Tactic.v10
-rw-r--r--plugins/field/LegacyField_Theory.v30
-rw-r--r--plugins/field/field.ml410
-rw-r--r--plugins/firstorder/formula.ml84
-rw-r--r--plugins/firstorder/formula.mli26
-rw-r--r--plugins/firstorder/g_ground.ml446
-rw-r--r--plugins/firstorder/ground.ml58
-rw-r--r--plugins/firstorder/ground_plugin.mllib2
-rw-r--r--plugins/firstorder/instances.ml72
-rw-r--r--plugins/firstorder/instances.mli4
-rw-r--r--plugins/firstorder/rules.ml56
-rw-r--r--plugins/firstorder/rules.mli2
-rw-r--r--plugins/firstorder/sequent.ml82
-rw-r--r--plugins/firstorder/sequent.mli6
-rw-r--r--plugins/firstorder/unify.ml72
-rw-r--r--plugins/fourier/Fourier_util.v50
-rw-r--r--plugins/fourier/fourier.ml20
-rw-r--r--plugins/fourier/fourierR.ml106
-rw-r--r--plugins/funind/Recdef.v12
-rw-r--r--plugins/funind/functional_principles_proofs.ml1168
-rw-r--r--plugins/funind/functional_principles_proofs.mli4
-rw-r--r--plugins/funind/functional_principles_types.ml480
-rw-r--r--plugins/funind/functional_principles_types.mli16
-rw-r--r--plugins/funind/g_indfun.ml4202
-rw-r--r--plugins/funind/indfun.ml600
-rw-r--r--plugins/funind/indfun_common.ml232
-rw-r--r--plugins/funind/indfun_common.mli52
-rw-r--r--plugins/funind/invfun.ml670
-rw-r--r--plugins/funind/merge.ml330
-rw-r--r--plugins/funind/rawterm_to_relation.ml1118
-rw-r--r--plugins/funind/rawterm_to_relation.mli4
-rw-r--r--plugins/funind/rawtermops.ml592
-rw-r--r--plugins/funind/rawtermops.mli60
-rw-r--r--plugins/funind/recdef.ml744
-rw-r--r--plugins/groebner/GroebnerR.v72
-rw-r--r--plugins/groebner/GroebnerZ.v4
-rw-r--r--plugins/groebner/groebner.ml442
-rw-r--r--plugins/groebner/ideal.ml4136
-rw-r--r--plugins/groebner/polynom.ml128
-rw-r--r--plugins/groebner/utile.ml20
-rw-r--r--plugins/interface/blast.ml282
-rw-r--r--plugins/interface/centaur.ml458
-rw-r--r--plugins/interface/coqparser.ml70
-rw-r--r--plugins/interface/dad.ml32
-rw-r--r--plugins/interface/debug_tac.ml446
-rw-r--r--plugins/interface/depends.ml4
-rw-r--r--plugins/interface/history.ml50
-rwxr-xr-xplugins/interface/line_parser.ml424
-rw-r--r--plugins/interface/name_to_ast.ml46
-rw-r--r--plugins/interface/paths.ml2
-rw-r--r--plugins/interface/pbp.ml120
-rw-r--r--plugins/interface/showproof.ml264
-rw-r--r--plugins/interface/showproof_ct.ml24
-rw-r--r--plugins/interface/translate.ml12
-rw-r--r--plugins/interface/xlate.ml368
-rw-r--r--plugins/micromega/Env.v24
-rw-r--r--plugins/micromega/EnvRing.v26
-rw-r--r--plugins/micromega/OrderedRing.v2
-rw-r--r--plugins/micromega/Psatz.v30
-rw-r--r--plugins/micromega/QMicromega.v4
-rw-r--r--plugins/micromega/RMicromega.v2
-rw-r--r--plugins/micromega/Refl.v2
-rw-r--r--plugins/micromega/RingMicromega.v118
-rw-r--r--plugins/micromega/Tauto.v30
-rw-r--r--plugins/micromega/VarMap.v36
-rw-r--r--plugins/micromega/ZCoeff.v2
-rw-r--r--plugins/micromega/ZMicromega.v132
-rw-r--r--plugins/micromega/certificate.ml358
-rw-r--r--plugins/micromega/coq_micromega.ml736
-rw-r--r--plugins/micromega/csdpcert.ml92
-rw-r--r--plugins/micromega/mfourier.ml516
-rw-r--r--plugins/micromega/micromega.ml10
-rw-r--r--plugins/micromega/mutils.ml126
-rw-r--r--plugins/micromega/persistent_cache.ml76
-rw-r--r--plugins/micromega/sos.ml14
-rw-r--r--plugins/micromega/sos.mli2
-rw-r--r--plugins/micromega/sos_lib.ml10
-rw-r--r--plugins/omega/OmegaLemmas.v38
-rw-r--r--plugins/omega/PreOmega.v204
-rw-r--r--plugins/omega/coq_omega.ml622
-rw-r--r--plugins/omega/g_omega.ml410
-rw-r--r--plugins/omega/omega.ml250
-rw-r--r--plugins/ring/LegacyArithRing.v4
-rw-r--r--plugins/ring/LegacyRing_theory.v20
-rw-r--r--plugins/ring/Ring_abstract.v14
-rw-r--r--plugins/ring/Ring_normalize.v28
-rw-r--r--plugins/ring/Setoid_ring_normalize.v22
-rw-r--r--plugins/ring/Setoid_ring_theory.v10
-rw-r--r--plugins/ring/g_ring.ml428
-rw-r--r--plugins/ring/ring.ml346
-rw-r--r--plugins/romega/ReflOmegaCore.v416
-rw-r--r--plugins/romega/const_omega.ml60
-rw-r--r--plugins/romega/const_omega.mli2
-rw-r--r--plugins/romega/g_romega.ml416
-rw-r--r--plugins/romega/refl_omega.ml498
-rw-r--r--plugins/rtauto/Bintree.v72
-rw-r--r--plugins/rtauto/Rtauto.v92
-rw-r--r--plugins/rtauto/proof_search.ml166
-rw-r--r--plugins/rtauto/proof_search.mli4
-rw-r--r--plugins/rtauto/refl_tauto.ml132
-rw-r--r--plugins/setoid_ring/ArithRing.v8
-rw-r--r--plugins/setoid_ring/BinList.v10
-rw-r--r--plugins/setoid_ring/Field_tac.v102
-rw-r--r--plugins/setoid_ring/Field_theory.v228
-rw-r--r--plugins/setoid_ring/InitialRing.v126
-rw-r--r--plugins/setoid_ring/RealField.v14
-rw-r--r--plugins/setoid_ring/Ring_polynom.v386
-rw-r--r--plugins/setoid_ring/Ring_tac.v54
-rw-r--r--plugins/setoid_ring/Ring_theory.v72
-rw-r--r--plugins/setoid_ring/ZArithRing.v10
-rw-r--r--plugins/setoid_ring/newring.ml498
-rw-r--r--plugins/subtac/equations.ml4354
-rw-r--r--plugins/subtac/eterm.ml94
-rw-r--r--plugins/subtac/eterm.mli8
-rw-r--r--plugins/subtac/g_eterm.ml42
-rw-r--r--plugins/subtac/g_subtac.ml430
-rw-r--r--plugins/subtac/subtac.ml82
-rw-r--r--plugins/subtac/subtac_cases.ml324
-rw-r--r--plugins/subtac/subtac_classes.ml58
-rw-r--r--plugins/subtac/subtac_classes.mli2
-rw-r--r--plugins/subtac/subtac_coercion.ml142
-rw-r--r--plugins/subtac/subtac_command.ml132
-rw-r--r--plugins/subtac/subtac_command.mli2
-rw-r--r--plugins/subtac/subtac_errors.ml6
-rw-r--r--plugins/subtac/subtac_obligations.ml208
-rw-r--r--plugins/subtac/subtac_obligations.mli14
-rw-r--r--plugins/subtac/subtac_pretyping.ml22
-rw-r--r--plugins/subtac/subtac_pretyping_F.ml130
-rw-r--r--plugins/subtac/subtac_utils.ml112
-rw-r--r--plugins/subtac/subtac_utils.mli4
-rw-r--r--plugins/subtac/test/ListDep.v8
-rw-r--r--plugins/subtac/test/ListsTest.v18
-rw-r--r--plugins/subtac/test/Mutind.v4
-rw-r--r--plugins/subtac/test/Test1.v2
-rw-r--r--plugins/subtac/test/euclid.v4
-rw-r--r--plugins/subtac/test/take.v2
-rw-r--r--plugins/subtac/test/wf.v2
-rw-r--r--plugins/syntax/ascii_syntax.ml8
-rw-r--r--plugins/syntax/nat_syntax.ml12
-rw-r--r--plugins/syntax/numbers_syntax.ml60
-rw-r--r--plugins/syntax/r_syntax.ml4
-rw-r--r--plugins/syntax/string_syntax.ml8
-rw-r--r--plugins/syntax/z_syntax.ml28
-rw-r--r--plugins/xml/acic.ml8
-rw-r--r--plugins/xml/acic2Xml.ml42
-rw-r--r--plugins/xml/cic2Xml.ml2
-rw-r--r--plugins/xml/cic2acic.ml26
-rw-r--r--plugins/xml/doubleTypeInference.ml44
-rw-r--r--plugins/xml/doubleTypeInference.mli2
-rw-r--r--plugins/xml/dumptree.ml422
-rw-r--r--plugins/xml/proof2aproof.ml20
-rw-r--r--plugins/xml/proofTree2Xml.ml46
-rw-r--r--plugins/xml/xmlcommand.ml32
-rw-r--r--pretyping/cases.ml174
-rw-r--r--pretyping/cases.mli2
-rw-r--r--pretyping/cbv.ml20
-rw-r--r--pretyping/classops.ml58
-rw-r--r--pretyping/classops.mli18
-rw-r--r--pretyping/clenv.ml46
-rw-r--r--pretyping/clenv.mli4
-rw-r--r--pretyping/coercion.ml64
-rw-r--r--pretyping/coercion.mli18
-rw-r--r--pretyping/detyping.ml152
-rw-r--r--pretyping/detyping.mli6
-rw-r--r--pretyping/evarconv.ml80
-rw-r--r--pretyping/evarconv.mli6
-rw-r--r--pretyping/evarutil.ml194
-rw-r--r--pretyping/evarutil.mli10
-rw-r--r--pretyping/evd.ml114
-rw-r--r--pretyping/evd.mli18
-rw-r--r--pretyping/indrec.ml250
-rw-r--r--pretyping/indrec.mli4
-rw-r--r--pretyping/inductiveops.ml36
-rw-r--r--pretyping/inductiveops.mli2
-rw-r--r--pretyping/matching.ml22
-rw-r--r--pretyping/matching.mli6
-rw-r--r--pretyping/pattern.ml24
-rw-r--r--pretyping/pattern.mli2
-rw-r--r--pretyping/pretype_errors.ml8
-rw-r--r--pretyping/pretype_errors.mli14
-rw-r--r--pretyping/pretyping.ml178
-rw-r--r--pretyping/pretyping.mli52
-rw-r--r--pretyping/rawterm.ml76
-rw-r--r--pretyping/rawterm.mli10
-rw-r--r--pretyping/recordops.ml68
-rwxr-xr-xpretyping/recordops.mli14
-rw-r--r--pretyping/reductionops.ml226
-rw-r--r--pretyping/reductionops.mli10
-rw-r--r--pretyping/retyping.ml6
-rw-r--r--pretyping/retyping.mli4
-rw-r--r--pretyping/tacred.ml150
-rw-r--r--pretyping/tacred.mli6
-rw-r--r--pretyping/term_dnet.ml102
-rw-r--r--pretyping/term_dnet.mli14
-rw-r--r--pretyping/termops.ml208
-rw-r--r--pretyping/termops.mli26
-rw-r--r--pretyping/typeclasses.ml108
-rw-r--r--pretyping/typeclasses.mli14
-rw-r--r--pretyping/typeclasses_errors.ml6
-rw-r--r--pretyping/typeclasses_errors.mli2
-rw-r--r--pretyping/typing.ml40
-rw-r--r--pretyping/typing.mli4
-rw-r--r--pretyping/unification.ml222
-rw-r--r--pretyping/unification.mli4
-rw-r--r--pretyping/vnorm.ml96
-rw-r--r--proofs/clenvtac.ml24
-rw-r--r--proofs/decl_expr.mli22
-rw-r--r--proofs/decl_mode.ml40
-rw-r--r--proofs/decl_mode.mli6
-rw-r--r--proofs/evar_refiner.ml12
-rw-r--r--proofs/evar_refiner.mli4
-rw-r--r--proofs/logic.ml166
-rw-r--r--proofs/logic.mli4
-rw-r--r--proofs/pfedit.ml78
-rw-r--r--proofs/pfedit.mli4
-rw-r--r--proofs/proof_trees.ml16
-rw-r--r--proofs/proof_type.ml6
-rw-r--r--proofs/proof_type.mli18
-rw-r--r--proofs/redexpr.ml20
-rw-r--r--proofs/refiner.ml248
-rw-r--r--proofs/refiner.mli12
-rw-r--r--proofs/tacexpr.ml28
-rw-r--r--proofs/tacmach.ml44
-rw-r--r--proofs/tacmach.mli4
-rw-r--r--proofs/tactic_debug.ml6
-rw-r--r--scripts/coqc.ml44
-rw-r--r--scripts/coqmktop.ml52
-rw-r--r--tactics/auto.ml370
-rw-r--r--tactics/auto.mli36
-rw-r--r--tactics/autorewrite.ml92
-rw-r--r--tactics/autorewrite.mli2
-rw-r--r--tactics/btermdn.ml54
-rw-r--r--tactics/btermdn.mli2
-rw-r--r--tactics/class_tactics.ml4220
-rw-r--r--tactics/contradiction.ml6
-rw-r--r--tactics/decl_interp.ml226
-rw-r--r--tactics/decl_proof_instr.ml822
-rw-r--r--tactics/decl_proof_instr.mli26
-rw-r--r--tactics/dhyp.ml40
-rw-r--r--tactics/dhyp.mli2
-rw-r--r--tactics/dn.ml36
-rw-r--r--tactics/dn.mli4
-rw-r--r--tactics/eauto.ml4172
-rw-r--r--tactics/eauto.mli2
-rw-r--r--tactics/elim.ml42
-rw-r--r--tactics/elim.mli2
-rw-r--r--tactics/eqdecide.ml454
-rw-r--r--tactics/equality.ml244
-rw-r--r--tactics/equality.mli24
-rw-r--r--tactics/evar_tactics.ml22
-rw-r--r--tactics/evar_tactics.mli2
-rw-r--r--tactics/extraargs.ml4108
-rw-r--r--tactics/extratactics.ml454
-rw-r--r--tactics/hiddentac.ml10
-rw-r--r--tactics/hiddentac.mli30
-rw-r--r--tactics/hipattern.ml4114
-rw-r--r--tactics/hipattern.mli40
-rw-r--r--tactics/inv.ml68
-rw-r--r--tactics/inv.mli2
-rw-r--r--tactics/leminv.ml86
-rw-r--r--tactics/leminv.mli2
-rw-r--r--tactics/nbtermdn.ml24
-rw-r--r--tactics/nbtermdn.mli2
-rw-r--r--tactics/refine.ml62
-rw-r--r--tactics/rewrite.ml4472
-rw-r--r--tactics/tacinterp.ml350
-rw-r--r--tactics/tacinterp.mli18
-rw-r--r--tactics/tacticals.ml70
-rw-r--r--tactics/tacticals.mli30
-rw-r--r--tactics/tactics.ml710
-rw-r--r--tactics/tactics.mli50
-rw-r--r--tactics/tauto.ml422
-rw-r--r--tactics/termdn.ml22
-rw-r--r--tactics/termdn.mli4
-rw-r--r--test-suite/bugs/closed/1519.v2
-rw-r--r--test-suite/bugs/closed/1780.v4
-rw-r--r--test-suite/bugs/closed/shouldfail/2006.v4
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1100.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1322.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1411.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1414.v22
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1425.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1446.v8
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1507.v12
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1568.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1576.v6
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1582.v6
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1618.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1634.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1683.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1738.v6
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1740.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1775.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1776.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1784.v12
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1791.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1844.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1901.v6
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1905.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1918.v30
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1925.v10
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1931.v4
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1935.v4
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1939.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1944.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1951.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/1981.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/2001.v8
-rw-r--r--test-suite/bugs/closed/shouldsucceed/2017.v6
-rw-r--r--test-suite/bugs/closed/shouldsucceed/2083.v4
-rw-r--r--test-suite/bugs/closed/shouldsucceed/2117.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/2139.v16
-rw-r--r--test-suite/bugs/closed/shouldsucceed/38.v2
-rw-r--r--test-suite/bugs/closed/shouldsucceed/846.v10
-rw-r--r--test-suite/bugs/opened/shouldnotfail/1416.v4
-rw-r--r--test-suite/bugs/opened/shouldnotfail/1501.v12
-rw-r--r--test-suite/bugs/opened/shouldnotfail/1596.v16
-rw-r--r--test-suite/bugs/opened/shouldnotfail/1671.v2
-rw-r--r--test-suite/complexity/injection.v6
-rw-r--r--test-suite/failure/Case5.v2
-rw-r--r--test-suite/failure/Case9.v2
-rw-r--r--test-suite/failure/guard.v2
-rw-r--r--test-suite/failure/inductive3.v2
-rw-r--r--test-suite/failure/proofirrelevance.v2
-rw-r--r--test-suite/failure/rewrite_in_hyp2.v2
-rw-r--r--test-suite/failure/subtyping.v6
-rw-r--r--test-suite/failure/subtyping2.v8
-rw-r--r--test-suite/failure/univ_include.v4
-rw-r--r--test-suite/failure/universes-buraliforti-redef.v8
-rw-r--r--test-suite/failure/universes-buraliforti.v8
-rw-r--r--test-suite/failure/universes3.v2
-rw-r--r--test-suite/ideal-features/Case9.v2
-rw-r--r--test-suite/ideal-features/complexity/evars_subst.v6
-rw-r--r--test-suite/ideal-features/eapply_evar.v4
-rw-r--r--test-suite/ideal-features/evars_subst.v6
-rw-r--r--test-suite/ideal-features/implicit_binders.v22
-rw-r--r--test-suite/ideal-features/universes.v4
-rw-r--r--test-suite/interactive/Evar.v2
-rw-r--r--test-suite/micromega/example.v22
-rw-r--r--test-suite/micromega/heap3_vcgen_25.v2
-rw-r--r--test-suite/micromega/qexample.v4
-rw-r--r--test-suite/micromega/rexample.v4
-rw-r--r--test-suite/micromega/square.v4
-rw-r--r--test-suite/micromega/zomicron.v4
-rw-r--r--test-suite/modules/PO.v8
-rw-r--r--test-suite/modules/Przyklad.v24
-rw-r--r--test-suite/modules/Tescik.v6
-rw-r--r--test-suite/modules/fun_objects.v2
-rw-r--r--test-suite/modules/injection_discriminate_inversion.v20
-rw-r--r--test-suite/modules/mod_decl.v10
-rw-r--r--test-suite/modules/modeq.v2
-rw-r--r--test-suite/modules/modul.v2
-rw-r--r--test-suite/modules/obj.v2
-rw-r--r--test-suite/modules/objects.v2
-rw-r--r--test-suite/modules/objects2.v2
-rw-r--r--test-suite/modules/sig.v4
-rw-r--r--test-suite/modules/sub_objects.v2
-rw-r--r--test-suite/modules/subtyping.v8
-rw-r--r--test-suite/output/Cases.v2
-rw-r--r--test-suite/output/Fixpoint.v2
-rw-r--r--test-suite/output/Notations.v12
-rw-r--r--test-suite/output/reduction.v2
-rw-r--r--test-suite/success/Abstract.v2
-rw-r--r--test-suite/success/AdvancedCanonicalStructure.v26
-rw-r--r--test-suite/success/AdvancedTypeClasses.v12
-rw-r--r--test-suite/success/Case12.v4
-rw-r--r--test-suite/success/Case15.v6
-rw-r--r--test-suite/success/Case17.v12
-rw-r--r--test-suite/success/Cases.v28
-rw-r--r--test-suite/success/CasesDep.v58
-rw-r--r--test-suite/success/Discriminate.v4
-rw-r--r--test-suite/success/Equations.v16
-rw-r--r--test-suite/success/Field.v10
-rw-r--r--test-suite/success/Fixpoint.v2
-rw-r--r--test-suite/success/Fourier.v4
-rw-r--r--test-suite/success/Funind.v98
-rw-r--r--test-suite/success/Hints.v4
-rw-r--r--test-suite/success/Inductive.v6
-rw-r--r--test-suite/success/Injection.v2
-rw-r--r--test-suite/success/Inversion.v14
-rw-r--r--test-suite/success/LegacyField.v10
-rw-r--r--test-suite/success/LetPat.v12
-rw-r--r--test-suite/success/Notations.v2
-rw-r--r--test-suite/success/Omega0.v44
-rw-r--r--test-suite/success/Omega2.v2
-rw-r--r--test-suite/success/OmegaPre.v2
-rw-r--r--test-suite/success/ProgramWf.v18
-rw-r--r--test-suite/success/Projection.v6
-rw-r--r--test-suite/success/ROmega.v2
-rw-r--r--test-suite/success/ROmega0.v44
-rw-r--r--test-suite/success/ROmega2.v4
-rw-r--r--test-suite/success/ROmegaPre.v2
-rw-r--r--test-suite/success/RecTutorial.v204
-rw-r--r--test-suite/success/Record.v16
-rw-r--r--test-suite/success/Simplify_eq.v4
-rw-r--r--test-suite/success/TestRefine.v8
-rw-r--r--test-suite/success/apply.v24
-rw-r--r--test-suite/success/cc.v19
-rw-r--r--test-suite/success/clear.v2
-rw-r--r--test-suite/success/coercions.v2
-rw-r--r--test-suite/success/conv_pbs.v48
-rw-r--r--test-suite/success/decl_mode.v40
-rw-r--r--test-suite/success/dependentind.v6
-rw-r--r--test-suite/success/destruct.v2
-rw-r--r--test-suite/success/eauto.v2
-rw-r--r--test-suite/success/evars.v18
-rw-r--r--test-suite/success/extraction.v106
-rw-r--r--test-suite/success/fix.v4
-rw-r--r--test-suite/success/hyps_inclusion.v6
-rw-r--r--test-suite/success/implicit.v4
-rw-r--r--test-suite/success/import_lib.v50
-rw-r--r--test-suite/success/induct.v2
-rw-r--r--test-suite/success/ltac.v10
-rw-r--r--test-suite/success/mutual_ind.v6
-rw-r--r--test-suite/success/parsing.v2
-rw-r--r--test-suite/success/refine.v12
-rw-r--r--test-suite/success/replace.v2
-rw-r--r--test-suite/success/setoid_ring_module.v4
-rw-r--r--test-suite/success/setoid_test.v2
-rw-r--r--test-suite/success/setoid_test2.v4
-rw-r--r--test-suite/success/setoid_test_function_space.v8
-rw-r--r--test-suite/success/simpl.v8
-rw-r--r--test-suite/success/specialize.v2
-rw-r--r--test-suite/success/unification.v18
-rw-r--r--test-suite/success/univers.v6
-rw-r--r--test-suite/typeclasses/clrewrite.v20
-rw-r--r--theories/Arith/Between.v6
-rw-r--r--theories/Arith/Compare_dec.v2
-rw-r--r--theories/Arith/Div2.v4
-rw-r--r--theories/Arith/Even.v20
-rw-r--r--theories/Arith/Lt.v2
-rw-r--r--theories/Arith/Max.v4
-rw-r--r--theories/Arith/Min.v2
-rw-r--r--theories/Arith/Minus.v4
-rw-r--r--theories/Arith/Mult.v12
-rw-r--r--theories/Arith/Plus.v10
-rw-r--r--theories/Arith/Wf_nat.v12
-rw-r--r--theories/Bool/Bool.v42
-rw-r--r--theories/Bool/Bvector.v28
-rw-r--r--theories/Bool/Sumbool.v8
-rw-r--r--theories/Classes/EquivDec.v24
-rw-r--r--theories/Classes/Equivalence.v20
-rw-r--r--theories/Classes/Functions.v2
-rw-r--r--theories/Classes/Init.v4
-rw-r--r--theories/Classes/Morphisms.v78
-rw-r--r--theories/Classes/Morphisms_Prop.v30
-rw-r--r--theories/Classes/Morphisms_Relations.v4
-rw-r--r--theories/Classes/RelationClasses.v50
-rw-r--r--theories/Classes/SetoidAxioms.v2
-rw-r--r--theories/Classes/SetoidClass.v12
-rw-r--r--theories/Classes/SetoidDec.v12
-rw-r--r--theories/Classes/SetoidTactics.v54
-rw-r--r--theories/FSets/FMapAVL.v670
-rw-r--r--theories/FSets/FMapFacts.v208
-rw-r--r--theories/FSets/FMapFullAVL.v264
-rw-r--r--theories/FSets/FMapInterface.v154
-rw-r--r--theories/FSets/FMapList.v454
-rw-r--r--theories/FSets/FMapPositive.v142
-rw-r--r--theories/FSets/FMapWeakList.v326
-rw-r--r--theories/FSets/FSetAVL.v626
-rw-r--r--theories/FSets/FSetBridge.v302
-rw-r--r--theories/FSets/FSetDecide.v42
-rw-r--r--theories/FSets/FSetEqProperties.v270
-rw-r--r--theories/FSets/FSetFacts.v62
-rw-r--r--theories/FSets/FSetFullAVL.v322
-rw-r--r--theories/FSets/FSetInterface.v100
-rw-r--r--theories/FSets/FSetList.v300
-rw-r--r--theories/FSets/FSetProperties.v160
-rw-r--r--theories/FSets/FSetToFiniteSet.v24
-rw-r--r--theories/FSets/FSetWeakList.v230
-rw-r--r--theories/FSets/OrderedType.v192
-rw-r--r--theories/FSets/OrderedTypeAlt.v34
-rw-r--r--theories/FSets/OrderedTypeEx.v34
-rw-r--r--theories/Init/Datatypes.v10
-rw-r--r--theories/Init/Logic_Type.v2
-rw-r--r--theories/Init/Specif.v14
-rw-r--r--theories/Init/Tactics.v40
-rw-r--r--theories/Init/Wf.v12
-rw-r--r--theories/Lists/List.v422
-rw-r--r--theories/Lists/ListSet.v24
-rw-r--r--theories/Lists/ListTactics.v6
-rw-r--r--theories/Lists/SetoidList.v110
-rw-r--r--theories/Lists/StreamMemo.v44
-rw-r--r--theories/Lists/Streams.v4
-rw-r--r--theories/Lists/TheoryList.v4
-rw-r--r--theories/Logic/Berardi.v6
-rw-r--r--theories/Logic/ChoiceFacts.v94
-rw-r--r--theories/Logic/ClassicalDescription.v8
-rw-r--r--theories/Logic/ClassicalEpsilon.v16
-rw-r--r--theories/Logic/ClassicalFacts.v48
-rw-r--r--theories/Logic/ClassicalUniqueChoice.v2
-rw-r--r--theories/Logic/Classical_Pred_Type.v2
-rw-r--r--theories/Logic/Classical_Prop.v8
-rw-r--r--theories/Logic/Decidable.v24
-rw-r--r--theories/Logic/DecidableType.v26
-rw-r--r--theories/Logic/DecidableTypeEx.v24
-rw-r--r--theories/Logic/Description.v2
-rw-r--r--theories/Logic/Diaconescu.v36
-rw-r--r--theories/Logic/Epsilon.v10
-rw-r--r--theories/Logic/EqdepFacts.v50
-rw-r--r--theories/Logic/Eqdep_dec.v24
-rw-r--r--theories/Logic/FunctionalExtensionality.v14
-rw-r--r--theories/Logic/IndefiniteDescription.v4
-rw-r--r--theories/Logic/JMeq.v6
-rw-r--r--theories/Logic/ProofIrrelevanceFacts.v4
-rw-r--r--theories/Logic/RelationalChoice.v2
-rw-r--r--theories/NArith/BinNat.v14
-rw-r--r--theories/NArith/BinPos.v86
-rw-r--r--theories/NArith/Ndec.v20
-rw-r--r--theories/NArith/Ndigits.v94
-rw-r--r--theories/NArith/Ndist.v18
-rw-r--r--theories/NArith/Nnat.v38
-rw-r--r--theories/NArith/Pnat.v28
-rw-r--r--theories/Numbers/BigNumPrelude.v68
-rw-r--r--theories/Numbers/Cyclic/Abstract/CyclicAxioms.v46
-rw-r--r--theories/Numbers/Cyclic/Abstract/NZCyclic.v8
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v70
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v90
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v164
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v306
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v140
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v62
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v110
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v84
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v72
-rw-r--r--theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v14
-rw-r--r--theories/Numbers/Cyclic/Int31/Cyclic31.v422
-rw-r--r--theories/Numbers/Cyclic/Int31/Int31.v126
-rw-r--r--theories/Numbers/Cyclic/ZModulo/ZModulo.v222
-rw-r--r--theories/Numbers/Integer/BigZ/ZMake.v68
-rw-r--r--theories/Numbers/Integer/SpecViaZ/ZSig.v8
-rw-r--r--theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v6
-rw-r--r--theories/Numbers/NaryFunctions.v66
-rw-r--r--theories/Numbers/NatInt/NZAxioms.v2
-rw-r--r--theories/Numbers/Natural/Abstract/NOrder.v2
-rw-r--r--theories/Numbers/Natural/BigN/NMake_gen.ml186
-rw-r--r--theories/Numbers/Natural/BigN/Nbasic.v62
-rw-r--r--theories/Numbers/Natural/SpecViaZ/NSig.v4
-rw-r--r--theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v4
-rw-r--r--theories/Numbers/Rational/BigQ/QMake.v202
-rw-r--r--theories/Numbers/Rational/SpecViaQ/QSig.v6
-rw-r--r--theories/Program/Basics.v6
-rw-r--r--theories/Program/Combinators.v2
-rw-r--r--theories/Program/Equality.v154
-rw-r--r--theories/Program/Subset.v26
-rw-r--r--theories/Program/Tactics.v48
-rw-r--r--theories/Program/Wf.v40
-rw-r--r--theories/QArith/QArith_base.v4
-rw-r--r--theories/QArith/Qcanon.v50
-rw-r--r--theories/QArith/Qfield.v10
-rw-r--r--theories/QArith/Qpower.v8
-rw-r--r--theories/QArith/Qreals.v6
-rw-r--r--theories/QArith/Qreduction.v18
-rw-r--r--theories/Reals/Alembert.v24
-rw-r--r--theories/Reals/AltSeries.v14
-rw-r--r--theories/Reals/ArithProp.v10
-rw-r--r--theories/Reals/Binomial.v2
-rw-r--r--theories/Reals/Cauchy_prod.v4
-rw-r--r--theories/Reals/Cos_plus.v94
-rw-r--r--theories/Reals/Cos_rel.v250
-rw-r--r--theories/Reals/DiscrR.v8
-rw-r--r--theories/Reals/Exp_prop.v6
-rw-r--r--theories/Reals/Integration.v2
-rw-r--r--theories/Reals/MVT.v24
-rw-r--r--theories/Reals/NewtonInt.v14
-rw-r--r--theories/Reals/PSeries_reg.v14
-rw-r--r--theories/Reals/PartSum.v16
-rw-r--r--theories/Reals/RIneq.v42
-rw-r--r--theories/Reals/RList.v30
-rw-r--r--theories/Reals/R_Ifp.v124
-rw-r--r--theories/Reals/R_sqr.v28
-rw-r--r--theories/Reals/R_sqrt.v16
-rw-r--r--theories/Reals/Ranalysis.v24
-rw-r--r--theories/Reals/Ranalysis1.v54
-rw-r--r--theories/Reals/Ranalysis2.v20
-rw-r--r--theories/Reals/Ranalysis3.v12
-rw-r--r--theories/Reals/Ranalysis4.v26
-rw-r--r--theories/Reals/Raxioms.v12
-rw-r--r--theories/Reals/Rbasic_fun.v88
-rw-r--r--theories/Reals/Rdefinitions.v4
-rw-r--r--theories/Reals/Rderiv.v106
-rw-r--r--theories/Reals/Reals.v2
-rw-r--r--theories/Reals/Rfunctions.v14
-rw-r--r--theories/Reals/Rgeom.v6
-rw-r--r--theories/Reals/RiemannInt.v210
-rw-r--r--theories/Reals/RiemannInt_SF.v274
-rw-r--r--theories/Reals/Rlimit.v56
-rw-r--r--theories/Reals/Rlogic.v4
-rw-r--r--theories/Reals/Rpower.v30
-rw-r--r--theories/Reals/Rprod.v22
-rw-r--r--theories/Reals/Rseries.v28
-rw-r--r--theories/Reals/Rsqrt_def.v10
-rw-r--r--theories/Reals/Rtopology.v194
-rw-r--r--theories/Reals/Rtrigo.v128
-rw-r--r--theories/Reals/Rtrigo_alt.v28
-rw-r--r--theories/Reals/Rtrigo_calc.v14
-rw-r--r--theories/Reals/Rtrigo_def.v12
-rw-r--r--theories/Reals/Rtrigo_fun.v16
-rw-r--r--theories/Reals/Rtrigo_reg.v10
-rw-r--r--theories/Reals/SeqSeries.v10
-rw-r--r--theories/Reals/Sqrt_reg.v16
-rw-r--r--theories/Relations/Operators_Properties.v44
-rw-r--r--theories/Relations/Relation_Definitions.v26
-rw-r--r--theories/Relations/Relation_Operators.v14
-rw-r--r--theories/Setoids/Setoid.v18
-rw-r--r--theories/Sets/Classical_sets.v4
-rw-r--r--theories/Sets/Constructive_sets.v12
-rw-r--r--theories/Sets/Cpo.v10
-rw-r--r--theories/Sets/Ensembles.v36
-rw-r--r--theories/Sets/Finite_sets.v2
-rw-r--r--theories/Sets/Finite_sets_facts.v8
-rw-r--r--theories/Sets/Image.v24
-rw-r--r--theories/Sets/Infinite_sets.v12
-rw-r--r--theories/Sets/Integers.v20
-rw-r--r--theories/Sets/Multiset.v26
-rw-r--r--theories/Sets/Partial_Order.v12
-rw-r--r--theories/Sets/Permut.v10
-rw-r--r--theories/Sets/Powerset_Classical_facts.v30
-rw-r--r--theories/Sets/Powerset_facts.v40
-rw-r--r--theories/Sets/Relations_1.v24
-rw-r--r--theories/Sets/Relations_2_facts.v2
-rw-r--r--theories/Sets/Relations_3.v16
-rw-r--r--theories/Sets/Uniset.v10
-rw-r--r--theories/Sorting/Heap.v20
-rw-r--r--theories/Sorting/PermutEq.v40
-rw-r--r--theories/Sorting/PermutSetoid.v34
-rw-r--r--theories/Sorting/Permutation.v50
-rw-r--r--theories/Sorting/Sorting.v4
-rw-r--r--theories/Strings/Ascii.v24
-rw-r--r--theories/Strings/String.v40
-rw-r--r--theories/Unicode/Utf8.v4
-rw-r--r--theories/Wellfounded/Disjoint_Union.v8
-rw-r--r--theories/Wellfounded/Inclusion.v2
-rw-r--r--theories/Wellfounded/Inverse_Image.v4
-rw-r--r--theories/Wellfounded/Lexicographic_Exponentiation.v78
-rw-r--r--theories/Wellfounded/Lexicographic_Product.v26
-rw-r--r--theories/Wellfounded/Transitive_Closure.v2
-rw-r--r--theories/Wellfounded/Union.v10
-rw-r--r--theories/Wellfounded/Well_Ordering.v6
-rw-r--r--theories/ZArith/BinInt.v54
-rw-r--r--theories/ZArith/Int.v178
-rw-r--r--theories/ZArith/Wf_Z.v8
-rw-r--r--theories/ZArith/ZArith_base.v2
-rw-r--r--theories/ZArith/ZArith_dec.v8
-rw-r--r--theories/ZArith/ZOdiv.v196
-rw-r--r--theories/ZArith/ZOdiv_def.v32
-rw-r--r--theories/ZArith/Zabs.v20
-rw-r--r--theories/ZArith/Zbinary.v64
-rw-r--r--theories/ZArith/Zcompare.v30
-rw-r--r--theories/ZArith/Zcomplements.v30
-rw-r--r--theories/ZArith/Zdiv.v130
-rw-r--r--theories/ZArith/Zeven.v36
-rw-r--r--theories/ZArith/Zgcd_alt.v54
-rw-r--r--theories/ZArith/Zhints.v134
-rw-r--r--theories/ZArith/Zlogarithm.v20
-rw-r--r--theories/ZArith/Zmax.v12
-rw-r--r--theories/ZArith/Zmin.v10
-rw-r--r--theories/ZArith/Zminmax.v12
-rw-r--r--theories/ZArith/Zmisc.v14
-rw-r--r--theories/ZArith/Znat.v22
-rw-r--r--theories/ZArith/Znumtheory.v214
-rw-r--r--theories/ZArith/Zorder.v38
-rw-r--r--theories/ZArith/Zpow_def.v8
-rw-r--r--theories/ZArith/Zpow_facts.v56
-rw-r--r--theories/ZArith/Zpower.v28
-rw-r--r--theories/ZArith/Zsqrt.v4
-rw-r--r--theories/ZArith/Zwf.v2
-rw-r--r--theories/ZArith/auxiliary.v4
-rw-r--r--tools/coq_makefile.ml486
-rw-r--r--tools/coq_tex.ml434
-rw-r--r--tools/coqdep.ml34
-rw-r--r--tools/coqdep_common.ml64
-rwxr-xr-xtools/coqdep_lexer.mll32
-rw-r--r--tools/coqdoc/alpha.ml4
-rw-r--r--tools/coqdoc/cdglobals.ml2
-rw-r--r--tools/coqdoc/cpretty.mll432
-rw-r--r--tools/coqdoc/index.mli8
-rw-r--r--tools/coqdoc/index.mll222
-rw-r--r--tools/coqdoc/main.ml148
-rw-r--r--tools/coqdoc/output.ml234
-rw-r--r--tools/coqwc.mll72
-rw-r--r--tools/gallina.ml22
-rw-r--r--tools/gallina_lexer.mll32
-rw-r--r--toplevel/auto_ind_decl.ml390
-rw-r--r--toplevel/auto_ind_decl.mli10
-rw-r--r--toplevel/autoinstance.ml70
-rw-r--r--toplevel/cerrors.ml68
-rw-r--r--toplevel/class.ml36
-rw-r--r--toplevel/class.mli2
-rw-r--r--toplevel/classes.ml102
-rw-r--r--toplevel/classes.mli8
-rw-r--r--toplevel/command.ml252
-rw-r--r--toplevel/command.mli16
-rw-r--r--toplevel/coqinit.ml58
-rw-r--r--toplevel/coqtop.ml44
-rw-r--r--toplevel/coqtop.mli6
-rw-r--r--toplevel/discharge.ml14
-rw-r--r--toplevel/discharge.mli2
-rw-r--r--toplevel/himsg.ml68
-rw-r--r--toplevel/himsg.mli4
-rw-r--r--toplevel/ind_tables.ml20
-rw-r--r--toplevel/ind_tables.mli12
-rw-r--r--toplevel/libtypes.ml38
-rw-r--r--toplevel/libtypes.mli6
-rw-r--r--toplevel/line_oriented_parser.ml2
-rw-r--r--toplevel/metasyntax.ml80
-rw-r--r--toplevel/metasyntax.mli4
-rw-r--r--toplevel/mltop.ml432
-rw-r--r--toplevel/mltop.mli4
-rw-r--r--toplevel/protectedtoplevel.ml20
-rw-r--r--toplevel/record.ml64
-rw-r--r--toplevel/record.mli8
-rw-r--r--toplevel/search.ml62
-rw-r--r--toplevel/search.mli6
-rw-r--r--toplevel/toplevel.ml92
-rw-r--r--toplevel/toplevel.mli2
-rw-r--r--toplevel/usage.ml10
-rw-r--r--toplevel/vernac.ml32
-rw-r--r--toplevel/vernac.mli2
-rw-r--r--toplevel/vernacentries.ml254
-rw-r--r--toplevel/vernacentries.mli2
-rw-r--r--toplevel/vernacexpr.ml44
-rw-r--r--toplevel/vernacinterp.ml12
-rw-r--r--toplevel/vernacinterp.mli4
-rw-r--r--toplevel/whelp.ml434
-rw-r--r--toplevel/whelp.mli2
973 files changed, 29073 insertions, 29074 deletions
diff --git a/checker/check.ml b/checker/check.ml
index 82df62b4c..0a75f0137 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 6ea153a3a..290e6ff8e 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 85ad129c9..1df187328 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"<unknown>")
- 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 591b353db..b55c5848e 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 fa302de64..260d159b3 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 8cbc964f4..0066e7848 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 c5b676bda..3d061b4c2 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 4bdbeee66..2d5ff3e43 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 9ff21bc3f..3d4f6be79 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 f1c8bea2a..e08efbe5b 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 9e7a23363..99babe632 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 498bd7753..a986e1898 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 17b063e2a..d5c9f4de6 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 d81cfe352..612e7562f 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 47590edb3..81c93ee53 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 f4ffb302c..b0d683ff3 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 edf119c66..88989b32e 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 f5b2496c8..92d898b31 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<n+m then raise LocalOccur
| _ -> 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<n+m then raise LocalOccur
| App(f,cl) ->
@@ -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 a96bba6a4..7c0141055 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 2d8f8ff22..0482f2f2a 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 1832ebec4..3a4f2f825 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 2153ef47c..4eb135d83 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 617163e7e..059526d9b 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 e537b1f2f..b145fffda 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 f4b3d7f6c..107b2904a 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 b35d5d489..d5ebde7cb 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 1e1144895..266bd1043 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 7bede1737..28aaf7520 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 972300dac..ed2c0e37e 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 ab65fa143..ee07b3fb8 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 8e04331c1..97aeb2f5a 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 "@[<hov 2>%s = %a@]@\n" k print_list s) m;
fprintf fmt "@.";
close_out c
diff --git a/ide/coq.ml b/ide/coq.ml
index 4fd48a306..a567fb4f5 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 df369cc18..c2f96a1fe 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 80ac5a200..e4a3ae56a 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 c0dfb9e6e..4b08f4b9b 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:"<CoqIde MenuBar>/" 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:"<CoqIde MenuBar>/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:"<CoqIde MenuBar>/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:"<CoqIde MenuBar>/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:"<CoqIde MenuBar>/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 "<Proof _Wizard>"
~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:"<CoqIde MenuBar>/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:"<CoqIde MenuBar>/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:"<CoqIde MenuBar>/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:"<CoqIde MenuBar>/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:"<CoqIde MenuBar>/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:"<CoqIde MenuBar>/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 d84158a0b..4c01e747a 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 8da4d9dda..e92a345e3 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 44018ff09..21516f7cf 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 ebf789fb3..14e803899 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 daa3839e0..bb35ed246 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 () -> ["<edit me>"])
- "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 89adad2c1..b0b9dc6fb 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 edc5c599c..39e8155d3 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 d2fe81e1d..18c2f7a4d 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 916a06e92..32717fa8e 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 e949daafe..52bd67215 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 82bcf2384..46ecfb1d7 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 c6e4b803b..82b305347 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 2d4dd4a78..386ef82af 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 3ab3823de..ff74a3c33 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 e1d7f33bb..9f44e5c6b 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 0def0b25d..bf2b74ee6 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 5441f4abe..1ab107c77 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 c8d48389c..84ea4df44 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 0d2fecfa2..0e61905c7 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 a56923fe5..08a74e614 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 e4e625205..e49f219af 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 bfccf03d1..b39f6e18b 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 6879dc965..b44cabe8b 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 79b58da84..9faea5406 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 c6dc12164..091a5c873 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 e6747db17..48e5b3c31 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 a550111a3..7b1a1ff4c 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 991cfac57..3825f3d87 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 3482dd3a0..041e32bf6 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 1f27e3c18..f39205d8b 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 58c28149d..8dec15b60 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 57e0deb10..f3036f226 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 baef2c628..a4142d694 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 bddd1eef2..3d09587d0 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 93fc60dfb..9d8412825 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 07ae87fa0..f16f5363c 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 3ba78e91d..747f7b9da 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 eb46a5d6e..bea0eae31 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<nl))
or (error
"Both ends of the recursive pattern differ in more than one place")
@@ -188,7 +188,7 @@ let aconstr_and_vars_of_rawconstr a =
let found = ref [] in
let rec aux = function
| RVar (_,id) -> 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 0b6cf46c5..2c28b3bea 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 ceba6e82a..f4d0bb2b2 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 "@[<v 0>%a@]" instruction_list c
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index c24b5a530..f4dc0b14d 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 721134252..a7e8b0b26 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 dfdcb0747..f33fd6cb0 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 7617c454d..89264e88b 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 ca6da65e1..965228fa1 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 c4759fa92..bce564397 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 ede0d6379..b6ff1fa15 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 edd3e498d..e42a732d3 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 4afdaa55e..23b1f2534 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 26b997f0f..58a5bf327 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 2640a4df1..894a33ef5 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 8b2402bb5..c48c01d78 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 454debd73..c7e27db6b 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 e30fe7737..26e9a6250 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 dc1522dbf..291ff0d45 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 de833c540..fb51660b3 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 9e1afdf19..0ae285528 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 dc29e4e98..c8b5fb269 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 75d460ce6..bf1d23241 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 ccf9b3f6c..c202d627d 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 6da102a94..19e4130ff 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 f877b5391..9f8d10900 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 2ac7b623b..238aa3544 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 6ae9649d6..d30168a1b 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 f4f52d83d..3d55fb69a 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 eef16dd8f..1fadec2ad 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 97697f5de..3f38cc2f7 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 11f0ddd17..4cd72a2ef 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 953c13aa9..0d61a29aa 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 d0efe2380..fb3b5c81b 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 0c0126762..421672201 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 518c6330d..abbf9b1b5 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 89f1b443b..0a404fff3 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 996051329..f2c9df156 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 44d13a0cb..a3e493db9 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 2baf38285..0f1cdc8e2 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 7469e1218..e73689bc8 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 07f82876f..ac1e3863a 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 1f77c3e43..861dc9a3f 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 8a2c3278c..68ea2ed3f 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<n+m then raise LocalOccur
| _ -> 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<n+m then raise LocalOccur
| App(f,cl) ->
@@ -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 bc1cac44a..5929250db 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 <p>Case c of lc1 | lc2 .. | lcn end *)
val destCase : constr -> case_info * constr * constr * constr array
-(* Destructs the $i$th function of the block
+(* 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 ccc62b756..c465adfac 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 abff3e8b7..69b13e3b8 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 116a74947..2d26d27e1 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 38bd0d394..9c7b6561c 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 53f230baa..27db208c6 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 23c755690..b0f15e75d 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 24af5da05..ef2024c7a 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 225dce9a6..2bfcc2aa8 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 7c515735d..0dd119f7b 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 665e00a30..576c20997 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 279ac9370..84de8f270 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 3b974652b..f505bbe14 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 b4232ebcf..4191ccdb1 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 481b9f8d4..7566624b8 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 b5a7bb728..0236cdab3 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 a01bbb0e2..b2f271472 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 1e3aa294d..d2bd458a7 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 e6f2907ec..fd870a21b 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 d700ffe16..2e680ad05 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 51ff79e32..760495099 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 907e2f256..e29f27955 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 dac88a473..1bf393fd0 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 8fc2daf96..cec10d644 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 c7cd14542..921a4ed56 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 47718bf3e..7ddb4a720 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 0bef2edb2..777e356de 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 1f203ec8d..2321abd1b 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 3d9803425..2a530b89b 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 04f3ca37d..8002a7ea2 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 20a97810e..b0948b0f4 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 ab2804a53..66d9bfa67 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 7617d5ca4..ecc546491 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 b43584f34..5c481b89a 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 b2e40d3cf..af66c0f28 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 80ae6b4b4..fdea309b8 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 ab2af2398..3647756f7 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 f2575def4..7c6801a8b 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 4832fe58d..ad4d31338 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 db5475b79..de5a9aa38 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 982a607f9..4afae3918 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 7556ed9e4..2932d7b66 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 95092a885..1c1483ad4 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 b161b966e..ddf44eec3 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<i then ar.(j)
- else if j=i then
+ Local i ->
+ let copy j =
+ if j<i then ar.(j)
+ else if j=i then
match !aux with Some a' -> a' | None -> failwith "Error"
else f (ar.(j))
in
@@ -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 5e32a1b0e..4579982bc 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 03b14e31c..5fd27f467 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 e42cb9621..0ebab9ca0 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 44536ce5b..49b7d7ba2 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 94457a9f8..1a68f8e20 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 6275c4b77..37ee34d1f 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 058bfa6ad..5cda0d28d 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 d5d0cb096..251c86aba 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 3ccff1f27..a9000604f 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 ed375a831..85de6ab8f 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 ec41c0706..e228de23a 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 deafacba2..3c2317122 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 86012b113..e4c5a6155 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 eba44a896..511986a57 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 c63634458..bca6b6502 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 aedb2d5a8..edd0aba0e 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 9f67eb462..6d2b01e8f 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 197e4c3f1..20c6bf1e4 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 f4d4900c3..0e2e304cd 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 0404d7cd8..2b335ea6c 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 b93ee87ee..43ca252c1 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 504c1ffdd..95894294b 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 41442fe53..6211ab378 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 831687723..9604a990c 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 1fc63929f..4efb69a21 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 563fa0210..bc28ed98c 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 074386417..31915c95a 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 774b148a5..98a482896 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 4fbc4c886..c4e766095 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 17f62b512..782e41ca7 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 784d79d87..e9b0bbd36 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 104231f97..963adcc7c 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 539b203d0..89edbb123 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 87e8e1deb..8d90499dc 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 e632e5bb8..14e4cfd37 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 f91f0170c..7e2b41926 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 91433b8a6..e812faeac 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 f869dc8e8..7f63428c8 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 168e532a8..8446bf50c 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 d4232eb95..90245fa45 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 846246ed0..c61bff02d 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 0ebbaba92..4cd798e3e 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 814236835..0f7029041 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 4356db844..0c815d262 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 4b40102ee..4edfbc748 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 6b5d03d91..1b53772f4 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 cfd05f4f7..b62548086 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 74a4d5e5d..80e1eb144 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 ad2afa97d..5767c9955 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 31fd4561e..40c712cdf 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 b0f0e110c..fd6fb6637 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 bed5e1b28..f113908f8 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 b672e9c23..081d5fd3b 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 26fa53550..95e921a24 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 48e3698d4..c24744f30 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 0518da327..12a3bb572 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 b23f94a70..eacad74c4 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 32f051948..1797eaf22 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 2ec914d6c..a5470a892 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 a796cef82..093910b4d 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 91cb681a5..cd3e7d2a8 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 469449749..7b9037d92 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 ("<Q_util." ^ name ^ ", not impl: " ^ desc)
diff --git a/parsing/tacextend.ml4 b/parsing/tacextend.ml4
index d52ab8dd7..517e34aa2 100644
--- a/parsing/tacextend.ml4
+++ b/parsing/tacextend.ml4
@@ -43,7 +43,7 @@ let rec make_let e = function
let loc = join_loc loc (MLast.loc_of_expr e) in
let e = make_let e l in
let v = <:expr< Genarg.out_gen $make_wit loc t$ $lid:p$ >> in
- let v =
+ 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 49cec626f..c09b3431e 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 "<Daimon>"
- | 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"<Your Proof Text here>")
- 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"<Your Tactic Text here>")
- else
+ (if nochange then
+ (str"<Your Tactic Text here>")
+ else
pr_change pf.goal)
++ fnl ()
| Some(Decl_proof opened,script) ->
assert (List.length script = 1);
begin
- if nochange then (mt ()) else (pr_change pf.goal ++ fnl ())
+ 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"<Your Tactic Text here>"
else str"<Your Proof Text here>"
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 dd05d5cd7..e8a3094b9 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 418980c54..9cc6f9de9 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 3bd52b6e1..5f56c7e69 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 1e57aa6cb..2a019ebff 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 7fd28390f..2a0ca688c 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 515d4aa93..4e6ea8022 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 7cdd46ab4..7ed077bda 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 f23ed49b6..d9db927a3 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 47d67725f..bc7d73f62 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 a7e1a8206..dc4698c5e 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_<number>'
+ (* [CM 07/09/2009] deactivated because it generates
+ unbound identifiers 'abstraction_<number>'
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 94dc0ef48..4a1d70d41 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 "@[<hov 2>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 b38a3d376..0efa24a23 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 658534151..949e91e34 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 32637bb74..4fb763a6d 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 e027c882e..505b07a14 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 3e4c0f6dd..0940b1352 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 1a796094b..dc85d2ee2 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 ffaefd5e3..3468e8a36 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 2b561616b..60a2e91a2 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 6403e7bbe..9d45c08b7 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 12ca9ad75..55231d766 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 0394ea4b7..1b1a39770 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 eaa47f5f9..50339d473 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 746e7c997..d4a39296a 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 63d9bdda6..5c1f228ac 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 131ba84b8..378efa035 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 7401491e4..2b4651dfb 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 0be3a4b39..45365cb2c 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 9e9d1e122..2e89ddb06 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 8302da5c1..c986a3026 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<auto with *>>)
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 a8d5fc2ef..8a0f02d27 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 1647e0f3d..447a1fb51 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 3e087cd8b..810262a69 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 aed2ec83d..95dd22ea8 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 75d69099a..515efea70 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 b804c93ae..fc32621ca 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 98b178bde..685d44a84 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 206de27ed..ce0eddccc 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 782129e5c..e3a4c6a55 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<j then bind j nt1
else bind i nt2
| Meta i,_ ->
let t=subst_meta !sigma nt2 in
- if Intset.is_empty (free_rels t) &&
+ 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<m1 || isMeta t in
List.for_all p sigma
diff --git a/plugins/fourier/Fourier_util.v b/plugins/fourier/Fourier_util.v
index c592af09a..0fd92d606 100644
--- a/plugins/fourier/Fourier_util.v
+++ b/plugins/fourier/Fourier_util.v
@@ -12,17 +12,17 @@ Require Export Rbase.
Comments "Lemmas used by the tactic Fourier".
Open Scope R_scope.
-
+
Lemma Rfourier_lt : forall x1 y1 a:R, x1 < y1 -> 0 < a -> a * x1 < a * y1.
intros; apply Rmult_lt_compat_l; assumption.
Qed.
-
+
Lemma Rfourier_le : forall x1 y1 a:R, x1 <= y1 -> 0 < a -> a * x1 <= a * y1.
red in |- *.
intros.
case H; auto with real.
Qed.
-
+
Lemma Rfourier_lt_lt :
forall x1 y1 x2 y2 a:R,
x1 < y1 -> x2 < y2 -> 0 < a -> x1 + a * x2 < y1 + a * y2.
@@ -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 dd54aea29..73fb49295 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 908267700..3f490babd 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<cres ou 0<=cres selon sres *)
(*print_string "Fourier's method can prove the goal...";flush stdout;*)
let lutil=ref [] in
- List.iter
+ List.iter
(fun (h,c) ->
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 2d206220e..00302a741 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 9087f5179..90eb49942 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 62eb528e0..ff98f2b97 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 49d1a179b..f6959d77e 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 cf28c6e6c..fb04c6ec2 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 28fec2e98..0e51eb7e1 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 46da3a01d..7cce53c7c 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 3583c8448..06f3291fe 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 e9aa692b6..87d646ab8 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 5f8587408..116a3c991 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 092830025..3538f6342 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<j then foldup i j else folddown i j
end
@@ -231,7 +231,7 @@ let prlinked x =
| Unlinked -> 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<relinfo.nbranches)
| _ -> 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 7e9ba3f8e..4bd0385ca 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 <nothing> 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 <nothing> with .... !*)
+ | el ->
+ (* this case correspond to
match el with brl end
- we first compute the list of lists corresponding to [el] and
- combine them .
- Then for each elemeent of the combinations,
- we compute the result we compute one list per branch in [brl] and
- finally we just concatenate those list
+ 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 0075fb0a0..a314050f7 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 92396af59..502960a14 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 358c6ba6c..455e7c89b 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 876f3de4b..92438db39 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 9122540d7..fc01c5886 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 8fd14aee2..7c40bbb70 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 da41a89b6..cc1b08a63 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 73db36d46..eae849921 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 6d2ed26e8..0a9c3e270 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 x<y then (let q2=Array.map copyP q1 in
q2.(0)<- plusP p q1.(0);
Prec (y,q2))
else if x>y 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<y
+ if x<y
then (let q2 = Array.map (fun z-> 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<d'
@@ -704,9 +704,9 @@ and gcd_sub_res p q x =
let c' = coefDom x q in
let r = snd (quo_rem_pol (((oppP c')^^(delta+1))@@p) (oppP q) x) in
gcd_sub_res_rec q r (c'^^delta) c' d' x
-
+
and gcd_sub_res_rec p q s c d x =
- if equal q cf0
+ if equal q cf0
then p
else (
let d' = deg x q in
@@ -731,7 +731,7 @@ and lazard_power c s d x =
*)
(*
- p = f1 f2^2 ... fn^r
+ p = f1 f2^2 ... fn^r
p/\p'= f2 f3^2...fn^(r-1)
sans_carré(p)= p/p/\p '= f1 f2 ... fn
*)
@@ -815,9 +815,9 @@ let prfactorise () =
print_lpoly (List.flatten c))
hfactorise
-let factorise =
- memoP "f" hfactorise
- (fun p ->
+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 fc7de1e33..40644489b 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 2f0095a56..55db032f3 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 ee46cef8b..e7084fbb0 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();
</cpa> *)
(* 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 df5e66b50..730af3ca2 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 c2ab2dc8d..fb0562c57 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 79c5fe8a8..9fade8b58 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 83c156f7b..1a5bfaf33 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 f73c20849..cfd33c186 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 0b13a092a..1c5afc1be 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 f5e8be31e..ef61a8202 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 a157ca925..dcccc39e8 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 663e4ce92..b4dfe8a76 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 aa11609ae..8eeeee34a 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 dd7f455d7..7632ebdfb 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 "<i>(" ++ str hyp ++ str ")</i>")
+ h 0 (sp_print g ++ spc () ++ str "<i>(" ++ str hyp ++ str ")</i>")
| 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 559860b2f..48f35ebab 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 be7472a48..a322c7a72 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 631417e0e..231004bca 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 04e68272e..e58f8e686 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 149b77316..803dd903a 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 9e675165f..a2b10ebaa 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 b266a1ab8..ae22b0c78 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 2e8c3daec..21f991ef8 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 801d8b212..c86fe8fb6 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 88b53583d..d556cd03e 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 42e0acb58..b1d021768 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 ed204d92b..c0b86f5ed 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 ced67e39d..f27cd15e3 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 70eb2331c..b02a9850e 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 2a1c2fe22..c5760229c 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 5e13db1b6..d10ae00c8 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 78087c070..d4e6d920b 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 c547b3d4a..6250e324a 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 d884f2659..5c45c8f5f 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 a0158b156..ec06fa58b 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 87c9d1bbe..f17e1c35b 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 87e55c9e1..2512dee92 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 42e22ffec..e38caba06 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 a9228365e..baf90d4da 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 fe8fcc924..56a854d6f 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 47e22a97f..a5a085a99 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 075188f54..e037ee8bf 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 a69f8ef74..3bfdce7fd 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<zify_nat>>
| "positive" -> Tacinterp.interp <:tactic<zify_positive>>
| "N" -> Tacinterp.interp <:tactic<zify_N>>
| "Z" -> Tacinterp.interp <:tactic<zify_op>>
| 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 fd774c16d..11ab9c039 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 "- " else if not_first then "+ " else "");
let c = abs f.c in
- if c =? one then
+ if c =? one then
Printf.printf "%s " (print_var f.v)
- else
- Printf.printf "%s %s " (string_of_bigint c) (print_var f.v);
+ else
+ Printf.printf "%s %s " (string_of_bigint c) (print_var f.v);
true)
false l
in
- if e >? zero then
+ if e >? zero then
Printf.printf "+ %s " (string_of_bigint e)
- else if e <? zero then
+ else if e <? zero then
Printf.printf "- %s " (string_of_bigint (abs e))
let rec trace_length l =
@@ -151,22 +151,22 @@ let rec trace_length l =
| _ -> 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 <? zero then begin
add_event (CONSTANT_NEG(nx.id,nx.constant)); raise UNSOLVABLE
end else add_event (FORGET_C nx.id)
else
- try
+ try
let (optnormal,optinvert) = Hashtbl.find table ne in
let final =
if kind = NORMAL then begin
- match optnormal with
- Some v ->
+ match optnormal with
+ Some v ->
let kept =
- if v.constant <? nx.constant
+ if v.constant <? nx.constant
then begin add_event (FORGET (v.id,nx.id));v end
else begin add_event (FORGET (nx.id,v.id));nx end in
(Some(kept),optinvert)
| None -> 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 <? low.constant then begin
add_event(CONTRADICTION (high,negate_eq low));
raise UNSOLVABLE
@@ -442,21 +442,21 @@ let redundancy_elimination new_eq_id system =
Hashtbl.remove table ne;
Hashtbl.add table ne final
with Not_found ->
- 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 <? zero -> 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 959d66c74..231b5fbb0 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 79f6976bd..30d29515f 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 9b85fb85e..2a9df21b3 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 ad1cc5cf1..7aeee2185 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 ce23d05af..9b4c46fe9 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 f50a2f30a..2c2314aff 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 5ca1bfced..d766e3445 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 2ed20b2bb..bf3b8ef6f 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 12176d661..a97f43d08 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<k*j.
- (* We should have a way to decide the equality and the order*)
+ (* We should have a way to decide the equality and the order*)
Parameter compare : int -> 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<j.
Axiom compare_Gt : forall i j, compare i j = Gt <-> 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<y <-> 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<n.
Proof.
@@ -440,7 +440,7 @@ Module IntProperties (I:Int).
intros; unfold beq; generalize (compare_Eq i j).
destruct compare; intuition discriminate.
Qed.
-
+
Lemma beq_true : forall i j, beq i j = true -> 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 1caa5db1c..2978d699e 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 0f00e9184..b8db71e40 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 39b6c2106..2db86e005 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<zify_nat>>
| "positive" -> Tacinterp.interp <:tactic<zify_positive>>
| "N" -> Tacinterp.interp <:tactic<zify_N>>
| "Z" -> Tacinterp.interp <:tactic<zify_op>>
| 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 fc4f7a8f0..570bb1877 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éflexive. *)
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 cd0f1afe9..36da9463b 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 4b95097e2..0d1d09c73 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 1fee72a60..562e2e3bd 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 "<complete>")
-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 a0e86b8d6..e52f6bbdc 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 b47bbaa93..23cb07050 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 601cabe00..e5a4c8d17 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 509020042..d403c9efe 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 0082eb9af..7aff8e0cb 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 fd99f786f..205bef6d5 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 e664b3b76..b5384f80b 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 60641bcf9..56473adb9 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 d88470369..faa83dedc 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 44e97bda7..e3eb418ad 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 531ab3ca5..b3250a510 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 942915abf..4cb5a05a3 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 14d10e54f..c6d9bf44a 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 5ae15e00a..ca4445cc2 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 d65b520b6..3c947e29c 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 413823ffe..1d1c51266 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 095e5fafc..53ce5b8d6 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 a1cbeb710..098418a7e 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 b5e288013..56134d708 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 5f2cb601b..d54bbee4e 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<n+m then raise Occur
| Evar (_,cl) -> ()
| _ -> 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 2b7626671..6fe14da34 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 917ed8059..eb9f3c8e3 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 ce7b5431b..4dd3dd32b 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 1095b143c..d1e890867 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 6f73bc942..6c0c4340f 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 3bbfe22bc..067da150e 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 fb74867f1..94bd059c2 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 2afcb1941..80d5b9465 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 91418e05e..e705e73c1 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 a1d960318..f818379e7 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 645e3e23e..288d3854f 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 dff1df8f9..e7ee6c748 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 da612c436..e3dbd127f 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 05fc0803f..2cea0841d 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 ac49ca96a..01e2d75f3 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 14b808549..7e0755d57 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 501aa7981..97c3d9414 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 2e17959c3..90ae8bae8 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 49fec2b80..5ccc154af 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 f9ca94ff6..f60abaf85 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 c62c81377..5d20c2a3c 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 94e4c103a..e58618219 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 4a5972cc7..f85309e67 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 d1c263dc8..bc02357ae 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 bfbe54c28..a10c76013 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 032ddbebe..40bc61bb8 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 64dc8a050..fb40ed86e 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 08d3a8501..981503a66 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 1ac022159..5bb7635b9 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 17d1d5dab..f8921aec9 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 2e14b5580..b604ec4c4 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 407f86b36..82e90876d 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 "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>"
+ | TacArg (Tacexp t) -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_glob_tactic (Global.env()) t) ++ str "\"/>"
| t -> str "<tactic cmd=\"" ++ xmlstream (Pptactic.pr_tactic (Global.env()) 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 "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\"/>")
| Some c ->
- (* Force evaluation *)
+ (* Force evaluation *)
let pb = print_constr_env env c in
(str "<hyp id=\"" ++ xmlstream (pr_id id) ++ str "\" type=\"" ++ xmlstream ptyp ++ str "\" body=\"" ++
xmlstream pb ++ 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 "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++
+ let pr_one (meta, typ) =
+ fnl () ++ str "<meta index=\"" ++ int meta ++ str " type=\"" ++ xmlstream (pr_ltype_env_at_top env typ) ++
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 "</goal>")
else
- (hov 2 (str "<goal type=\"declarative\">" ++
+ (hov 2 (str "<goal type=\"declarative\">" ++
(pr_context_xml env)) ++
fnl () ++ str "</goal>")
;;
@@ -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 "</tree>"
;;
-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 f7524671f..1beabf26c 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 7503d6328..3f1e0a630 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 4a27c3247..a46500b89 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 "<b>Require</b> <a helm:helm_link=\"href\" href=\"theory:%s.theory\">%s</a>.<br/>"
(uri_of_dirpath d) (Names.string_of_dirpath d)))
;;
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 1f9cc0f1f..899fb64e1 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<n+m then raise Occur
| Evar (_,cl) -> ()
| _ -> 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 4b203586a..e6d42e10d 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 70cf980f4..8c03d0df4 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 348ae46dc..a4b4260ad 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 "<a class path>"
: (int * int) * inheritance_path -> std_ppcmds)
let install_path_printer f = path_printer := f
-
+
let print_path x = !path_printer x
-let message_ambig l =
+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 a5f139ab1..63d5b0a4e 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 420cbe290..4b5e40408 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 dfa751349..8e4dba5b5 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 ee4306b7d..586ad716d 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 ff33d679d..0329cc07c 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 2c3de28a5..f9c872f9e 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 72379dfcf..d1e0d1049 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 f197f7a9a..b6e697e4d 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 a281a3898..a85f0f739 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 451860477..8d19feea4 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 8df301c66..dc212c9ca 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 191c8e62a..c96cc20cf 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 e5cf8e269..07706c0ba 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 92c5dfcc3..eed795cdc 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 d7507bd66..ac6a61c3c 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 727fd6f85..bfe1522f9 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 cea769955..a9a51d9ac 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 341fc28f2..0b1e05de9 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 4b3bc6c05..98d16b112 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 d4b21fba5..be37e6531 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 ee0eefade..b0229ab61 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 06d1aa533..aa83f71c2 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 a276b4ed5..ca48f7021 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 d8ae03130..956b778e0 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 9b1f57484..7524c72a6 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 d8eae2d0d..727ac117c 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 6bb4eceb3..5cf227440 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 c29895912..048ec92de 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 4d28ee55b..5d3180ff7 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 1bff68cbf..bbc0ceae7 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 535101d74..3c3190484 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 b16508053..1e0649da6 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 9b65494c1..8576d5baa 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 fc790c672..51c00122b 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 c29a3f335..26d62379a 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 4c6c5e631..f47485780 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 f6c1b5b61..0e7fdb82a 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 47bc97251..f0a7ce4c8 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 3d167ebb0..f28fee951 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 2e4f978f5..097cba590 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 c2f046440..c9ee9adf0 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 cec46d780..ae9dec97f 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 4af1333e9..5cf850890 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 434736667..f4d032bf1 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 dbb416bee..0aa65bef3 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 92c176593..fe18a0d19 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 43c9dd2e9..2df1c648a 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 6eb7302f0..c894d2b51 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 87dd26779..bdc1f6b66 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 d02060fc0..20a95dabf 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 cdb7b0675..a32b9777b 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 6be3abdfe..e225c828d 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 d7a1232ad..25c668f5d 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 a35a9b58b..ab0fdf831 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 f1f33930e..eddf387f9 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 8bc48ed54..0d56da382 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 62668f7f3..11324ede9 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 9a40ba319..8dcd8edc2 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 2e2f23065..b5f46d788 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 8a466d8df..29417e8b6 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 9db87d22e..4a7cb2f93 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 8efc26631..880efc2d0 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 8b3789c3b..c66e9c84b 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<nf+nl then errorlabstrm "Refiner.thensn_tac" (str "Not enough subgoals.");
let gll,pl =
List.split
- (list_map_i (fun i ->
+ (list_map_i (fun i ->
apply_sig_tac sigr (if i<nf then tacfi.(i) else 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 9a587a965..ff902d880 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 f53327249..ba3c27e63 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 40917b085..0faba52ea 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 581933c83..a808ca419 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 6674d04ea..ea8ab5b62 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 64a3dcf91..6281f01eb 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 50059ae17..936e159de 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 547ad2a77..8b68fa09b 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 982a4e68e..007a116d1 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 0d5a4ba25..dbaedeefc 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 17777084d..cf0d58ccb 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 379949f46..b409fc9b8 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 86107641d..b41ecbf77 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 e9dfce78b..be8b0fb80 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 4b48064b3..46ed2134d 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 02dace837..77357e3fa 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 515b184da..c2a32471e 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 fa1a703b9..a05c36e93 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 c28a87f0e..e3dddacb0 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 3277fd2e6..41fd497f7 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 0809c80eb..359e3fe7f 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 e37ed9af3..b4b2e6c89 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 3a16cd793..25efd5a05 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 d2ac36fe8..7359d070e 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 fd5d65d85..935431bf9 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 1fd8a9c2b..25ae07000 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 7b0e5e0ef..d535e56e1 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 20e32bea3..1c9cae30e 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 <eqname>_<suffsort>_r
with type (A:<sort>)(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 9d5bcca7a..7b63099c7 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 0d08b72aa..ad392c7d8 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 7a305f200..2e30cdfbe 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 4e3e04c67..e6eefea8a 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 f03084d4d..c7c235cc0 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 e6130cfcd..73aeec501 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 e0c267c07..f4da57144 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 bf34a5598..b2824fbfb 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 3f5411e00..001755b1e 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 ae76e6b26..5a1fb6eee 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 322e139f0..8ec0e2db2 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 9a39b2272..c2be67d75 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 3e12f770e..b4b5737b5 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 431748868..4e72d0708 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 8665cc705..350b53df7 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 ff644c143..5258b319b 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 02bff3b15..1c48988c7 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<add_morphism_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 28173b7a3..8e55d4f5c 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 6b7aabe2e..18873d1c6 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 2b69d7233..a20fe72ef 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 762c7dc76..b9c8ab928 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 1ac95f728..7796c36fb 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-être troublant de faire "Generalize Dependent H n" dans
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 ee2250b34..40ff0b688 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 ad2fd9009..ebfb9446f 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 591b2947c..32e65239d 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 a9f11b3af..92a1b8c3e 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 98e3e2144..de60de59e 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 3929fbae2..ade4462a7 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 f67e997e8..91a16f955 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 6d619c748..32c78b4b9 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 7e21aa7ce..1ec7d452a 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 e330d46fd..a1a7b288a 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 06922e50a..495a16bca 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 8e26209a1..6be30174a 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 d4e7cea81..8cb2d653b 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 32e6489c5..f1872a2bb 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 9f10f7490..3609e9c83 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 c9ebbd142..3621f7a1f 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 47953a66f..be5d3dd21 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<n -> 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 a90290bfb..a9b067ceb 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 e0c540f36..0150c2503 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 1571ee20e..3e99694b3 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 0deed3663..c2926a2b2 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 d9ce546a2..ec4a7a6bc 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 dab4120b9..932949a37 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 abf854553..58491f9de 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 5855b1683..8c2e50e07 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 694f056e8..be0e8ae8b 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 545f26154..5627612f6 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 598db3660..7d86adbfb 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 fb2725c97..8c81d7510 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 9d4a3e047..474ec935b 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 17eb721ad..4caee1c36 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 bc8be78fe..930ace1d5 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 641dcb7af..72396d490 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 3aa55e834..5e61529b4 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 7d9f9eb26..ee2918c6e 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 4fbd6b22d..12c0ef9bf 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 0c3b96dad..99952682d 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 323021dea..c50ad036d 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 948cea3ee..df6661483 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 63f91e565..6fc046495 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 763d85e2c..6377a8b74 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 4f71d097f..415a1b27d 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 7bc04b1fe..4fc8d7c97 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 a963b225f..ee5ec1fa6 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 c6f4302d8..da67d9b04 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 85c09dbd1..1845dd1f6 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 766bf524c..de77e35d3 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 800c431ec..d95c21084 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 db2d9c53f..335996c27 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 29996fd45..494443f1c 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 a3b99f631..d63c49403 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<i *) | left _ _ (left _ _ _) => 0
(* k=i *) | left _ _ _ => 0
(* k>i *) | right _ _ _ => 0
diff --git a/test-suite/failure/guard.v b/test-suite/failure/guard.v
index 7e07a9058..75e511386 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 e5a4e1b66..cf035edf7 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 eedf2612b..93e159e8b 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 a32037a21..1533966ef 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 35fd20369..127da8513 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 0a75ae456..addd3b459 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 4be70d888..56f04f9d6 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 049f97f22..034b7f094 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 d18d21195..1f96ab34a 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 427cec190..8fb414d5a 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 800c431ec..d95c21084 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 6f9f86a95..b3dfb33cd 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 b10d5dbf9..8c9a448e7 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 6f9f86a95..b3dfb33cd 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 5b66944b5..2ec727808 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 6db4cfe18..49530ebce 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 1bc1f71d5..50c5bba0f 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 5cb103953..f424f0fcc 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 0298303f5..efb5c7fd5 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 1fa250e09..c9c779f90 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 d7386a4ec..c957add69 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 b78bba25c..4c00ffe4a 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 60c16a998..3b2460233 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 354c3957f..71d331772 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 014f6c604..e3694b818 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 8dadace77..1d1b1e0ab 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 f4dc19b3e..dce2ffd50 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 88c19cb1a..d4ac7b3a2 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 b886eb59d..8b40213a4 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 45cf9f124..1238ee9de 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 9d24d6ce4..36a542ef0 100644
--- a/test-suite/modules/modul.v
+++ b/test-suite/modules/modul.v
@@ -6,7 +6,7 @@ Module M.
Hint Resolve w.
(* <Warning> : 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 97337a125..fda1a074a 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 070f859ea..d3a4c0b05 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 e286609e5..220e2b369 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 4cb6291df..da5d25fa2 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 5eec07758..fdfd09f80 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.
(* <Warning> : 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 2df8e84e5..dd7daf429 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 37ee71e95..b63375867 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 2b13c2041..af5f05f65 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 b37c3638a..8d16dff5b 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 4a460a83f..c4592369f 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 fc8800a56..ffd50f6ef 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 8e613dcaa..c1405cf91 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 e6950a2a1..219a8a755 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 f6a0d5780..729ab824f 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 8431880d1..69fca48e2 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 061e136e0..66af9e0d3 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 ccd92f696..e63972ce1 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<i *) | inleft (left _) => 0
(* k=i *) | inleft _ => 0
(* k>i *) | inright _ => 0
@@ -1188,7 +1188,7 @@ Type
Type
match compare 0 0 with
-
+
(* k<i *) | inleft (left _) => 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 63957885c..297218433 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 _ _).
(* <Warning> : 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 b57c54781..dffad3230 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 e31135c2f..d6e17f30d 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 6fb922b0f..ab90dc88a 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 cf8210733..4130a16ca 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 2d184fef1..b63bead47 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 1c3e56f20..b17adef67 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 98b5992ad..a8cc7f745 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 724ba502c..203fbbb77 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 867d73746..c5cd7380a 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 b08ffcc32..71e53191b 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 d53e40108..fada3bd54 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 545b8aeb8..4c790680d 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 84ff2608a..1bff74933 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 accaec41e..b8f8660e9 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 54b13702a..c4d086a34 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 bb800b7a0..f4996734b 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 1898853f6..a6a0da878 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 88da60133..d8faa88a7 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 0c37c59ac..801ece9e3 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 86cf49cb5..1348bb623 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 a3be2898c..87e8c8e33 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 550edca50..bd473fa60 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 60e170e4f..14d27924e 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 c0065809d..8334322c9 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 5b856e3da..d9abdbf5a 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 dd84402df..5f44c7525 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 f95352b65..8014f73fc 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 94d827fd5..b565183b9 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 8169361c4..976bec737 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 525348dec..3d1c91bbe 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 062c3ee5c..f6ebacaea 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 fede31a8a..bc1757fd5 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 6de7c2197..54bfaa35c 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 59d583fee..e5f1c6187 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 26339d513..c7a2a6c9d 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 6764cfa35..3d3b3b9ef 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 74d87ffa7..d3bdb1b6d 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 78b01f3e1..be4e06845 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 21bfc0758..af81e53d6 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 9034d6a6f..aabb057a4 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 c3dc2fc62..fcedb2b1a 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 1cf707583..b78651c91 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 211ca28b0..09d21628b 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 463efed3f..f63dfc385 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 d1b679d55..3d06d1d0f 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 b654277c8..4d743a6d7 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<n -> 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 94b75c7f0..6acdd5161 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 e947c6d9c..2d9e85b54 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 be5999df5..033b3f485 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 b89787bb0..6baf79701 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 ead93d913..381cda2cd 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 b4de4932e..271e6ef76 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 4929ae4c0..578373217 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 a7e129a38..52c27587a 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 3c2c08831..469cbeb74 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 2978fda26..f21acd4cb 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 3f96d4341..208c25789 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 573f54e9f..a684d5a10 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 4c3b2ff84..999a64544 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 d2a4006a0..eaa1bb2d6 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 5d6e231c5..1fb5b3e55 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 e43b804e5..dcc973a96 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 7654c856c..503029015 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 1bf6102e9..b6ea04c01 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 1183dc2ee..7b48ffe05 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 5f7517c75..cba87f9e5 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 e87901080..d142cb77f 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 dcb10f3cf..bc42c6564 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 9dbd90f05..2682a8848 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ée est de faire un type dépendant dans lequel la
longueur est un paramètre de construction. Cela complique un
peu les inductions structurelles 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 03aa8baeb..06ab77cfb 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 6ce34535e..4b9b26384 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 100ddbe3e..aa20ebd49 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 b92e4d174..80d60d658 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 3e2eb4f40..7be92139e 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 595ad1297..55aad6e73 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 b672651b9..5b61e2c07 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 b603a2e41..e9301298e 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 5c6524481..b2f62cb87 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 469b9eae6..ebc1d7be9 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 055f02f8b..6af4b5ffe 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 d68e3fd22..71d80c959 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 f58f227e5..12356385c 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 bf10728c8..189cf88ad 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 e09db9b6e..88ca717e2 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 3ebb0c1af..52766bf96 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 ebc99933b..cd51b2aff 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 a99c6a908..4c21e1738 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 10c7ce4a8..112ccce30 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 0c12516c4..e29bde236 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 10e06711f..0f0e675ee 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 e0e858211..796db9f8f 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 b7a1deb77..89cdc932f 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 7ec360a66..d843bbcd6 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 a96def34a..412b6f5c5 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 81ed9a572..bc0d758bd 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 1f21a2262..d94ff7c95 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 4e46610bc..eb6f7b222 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 6a062ea14..032f0c1b3 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 7938beda7..23420109c 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 d03e3bdc8..7a3e60d38 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 8c4c6818a..4e5d39faf 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 95c9c31a9..3a9fa1a73 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 e6312a147..e76cead2d 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 147d1e8d3..8d790d1fd 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 bdec651da..1333f3545 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 2244e1b9a..748229b17 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 39cd268d9..0d36d40e3 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 2d35a4b23..f1baf71a7 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 9add5f48d..f2961635e 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 77caa9c22..d8a8183f3 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 2da70c467..0a21a9e27 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 f55043d37..20af2878b 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 bdbe0eccc..e8b935841 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 472265f3e..ace157749 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 226d07149..5185f2c53 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 27e375f62..5b2f5063b 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 3f4c4354b..32880b2f7 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 dad60fb77..2b9df6d97 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 c45aeb6f9..0d65a89ba 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 d4ba4a3a7..9ec916a7d 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 2e739dd51..c1f9881fa 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 ce94bec14..b30308af5 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 8d2e946de..df732959f 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 6129128de..c6d32d9be 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 fed25ad74..625f776bf 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 57a2248b3..022102f70 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 41cde8aa5..a8a56ae74 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 95a07f2f3..18f3181b6 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 ead91c9ec..d433be944 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 74d9726a6..a4b4b5b4a 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 1943c1629..c7cb9b0d4 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 31b633c25..bf29c63dd 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 ce9405f85..3651c1b2f 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 7d9e11296..127be1134 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 dd3178ebe..4c48d95cd 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 9ad6b7220..49fa12224 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 eaf3f126a..e02f2817c 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 af281b73f..21ff55c19 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 e9bc4b266..ef381c7f2 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 ea5f02bba..b1f2668e6 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<n),
+Lemma Bnth_Nbit : forall n (bv:Bvector n) p (H:p<n),
Bnth _ bv p H = Nbit (Bv2N _ bv) p.
Proof.
induction bv; intros.
@@ -726,7 +726,7 @@ Qed.
(** Xor is the same in the two worlds. *)
-Lemma Nxor_BVxor : forall n (bv bv' : Bvector n),
+Lemma Nxor_BVxor : forall n (bv bv' : Bvector n),
Bv2N _ (BVxor _ bv bv') = Nxor (Bv2N _ bv) (Bv2N _ bv').
Proof.
induction n.
@@ -735,7 +735,7 @@ rewrite (V0_eq _ bv), (V0_eq _ bv'); simpl; auto.
intros.
rewrite (VSn_eq _ _ bv), (VSn_eq _ _ bv'); simpl; auto.
rewrite IHn.
-destruct (Vhead bool n bv); destruct (Vhead bool n bv');
+destruct (Vhead bool n bv); destruct (Vhead bool n bv');
destruct (Bv2N n (Vtail bool n bv)); destruct (Bv2N n (Vtail bool n bv')); simpl; auto.
Qed.
diff --git a/theories/NArith/Ndist.v b/theories/NArith/Ndist.v
index 678d37c1e..92559ff67 100644
--- a/theories/NArith/Ndist.v
+++ b/theories/NArith/Ndist.v
@@ -34,7 +34,7 @@ Definition Nplength (a:N) :=
Lemma Nplength_infty : forall a:N, Nplength a = infty -> 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 36a1f1d8f..0016d035f 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 bf42c5e99..f989e01d0 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 a08c6e62f..3a64a8dc1 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 -> 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 b7a427532..32d150331 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 125fd3f12..589159390 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 d60af33ec..b4f6a8160 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 37b9f47b4..82480fa2e 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 b590e9b3c..db3b622b0 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 d3dfd2505..03c611442 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 1f1d609f1..fd6718e4e 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 d9c234093..28dff1a29 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 cc3221401..b215f6a86 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 c72abed61..ac2232cc0 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 638bf6916..d3a08c6e0 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 73fd266e4..3bd4b8127 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 3835c6cde..6e71bad82 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 12c0cc264..1168e7fd6 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 7373acc9a..1b1283400 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 cbf6f701f..dc2225634 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 4e4593983..00e292db0 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 4d1054553..030c589ff 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 feb7a4916..a8adf49af 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 1ef780986..a9c023856 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 5212e6381..f02baca2c 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 7424d877b..c22680be3 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 c3fdd1bf4..d42db97d5 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 e53e627ec..5295aaec2 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 773807120..578cb6256 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 67411eac8..0973b7d8d 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 7c88d25aa..8be66493e 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 9335f4834..c54756881 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 33ad3b556..e12f57668 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 f35dc7adc..381a0bae4 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 14dc47358..a6aa4d524 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 7e8fedceb..881297955 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 041b318e8..9b7ea0474 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 16733c3b8..dff556b98 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 c34423b4d..266d81e01 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<y/\y<z) : Qc_scope.
@@ -141,9 +141,9 @@ Proof.
intros.
destruct (Qeq_dec x y) as [H|H]; auto.
right; contradict H; subst; auto with qarith.
-Defined.
+Defined.
-(** The addition, multiplication and opposite are defined
+(** The addition, multiplication and opposite are defined
in the straightforward way: *)
Definition Qcplus (x y : Qc) := !!(x+y).
@@ -155,9 +155,9 @@ Notation "- x" := (Qcopp x) : Qc_scope.
Definition Qcminus (x y : Qc) := x+-y.
Infix "-" := Qcminus : Qc_scope.
Definition Qcinv (x : Qc) := !!(/x).
-Notation "/ x" := (Qcinv x) : Qc_scope.
+Notation "/ x" := (Qcinv x) : Qc_scope.
Definition Qcdiv (x y : Qc) := x*/y.
-Infix "/" := Qcdiv : Qc_scope.
+Infix "/" := Qcdiv : Qc_scope.
(** [0] and [1] are apart *)
@@ -167,8 +167,8 @@ Proof.
intros H; discriminate H.
Qed.
-Ltac qc := match goal with
- | q:Qc |- _ => 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 5373c1db3..fbfae55c3 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 efaefbb7c..fa341dd9c 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 d57a8c824..12e371ee9 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 6b16cfff4..27e3c4e02 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 4511657a0..6e2488f5d 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 952853a86..cccc8ceec 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 a5c5ddaf8..f22ff5cb2 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 3a8e816bc..0d34d22c5 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 c1c61586a..6ea0767d0 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 a0675827b..6c08356a7 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 56423f337..7a893c53c 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 603010c91..45e91577e 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 177035c4e..1c74f55a0 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 95237d116..774a0bd5c 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 ca4c38954..4037e3dec 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 43ddfaf4a..74bcf7dcd 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 623ae6311..97793386d 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 40972fbcf..6a33b8092 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 b2e561922..93b723af3 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 35a92793c..a95985d3b 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 dd589646d..57b2c7675 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 31a9b0b59..6460a9271 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 627f04102..ef9caa402 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 371c1af74..500dd5295 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 de43711c3..1516b3384 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 d9937e225..66bac9de7 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 cb48a26b8..3de97ba90 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 adda4e5a5..1ed3fb713 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 eddcb561a..9715414f5 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 1fcf6f61e..5c3a929af 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 897d5c710..023cfc93c 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 398d840d9..3309f7d50 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 8c3d3feac..d18213db4 100644
--- a/theories/Reals/Reals.v
+++ b/theories/Reals/Reals.v
@@ -23,7 +23,7 @@
- Sup: for goals like ``?1<?2``
- RCompute: for equalities with constants like ``10*10==100``
- Reg: for goals like (continuity_pt ?1 ?2) or (derivable_pt ?1 ?2) *)
-
+
Require Export Rbase.
Require Export Rfunctions.
Require Export SeqSeries.
diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v
index 68862f492..a57bb1638 100644
--- a/theories/Reals/Rfunctions.v
+++ b/theories/Reals/Rfunctions.v
@@ -38,13 +38,13 @@ Lemma INR_fact_neq_0 : forall n:nat, INR (fact n) <> 0.
Proof.
intro; red in |- *; intro; apply (not_O_INR (fact n) (fact_neq_0 n));
assumption.
-Qed.
+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 9e83150fc..8890cbb50 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 79e4fd2a1..88cead7a5 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 14f1ea6af..e7f0375f0 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 287fda493..810a7de03 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 e535a5568..d940a1d11 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 6dfb2d604..57bc050a9 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 e6801e6d6..f02b77564 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 5436b4daa..62f1940bf 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 b228f8985..33c20355c 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 c36542d2b..c115969e3 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 c9f83d639..c637b7ab9 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 36ed0c1a0..fe2da8391 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 d6a0f262a..a7fddb473 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 7f62f538b..9588e4438 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 173fe4960..cb53b5346 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 dc65dd2e9..5b731488b 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 e41addadb..dbfc85bb9 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 42860180f..4f336648b 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 2ced22298..d35841e00 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 977135fab..c03c4b95f 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 eec3f8ebd..2d1503f23 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 9eef2bc1d..c5530e7ca 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 62fd4df1a..5f6860997 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 65ce03e28..0719365f1 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 c1e64babc..8c69e6877 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 339298572..0fa9c74a8 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 a75c3b767..019c25a55 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 0615c9c9d..fdcc4150f 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 da3aec320..64c341bd3 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 6b02e8383..b63ec1d47 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 ec44a6e58..443713211 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 42130bbb5..75b9f2efa 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 8589f387e..4fe8f4f6a 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 6c9a064c1..f593031a0 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 8116045b6..36d2150c3 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 dee4af65a..76f7f1ec8 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 f15bf19e6..85d0cffcc 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 d5257c12c..3554901b9 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 ec8fb7e6d..970db1827 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 03dc55ef9..909c79838 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 2d639d096..6d5564ed7 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 f7bd37ee2..9bfe31ed1 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 1ea71972b..803a6143f 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 a92212054..9daf71b2b 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 4c8173172..2d76b25a2 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 5a2cc9695..6d3dc02a9 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 7d6696b78..82a60c189 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 6b6a55d99..940cec9bd 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 f6ce84f98..785d623b4 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 e72b1e11d..01049989e 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 df6a61198..c57e70725 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 69421255d..ff1889000 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 f41b6e93d..5144c0bee 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 5e33da5ff..bce32af48 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 ebf4ba98e..fbb3d9e3c 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 7296897ef..e11b89248 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 a0bf8e3f8..b8301d0f4 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 24d2696c5..de05c296d 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<?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPlt ex ey)
- | (?x<=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPle ex ey)
- | (?x>?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EPgt ex ey)
+ | (?x<=?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(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 7744b7e54..46f64c88d 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 767f9abc4..956221cb3 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 f024339d8..6e69350db 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 758b22817..28b664aa4 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<a -> 0<b ->
@@ -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 2c84765ee..c73b6f091 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 a52df1bfc..51c2a2905 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 3149572be..4c9ee2405 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 35a900afd..f146a80e1 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 (x<y)%Z in H |
+ change (x<y)%Z in H |
change (x>y)%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 df28b56c8..293a81f14 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 f341b193e..3435874cc 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 a0a75cf1e..091310439 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 42feedae0..512362190 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<N)%nat -> 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<a<b]. *)
Lemma Zgcdn_is_gcd :
- forall n a b, (Zgcd_bound a <= n)%nat ->
+ 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 e2b435aba..5459e693d 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 68e9c7733..70a959c2a 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 59fcfa494..413b685a2 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 beb91a738..fa454fa96 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 6ea02a483..83dceb84b 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 34e76b8ac..93ac74d54 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 5d3b20160..46b23fe63 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 f6d73d7eb..dac4a6928 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<p /\ (forall n, 1<n<p -> ~ (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<b
-*)
+ or gcd (a-b) (2*b+1), depending on whether a<b
+*)
Open Scope positive_scope.
-Fixpoint Pgcdn (n: nat) (a b : positive) { struct n } : positive :=
- match n with
+Fixpoint Pgcdn (n: nat) (a b : positive) { struct n } : positive :=
+ match n with
| O => 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 9ab0aadfd..7aef3ea8e 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 b0f372deb..620d6324f 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 bf25de4d6..40917519e 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 7ee8b9766..508e6601c 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 a97750d77..b845cf47a 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 650c79745..32d6de19a 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 5edf68013..6ebdcb50a 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 8a39c383a..486c8804f 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 30f55468b..c46a187c5 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 5faedf682..9be50c62c 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 43395b0e9..21fc66fc6 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 3c7d09e1f..b13c16bad 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 aef17031d..fe26e0086 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 2ee90820f..4994a1280 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 d9ed86297..22d81d6f5 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 bfb57dad2..f8a8730d0 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 62ae42c1a..a39450986 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 3c4c9a656..d2b66f993 100644
--- a/tools/coqdoc/main.ml
+++ b/tools/coqdoc/main.ml
@@ -54,7 +54,7 @@ let usage () =
prerr_endline " --files-from <file> read file names to process in <file>";
prerr_endline " --glob-from <file> read globalization information from <file>";
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 <url> 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 "<h1>%s</h1>\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 302cbffce..0c5e9ff29 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 "</div>\n\n<div id=\"footer\">\n<hr/><a href=\"%s.html\">Index</a>" !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 "</div>\n\n</div>\n\n</body>\n</html>"
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 "<br/>\n"
- let empty_line_of_code () =
+ let empty_line_of_code () =
printf "\n<br/>\n"
let char = function
@@ -477,7 +477,7 @@ module Html = struct
let start_verbatim () = printf "<pre>"
let stop_verbatim () = printf "</pre>\n"
- let module_ref m s =
+ let module_ref m s =
match find_module m with
| Local ->
printf "<a class=\"modref\" href=\"%s.html\">" m; raw_ident s; printf "</a>"
@@ -491,56 +491,56 @@ module Html = struct
match find_module m with
| Local ->
printf "<a class=\"idref\" href=\"%s.html#%s\">" m fid;
- printf "<span class=\"id\" type=\"%s\">" typ;
+ printf "<span class=\"id\" type=\"%s\">" typ;
raw_ident s;
printf "</span></a>"
| Coqlib when !externals ->
let m = Filename.concat !coqlib m in
printf "<a class=\"idref\" href=\"%s.html#%s\">" m fid;
- printf "<span class=\"id\" type=\"%s\">" typ;
+ printf "<span class=\"id\" type=\"%s\">" typ;
raw_ident s; printf "</span></a>"
| Coqlib | Unknown ->
printf "<span class=\"id\" type=\"%s\">" typ; raw_ident s; printf "</span>"
-
- let reference s r =
+
+ let reference s r =
match r with
- | Def (fullid,ty) ->
- printf "<a name=\"%s\">" fullid;
- printf "<span class=\"id\" type=\"%s\">" (type_name ty);
+ | Def (fullid,ty) ->
+ printf "<a name=\"%s\">" fullid;
+ printf "<span class=\"id\" type=\"%s\">" (type_name ty);
raw_ident s; printf "</span></a>"
| 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 "<span class=\"id\" type=\"mod\">"; raw_ident s ; printf "</span>"
- let ident s loc =
+ let ident s loc =
if is_keyword s then begin
- printf "<span class=\"id\" type=\"keyword\">";
- raw_ident s;
+ printf "<span class=\"id\" type=\"keyword\">";
+ raw_ident s;
printf "</span>"
- end else
+ end else
begin
try reference s (Index.find (get_module false) loc)
with Not_found ->
if is_tactic s then
(printf "<span class=\"id\" type=\"tactic\">"; raw_ident s; printf "</span>")
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 "<span class=\"id\" type=\"var\">"; raw_ident s ; printf "</span>")
else (printf "<span class=\"id\" type=\"var\">"; raw_ident s ; printf "</span>")
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 "<font size=-2>&#9744;</font>"
- let rec reach_item_level n =
+ let rec reach_item_level n =
if !item_level < n then begin
printf "<ul>\n<li>"; incr item_level;
reach_item_level n
@@ -576,11 +576,11 @@ module Html = struct
printf "\n<div class=\"doc\">\n"
let end_doc () = in_doc := false;
- stop_item ();
+ stop_item ();
if not !raw_comments then printf "\n</div>\n"
let start_emph () = printf "<i>"
-
+
let stop_emph () = printf "</i>"
let start_comment () = printf "<span class=\"comment\">(*"
@@ -620,19 +620,19 @@ module Html = struct
if l <> [] then begin
let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in
printf "<a name=\"%s_%c\"></a><h2>%c %s</h2>\n" idx c c cat;
- List.iter
- (fun (id,(text,link)) ->
+ List.iter
+ (fun (id,(text,link)) ->
printf "<a href=\"%s\">%s</a> %s<br/>\n" link id text) l;
printf "<br/><br/>"
end
-
+
let all_letters i = List.iter (letter_index false i.idx_name) i.idx_entries
(* 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 <a href=\"%s.html\">%s</a>]" m m in
(text, sprintf "%s.html#%s" m s)) idx
(* Impression de la table d'index *)
let print_index_table_item i =
printf "<tr>\n<td>%s Index</td>\n" (String.capitalize i.idx_name);
- List.iter
- (fun (c,l) ->
+ List.iter
+ (fun (c,l) ->
if l <> [] then
printf "<td><a href=\"%s\">%c</a></td>\n" (index_ref i c) c
else
@@ -666,11 +666,11 @@ module Html = struct
printf "<td>(%d %s)</td>\n" n (if n > 1 then "entries" else "entry");
printf "</tr>\n"
- let print_index_table idxl =
+ let print_index_table idxl =
printf "<table>\n";
List.iter print_index_table_item idxl;
printf "</table>\n"
-
+
let make_one_multi_index prt_tbl i =
(* Attn: make_one_multi_index créé un nouveau fichier... *)
let idx = i.idx_name in
@@ -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 "<h1>%s</h1>\n" !title;
print_table ();
- if not (!multi_index) then
+ if not (!multi_index) then
begin
List.iter print_one_index all_index;
printf "<hr/>"; 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 "<a href=\"%s.html\"><h2>%s %s</h2></a>\n" m ln ms
| Toc_section (n, f, r) ->
- item n;
+ item n;
printf "<a href=\"%s\">" r; f (); printf "</a>\n"
in
printf "<div id=\"toc\">\n";
Queue.iter make_toc_entry toc_q;
stop_item ();
printf "</div>\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 "<kw|"; raw_ident s; 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 "<with|mode|math|\\<%s\\>>" 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<item>"; 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 9c0019342..f3646a8a1 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 8b3944207..8ba9ae104 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 b47a04b2c..6d35d8397 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 5ddf2b705..3e025b032 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<n then find (i+1)
+ let rec find i =
+ if avoid.(n-i) = s then avoid.(n-i-x)
+ else (if i<n then find (i+1)
else error ("Var "^(string_of_id s)^" seems unknown.")
)
in mkVar (find 1)
@@ -317,47 +317,47 @@ let do_replace_lb aavoid narg gls p q =
(
let mp,dir,lbl = repr_con (destConst v) in
mkConst (make_con mp dir (mk_label (
- if offset=1 then ("eq_"^(string_of_label lbl))
+ if offset=1 then ("eq_"^(string_of_label lbl))
else ((string_of_label lbl)^"_lb")
)))
)
in
let type_of_pq = pf_type_of gls p in
let u,v = destruct_ind type_of_pq
- in let lb_type_of_p =
- try find_lb_proof u
- with Not_found ->
+ 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<n then find (i+1)
+ let rec find i =
+ if avoid.(n-i) = s then avoid.(n-i-x)
+ else (if i<n then find (i+1)
else error ("Var "^(string_of_id s)^" seems unknown.")
)
in mkVar (find 1)
@@ -366,60 +366,60 @@ let do_replace_bl ind gls aavoid narg lft rgt =
(
let mp,dir,lbl = repr_con (destConst v) in
mkConst (make_con mp dir (mk_label (
- if offset=1 then ("eq_"^(string_of_label lbl))
+ if offset=1 then ("eq_"^(string_of_label lbl))
else ((string_of_label lbl)^"_bl")
)))
)
in
- let rec aux l1 l2 =
+ let rec aux l1 l2 =
match (l1,l2) with
| (t1::q1,t2::q2) -> 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 b8fa1710e..291ce7bb1 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 4946ee933..cc174ebac 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 f9a336430..dfedc178f 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"<unknown>")
- 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 11c5bf398..3a3588743 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 3bbc2f043..3398e3fab 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 2eeb8a7de..50bcf589b 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 c79eccab8..7a8e9a923 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 1da86712d..735e1ff27 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 d648fc10e..14cfef6b2 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 729db2d02..4007a96bb 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 a699e528b..d66e975fc 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 6f3edf57f..87f4bdeb5 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 dfed4a3be..4c21e4915 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 c8af4d1da..c6496cd4b 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 b005aedf6..99e228dd4 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 8cc179e81..848fec79c 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 5df33d459..49c8ce715 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 2edb294f9..a97c2daaa 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 c999c0609..fa636989a 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 be5e9312a..d57ecb948 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 9f5d72c5a..a9dcff3e7 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 9912f3281..288f1850e 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 d9f70610b..53822b473 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 c390c7c52..e33363f3a 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 715355635..2b5de5708 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 db5a5c4c5..ad1beb553 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 ef3ee5087..152ae5b70 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 0e23af5c0..b9864f083 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 66dc28e2d..8457ef020 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 96163f7da..cc764fbde 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 54e491f90..d14acaab9 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 63a87201b..3f2fa83ad 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 fcb14b2c6..257660481 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 ee962334e..a14e8ad45 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 f1ea6fa44..4dff36e53 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 be7c29bab..c97c24cd1 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 300ff44f8..44e8b7ab4 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 080acc7fc..56fbd192b 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 8520686d6..211d20d39 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 95c2f45d6..7adc74930 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 b7db4b431..dac56e7d6 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 4ad615a62..2f1621a7a 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