diff options
350 files changed, 12817 insertions, 5479 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 2a325f2d71..698452cb2b 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -1,10 +1,17 @@ # This file describes the maintainers for the main components. See # `dev/doc/MERGING.md`. -########## GitHub metadata, including this file ########## +########## Contributing process ########## -/.github/ @maximedenes -# Secondary maintainer @Zimmi48 +/.github/ @coq/contributing-process-maintainers + +/CONTRIBUTING.md @coq/contributing-process-maintainers + +/dev/doc/release-process.md @coq/contributing-process-maintainers + +/dev/doc/MERGING.md @coq/pushers +# This ensures that all members of the @coq/pushers +# team are notified when the merging doc changes. ########## Build system ########## @@ -45,19 +52,12 @@ azure-pipelines.yml @coq/ci-maintainers /INSTALL* @Zimmi48 # Secondary maintainer @maximedenes -/CONTRIBUTING.md @Zimmi48 -# Secondary maintainer @maximedenes - /CODE_OF_CONDUCT.md @Zimmi48 # Secondary maintainer @mattam82 /dev/doc/ @Zimmi48 # Secondary maintainer @maximedenes -/dev/doc/MERGING.md @coq/pushers -# This ensures that all members of the @coq/pushers -# team are notified when the merging doc changes. - /dev/doc/changes.md @ghost # Trick to avoid getting review requests # each time someone modifies the dev changelog diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7c9a5c9a31..c644059af0 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -2,15 +2,20 @@ image: "$IMAGE" stages: - docker - - build - - test + - stage-1 # No dependencies + - stage-2 # Only dependencies in stage 1 + - stage-3 # Only dependencies in stage 1 and 2 + - stage-4 # Only dependencies in stage 1, 2 and 3 - deploy +# When a job has no dependencies, it goes to stage 1. +# Otherwise, we set "needs" and "dependencies" to the same value. + # some default values variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-07-06-V22" + CACHEKEY: "bionic_coq-V2019-08-08-V01" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -53,7 +58,7 @@ before_script: # TODO figure out how to build doc for installed Coq .build-template: - stage: build + stage: stage-1 artifacts: name: "$CI_JOB_NAME" paths: @@ -91,7 +96,7 @@ before_script: # Template for building Coq + stdlib, typical use: overload the switch .dune-template: - stage: build + stage: stage-1 dependencies: [] script: - set -e @@ -107,7 +112,9 @@ before_script: expire_in: 1 week .dune-ci-template: - stage: test + stage: stage-2 + needs: + - build:edge+flambda:dune:dev dependencies: - build:edge+flambda:dune:dev script: @@ -129,7 +136,7 @@ before_script: # overridden otherwise the CI will fail. .doc-template: - stage: test + stage: stage-2 dependencies: - not-a-real-job script: @@ -144,7 +151,7 @@ before_script: # set dependencies when using .test-suite-template: - stage: test + stage: stage-2 dependencies: - not-a-real-job script: @@ -167,7 +174,7 @@ before_script: # set dependencies when using .validate-template: - stage: test + stage: stage-2 dependencies: - not-a-real-job script: @@ -183,18 +190,22 @@ before_script: expire_in: 2 months .ci-template: - stage: test + stage: stage-2 script: - set -e - echo 'start:coq.test' - make -f Makefile.ci -j "$NJOBS" "${CI_JOB_NAME#*:}" - echo 'end:coq.test' - set +e + needs: + - build:base dependencies: - build:base .ci-template-flambda: extends: .ci-template + needs: + - build:edge+flambda dependencies: - build:edge+flambda variables: @@ -202,7 +213,7 @@ before_script: OPAM_VARIANT: "+flambda" .windows-template: - stage: test + stage: stage-1 artifacts: name: "%CI_JOB_NAME%" paths: @@ -261,7 +272,7 @@ build:edge+flambda:dune:dev: build:base+async: extends: .build-template - stage: test + stage: stage-1 variables: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" COQUSERFLAGS: "-async-proofs on" @@ -295,7 +306,7 @@ windows32: - /^pr-.*$/ lint: - stage: test + stage: stage-1 script: dev/lint-repository.sh dependencies: [] variables: @@ -303,7 +314,7 @@ lint: OPAM_SWITCH: base pkg:opam: - stage: test + stage: stage-1 # OPAM will build out-of-tree so no point in importing artifacts dependencies: [] script: @@ -320,7 +331,7 @@ pkg:opam: .nix-template: image: nixorg/nix:latest # Minimal NixOS image which doesn't even contain git - stage: test + stage: stage-1 variables: # By default we use coq.cachix.org as an extra substituter but this can be overridden EXTRA_SUBSTITUTERS: https://coq.cachix.org @@ -367,7 +378,8 @@ pkg:nix:deploy:channel: only: variables: - $CACHIX_DEPLOYMENT_KEY - dependencies: + dependencies: [] + needs: - pkg:nix:deploy script: - echo "$CACHIX_DEPLOYMENT_KEY" | tr -d '\r' | ssh-add - > /dev/null @@ -385,6 +397,8 @@ doc:refman: extends: .doc-template dependencies: - build:base + needs: + - build:base doc:refman:dune: extends: .dune-ci-template @@ -414,6 +428,10 @@ doc:refman:deploy: - doc:ml-api:odoc - doc:refman:dune - doc:stdlib:dune + needs: + - doc:ml-api:odoc + - doc:refman:dune + - doc:stdlib:dune script: - echo "$DOCUMENTATION_DEPLOY_KEY" | tr -d '\r' | ssh-add - > /dev/null - git clone git@github.com:coq/doc.git _deploy @@ -441,11 +459,15 @@ test-suite:base: extends: .test-suite-template dependencies: - build:base + needs: + - build:base test-suite:base+32bit: extends: .test-suite-template dependencies: - build:base+32bit + needs: + - build:base+32bit variables: OPAM_VARIANT: "+32bit" only: *full-ci @@ -454,15 +476,19 @@ test-suite:edge+flambda: extends: .test-suite-template dependencies: - build:edge+flambda + needs: + - build:edge+flambda variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" only: *full-ci test-suite:egde:dune:dev: - stage: test + stage: stage-2 dependencies: - build:edge+flambda:dune:dev + needs: + - build:edge+flambda:dune:dev script: make -f Makefile.dune test-suite variables: OPAM_SWITCH: edge @@ -476,7 +502,7 @@ test-suite:egde:dune:dev: # expire_in: never test-suite:edge+trunk+make: - stage: test + stage: stage-1 dependencies: [] script: - opam switch create 4.09.0 --empty @@ -503,7 +529,7 @@ test-suite:edge+trunk+make: only: *full-ci test-suite:edge+trunk+dune: - stage: test + stage: stage-1 dependencies: [] script: - opam switch create 4.09.0 --empty @@ -535,6 +561,8 @@ test-suite:base+async: extends: .test-suite-template dependencies: - build:base + needs: + - build:base variables: COQFLAGS: "-async-proofs on -async-proofs-cache force" timeout: "timeout 100m" @@ -547,11 +575,15 @@ validate:base: extends: .validate-template dependencies: - build:base + needs: + - build:base validate:base+32bit: extends: .validate-template dependencies: - build:base+32bit + needs: + - build:base+32bit variables: OPAM_VARIANT: "+32bit" only: *full-ci @@ -560,6 +592,8 @@ validate:edge+flambda: extends: .validate-template dependencies: - build:edge+flambda + needs: + - build:edge+flambda variables: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" @@ -569,6 +603,8 @@ validate:quick: extends: .validate-template dependencies: - build:quick + needs: + - build:quick only: variables: - $UNRELIABLE =~ /enabled/ @@ -584,6 +620,13 @@ library:ci-bedrock2: library:ci-color: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - plugin:ci-bignums + dependencies: + - build:edge+flambda + - plugin:ci-bignums library:ci-compcert: extends: .ci-template-flambda @@ -608,6 +651,13 @@ library:ci-flocq: library:ci-corn: extends: .ci-template-flambda + stage: stage-4 + needs: + - build:edge+flambda + - library:ci-math-classes + dependencies: + - build:edge+flambda + - library:ci-math-classes library:ci-geocoq: extends: .ci-template-flambda @@ -618,6 +668,20 @@ library:ci-hott: library:ci-iris-lambda-rust: extends: .ci-template-flambda +library:ci-math-classes: + extends: .ci-template-flambda + stage: stage-3 + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci + needs: + - build:edge+flambda + - plugin:ci-bignums + dependencies: + - build:edge+flambda + - plugin:ci-bignums + library:ci-math-comp: extends: .ci-template-flambda @@ -642,7 +706,11 @@ plugin:ci-aac_tactics: extends: .ci-template plugin:ci-bignums: - extends: .ci-template + extends: .ci-template-flambda + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci plugin:ci-coq_dpdgraph: extends: .ci-template @@ -666,7 +734,7 @@ plugin:ci-paramcoq: extends: .ci-template plugin:plugin-tutorial: - stage: test + stage: stage-1 dependencies: [] script: - ./configure -local -warn-error yes diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 529a912bb6..cbead97529 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -21,6 +21,7 @@ well. - [Support](#support) - [Standard libraries](#standard-libraries) - [Maintaining existing packages in coq-community](#maintaining-existing-packages-in-coq-community) + - [Contributing to the editor support packages](#contributing-to-the-editor-support-packages) - [Contributing to the website or the package archive](#contributing-to-the-website-or-the-package-archive) - [Other ways of creating content](#other-ways-of-creating-content) - [Issues](#issues) @@ -208,6 +209,10 @@ manifesto's README][coq-community-manifesto]. ### Contributing to the editor support packages ### +Besides CoqIDE, whose sources are available in this repository, and to +which you are welcome to contribute, there are a number of alternative +user interfaces for Coq, more often as an editor support package. + Here are the URLs of the repositories of the various editor support packages: @@ -216,6 +221,11 @@ packages: - Coqtail (Vim) <https://github.com/whonore/Coqtail> - VsCoq Reloaded (VsCode) <https://github.com/coq-community/vscoq> +And here are alternative user interfaces to be run in the web browser: + +- JsCoq (Coq executed in your browser) <https://github.com/ejgallego/jscoq> +- Jupyter kernel for Coq <https://github.com/EugeneLoy/coq_jupyter/> + Each of them has their own contribution process. ### Contributing to the website or the package archive ### @@ -616,8 +626,26 @@ documentation][coqdoc-documentation] to learn more. ### Fixing bugs and performing small changes ### -Just open a PR with your fix. If it is not yet completed, do not -hesitate to open a [*draft PR*][GitHub-draft-PR] to get early +Before fixing a bug, it is best to check that it was reported before: + +- If it was already reported and you intend to fix it, self-assign the + issue (if you have the permission), or leave a comment marking your + intention to work on it (and a contributor with write-access may + then assign the issue to you). + +- If the issue already has an assignee, you should check with them if + they still intend to work on it. If the assignment is several + weeks, months, or even years (!) old, there are good chances that it + does not reflect their current priorities. + +- If the bug has not been reported before, it can be a good idea to + open an issue about it, while stating that you are preparing a fix. + The issue can be the place to discuss about the bug itself while the + PR will be the place to discuss your proposed fix. + +In any case, feel free to just ignore the recommendation above, and +jump ahead and open a PR with your fix. If it is not yet complete, do +not hesitate to open a [*draft PR*][GitHub-draft-PR] to get early feedback, and talk to developers on [Gitter][]. It is generally a good idea to add a regression test to the @@ -638,12 +666,12 @@ merged. So it is recommended that before spending a lot of time coding, you seek feedback from maintainers to see if your change would be -supported, and if they have recommendation about its implementation. +supported, and if they have recommendations about its implementation. You can do this informally by opening an issue, or more formally by producing a design document as a [Coq Enhancement Proposal][CEP]. Another recommendation is that you do not put several unrelated -changes (even if you produced them together) in the same PR. In +changes in the same PR (even if you produced them together). In particular, make sure you split bug fixes into separate PRs when this is possible. More generally, smaller-sized PRs, or PRs changing less components, are more likely to be reviewed and merged promptly. @@ -9,7 +9,7 @@ WHAT DO YOU NEED ? - OCaml (version >= 4.05.0) (available at https://ocaml.org/) - (This version of Coq has been tested up to OCaml 4.08.0) + (This version of Coq has been tested up to OCaml 4.08.1) - The Num package, which used to be part of the OCaml standard library, if you are using an OCaml version >= 4.06.0 @@ -108,7 +108,7 @@ GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) $(addsuffix .mli, $(GRAMFILES)) GENGRAMFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h -GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) +GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe COQ_EXPORTED += GRAMFILES GRAMMLFILES GENGRAMFILES GENMLFILES GENHFILES GENFILES ## More complex file lists @@ -263,7 +263,7 @@ clean-ide: rm -f ide/input_method_lexer.ml rm -f ide/highlight.ml ide/config_lexer.ml ide/config_parser.mli ide/config_parser.ml rm -f ide/utf8_convert.ml - rm -f ide/default.bindings + rm -f ide/default.bindings ide/default_bindings_src.exe rm -rf $(COQIDEAPP) mlgclean: diff --git a/Makefile.build b/Makefile.build index d1ed9a6f96..610af5fe40 100644 --- a/Makefile.build +++ b/Makefile.build @@ -396,9 +396,8 @@ doc_gram_rsts: doc/tools/docgram/orderedGrammar ########################################################################### # Specific rules for Uint63 ########################################################################### -kernel/uint63.ml: kernel/write_uint63.ml kernel/uint63_i386_31.ml kernel/uint63_amd64_63.ml - $(SHOW)'WRITE $@' - $(HIDE)(cd kernel && ocaml unix.cma $(shell basename $<)) +kernel/uint63.ml: kernel/uint63_$(OCAML_INT_SIZE).ml + rm -f $@ && cp $< $@ && chmod a-w $@ ########################################################################### # Main targets (coqtop.opt, coqtop.byte) @@ -642,12 +641,6 @@ gramlib/.pack/gramlib__G%: gramlib/g% | gramlib/.pack # Specific rules for gramlib to pack it Dune / OCaml 4.08 style GRAMOBJS=$(addsuffix .cmo, $(GRAMFILES)) -gramlib/.pack/%: COND_BYTEFLAGS+=-no-alias-deps -w -49 -gramlib/.pack/%: COND_OPTFLAGS+=-no-alias-deps -w -49 - -gramlib/.pack/gramlib.%: COND_OPENFLAGS= -gramlib/.pack/gramlib__%: COND_OPENFLAGS=-open Gramlib - gramlib/.pack/gramlib.cma: $(GRAMOBJS) gramlib/.pack/gramlib.cmo $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $^ @@ -701,14 +694,15 @@ kernel/kernel.cmxa: kernel/kernel.mllib COND_IDEFLAGS=$(if $(filter ide/fake_ide% tools/coq_makefile%,$<), -I ide -I ide/protocol,) COND_PRINTERFLAGS=$(if $(filter dev/%,$<), -I dev,) -# For module packing -COND_OPENFLAGS= +COND_GRAMFLAGS=$(if $(filter gramlib/.pack/%,$<),-no-alias-deps -w -49,) $(if $(filter gramlib/.pack/gramlib__%,$<),-open Gramlib,) + +COND_KERFLAGS=$(if $(filter kernel/%,$<),-w +a-4-44-50,) COND_BYTEFLAGS= \ - $(COND_IDEFLAGS) $(COND_PRINTERFLAGS) $(MLINCLUDES) $(BYTEFLAGS) $(COND_OPENFLAGS) + $(COND_IDEFLAGS) $(COND_PRINTERFLAGS) $(MLINCLUDES) $(BYTEFLAGS) $(COND_GRAMFLAGS) $(COND_KERFLAGS) COND_OPTFLAGS= \ - $(COND_IDEFLAGS) $(MLINCLUDES) $(OPTFLAGS) $(COND_OPENFLAGS) + $(COND_IDEFLAGS) $(MLINCLUDES) $(OPTFLAGS) $(COND_GRAMFLAGS) $(COND_KERFLAGS) plugins/micromega/%.cmi: plugins/micromega/%.mli $(SHOW)'OCAMLC $<' @@ -718,8 +712,6 @@ plugins/nsatz/%.cmi: plugins/nsatz/%.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< -kernel/%.cmi: COND_BYTEFLAGS+=-w +a-4-44-50 - %.cmi: %.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -732,8 +724,6 @@ plugins/nsatz/%.cmo: plugins/nsatz/%.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< -kernel/%.cmo: COND_BYTEFLAGS+=-w +a-4-44-50 - %.cmo: %.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -783,8 +773,6 @@ user-contrib/%.cmx: user-contrib/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< -kernel/%.cmx: COND_OPTFLAGS+=-w +a-4-44-50 - %.cmx: %.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) -c $< diff --git a/Makefile.ci b/Makefile.ci index 677fd734bf..de03ee8e84 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -18,7 +18,6 @@ CI_TARGETS= \ ci-coq_dpdgraph \ ci-coquelicot \ ci-corn \ - ci-cpdt \ ci-cross-crypto \ ci-elpi \ ci-ext-lib \ @@ -41,7 +40,6 @@ CI_TARGETS= \ ci-sf \ ci-simple-io \ ci-stdlib2 \ - ci-tlc \ ci-unimath \ ci-verdi-raft \ ci-vst diff --git a/Makefile.ide b/Makefile.ide index cb026cdf43..0a11f83a18 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -121,7 +121,7 @@ $(COQIDEBYTE): $(LINKIDE) ide/coqide_os_specific.ml: ide/coqide_$(IDEINT).ml.in config/Makefile @rm -f $@ cp $< $@ - @chmod -w $@ + @chmod a-w $@ ide/%.cmi: ide/%.mli $(SHOW)'OCAMLC $<' diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 862c54900f..84f080cc73 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -72,7 +72,7 @@ jobs: opam list displayName: 'Install OCaml dependencies' env: - COMPILER: "4.08.0" + COMPILER: "4.08.1" FINDLIB_VER: ".1.8.0" OPAMYES: "true" diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index f2df99dcd6..d20eea7874 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -142,8 +142,12 @@ let check_inductive env mind mb = mind_universes; mind_variance; mind_private; mind_typing_flags; } = - (* Locally set the oracle for further typechecking *) - let env = Environ.set_oracle env mb.mind_typing_flags.conv_oracle in + (* Locally set typing flags for further typechecking *) + let mb_flags = mb.mind_typing_flags in + let env = Environ.set_typing_flags {env.env_typing_flags with check_guarded = mb_flags.check_guarded; + check_positive = mb_flags.check_positive; + check_universes = mb_flags.check_universes; + conv_oracle = mb_flags.conv_oracle} env in Indtypes.check_inductive env mind entry in let check = check mind in diff --git a/checker/check_stat.ml b/checker/check_stat.ml index 62f72c8edc..a67945ae94 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -31,14 +31,31 @@ let pr_engagement env = | PredicativeSet -> str "Theory: Set is predicative" end -let is_ax _ cb = not (Declareops.constant_has_body cb) -let pr_ax env = - let axs = fold_constants (fun c ce acc -> if is_ax c ce then c::acc else acc) env [] in +let pr_assumptions ass axs = if axs = [] then - str "Axioms: <none>" + str ass ++ str ": <none>" else - hv 2 (str "Axioms:" ++ fnl() ++ prlist_with_sep fnl Constant.print axs) + hv 2 (str ass ++ str ":" ++ fnl() ++ prlist_with_sep fnl str axs) + +let pr_axioms env = + let csts = fold_constants (fun c cb acc -> if not (Declareops.constant_has_body cb) then Constant.to_string c :: acc else acc) env [] in + pr_assumptions "Axioms" csts + +let pr_type_in_type env = + let csts = fold_constants (fun c cb acc -> if not cb.const_typing_flags.check_universes then Constant.to_string c :: acc else acc) env [] in + let csts = fold_inductives (fun c cb acc -> if not cb.mind_typing_flags.check_universes then MutInd.to_string c :: acc else acc) env csts in + pr_assumptions "Constants/Inductives relying on type-in-type" csts + +let pr_unguarded env = + let csts = fold_constants (fun c cb acc -> if not cb.const_typing_flags.check_guarded then Constant.to_string c :: acc else acc) env [] in + let csts = fold_inductives (fun c cb acc -> if not cb.mind_typing_flags.check_guarded then MutInd.to_string c :: acc else acc) env csts in + pr_assumptions "Constants/Inductives relying on unsafe (co)fixpoints" csts + +let pr_nonpositive env = + let inds = fold_inductives (fun c cb acc -> if not cb.mind_typing_flags.check_positive then MutInd.to_string c :: acc else acc) env [] in + pr_assumptions "Inductives whose positivity is assumed" inds + let print_context env = if !output_context then begin @@ -47,7 +64,10 @@ let print_context env = (fnl() ++ str"CONTEXT SUMMARY" ++ fnl() ++ str"===============" ++ fnl() ++ fnl() ++ str "* " ++ hov 0 (pr_engagement env ++ fnl()) ++ fnl() ++ - str "* " ++ hov 0 (pr_ax env))); + str "* " ++ hov 0 (pr_axioms env ++ fnl()) ++ fnl() ++ + str "* " ++ hov 0 (pr_type_in_type env ++ fnl()) ++ fnl() ++ + str "* " ++ hov 0 (pr_unguarded env ++ fnl()) ++ fnl() ++ + str "* " ++ hov 0 (pr_nonpositive env))) end let stats env = diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 9b41fbcb7a..3128e125dd 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -17,48 +17,55 @@ let set_indirect_accessor f = indirect_accessor := f let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ Constant.print kn); - (* Locally set the oracle for further typechecking *) - let oracle = env.env_typing_flags.conv_oracle in - let env = Environ.set_oracle env cb.const_typing_flags.conv_oracle in - (* [env'] contains De Bruijn universe variables *) - let poly, env' = + let cb_flags = cb.const_typing_flags in + let env = Environ.set_typing_flags + {env.env_typing_flags with + check_guarded = cb_flags.check_guarded; + check_universes = cb_flags.check_universes; + conv_oracle = cb_flags.conv_oracle;} + env + in + let poly, env = match cb.const_universes with - | Monomorphic ctx -> false, env + | Monomorphic ctx -> + (* Monomorphic universes are stored at the library level, the + ones in const_universes should not be needed *) + false, env | Polymorphic auctx -> let ctx = Univ.AUContext.repr auctx in + (* [env] contains De Bruijn universe variables *) let env = push_context ~strict:false ctx env in true, env in let ty = cb.const_type in - let _ = infer_type env' ty in - let otab = Environ.opaque_tables env' in - let body, env' = match cb.const_body with - | Undef _ | Primitive _ -> None, env' - | Def c -> Some (Mod_subst.force_constr c), env' - | OpaqueDef o -> - let c, u = Opaqueproof.force_proof !indirect_accessor otab o in - let env' = match u, cb.const_universes with - | Opaqueproof.PrivateMonomorphic (), Monomorphic _ -> env' - | Opaqueproof.PrivatePolymorphic (_, local), Polymorphic _ -> - push_subgraph local env' - | _ -> assert false - in - Some c, env' + let _ = infer_type env ty in + let otab = Environ.opaque_tables env in + let body, env = match cb.const_body with + | Undef _ | Primitive _ -> None, env + | Def c -> Some (Mod_subst.force_constr c), env + | OpaqueDef o -> + let c, u = Opaqueproof.force_proof !indirect_accessor otab o in + let env = match u, cb.const_universes with + | Opaqueproof.PrivateMonomorphic (), Monomorphic _ -> env + | Opaqueproof.PrivatePolymorphic (_, local), Polymorphic _ -> + push_subgraph local env + | _ -> assert false + in + Some c, env in let () = match body with | Some bd -> - let j = infer env' bd in - (try conv_leq env' j.uj_type ty + let j = infer env bd in + (try conv_leq env j.uj_type ty with NotConvertible -> Type_errors.error_actual_type env j ty) | None -> () in - let env = - if poly then add_constant kn cb env - else add_constant kn cb env' - in - (* Reset the value of the oracle *) - Environ.set_oracle env oracle + () + +let check_constant_declaration env kn cb = + let () = check_constant_declaration env kn cb in + Environ.add_constant kn cb env (** {6 Checking modules } *) diff --git a/checker/values.ml b/checker/values.ml index 8dc09aed87..cc9ac1f834 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -219,7 +219,7 @@ let v_cst_def = [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]; [|v_primitive|]|] let v_typing_flags = - v_tuple "typing_flags" [|v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool|] + v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool; v_bool|] let v_univs = v_sum "universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] diff --git a/configure.ml b/configure.ml index 3ced82718e..cef4faaf1a 100644 --- a/configure.ml +++ b/configure.ml @@ -1141,6 +1141,7 @@ let write_makefile f = pr "# Your architecture\n"; pr "# Can be obtain by UNIX command arch\n"; pr "ARCH=%s\n" arch; + pr "OCAML_INT_SIZE:=%d\n" Sys.int_size; pr "HASNATDYNLINK=%s\n\n" natdynlinkflag; pr "# Supplementary libs for some systems, currently:\n"; pr "# . Sun Solaris: -cclib -lunix -cclib -lnsl -cclib -lsocket\n"; @@ -20,7 +20,7 @@ license: "LGPL-2.1" depends: [ "ocaml" { >= "4.05.0" } - "dune" { build & >= "1.6.0" } + "dune" { build & >= "1.10.0" } "ocamlfind" { build } "num" ] diff --git a/coqide-server.opam b/coqide-server.opam index 0325d2549c..5712ca08c2 100644 --- a/coqide-server.opam +++ b/coqide-server.opam @@ -19,7 +19,7 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.6.0" } + "dune" { build & >= "1.10.0" } "coq" { = version } ] diff --git a/coqide.opam b/coqide.opam index 2507acbb26..d680ebb5f4 100644 --- a/coqide.opam +++ b/coqide.opam @@ -17,7 +17,7 @@ dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" depends: [ - "dune" { build & >= "1.6.0" } + "dune" { build & >= "1.10.0" } "coqide-server" { = version } "lablgtk3" { >= "3.0.beta5" } "lablgtk3-sourceview3" { >= "3.0.beta5" } diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index 0c8213b8f5..78c0b4b2c7 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1132,7 +1132,7 @@ function make_findlib { function make_dune { make_ocaml - if build_prep https://github.com/ocaml/dune/archive/ 1.6.3 tar.gz 1 dune-1.6.3 ; then + if build_prep https://github.com/ocaml/dune/archive/ 1.10.0 tar.gz 1 dune-1.10.0 ; then log2 make release log2 make install diff --git a/dev/ci/README-developers.md b/dev/ci/README-developers.md index 408d36df7f..9ed7180807 100644 --- a/dev/ci/README-developers.md +++ b/dev/ci/README-developers.md @@ -120,15 +120,18 @@ Currently available artifacts are: Additionally, an experimental Dune build is provided: https://gitlab.com/coq/coq/-/jobs/artifacts/master/browse/_build/?job=build:edge:dune:dev -- the Coq documentation, built in the `doc:*` jobs. When submitting - a documentation PR, this can help reviewers checking the rendered result: - - + Coq's Reference Manual [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/sphinx/html/index.html?job=doc:refman - + Coq's Standard Library Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_install_ci/share/doc/coq/html/stdlib/index.html?job=build:base - + Coq's ML API Documentation [master branch] - https://gitlab.com/coq/coq/-/jobs/artifacts/master/file/_build/default/_doc/_html/index.html?job=doc:ml-api:odoc +- the Coq documentation, built in the `doc:*` jobs. When submitting a + documentation PR, this can help reviewers checking the rendered + result. **@coqbot** will automatically post links to these + artifacts in the PR checks section. Furthemore, these artifacts are + automatically deployed at: + + + Coq's Reference Manual [master branch]: + <https://coq.github.io/doc/master/refman/> + + Coq's Standard Library Documentation [master branch]: + <https://coq.github.io/doc/master/stdlib/> + + Coq's ML API Documentation [master branch]: + <https://coq.github.io/doc/master/api/> ### GitLab and Windows diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh index 34d748e1cc..03ce5a6b5d 100755 --- a/dev/ci/azure-opam.sh +++ b/dev/ci/azure-opam.sh @@ -2,7 +2,7 @@ set -e -x -OPAM_VARIANT=ocaml-variants.4.08.0+mingw64c +OPAM_VARIANT=ocaml-variants.4.08.1+mingw64c wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz tar -xf opam64.tar.xz diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index ad22c394d8..3923fea30e 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -56,14 +56,14 @@ # NB: stdpp and Iris refs are gotten from the opam files in the Iris # and lambdaRust repos respectively. -: "${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp}" +: "${stdpp_CI_GITURL:=https://gitlab.mpi-sws.org/iris/stdpp}" : "${stdpp_CI_ARCHIVEURL:=${stdpp_CI_GITURL}/-/archive}" -: "${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/FP/iris-coq}" +: "${Iris_CI_GITURL:=https://gitlab.mpi-sws.org/iris/iris}" : "${Iris_CI_ARCHIVEURL:=${Iris_CI_GITURL}/-/archive}" : "${lambdaRust_CI_REF:=master}" -: "${lambdaRust_CI_GITURL:=https://gitlab.mpi-sws.org/FP/LambdaRust-coq}" +: "${lambdaRust_CI_GITURL:=https://gitlab.mpi-sws.org/iris/lambda-rust}" : "${lambdaRust_CI_ARCHIVEURL:=${lambdaRust_CI_GITURL}/-/archive}" ######################################################################## diff --git a/dev/ci/ci-cpdt.sh b/dev/ci/ci-cpdt.sh deleted file mode 100755 index ca759c7b39..0000000000 --- a/dev/ci/ci-cpdt.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -wget http://adam.chlipala.net/cpdt/cpdt.tgz -tar xvfz cpdt.tgz - -( cd cpdt && make clean && make ) diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh deleted file mode 100755 index a2f0bea555..0000000000 --- a/dev/ci/ci-tlc.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -FORCE_GIT=1 -git_download tlc - -( cd "${CI_BUILD_DIR}/tlc" && make ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 011c7fbdec..7175b5ffd5 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-07-06-V22" +# CACHEKEY: "bionic_coq-V2019-08-08-V01" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -56,7 +56,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ opam install $BASE_OPAM # EDGE switch -ENV COMPILER_EDGE="4.08.0" \ +ENV COMPILER_EDGE="4.08.1" \ COQIDE_OPAM_EDGE="cairo2.0.6 lablgtk3-sourceview3.3.0.beta6" \ BASE_OPAM_EDGE="dune-release.1.3.1" diff --git a/dev/ci/user-overlays/10642-SkySkimmer-feedback-added-axiom.sh b/dev/ci/user-overlays/10642-SkySkimmer-feedback-added-axiom.sh new file mode 100644 index 0000000000..413805e8e9 --- /dev/null +++ b/dev/ci/user-overlays/10642-SkySkimmer-feedback-added-axiom.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10642" ] || [ "$CI_BRANCH" = "feedback-added-axiom" ]; then + + elpi_CI_REF=feedback-added-axiom + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + +fi diff --git a/dev/ci/user-overlays/10660-ejgallego-errors+private.sh b/dev/ci/user-overlays/10660-ejgallego-errors+private.sh new file mode 100644 index 0000000000..21ff60493b --- /dev/null +++ b/dev/ci/user-overlays/10660-ejgallego-errors+private.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10660" ] || [ "$CI_BRANCH" = "errors+private" ]; then + + coqhammer_CI_REF=errors+private + coqhammer_CI_GITURL=https://github.com/ejgallego/coqhammer + +fi diff --git a/dev/ci/user-overlays/10665-ejgallego-api+varkind.sh b/dev/ci/user-overlays/10665-ejgallego-api+varkind.sh new file mode 100644 index 0000000000..0c47f6a60b --- /dev/null +++ b/dev/ci/user-overlays/10665-ejgallego-api+varkind.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "10665" ] || [ "$CI_BRANCH" = "api+varkind" ]; then + + elpi_CI_REF=api+varkind + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + quickchick_CI_REF=api+varkind + quickchick_CI_GITURL=https://github.com/ejgallego/QuickChick + +fi diff --git a/dev/ci/user-overlays/10674-ejgallego-proofs+declare_unif.sh b/dev/ci/user-overlays/10674-ejgallego-proofs+declare_unif.sh new file mode 100644 index 0000000000..6dc44aa627 --- /dev/null +++ b/dev/ci/user-overlays/10674-ejgallego-proofs+declare_unif.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10674" ] || [ "$CI_BRANCH" = "proofs+declare_unif" ]; then + + equations_CI_REF=proofs+declare_unif + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + +fi diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 372e40a0b7..37c6e2f619 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -52,7 +52,7 @@ order to use them, do: ``` $ make -f Makefile.dune voboot # Only once per session -$ dune exec dev/shim/coqtop-prelude +$ dune exec -- dev/shim/coqtop-prelude ``` or `quickide` / `dev/shim/coqide-prelude` for CoqIDE. These targets @@ -108,14 +108,14 @@ automatically. You can use `ocamldebug` with Dune; after a build, do: ``` -dune exec dev/dune-dbg /path/to/foo.v +dune exec -- dev/dune-dbg /path/to/foo.v (ocd) source dune_db ``` or ``` -dune exec dev/dune-dbg checker Foo +dune exec -- dev/dune-dbg checker Foo (ocd) source dune_db ``` @@ -130,7 +130,7 @@ For running in emacs, use `coqdev-ocamldebug` from `coqdev.el`. After doing `make -f Makefile.dune voboot`, the following commands should work: ``` -dune exec dev/shim/coqbyte-prelude +dune exec -- dev/shim/coqbyte-prelude > Drop. # #directory "dev";; # #use "include_dune";; diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 01c2b574a2..d00c8cb11a 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -119,6 +119,16 @@ Universes GH issue number: #8341 risk: unlikely to be activated by chance (requires a plugin) + component: template polymorphism + summary: template polymorphism not collecting side constrains on the universe level of a parameter; this is a general form of the previous issue about template polymorphism exploiting other ways to generate untracked constraints introduced: morally at the introduction of template polymorphism, 23 May 2006, 9c2d70b, r8845, Herbelin impacted released versions: at least V8.4-V8.4pl6, V8.5-V8.5pl3, V8.6-V8.6pl2, V8.7.0-V8.7.1, V8.8.0-V8.8.1, V8.9.0-V8.9.1, in theory also V8.1-V8.1pl4, V8.2-V8.2pl2, V8.3-V8.3pl2 but not exploit found there yet (an exploit using a plugin to force sharing of universe level is in principle possible though) + impacted development branches: all from 8.4 to 8.9 at the time of writing and suspectingly also all from 8.1 to 8.4 if a way to create untracked constraints can be found + impacted coqchk versions: a priori all (tested with V8.4 and V8.9 which accept the exploit) + fixed in: soon in master and V8.10.0 (PR #9918, Aug 2019, Dénès and Sozeau) + found by: Gilbert using explicit sharing of universes, exploit found for 8.5-8.9 by Pédrot, other variants generating sharing using sections, or using ltac tricks by Sozeau, exploit in 8.4 by Herbelin and Jason Gross by adding new tricks to Sozeau's variants + exploit: test-suite/failure/Template.v + GH issue number: #9294 + risk: moderate risk to be activated by chance + Primitive projections component: primitive projections, guard condition diff --git a/dev/dune-workspace.all b/dev/dune-workspace.all index c7f36ee964..7e53f13e45 100644 --- a/dev/dune-workspace.all +++ b/dev/dune-workspace.all @@ -3,5 +3,5 @@ ; Add custom flags here. Default developer profile is `dev` (context (opam (switch 4.05.0))) (context (opam (switch 4.05.0+32bit))) -(context (opam (switch 4.08.0))) -(context (opam (switch 4.08.0+flambda))) +(context (opam (switch 4.08.1))) +(context (opam (switch 4.08.1+flambda))) diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index 8dfe1e7833..8736c0f9b8 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/bc9df0f66110039e495b6debe3a6cda4a1bb0fed.tar.gz"; - sha256 = "0y2w259j0vqiwjhjvlbsaqnp1nl2zwz6sbwwhkrqn7k7fmhmxnq1"; + url = "https://github.com/NixOS/nixpkgs/archive/31c38894c90429c9554eab1b416e59e3b6e054df.tar.gz"; + sha256 = "1fv14rj5zslzm14ak4lvwqix94gm18h28376h4hsmrqqpnfqwsdw"; }) diff --git a/doc/changelog/01-kernel/09918-unsound-template-polymorphism.rst b/doc/changelog/01-kernel/09918-unsound-template-polymorphism.rst new file mode 100644 index 0000000000..87e89a70f1 --- /dev/null +++ b/doc/changelog/01-kernel/09918-unsound-template-polymorphism.rst @@ -0,0 +1,30 @@ +- Fix soundness issue with template polymorphism (`#9294 + <https://github.com/coq/coq/issues/9294>`_) + + Declarations of template-polymorphic inductive types ignored the + provenance of the universes they were abstracting on and did not + detect if they should be greater or equal to :math:`\Set` in + general. Previous universes and universes introduced by the inductive + definition could have constraints that prevented their instantiation + with e.g. :math:`\Prop`, resulting in unsound instantiations later. The + implemented fix only allows abstraction over universes introduced by + the inductive declaration, and properly records all their constraints + by making them by default only :math:`>= \Prop`. It is also checked + that a template polymorphic inductive actually is polymorphic on at + least one universe. + + This prevents inductive declarations in sections to be universe + polymorphic over section parameters. For a backward compatible fix, + simply hoist the inductive definition out of the section. + An alternative is to declare the inductive as universe-polymorphic and + cumulative in a universe-polymorphic section: all universes and + constraints will be properly gathered in this case. + See :ref:`Template-polymorphism` for a detailed exposition of the + rules governing template-polymorphic types. + + To help users incrementally fix this issue, a command line option + `-no-template-check` and a global flag :flag:`Template Check` are + available to selectively disable the new check. Use at your own risk. + + (`#9918 <https://github.com/coq/coq/pull/9918>`_, by Matthieu Sozeau + and Maxime Dénès). diff --git a/doc/changelog/05-tactic-language/10324-ltac2-ssr-ampersand.rst b/doc/changelog/05-tactic-language/10324-ltac2-ssr-ampersand.rst new file mode 100644 index 0000000000..fba09f5e87 --- /dev/null +++ b/doc/changelog/05-tactic-language/10324-ltac2-ssr-ampersand.rst @@ -0,0 +1,5 @@ +- White spaces are forbidden in the “&ident” syntax for ltac2 references + that are described in :ref:`ltac2_built-in-quotations` + (`#10324 <https://github.com/coq/coq/pull/10324>`_, + fixes `#10088 <https://github.com/coq/coq/issues/10088>`_, + authored by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-commands-and-options/10291-typing-flags.rst b/doc/changelog/07-commands-and-options/10291-typing-flags.rst new file mode 100644 index 0000000000..ef7adde801 --- /dev/null +++ b/doc/changelog/07-commands-and-options/10291-typing-flags.rst @@ -0,0 +1,4 @@ +- Adding unsafe commands to enable/disable guard checking, positivity checking + and universes checking (providing a local `-type-in-type`). + See :ref:`controlling-typing-flags`. + (`#10291 <https://github.com/coq/coq/pull/10291>`_ by Simon Boulier). diff --git a/doc/changelog/08-tools/10577-extraction-dependent-projections.rst b/doc/changelog/08-tools/10577-extraction-dependent-projections.rst new file mode 100644 index 0000000000..4d52355542 --- /dev/null +++ b/doc/changelog/08-tools/10577-extraction-dependent-projections.rst @@ -0,0 +1,9 @@ +- Fix a printing bug of OCaml extraction on dependent record projections, which + produced improper `assert false`. This change makes the OCaml extractor + internally inline record projections by default; thus the monolithic OCaml + extraction (:cmd:`Extraction` and :cmd:`Recursive Extraction`) does not + produce record projection constants anymore except for record projections + explicitly instructed to extract, and records declared in opaque modules + (`#10577 <https://github.com/coq/coq/pull/10577>`_, + fixes `#7348 <https://github.com/coq/coq/issues/7348>`_, + by Kazuhiko Sakaguchi). diff --git a/doc/changelog/10-standard-library/09811-remove-zlogarithm.rst b/doc/changelog/10-standard-library/09811-remove-zlogarithm.rst new file mode 100644 index 0000000000..ab625b9e03 --- /dev/null +++ b/doc/changelog/10-standard-library/09811-remove-zlogarithm.rst @@ -0,0 +1,4 @@ +- Removes deprecated modules `Coq.ZArith.Zlogarithm` + and `Coq.ZArith.Zsqrt_compat` + (#9881 <https://github.com/coq/coq/pull/9811> + by Vincent Laporte). diff --git a/doc/changelog/10-standard-library/10445-constructive-reals.rst b/doc/changelog/10-standard-library/10445-constructive-reals.rst new file mode 100644 index 0000000000..d69056fc2f --- /dev/null +++ b/doc/changelog/10-standard-library/10445-constructive-reals.rst @@ -0,0 +1,12 @@ +- New module `Reals.ConstructiveCauchyReals` defines constructive real numbers + by Cauchy sequences of rational numbers. Classical real numbers are now defined + as a quotient of these constructive real numbers, which significantly reduces + the number of axioms needed (see `Reals.Rdefinitions` and `Reals.Raxioms`), + while preserving backward compatibility. + + Futhermore, the new axioms for classical real numbers include the limited + principle of omniscience (`sig_forall_dec`), which is a logical principle + instead of an ad hoc property of the real numbers. + + See `#10445 <https://github.com/coq/coq/pull/10445>`_, by Vincent Semeria, + with the help and review of Guillaume Melquiond and Bas Spitters. diff --git a/doc/changelog/10-standard-library/10651-new-lemmas-for-lists.rst b/doc/changelog/10-standard-library/10651-new-lemmas-for-lists.rst new file mode 100644 index 0000000000..864c4e6a7e --- /dev/null +++ b/doc/changelog/10-standard-library/10651-new-lemmas-for-lists.rst @@ -0,0 +1,6 @@ +- New lemmas on :g:`combine`, :g:`filter`, :g:`nodup`, :g:`nth`, and + :g:`nth_error` functions on lists. The lemma :g:`filter_app` was moved to the + :g:`List` module. + + See `#10651 <https://github.com/coq/coq/pull/10651>`_, and + `#10731 <https://github.com/coq/coq/pull/10731>`_, by Oliver Nash. diff --git a/doc/plugin_tutorial/tuto0/src/dune b/doc/plugin_tutorial/tuto0/src/dune index 79d561061d..ab9b4dd531 100644 --- a/doc/plugin_tutorial/tuto0/src/dune +++ b/doc/plugin_tutorial/tuto0/src/dune @@ -3,7 +3,4 @@ (public_name coq.plugins.tutorial.p0) (libraries coq.plugins.ltac)) -(rule - (targets g_tuto0.ml) - (deps (:pp-file g_tuto0.mlg) ) - (action (run coqpp %{pp-file}))) +(coq.pp (modules g_tuto0)) diff --git a/doc/plugin_tutorial/tuto1/src/dune b/doc/plugin_tutorial/tuto1/src/dune index cf9c674b14..054d5ecd26 100644 --- a/doc/plugin_tutorial/tuto1/src/dune +++ b/doc/plugin_tutorial/tuto1/src/dune @@ -3,7 +3,4 @@ (public_name coq.plugins.tutorial.p1) (libraries coq.plugins.ltac)) -(rule - (targets g_tuto1.ml) - (deps (:pp-file g_tuto1.mlg) ) - (action (run coqpp %{pp-file}))) +(coq.pp (modules g_tuto1)) diff --git a/doc/plugin_tutorial/tuto2/src/dune b/doc/plugin_tutorial/tuto2/src/dune index 68ddd13947..8c4b04b1ae 100644 --- a/doc/plugin_tutorial/tuto2/src/dune +++ b/doc/plugin_tutorial/tuto2/src/dune @@ -3,7 +3,4 @@ (public_name coq.plugins.tutorial.p2) (libraries coq.plugins.ltac)) -(rule - (targets g_tuto2.ml) - (deps (:pp-file g_tuto2.mlg) ) - (action (run coqpp %{pp-file}))) +(coq.pp (modules g_tuto2)) diff --git a/doc/plugin_tutorial/tuto3/src/dune b/doc/plugin_tutorial/tuto3/src/dune index ba6d8b288f..678dd71328 100644 --- a/doc/plugin_tutorial/tuto3/src/dune +++ b/doc/plugin_tutorial/tuto3/src/dune @@ -4,7 +4,4 @@ (flags :standard -warn-error -3) (libraries coq.plugins.ltac)) -(rule - (targets g_tuto3.ml) - (deps (:pp-file g_tuto3.mlg)) - (action (run coqpp %{pp-file}))) +(coq.pp (modules g_tuto3)) diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index 903ee115c9..cdb7ea834f 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -162,7 +162,7 @@ need to process all the proofs of the ``.v`` file. The asynchronous processing of proofs can decouple the generation of a compiled file (like the ``.vo`` one) that can be loaded by ``Require`` from the generation and checking of the proof objects. The ``-quick`` flag can be -passed to ``coqc`` or ``coqtop`` to produce, quickly, ``.vio`` files. +passed to ``coqc`` to produce, quickly, ``.vio`` files. Alternatively, when using a Makefile produced by ``coq_makefile``, the ``quick`` target can be used to compile all files using the ``-quick`` flag. @@ -182,7 +182,7 @@ running ``coqc`` as usual. Alternatively one can turn each ``.vio`` into the corresponding ``.vo``. All .vio files can be processed in parallel, hence this alternative might -be faster. The command ``coqtop -schedule-vio2vo 2 a b c`` can be used to +be faster. The command ``coqc -schedule-vio2vo 2 a b c`` can be used to obtain a good scheduling for two workers to produce ``a.vo``, ``b.vo``, and ``c.vo``. When using a Makefile produced by ``coq_makefile``, the ``vio2vo`` target can be used for that purpose. Variable ``J`` should be set to the number @@ -197,7 +197,7 @@ There is an extra, possibly even faster, alternative: just check the proof tasks stored in ``.vio`` files without producing the ``.vo`` files. This is possibly faster because all the proof tasks are independent, hence one can further partition the job to be done between workers. The -``coqtop -schedule-vio-checking 6 a b c`` command can be used to obtain a +``coqc -schedule-vio-checking 6 a b c`` command can be used to obtain a good scheduling for 6 workers to check all the proof tasks of ``a.vio``, ``b.vio``, and ``c.vio``. Auxiliary files are used to predict how long a proof task will take, assuming it will take the same amount of time it took diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 6ac55e7bf4..c591a1f1de 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -894,8 +894,8 @@ Standard Library and other packages. They are still delimited by `%int` and `%uint`. - Syntax notations for `string`, `ascii`, `Z`, `positive`, `N`, `R`, - and `int31` are no longer available merely by `Require`ing the files - that define the inductives. You must `Import` `Coq.Strings.String.StringSyntax` + and `int31` are no longer available merely by :cmd:`Require`\ing the files + that define the inductives. You must :cmd:`Import` `Coq.Strings.String.StringSyntax` (after `Require` `Coq.Strings.String`), `Coq.Strings.Ascii.AsciiSyntax` (after `Require` `Coq.Strings.Ascii`), `Coq.ZArith.BinIntDef`, `Coq.PArith.BinPosDef`, `Coq.NArith.BinNatDef`, `Coq.Reals.Rdefinitions`, and diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index ef183174d7..1611e9dd52 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -70,7 +70,7 @@ and function types over these sorts. Formally, we call :math:`\Sort` the set of sorts which is defined by: .. math:: - + \Sort \equiv \{\SProp,\Prop,\Set,\Type(i)\;|\; i~∈ ℕ\} Their properties, such as: :math:`\Prop:\Type(1)`, :math:`\Set:\Type(1)`, and @@ -436,7 +436,7 @@ instance the identity function over a given type :math:`T` can be written this a *reduction* (or a *conversion*) rule we call :math:`β`: .. math:: - + E[Γ] ⊢ ((λx:T.~t)~u)~\triangleright_β~\subst{t}{x}{u} We say that :math:`\subst{t}{x}{u}` is the *β-contraction* of @@ -474,14 +474,14 @@ with its value, that is to expand (or unfold) it into its value. This reduction is called δ-reduction and shows as follows. .. inference:: Delta-Local - + \WFE{\Gamma} (x:=t:T) ∈ Γ -------------- E[Γ] ⊢ x~\triangleright_Δ~t .. inference:: Delta-Global - + \WFE{\Gamma} (c:=t:T) ∈ E -------------- @@ -499,7 +499,7 @@ destroyed, this reduction differs from δ-reduction. It is called ζ-reduction and shows as follows. .. inference:: Zeta - + \WFE{\Gamma} \WTEG{u}{U} \WTE{\Gamma::(x:=u:U)}{t}{T} @@ -533,17 +533,17 @@ for :math:`x` an arbitrary variable name fresh in :math:`t`. .. math:: f ~:~ ∀ x:\Type(2),~\Type(1) - + then .. math:: λ x:\Type(1).~(f~x) ~:~ ∀ x:\Type(1),~\Type(1) - + We could not allow .. math:: λ x:\Type(1).~(f~x) ~\triangleright_η~ f - + because the type of the reduced term :math:`∀ x:\Type(2),~\Type(1)` would not be convertible to the type of the original term :math:`∀ x:\Type(1),~\Type(1)`. @@ -665,7 +665,7 @@ a *subtyping* relation inductively defined by: .. math:: [c_1 : ∀Γ_P' ,∀ T_{1,1}' … T_{1,n_1}' ,~t'~v_{1,1}' … v_{1,m}' ;~…;~ c_k : ∀Γ_P' ,∀ T_{k,1}' … T_{k,n_k}' ,~t'~v_{k,1}' … v_{k,m}' ] - + respectively then .. math:: @@ -695,7 +695,7 @@ a *subtyping* relation inductively defined by: The conversion rule up to subtyping is now exactly: .. inference:: Conv - + E[Γ] ⊢ U : s E[Γ] ⊢ t : T E[Γ] ⊢ T ≤_{βδιζη} U @@ -716,13 +716,13 @@ that :math:`t_0` is :math:`λ x:T.~u_0` then one step of β-head reduction of :m .. math:: λ x_1 :T_1 .~… λ x_k :T_k .~(λ x:T.~u_0~t_1 … t_n ) ~\triangleright~ λ (x_1 :T_1 )…(x_k :T_k ).~(\subst{u_0}{x}{t_1}~t_2 … t_n ) - + Iterating the process of head reduction until the head of the reduced term is no more an abstraction leads to the *β-head normal form* of :math:`t`: .. math:: t \triangleright … \triangleright λ x_1 :T_1 .~…λ x_k :T_k .~(v~u_1 … u_m ) - + where :math:`v` is not an abstraction (nor an application). Note that the head normal form must not be confused with the normal form since some :math:`u_i` can be reducible. Similar notions of head-normal forms involving δ, ι @@ -828,7 +828,7 @@ We have to give the type of constants in a global environment :math:`E` which contains an inductive definition. .. inference:: Ind - + \WFE{Γ} \ind{p}{Γ_I}{Γ_C} ∈ E (a:A)∈Γ_I @@ -836,7 +836,7 @@ contains an inductive definition. E[Γ] ⊢ a : A .. inference:: Constr - + \WFE{Γ} \ind{p}{Γ_I}{Γ_C} ∈ E (c:C)∈Γ_C @@ -917,7 +917,7 @@ condition* for a constant :math:`X` in the following cases: + :math:`T=(X~t_1 … t_n )` and :math:`X` does not occur free in any :math:`t_i` + :math:`T=∀ x:U,~V` and :math:`X` occurs only strictly positively in :math:`U` and the type :math:`V` satisfies the positivity condition for :math:`X`. - + Strict positivity +++++++++++++++++ @@ -931,10 +931,10 @@ cases: strictly positively in type :math:`V` + :math:`T` converts to :math:`(I~a_1 … a_m~t_1 … t_p )` where :math:`I` is the name of an inductive definition of the form - + .. math:: \ind{m}{I:A}{c_1 :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_1 ;~…;~c_n :∀ p_1 :P_1 ,… ∀p_m :P_m ,~C_n} - + (in particular, it is not mutually defined and it has :math:`m` parameters) and :math:`X` does not occur in any of the :math:`t_i`, and the (instantiated) types of constructor @@ -998,7 +998,7 @@ such that :math:`Γ_I` is :math:`[I_1 :∀ Γ_P ,A_1 ;~…;~I_k :∀ Γ_P ,A_k]` (E[Γ_I ;Γ_P ] ⊢ C_i : s_{q_i} )_{i=1… n} ------------------------------------------ \WF{E;~\ind{p}{Γ_I}{Γ_C}}{} - + provided that the following side conditions hold: @@ -1052,30 +1052,10 @@ between universes for inductive types in the Type hierarchy. Template polymorphism +++++++++++++++++++++ -Inductive types can be made polymorphic over their arguments -in :math:`\Type`. - -.. flag:: Auto Template Polymorphism - - This option, enabled by default, makes every inductive type declared - at level :math:`\Type` (without annotations or hiding it behind a - definition) template polymorphic. - - This can be prevented using the ``notemplate`` attribute. - - An inductive type can be forced to be template polymorphic using the - ``template`` attribute. - - Template polymorphism and universe polymorphism (see Chapter - :ref:`polymorphicuniverses`) are incompatible, so if the later is - enabled it will prevail over automatic template polymorphism and - cause an error when using the ``template`` attribute. - -.. warn:: Automatically declaring @ident as template polymorphic. - - Warning ``auto-template`` can be used to find which types are - implicitly declared template polymorphic by :flag:`Auto Template - Polymorphism`. +Inductive types can be made polymorphic over the universes introduced by +their parameters in :math:`\Type`, if the minimal inferred sort of the +inductive declarations either mention some of those parameter universes +or is computed to be :math:`\Prop` or :math:`\Set`. If :math:`A` is an arity of some sort and :math:`s` is a sort, we write :math:`A_{/s}` for the arity obtained from :math:`A` by replacing its sort with :math:`s`. @@ -1117,10 +1097,11 @@ provided that the following side conditions hold: + there are sorts :math:`s_i`, for :math:`1 ≤ i ≤ k` such that, for :math:`Γ_{I'} = [I_1 :∀ Γ_{P'} ,(A_1)_{/s_1} ;~…;~I_k :∀ Γ_{P'} ,(A_k)_{/s_k}]` we have :math:`(E[Γ_{I′} ;Γ_{P′}] ⊢ C_i : s_{q_i})_{i=1… n}` ; - + the sorts :math:`s_i` are such that all eliminations, to - :math:`\Prop`, :math:`\Set` and :math:`\Type(j)`, are allowed - (see Section :ref:`Destructors`). - + + the sorts :math:`s_i` are all introduced by the inductive + declaration and have no universe constraints beside being greater + than or equal to :math:`\Prop`, and such that all + eliminations, to :math:`\Prop`, :math:`\Set` and :math:`\Type(j)`, + are allowed (see Section :ref:`Destructors`). Notice that if :math:`I_j~q_1 … q_r` is typable using the rules **Ind-Const** and @@ -1141,6 +1122,61 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or :math:`C_i~q_1 … q_r` is mapped to the names chosen in the specific instance of :math:`\ind{p}{Γ_I}{Γ_C}`. +.. warning:: + + The restriction that sorts are introduced by the inductive + declaration prevents inductive types declared in sections to be + template-polymorphic on universes introduced previously in the + section: they cannot parameterize over the universes introduced with + section variables that become parameters at section closing time, as + these may be shared with other definitions from the same section + which can impose constraints on them. + +.. flag:: Auto Template Polymorphism + + This option, enabled by default, makes every inductive type declared + at level :math:`\Type` (without annotations or hiding it behind a + definition) template polymorphic if possible. + + This can be prevented using the ``notemplate`` attribute. + +.. warn:: Automatically declaring @ident as template polymorphic. + + Warning ``auto-template`` can be used to find which types are + implicitly declared template polymorphic by :flag:`Auto Template + Polymorphism`. + + An inductive type can be forced to be template polymorphic using the + ``template`` attribute: it should then fullfill the criterion to + be template polymorphic or an error is raised. + +.. exn:: Inductive @ident cannot be made template polymorphic. + + This error is raised when the `#[universes(template)]` attribute is + on but the inductive cannot be made polymorphic on any universe or be + inferred to live in :math:`\Prop` or :math:`\Set`. + + Template polymorphism and universe polymorphism (see Chapter + :ref:`polymorphicuniverses`) are incompatible, so if the later is + enabled it will prevail over automatic template polymorphism and + cause an error when using the ``template`` attribute. + +.. flag:: Template Check + + Unsetting option :flag:`Template Check` disables the check of + locality of the sorts when abstracting the inductive over its + parameters. This is a deprecated and *unsafe* flag that can introduce + inconsistencies, it is only meant to help users incrementally update + code from Coq versions < 8.10 which did not implement this check. + The `Coq89.v` compatibility file sets this flag globally. A global + ``-no-template-check`` command line option is also available. Use at + your own risk. Use of this flag is recorded in the typing flags + associated to a definition but is *not* supported by the |Coq| + checker (`coqchk`). It will appear in :g:`Print Assumptions` and + :g:`About @ident` output involving inductive declarations that were + (potentially unsoundly) assumed to be template polymorphic. + + In practice, the rule **Ind-Family** is used by |Coq| only when all the inductive types of the inductive definition are declared with an arity whose sort is in the Type hierarchy. Then, the polymorphism is over @@ -1154,10 +1190,10 @@ inductive type is set in :math:`\Set` (even in case :math:`\Set` is impredicativ Section The-Calculus-of-Inductive-Construction-with-impredicative-Set_), and otherwise in the Type hierarchy. -Note that the side-condition about allowed elimination sorts in the -rule **Ind-Family** is just to avoid to recompute the allowed elimination -sorts at each instance of a pattern matching (see Section :ref:`Destructors`). As -an example, let us consider the following definition: +Note that the side-condition about allowed elimination sorts in the rule +**Ind-Family** avoids to recompute the allowed elimination sorts at each +instance of a pattern matching (see Section :ref:`Destructors`). As an +example, let us consider the following definition: .. example:: @@ -1320,7 +1356,7 @@ using the syntax: \Match~m~\as~x~\In~I~\_~a~\return~P~\with~ (c_1~x_{11} ... x_{1p_1} ) ⇒ f_1 | … | (c_n~x_{n1} ... x_{np_n} ) ⇒ f_n~\kwend - + The :math:`\as` part can be omitted if either the result type does not depend on :math:`m` (non-dependent elimination) or :math:`m` is a variable (in this case, :math:`m` can occur in :math:`P` where it is considered a bound variable). The :math:`\In` part @@ -1360,7 +1396,7 @@ There is no restriction on the sort of the predicate to be eliminated. ----------------------- [I:∀ x:A,~A′|∀ x:A,~B′] - + .. inference:: Set & Type s_1 ∈ \{\Set,\Type(j)\} @@ -1376,7 +1412,7 @@ is also of sort :math:`\Prop` or is of the morally smaller sort :math:`\SProp`. .. inference:: Prop - + s ∈ \{\SProp,\Prop\} -------------------- [I:\Prop|I→s] @@ -1404,7 +1440,7 @@ the proof of :g:`or A B` is not accepted: Fail Definition choice (A B: Prop) (x:or A B) := match x with or_introl _ _ a => true | or_intror _ _ b => false end. - + From the computational point of view, the structure of the proof of :g:`(or A B)` in this term is needed for computing the boolean value. @@ -1441,7 +1477,7 @@ this type. :math:`\Prop` for which more eliminations are allowed. .. inference:: Prop-extended - + I~\kw{is an empty or singleton definition} s ∈ \Sort ------------------------------------- @@ -1589,7 +1625,7 @@ An ι-redex is a term of the following form: .. math:: \case((c_{p_i}~q_1 … q_r~a_1 … a_m ),P,f_1 |… |f_l ) - + with :math:`c_{p_i}` the :math:`i`-th constructor of the inductive type :math:`I` with :math:`r` parameters. @@ -1636,7 +1672,7 @@ Typing rule The typing rule is the expected one for a fixpoint. .. inference:: Fix - + (E[Γ] ⊢ A_i : s_i )_{i=1… n} (E[Γ;~f_1 :A_1 ;~…;~f_n :A_n ] ⊢ t_i : A_i )_{i=1… n} ------------------------------------------------------- @@ -1749,7 +1785,7 @@ The reduction for fixpoints is: .. math:: (\Fix~f_i \{F\}~a_1 …a_{k_i}) ~\triangleright_ι~ \subst{t_i}{f_k}{\Fix~f_k \{F\}}_{k=1… n} ~a_1 … a_{k_i} - + when :math:`a_{k_i}` starts with a constructor. This last restriction is needed in order to keep strong normalization and corresponds to the reduction for primitive recursive operators. The following reductions are now @@ -1808,11 +1844,11 @@ and :math:`\subst{E}{|Γ|}{|Γ|c}` to mean the parallel substitution {\WF{E;~c:U;~E′;~c′:=λ x:U.~\subst{t}{c}{x}:∀x:U,~\subst{T}{c}{x};~\subst{E″}{c′}{(c′~c)}} {\subst{Γ}{c′}{(c′~c)}}} - + .. math:: \frac{\WF{E;~c:U;~E′;~c′:T;~E″}{Γ}} {\WF{E;~c:U;~E′;~c′:∀ x:U,~\subst{T}{c}{x};~\subst{E″}{c′}{(c′~c)}}{\subst{Γ}{c′}{(c′~c)}}} - + .. math:: \frac{\WF{E;~c:U;~E′;~\ind{p}{Γ_I}{Γ_C};~E″}{Γ}} {\WFTWOLINES{E;~c:U;~E′;~\ind{p+1}{∀ x:U,~\subst{Γ_I}{c}{x}}{∀ x:U,~\subst{Γ_C}{c}{x}};~ @@ -1853,7 +1889,7 @@ One can consequently derive the following property. .. _First-pruning-property: .. inference:: First pruning property: - + \WF{E;~c:U;~E′}{Γ} c~\kw{does not occur in}~E′~\kw{and}~Γ -------------------------------------- @@ -1933,5 +1969,3 @@ impredicative system for sort :math:`\Set` become: s ∈ \{\Type(i)\} ---------------- [I:\Set|I→ s] - - diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index acf68e9fd2..dc4f91e66b 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -260,10 +260,7 @@ To eliminate the (co-)inductive type, one must use its defined primitive project For compatibility, the parameters still appear to the user when printing terms even though they are absent in the actual AST manipulated by the kernel. This can be changed by unsetting the -:flag:`Printing Primitive Projection Parameters` flag. Further compatibility -printing can be deactivated thanks to the ``Printing Primitive Projection -Compatibility`` option which governs the printing of pattern matching -over primitive records. +:flag:`Printing Primitive Projection Parameters` flag. There are currently two ways to introduce primitive records types: diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 91dfa34494..2cbd41af8b 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -778,7 +778,8 @@ Simple inductive types The types of the constructors have to satisfy a *positivity condition* (see Section :ref:`positivity`). This condition ensures the soundness of - the inductive definition. + the inductive definition. The positivity checking can be disabled using + the option :flag:`Positivity Checking` (see :ref:`controlling-typing-flags`). .. exn:: The conclusion of @type is not valid; it must be built from @ident. diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 554f6bf230..47ecfb9db0 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -522,10 +522,7 @@ of your project. (flags :standard -warn-error -3-9-27-32-33-50) (libraries coq.plugins.cc coq.plugins.extraction)) - (rule - (targets g_equations.ml) - (deps (:pp-file g_equations.mlg)) - (action (run coqpp %{pp-file}))) + (coq.pp (modules g_equations)) And a Coq-specific part that depends on it via the ``libraries`` field: diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index ceaa2775bf..045d028d02 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -17,16 +17,16 @@ Coq, yet it is at the same time its Achilles' heel. Indeed, Ltac: - is error-prone and fragile - has an intricate implementation -Following the need of users that start developing huge projects relying +Following the need of users who are developing huge projects relying critically on Ltac, we believe that we should offer a proper modern language that features at least the following: - at least informal, predictable semantics -- a typing system -- standard programming facilities (i.e. datatypes) +- a type system +- standard programming facilities (e.g., datatypes) This new language, called Ltac2, is described in this chapter. It is still -experimental but we encourage nonetheless users to start testing it, +experimental but we nonetheless encourage users to start testing it, especially wherever an advanced tactic language is needed. The previous implementation of Ltac, described in the previous chapter, will be referred to as Ltac1. @@ -36,9 +36,9 @@ as Ltac1. General design -------------- -There are various alternatives to Ltac1, such that Mtac or Rtac for instance. -While those alternatives can be quite distinct from Ltac1, we designed -Ltac2 to be closest as reasonably possible to Ltac1, while fixing the +There are various alternatives to Ltac1, such as Mtac or Rtac for instance. +While those alternatives can be quite different from Ltac1, we designed +Ltac2 to be as close as reasonably possible to Ltac1, while fixing the aforementioned defects. In particular, Ltac2 is: @@ -47,11 +47,11 @@ In particular, Ltac2 is: * a call-by-value functional language * with effects - * together with Hindley-Milner type system + * together with the Hindley-Milner type system - a language featuring meta-programming facilities for the manipulation of Coq-side terms -- a language featuring notation facilities to help writing palatable scripts +- a language featuring notation facilities to help write palatable scripts We describe more in details each point in the remainder of this document. @@ -77,7 +77,7 @@ Sticking to a standard ML type system can be considered somewhat weak for a meta-language designed to manipulate Coq terms. In particular, there is no way to statically guarantee that a Coq term resulting from an Ltac2 computation will be well-typed. This is actually a design choice, motivated -by retro-compatibility with Ltac1. Instead, well-typedness is deferred to +by backward compatibility with Ltac1. Instead, well-typedness is deferred to dynamic checks, allowing many primitive functions to fail whenever they are provided with an ill-typed term. @@ -92,7 +92,7 @@ Type Syntax ~~~~~~~~~~~ At the level of terms, we simply elaborate on Ltac1 syntax, which is quite -close to e.g. the one of OCaml. Types follow the simply-typed syntax of OCaml. +close to OCaml. Types follow the simply-typed syntax of OCaml. The non-terminal :production:`lident` designates identifiers starting with a lowercase. @@ -122,7 +122,7 @@ Built-in types include: Type declarations ~~~~~~~~~~~~~~~~~ -One can define new types by the following commands. +One can define new types with the following commands. .. cmd:: Ltac2 Type {? @ltac2_typeparams } @lident :name: Ltac2 Type @@ -149,7 +149,7 @@ One can define new types by the following commands. Variants are sum types defined by constructors and eliminated by pattern-matching. They can be recursive, but the `rec` flag must be - explicitly set. Pattern-maching must be exhaustive. + explicitly set. Pattern matching must be exhaustive. Records are product types with named fields and eliminated by projection. Likewise they can be recursive if the `rec` flag is set. @@ -158,15 +158,15 @@ One can define new types by the following commands. Open variants are a special kind of variant types whose constructors are not statically defined, but can instead be extended dynamically. A typical example - is the standard `exn` type. Pattern-matching must always include a catch-all - clause. They can be extended by this command. + is the standard `exn` type. Pattern matching on open variants must always include a catch-all + clause. They can be extended with this command. Term Syntax ~~~~~~~~~~~ The syntax of the functional fragment is very close to the one of Ltac1, except that it adds a true pattern-matching feature, as well as a few standard -constructions from ML. +constructs from ML. .. productionlist:: coq ltac2_var : `lident` @@ -202,7 +202,7 @@ constructions from ML. In practice, there is some additional syntactic sugar that allows e.g. to bind a variable and match on it at the same time, in the usual ML style. -There is a dedicated syntax for list and array literals. +There is dedicated syntax for list and array literals. .. note:: @@ -217,7 +217,7 @@ Ltac Definitions This command defines a new global Ltac2 value. For semantic reasons, the body of the Ltac2 definition must be a syntactical - value, i.e. a function, a constant or a pure constructor recursively applied to + value, that is, a function, a constant or a pure constructor recursively applied to values. If ``rec`` is set, the tactic is expanded into a recursive binding. @@ -247,7 +247,7 @@ if ever we implement native compilation. The expected equations are as follows:: (t any term, V values, C constructor) Note that call-by-value reduction is already a departure from Ltac1 which uses -heuristics to decide when evaluating an expression. For instance, the following +heuristics to decide when to evaluate an expression. For instance, the following expressions do not evaluate the same way in Ltac1. :n:`foo (idtac; let x := 0 in bar)` @@ -255,7 +255,7 @@ expressions do not evaluate the same way in Ltac1. :n:`foo (let x := 0 in bar)` Instead of relying on the :n:`idtac` idiom, we would now require an explicit thunk -not to compute the argument, and :n:`foo` would have e.g. type +to not compute the argument, and :n:`foo` would have e.g. type :n:`(unit -> unit) -> unit`. :n:`foo (fun () => let x := 0 in bar)` @@ -263,19 +263,19 @@ not to compute the argument, and :n:`foo` would have e.g. type Typing ~~~~~~ -Typing is strict and follows Hindley-Milner system. Unlike Ltac1, there +Typing is strict and follows the Hindley-Milner system. Unlike Ltac1, there are no type casts at runtime, and one has to resort to conversion functions. See notations though to make things more palatable. -In this setting, all usual argument-free tactics have type :n:`unit -> unit`, but -one can return as well a value of type :n:`t` thanks to terms of type :n:`unit -> t`, +In this setting, all the usual argument-free tactics have type :n:`unit -> unit`, but +one can return a value of type :n:`t` thanks to terms of type :n:`unit -> t`, or take additional arguments. Effects ~~~~~~~ Effects in Ltac2 are straightforward, except that instead of using the -standard IO monad as the ambient effectful world, Ltac2 is going to use the +standard IO monad as the ambient effectful world, Ltac2 is has a tactic monad. Note that the order of evaluation of application is *not* specified and is @@ -288,15 +288,15 @@ Intuitively a thunk of type :n:`unit -> 'a` can do the following: - It can perform non-backtracking IO like printing and setting mutable variables - It can fail in a non-recoverable way -- It can use first-class backtrack. The proper way to figure that is that we - morally have the following isomorphism: +- It can use first-class backtracking. One way to think about this is that + thunks are isomorphic to this type: :n:`(unit -> 'a) ~ (unit -> exn + ('a * (exn -> 'a)))` i.e. thunks can produce a lazy list of results where each tail is waiting for a continuation exception. -- It can access a backtracking proof state, made out amongst other things of +- It can access a backtracking proof state, consisting among other things of the current evar assignation and the list of goals under focus. -We describe more thoroughly the various effects existing in Ltac2 hereafter. +We now describe more thoroughly the various effects in Ltac2. Standard IO +++++++++++ @@ -315,28 +315,28 @@ Fatal errors ++++++++++++ The Ltac2 language provides non-backtracking exceptions, also known as *panics*, -through the following primitive in module `Control`.:: +through the following primitive in module `Control`:: val throw : exn -> 'a Unlike backtracking exceptions from the next section, this kind of error is never caught by backtracking primitives, that is, throwing an exception -destroys the stack. This is materialized by the following equation, where `E` -is an evaluation context.:: +destroys the stack. This is codified by the following equation, where `E` +is an evaluation context:: E[throw e] ≡ throw e (e value) -There is currently no way to catch such an exception and it is a design choice. -There might be at some future point a way to catch it in a brutal way, -destroying all backtrack and return values. +There is currently no way to catch such an exception, which is a deliberate design choice. +Eventually there might be a way to catch it and +destroy all backtrack and return values. -Backtrack -+++++++++ +Backtracking +++++++++++++ In Ltac2, we have the following backtracking primitives, defined in the -`Control` module.:: +`Control` module:: Ltac2 Type 'a result := [ Val ('a) | Err (exn) ]. @@ -344,7 +344,7 @@ In Ltac2, we have the following backtracking primitives, defined in the val plus : (unit -> 'a) -> (exn -> 'a) -> 'a val case : (unit -> 'a) -> ('a * (exn -> 'a)) result -If one sees thunks as lazy lists, then `zero` is the empty list and `plus` is +If one views thunks as lazy lists, then `zero` is the empty list and `plus` is list concatenation, while `case` is pattern-matching. The backtracking is first-class, i.e. one can write @@ -376,8 +376,8 @@ represent several goals, including none. Thus, there is no such thing as *the current goal*. Goals are naturally ordered, though. It is natural to do the same in Ltac2, but we must provide a way to get access -to a given goal. This is the role of the `enter` primitive, that applies a -tactic to each currently focused goal in turn.:: +to a given goal. This is the role of the `enter` primitive, which applies a +tactic to each currently focused goal in turn:: val enter : (unit -> unit) -> unit @@ -427,6 +427,8 @@ In general, quotations can be introduced in terms using the following syntax, wh .. prodn:: ltac2_term += @ident : ( @quotentry ) +.. _ltac2_built-in-quotations: + Built-in quotations +++++++++++++++++++ @@ -439,10 +441,11 @@ The current implementation recognizes the following built-in quotations: holes at runtime (type ``Init.constr`` as well). - ``pattern``, which parses Coq patterns and produces a pattern used for term matching (type ``Init.pattern``). -- ``reference``, which parses either a :n:`@qualid` or :n:`& @ident`. Qualified names +- ``reference``, which parses either a :n:`@qualid` or :n:`&@ident`. Qualified names are globalized at internalization into the corresponding global reference, while ``&id`` is turned into ``Std.VarRef id``. This produces at runtime a - ``Std.reference``. + ``Std.reference``. There shall be no white space between the ampersand + symbol (``&``) and the identifier (:n:`@ident`). The following syntactic sugar is provided for two common cases. @@ -452,9 +455,9 @@ The following syntactic sugar is provided for two common cases. Strict vs. non-strict mode ++++++++++++++++++++++++++ -Depending on the context, quotations producing terms (i.e. ``constr`` or +Depending on the context, quotation-producing terms (i.e. ``constr`` or ``open_constr``) are not internalized in the same way. There are two possible -modes, respectively called the *strict* and the *non-strict* mode. +modes, the *strict* and the *non-strict* mode. - In strict mode, all simple identifiers appearing in a term quotation are required to be resolvable statically. That is, they must be the short name of @@ -467,7 +470,7 @@ modes, respectively called the *strict* and the *non-strict* mode. of the term at runtime will fail if there is no such variable in the dynamic context. -Strict mode is enforced by default, e.g. for all Ltac2 definitions. Non-strict +Strict mode is enforced by default, such as for all Ltac2 definitions. Non-strict mode is only set when evaluating Ltac2 snippets in interactive proof mode. The rationale is that it is cumbersome to explicitly add ``&`` interactively, while it is expected that global tactics enforce more invariants on their code. @@ -490,12 +493,12 @@ for their side-effects. Semantics +++++++++ -Interpretation of a quoted Coq term is done in two phases, internalization and +A quoted Coq term is interpreted in two phases, internalization and evaluation. -- Internalization is part of the static semantics, i.e. it is done at Ltac2 +- Internalization is part of the static semantics, that is, it is done at Ltac2 typing time. -- Evaluation is part of the dynamic semantics, i.e. it is done when +- Evaluation is part of the dynamic semantics, that is, it is done when a term gets effectively computed by Ltac2. Note that typing of Coq terms is a *dynamic* process occurring at Ltac2 @@ -672,7 +675,7 @@ at parsing time. Scopes are described using a form of S-expression. .. prodn:: ltac2_scope ::= {| @string | @int | @lident ({+, @ltac2_scope}) } -A few scopes contain antiquotation features. For sake of uniformity, all +A few scopes contain antiquotation features. For the sake of uniformity, all antiquotations are introduced by the syntax :n:`$@lident`. The following scopes are built-in. @@ -713,15 +716,15 @@ The following scopes are built-in. - :n:`self`: - + parses a Ltac2 expression at the current level and return it as is. + + parses a Ltac2 expression at the current level and returns it as is. - :n:`next`: - + parses a Ltac2 expression at the next level and return it as is. + + parses a Ltac2 expression at the next level and returns it as is. - :n:`tactic(n = @int)`: - + parses a Ltac2 expression at the provided level :n:`n` and return it as is. + + parses a Ltac2 expression at the provided level :n:`n` and returns it as is. - :n:`thunk(@ltac2_scope)`: @@ -747,7 +750,7 @@ The following scopes are built-in. out of the parsed values in the same order. As an optimization, all subscopes of the form :n:`STRING` are left out of the returned tuple, instead of returning a useless unit value. It is forbidden for the various - subscopes to refer to the global entry using self or next. + subscopes to refer to the global entry using :n:`self` or :n:`next`. A few other specific scopes exist to handle Ltac1-like syntax, but their use is discouraged and they are thus not documented. @@ -758,7 +761,7 @@ planned. Notations ~~~~~~~~~ -The Ltac2 parser can be extended by syntactic notations. +The Ltac2 parser can be extended with syntactic notations. .. cmd:: Ltac2 Notation {+ {| @lident (@ltac2_scope) | @string } } {? : @int} := @ltac2_term :name: Ltac2 Notation @@ -793,10 +796,10 @@ Abbreviations .. cmdv:: Ltac2 Notation @lident := @ltac2_term - This command introduces a special kind of notations, called abbreviations, + This command introduces a special kind of notation, called an abbreviation, that is designed so that it does not add any parsing rules. It is similar in spirit to Coq abbreviations, insofar as its main purpose is to give an - absolute name to a piece of pure syntax, which can be transparently referred + absolute name to a piece of pure syntax, which can be transparently referred to by this name as if it were a proper definition. The abbreviation can then be manipulated just as a normal Ltac2 definition, @@ -851,7 +854,7 @@ corresponding code for its side effects. In particular, it cannot return values, and the quotation has type :n:`unit`. Ltac1 **cannot** implicitly access variables from the Ltac2 scope, but this can -be done via an explicit annotation to the :n:`ltac1` quotation. +be done with an explicit annotation on the :n:`ltac1` quotation. .. productionlist:: coq ltac2_term : ltac1 : ( `ident` ... `ident` |- `ltac_expr` ) @@ -888,7 +891,7 @@ Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation instead. Note that the tactic expression is evaluated eagerly, if one wants to use it as -an argument to a Ltac1 function, she has to resort to the good old +an argument to a Ltac1 function, one has to resort to the good old :n:`idtac; ltac2:(foo)` trick. For instance, the code below will fail immediately and won't print anything. @@ -923,8 +926,8 @@ Due to conflicts, a few syntactic rules have changed. - The dispatch tactical :n:`tac; [foo|bar]` is now written :n:`tac > [foo|bar]`. - Levels of a few operators have been revised. Some tacticals now parse as if - they were a normal function, i.e. one has to put parentheses around the - argument when it is complex, e.g an abstraction. List of affected tacticals: + they were normal functions. Parentheses are now required around complex + arguments, such as abstractions. The tacticals affected are: :n:`try`, :n:`repeat`, :n:`do`, :n:`once`, :n:`progress`, :n:`time`, :n:`abstract`. - :n:`idtac` is no more. Either use :n:`()` if you expect nothing to happen, :n:`(fun () => ())` if you want a thunk (see next section), or use printing @@ -1010,4 +1013,4 @@ Exception catching Ltac2 features a proper exception-catching mechanism. For this reason, the Ltac1 mechanism relying on `fail` taking integers, and tacticals decreasing it, has been removed. Now exceptions are preserved by all tacticals, and it is -your duty to catch them and reraise them depending on your use. +your duty to catch them and re-raise them as needed. diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 774732825a..2885d6dc33 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -627,6 +627,7 @@ file is a particular case of module called *library file*. as ``Export``. .. cmdv:: From @dirpath Require @qualid + :name: From ... Require ... This command acts as :cmd:`Require`, but picks any library whose absolute name is of the form :n:`@dirpath.@dirpath’.@qualid` @@ -1204,6 +1205,79 @@ Controlling the locality of commands occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this category. +.. _controlling-typing-flags: + +Controlling Typing Flags +---------------------------- + +.. flag:: Guard Checking + + This option can be used to enable/disable the guard checking of + fixpoints. Warning: this can break the consistency of the system, use at your + own risk. Decreasing argument can still be specified: the decrease is not checked + anymore but it still affects the reduction of the term. Unchecked fixpoints are + printed by :cmd:`Print Assumptions`. + +.. flag:: Positivity Checking + + This option can be used to enable/disable the positivity checking of inductive + types and the productivity checking of coinductive types. Warning: this can + break the consistency of the system, use at your own risk. Unchecked + (co)inductive types are printed by :cmd:`Print Assumptions`. + +.. flag:: Universe Checking + + This option can be used to enable/disable the checking of universes, providing a + form of "type in type". Warning: this breaks the consistency of the system, use + at your own risk. Constants relying on "type in type" are printed by + :cmd:`Print Assumptions`. It has the same effect as `-type-in-type` command line + argument (see :ref:`command-line-options`). + +.. cmd:: Print Typing Flags + + Print the status of the three typing flags: guard checking, positivity checking + and universe checking. + +.. example:: + + .. coqtop:: all reset + + Unset Guard Checking. + + Print Typing Flags. + + Fixpoint f (n : nat) : False + := f n. + + Fixpoint ackermann (m n : nat) {struct m} : nat := + match m with + | 0 => S n + | S m => + match n with + | 0 => ackermann m 1 + | S n => ackermann m (ackermann (S m) n) + end + end. + + Print Assumptions ackermann. + + Note that the proper way to define the Ackermann function is to use + an inner fixpoint: + + .. coqtop:: all reset + + Fixpoint ack m := + fix ackm n := + match m with + | 0 => S n + | S m' => + match n with + | 0 => ack m' 1 + | S n' => ack m' (ackm n') + end + end. + + .. _internal-registration-commands: Internal registration commands diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index a561de1d0c..cc91776a4d 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -181,14 +181,12 @@ through the <tt>Require Import</tt> command.</p> theories/ZArith/Zhints.v (theories/ZArith/ZArith_base.v) theories/ZArith/Zcomplements.v - theories/ZArith/Zsqrt_compat.v theories/ZArith/Zpow_def.v theories/ZArith/Zpow_alt.v theories/ZArith/Zpower.v theories/ZArith/Zdiv.v theories/ZArith/Zquot.v theories/ZArith/Zeuclid.v - theories/ZArith/Zlogarithm.v (theories/ZArith/ZArith.v) theories/ZArith/Zgcd_alt.v theories/ZArith/Zwf.v @@ -516,7 +514,11 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> theories/Reals/Rdefinitions.v + theories/Reals/ConstructiveReals.v + theories/Reals/ConstructiveCauchyReals.v theories/Reals/Raxioms.v + theories/Reals/ConstructiveRIneq.v + theories/Reals/ConstructiveRealsLUB.v theories/Reals/RIneq.v theories/Reals/DiscrR.v theories/Reals/ROrderedType.v @@ -561,6 +563,7 @@ through the <tt>Require Import</tt> command.</p> theories/Reals/Ranalysis5.v theories/Reals/Ranalysis_reg.v theories/Reals/Rcomplete.v + theories/Reals/ConstructiveRcomplete.v theories/Reals/RiemannInt.v theories/Reals/RiemannInt_SF.v theories/Reals/Rpow_def.v diff --git a/dune-project b/dune-project index f0ac11ba61..45d9d06314 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,8 @@ -(lang dune 1.6) +(lang dune 1.10) (name coq) +(using coq 0.1) + +; We cannot set this to true until as long as the build is not +; properly bootstrapped [that is, we remove the voboot target] +; +; (generate_opam_files true) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index ea71be8e43..c946125d3f 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -861,12 +861,12 @@ let compare_constructor_instances evd u u' = in Evd.add_universe_constraints evd soft -(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and - [u] up to existential variable instantiation and equalisable - universes. The term [t] is interpreted in [sigma1] while [u] is - interpreted in [sigma2]. The universe constraints in [sigma2] are - assumed to be an extension of those in [sigma1]. *) -let eq_constr_univs_test sigma1 sigma2 t u = +(** [eq_constr_univs_test ~evd ~extended_evd t u] tests equality of + [t] and [u] up to existential variable instantiation and + equalisable universes. The term [t] is interpreted in [evd] while + [u] is interpreted in [extended_evd]. The universe constraints in + [extended_evd] are assumed to be an extension of those in [evd]. *) +let eq_constr_univs_test ~evd ~extended_evd t u = (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *) let open Evd in let t = EConstr.Unsafe.to_constr t @@ -877,8 +877,8 @@ let eq_constr_univs_test sigma1 sigma2 t u = in let ans = UnivProblem.eq_constr_univs_infer_with - (fun t -> kind_of_term_upto sigma1 t) - (fun u -> kind_of_term_upto sigma2 u) - (universes sigma2) fold t u sigma2 + (fun t -> kind_of_term_upto evd t) + (fun u -> kind_of_term_upto extended_evd u) + (universes extended_evd) fold t u extended_evd in match ans with None -> false | Some _ -> true diff --git a/engine/evarutil.mli b/engine/evarutil.mli index e9d579af32..7877b94582 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -204,12 +204,17 @@ val finalize : ?abort_on_undefined_evars:bool -> evar_map -> val kind_of_term_upto : evar_map -> Constr.constr -> (Constr.constr, Constr.types, Sorts.t, Univ.Instance.t) kind_of_term -(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and - [u] up to existential variable instantiation and equalisable - universes. The term [t] is interpreted in [sigma1] while [u] is - interpreted in [sigma2]. The universe constraints in [sigma2] are - assumed to be an extension of those in [sigma1]. *) -val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool +(** [eq_constr_univs_test ~evd ~extended_evd t u] tests equality of + [t] and [u] up to existential variable instantiation and + equalisable universes. The term [t] is interpreted in [evd] while + [u] is interpreted in [extended_evd]. The universe constraints in + [extended_evd] are assumed to be an extension of those in [evd]. *) +val eq_constr_univs_test : + evd:Evd.evar_map -> + extended_evd:Evd.evar_map -> + constr -> + constr -> + bool (** [compare_cumulative_instances cv_pb variance u1 u2 sigma] Returns [Inl sigma'] where [sigma'] is [sigma] augmented with universe diff --git a/engine/evd.ml b/engine/evd.ml index b621a3fe2f..6a721a1a8a 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -702,7 +702,7 @@ let empty = { } let from_env e = - { empty with universes = UState.make (Environ.universes e) } + { empty with universes = UState.make ~lbound:(Environ.universes_lbound e) (Environ.universes e) } let from_ctx ctx = { empty with universes = ctx } diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index 7c06bb59f1..3c383b2e00 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -30,7 +30,7 @@ exception Exception of exn (** This exception is used to signal abortion in [timeout] functions. *) -exception Timeout +exception Tac_Timeout (** This exception is used by the tactics to signal failure by lack of successes, rather than some other exceptions (like system @@ -38,7 +38,6 @@ exception Timeout exception TacticFailure of exn let _ = CErrors.register_handler begin function - | Timeout -> CErrors.user_err ~hdr:"Some timeout function" (Pp.str"Timeout!") | Exception e -> CErrors.print e | TacticFailure e -> CErrors.print e | _ -> raise CErrors.Unhandled @@ -99,7 +98,7 @@ struct let print_char = fun c -> (); fun () -> print_char c let timeout = fun n t -> (); fun () -> - Control.timeout n t () (Exception Timeout) + Control.timeout n t () (Exception Tac_Timeout) let make f = (); fun () -> try f () @@ -108,7 +107,7 @@ struct Util.iraise (Exception e, info) (** Use the current logger. The buffer is also flushed. *) - let print_debug s = make (fun _ -> Feedback.msg_info s) + let print_debug s = make (fun _ -> Feedback.msg_debug s) let print_info s = make (fun _ -> Feedback.msg_info s) let print_warning s = make (fun _ -> Feedback.msg_warning s) let print_notice s = make (fun _ -> Feedback.msg_notice s) diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index 90c920439a..75920455ce 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -30,7 +30,7 @@ exception Exception of exn (** This exception is used to signal abortion in [timeout] functions. *) -exception Timeout +exception Tac_Timeout (** This exception is used by the tactics to signal failure by lack of successes, rather than some other exceptions (like system diff --git a/engine/proofview.ml b/engine/proofview.ml index 8b5bd4cd80..1f076470c1 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -849,7 +849,8 @@ let give_up = module Progress = struct - let eq_constr = Evarutil.eq_constr_univs_test + let eq_constr evd extended_evd = + Evarutil.eq_constr_univs_test ~evd ~extended_evd (** equality function on hypothesis contexts *) let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = @@ -879,10 +880,10 @@ module Progress = struct eq_evar_body sigma1 sigma2 ei1.evar_body ei2.evar_body (** Equality function on goals *) - let goal_equal evars1 gl1 evars2 gl2 = - let evi1 = Evd.find evars1 gl1 in - let evi2 = Evd.find evars2 gl2 in - eq_evar_info evars1 evars2 evi1 evi2 + let goal_equal ~evd ~extended_evd evar extended_evar = + let evi = Evd.find evd evar in + let extended_evi = Evd.find extended_evd extended_evar in + eq_evar_info evd extended_evd evi extended_evi end @@ -899,17 +900,17 @@ let tclPROGRESS t = let test = quick_test || Util.List.for_all2eq begin fun i f -> - Progress.goal_equal initial.solution (drop_state i) final.solution (drop_state f) + Progress.goal_equal ~evd:initial.solution + ~extended_evd:final.solution (drop_state i) (drop_state f) end initial.comb final.comb in if not test then tclUNIT res else - tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS" , Pp.str"Failed to progress.")) + tclZERO (CErrors.UserError (Some "Proofview.tclPROGRESS", Pp.str "Failed to progress.")) -exception Timeout let _ = CErrors.register_handler begin function - | Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") + | Logic_monad.Tac_Timeout -> CErrors.user_err ~hdr:"Proofview.tclTIMEOUT" (Pp.str"Tactic timeout!") | _ -> raise CErrors.Unhandled end @@ -934,7 +935,8 @@ let tclTIMEOUT n t = end begin let open Logic_monad.NonLogical in function (e, info) -> match e with - | Logic_monad.Timeout -> return (Util.Inr (Timeout, info)) + | Logic_monad.Tac_Timeout -> + return (Util.Inr (Logic_monad.Tac_Timeout, info)) | Logic_monad.TacticFailure e -> return (Util.Inr (e, info)) | e -> Logic_monad.NonLogical.raise ~info e diff --git a/engine/proofview.mli b/engine/proofview.mli index f90f02f3e1..764a4a0058 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -398,14 +398,23 @@ val give_up : unit tactic val tclPROGRESS : 'a tactic -> 'a tactic module Progress : sig - val goal_equal : Evd.evar_map -> Evar.t -> Evd.evar_map -> Evar.t -> bool +(** [goal_equal ~evd ~extended_evd evar extended_evar] tests whether + the [evar_info] from [evd] corresponding to [evar] is equal to that + from [extended_evd] corresponding to [extended_evar], up to + existential variable instantiation and equalisable universes. The + universe constraints in [extended_evd] are assumed to be an + extension of the universe constraints in [evd]. *) + val goal_equal : + evd:Evd.evar_map -> + extended_evd:Evd.evar_map -> + Evar.t -> + Evar.t -> + bool end (** Checks for interrupts *) val tclCHECKINTERRUPT : unit tactic -exception Timeout - (** [tclTIMEOUT n t] can have only one success. In case of timeout if fails with [tclZERO Timeout]. *) val tclTIMEOUT : int -> 'a tactic -> 'a tactic diff --git a/engine/uState.ml b/engine/uState.ml index 5ed016e0d0..cb40e6eadd 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -34,6 +34,7 @@ type t = (** The subset of unification variables that can be instantiated with algebraic universes as they appear in inferred types only. *) uctx_universes : UGraph.t; (** The current graph extended with the local constraints *) + uctx_universes_lbound : Univ.Level.t; (** The lower bound on universes (e.g. Set or Prop) *) uctx_initial_universes : UGraph.t; (** The graph at the creation of the evar_map *) uctx_weak_constraints : UPairSet.t } @@ -47,6 +48,7 @@ let empty = uctx_univ_variables = LMap.empty; uctx_univ_algebraic = LSet.empty; uctx_universes = initial_sprop_cumulative; + uctx_universes_lbound = Univ.Level.set; uctx_initial_universes = initial_sprop_cumulative; uctx_weak_constraints = UPairSet.empty; } @@ -54,10 +56,12 @@ let elaboration_sprop_cumul = Goptions.declare_bool_option_and_ref ~depr:false ~name:"SProp cumulativity during elaboration" ~key:["Elaboration";"StrictProp";"Cumulativity"] ~value:true -let make u = +let make ~lbound u = let u = if elaboration_sprop_cumul () then UGraph.make_sprop_cumulative u else u in - { empty with - uctx_universes = u; uctx_initial_universes = u} + { empty with + uctx_universes = u; + uctx_universes_lbound = lbound; + uctx_initial_universes = u} let is_empty ctx = ContextSet.is_empty ctx.uctx_local && @@ -83,7 +87,7 @@ let union ctx ctx' = let newus = LSet.diff newus (LMap.domain ctx.uctx_univ_variables) in let weak = UPairSet.union ctx.uctx_weak_constraints ctx'.uctx_weak_constraints in let declarenew g = - LSet.fold (fun u g -> UGraph.add_universe u false g) newus g + LSet.fold (fun u g -> UGraph.add_universe u ~lbound:ctx.uctx_universes_lbound ~strict:false g) newus g in let names_rev = LMap.lunion (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); @@ -99,6 +103,7 @@ let union ctx ctx' = else let cstrsr = ContextSet.constraints ctx'.uctx_local in UGraph.merge_constraints cstrsr (declarenew ctx.uctx_universes)); + uctx_universes_lbound = ctx.uctx_universes_lbound; uctx_weak_constraints = weak} let context_set ctx = ctx.uctx_local @@ -431,18 +436,19 @@ let check_univ_decl ~poly uctx decl = (ContextSet.constraints uctx.uctx_local); ctx -let restrict_universe_context (univs, csts) keep = +let restrict_universe_context ~lbound (univs, csts) keep = let removed = LSet.diff univs keep in if LSet.is_empty removed then univs, csts else let allunivs = Constraint.fold (fun (u,_,v) all -> LSet.add u (LSet.add v all)) csts univs in let g = UGraph.initial_universes in - let g = LSet.fold (fun v g -> if Level.is_small v then g else UGraph.add_universe v false g) allunivs g in + let g = LSet.fold (fun v g -> if Level.is_small v then g else + UGraph.add_universe v ~lbound ~strict:false g) allunivs g in let g = UGraph.merge_constraints csts g in let allkept = LSet.union (UGraph.domain UGraph.initial_universes) (LSet.diff allunivs removed) in let csts = UGraph.constraints_for ~kept:allkept g in let csts = Constraint.filter (fun (l,d,r) -> - not ((Level.is_set l && d == Le) || (Level.is_prop l && d == Lt && Level.is_set r))) csts in + not ((Level.equal l lbound && d == Le) || (Level.is_prop l && d == Lt && Level.is_set r))) csts in (LSet.inter univs keep, csts) let restrict ctx vars = @@ -450,7 +456,7 @@ let restrict ctx vars = let vars = Names.Id.Map.fold (fun na l vars -> LSet.add l vars) (fst ctx.uctx_names) vars in - let uctx' = restrict_universe_context ctx.uctx_local vars in + let uctx' = restrict_universe_context ~lbound:ctx.uctx_universes_lbound ctx.uctx_local vars in { ctx with uctx_local = uctx' } let demote_seff_univs universes uctx = @@ -497,7 +503,7 @@ let merge ?loc ~sideff ~extend rigid uctx ctx' = else ContextSet.append ctx' uctx.uctx_local in let declare g = LSet.fold (fun u g -> - try UGraph.add_universe u false g + try UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false u g with UGraph.AlreadyDeclared when sideff -> g) levels g in @@ -544,16 +550,17 @@ let new_univ_variable ?loc rigid name | None -> add_uctx_loc u loc uctx.uctx_names in let initial = - UGraph.add_universe u false uctx.uctx_initial_universes + UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false u uctx.uctx_initial_universes in let uctx' = {uctx' with uctx_names = names; uctx_local = ctx'; - uctx_universes = UGraph.add_universe u false uctx.uctx_universes; + uctx_universes = UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false + u uctx.uctx_universes; uctx_initial_universes = initial} in uctx', u -let make_with_initial_binders e us = - let uctx = make e in +let make_with_initial_binders ~lbound e us = + let uctx = make ~lbound e in List.fold_left (fun uctx { CAst.loc; v = id } -> fst (new_univ_variable ?loc univ_rigid (Some id) uctx)) @@ -561,10 +568,10 @@ let make_with_initial_binders e us = let add_global_univ uctx u = let initial = - UGraph.add_universe u true uctx.uctx_initial_universes + UGraph.add_universe ~lbound:Univ.Level.set ~strict:true u uctx.uctx_initial_universes in let univs = - UGraph.add_universe u true uctx.uctx_universes + UGraph.add_universe ~lbound:Univ.Level.set ~strict:true u uctx.uctx_universes in { uctx with uctx_local = ContextSet.add_universe u uctx.uctx_local; uctx_initial_universes = initial; @@ -679,8 +686,9 @@ let refresh_undefined_univ_variables uctx = uctx.uctx_univ_variables LMap.empty in let weak = UPairSet.fold (fun (u,v) acc -> UPairSet.add (subst_fn u, subst_fn v) acc) uctx.uctx_weak_constraints UPairSet.empty in - let declare g = LSet.fold (fun u g -> UGraph.add_universe u false g) - (ContextSet.levels ctx') g in + let lbound = uctx.uctx_universes_lbound in + let declare g = LSet.fold (fun u g -> UGraph.add_universe u ~lbound ~strict:false g) + (ContextSet.levels ctx') g in let initial = declare uctx.uctx_initial_universes in let univs = declare UGraph.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; @@ -688,14 +696,16 @@ let refresh_undefined_univ_variables uctx = uctx_seff_univs = uctx.uctx_seff_univs; uctx_univ_variables = vars; uctx_univ_algebraic = alg; uctx_universes = univs; + uctx_universes_lbound = lbound; uctx_initial_universes = initial; uctx_weak_constraints = weak; } in uctx', subst let minimize uctx = let open UnivMinim in + let lbound = uctx.uctx_universes_lbound in let ((vars',algs'), us') = - normalize_context_set uctx.uctx_universes uctx.uctx_local uctx.uctx_univ_variables + normalize_context_set ~lbound uctx.uctx_universes uctx.uctx_local uctx.uctx_univ_variables uctx.uctx_univ_algebraic uctx.uctx_weak_constraints in if ContextSet.equal us' uctx.uctx_local then uctx @@ -709,6 +719,7 @@ let minimize uctx = uctx_univ_variables = vars'; uctx_univ_algebraic = algs'; uctx_universes = universes; + uctx_universes_lbound = lbound; uctx_initial_universes = uctx.uctx_initial_universes; uctx_weak_constraints = UPairSet.empty; (* weak constraints are consumed *) } diff --git a/engine/uState.mli b/engine/uState.mli index 9689f2e961..52e48c4eeb 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -25,9 +25,9 @@ type t val empty : t -val make : UGraph.t -> t +val make : lbound:Univ.Level.t -> UGraph.t -> t -val make_with_initial_binders : UGraph.t -> lident list -> t +val make_with_initial_binders : lbound:Univ.Level.t -> UGraph.t -> lident list -> t val is_empty : t -> bool @@ -88,11 +88,11 @@ val universe_of_name : t -> Id.t -> Univ.Level.t (** {5 Unification} *) -(** [restrict_universe_context (univs,csts) keep] restricts [univs] to +(** [restrict_universe_context lbound (univs,csts) keep] restricts [univs] to the universes in [keep]. The constraints [csts] are adjusted so that transitive constraints between remaining universes (those in [keep] and those not in [univs]) are preserved. *) -val restrict_universe_context : ContextSet.t -> LSet.t -> ContextSet.t +val restrict_universe_context : lbound:Univ.Level.t -> ContextSet.t -> LSet.t -> ContextSet.t (** [restrict uctx ctx] restricts the local universes of [uctx] to [ctx] extended by local named universes and side effect universes diff --git a/engine/univMinim.ml b/engine/univMinim.ml index 1b7c33b9c1..30fdd28997 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -269,11 +269,11 @@ module UPairs = OrderedType.UnorderedPair(Univ.Level) module UPairSet = Set.Make (UPairs) (* TODO check is_small/sprop *) -let normalize_context_set g ctx us algs weak = +let normalize_context_set ~lbound g ctx us algs weak = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in (* Keep the Prop/Set <= i constraints separate for minimization *) let smallles, csts = - Constraint.partition (fun (l,d,r) -> d == Le && Level.is_small l) csts + Constraint.partition (fun (l,d,r) -> d == Le && (Level.equal l lbound || Level.is_sprop l)) csts in let smallles = if get_set_minimization () then Constraint.filter (fun (l,d,r) -> LSet.mem r ctx && not (Level.is_sprop l)) smallles @@ -282,12 +282,12 @@ let normalize_context_set g ctx us algs weak = let csts, partition = (* We first put constraints in a normal-form: all self-loops are collapsed to equalities. *) - let g = LSet.fold (fun v g -> UGraph.add_universe v false g) + let g = LSet.fold (fun v g -> UGraph.add_universe ~lbound ~strict:false v g) ctx UGraph.initial_universes in let add_soft u g = if not (Level.is_small u || LSet.mem u ctx) - then try UGraph.add_universe u false g with UGraph.AlreadyDeclared -> g + then try UGraph.add_universe ~lbound ~strict:false u g with UGraph.AlreadyDeclared -> g else g in let g = Constraint.fold @@ -300,7 +300,7 @@ let normalize_context_set g ctx us algs weak = (* We ignore the trivial Prop/Set <= i constraints. *) let noneqs = Constraint.filter - (fun (l,d,r) -> not ((d == Le && Level.is_small l) || + (fun (l,d,r) -> not ((d == Le && Level.equal l lbound) || (Level.is_prop l && d == Lt && Level.is_set r))) csts in diff --git a/engine/univMinim.mli b/engine/univMinim.mli index 21f6efe86a..72b432e62f 100644 --- a/engine/univMinim.mli +++ b/engine/univMinim.mli @@ -25,7 +25,7 @@ module UPairSet : CSet.S with type elt = (Level.t * Level.t) (a global one if there is one) and transitively saturate the constraints w.r.t to the equalities. *) -val normalize_context_set : UGraph.t -> ContextSet.t -> +val normalize_context_set : lbound:Univ.Level.t -> UGraph.t -> ContextSet.t -> universe_opt_subst (* The defined and undefined variables *) -> LSet.t (* univ variables that can be substituted by algebraics *) -> UPairSet.t (* weak equality constraints *) -> diff --git a/engine/univops.mli b/engine/univops.mli index 6cc7868a38..1f1edbed16 100644 --- a/engine/univops.mli +++ b/engine/univops.mli @@ -15,5 +15,5 @@ open Univ val universes_of_constr : constr -> LSet.t [@@ocaml.deprecated "Use [Vars.universes_of_constr]"] -val restrict_universe_context : ContextSet.t -> LSet.t -> ContextSet.t +val restrict_universe_context : lbound:Univ.Level.t -> ContextSet.t -> LSet.t -> ContextSet.t [@@ocaml.deprecated "Use [UState.restrict_universe_context]"] diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index f96cfebed5..ff0b90dcff 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -10,6 +10,9 @@ open Util module type GLexerType = Plexing.Lexer +type ty_norec = TyNoRec +type ty_mayrec = TyMayRec + module type S = sig type te @@ -23,12 +26,10 @@ module type S = val create : string -> 'a e val parse : 'a e -> parsable -> 'a val name : 'a e -> string - val of_parser : string -> (te Stream.t -> 'a) -> 'a e + val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a e val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit end - type ty_norec = TyNoRec - type ty_mayrec = TyMayRec type ('self, 'trec, 'a) ty_symbol type ('self, 'trec, 'f, 'r) ty_rule type 'a ty_rules @@ -92,9 +93,6 @@ let tokens con = egram.gtokens; !list -type ty_norec = TyNoRec -type ty_mayrec = TyMayRec - type ('a, 'b, 'c) ty_and_rec = | NoRec2 : (ty_norec, ty_norec, ty_norec) ty_and_rec | MayRec2 : ('a, 'b, ty_mayrec) ty_and_rec @@ -112,7 +110,7 @@ type 'a ty_entry = { and 'a ty_desc = | Dlevels of 'a ty_level list -| Dparser of 'a parser_t +| Dparser of (Plexing.location_function -> 'a parser_t) and 'a ty_level = Level : (_, _, 'a) ty_rec_level -> 'a ty_level @@ -1449,7 +1447,7 @@ let start_parser_of_entry entry = match entry.edesc with Dlevels [] -> empty_entry entry.ename | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun levn strm -> p strm + | Dparser p -> fun levn strm -> p !floc strm (* Extend syntax *) @@ -1549,9 +1547,9 @@ let clear_entry e = let parse_token_stream (e : 'a e) ts : 'a = e.estart 0 ts let name e = e.ename - let of_parser n (p : te Stream.t -> 'a) : 'a e = + let of_parser n (p : Plexing.location_function -> te Stream.t -> 'a) : 'a e = { ename = n; - estart = (fun _ -> p); + estart = (fun _ -> p !floc); econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); edesc = Dparser p} diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index ec4ec62409..9e48460206 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -19,6 +19,9 @@ module type GLexerType = Plexing.Lexer (** The input signature for the functor [Grammar.GMake]: [te] is the type of the tokens. *) +type ty_norec = TyNoRec +type ty_mayrec = TyMayRec + module type S = sig type te @@ -32,12 +35,10 @@ module type S = val create : string -> 'a e val parse : 'a e -> parsable -> 'a val name : 'a e -> string - val of_parser : string -> (te Stream.t -> 'a) -> 'a e + val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a e val parse_token_stream : 'a e -> te Stream.t -> 'a val print : Format.formatter -> 'a e -> unit end - type ty_norec = TyNoRec - type ty_mayrec = TyMayRec type ('self, 'trec, 'a) ty_symbol type ('self, 'trec, 'f, 'r) ty_rule type 'a ty_rules diff --git a/ide/coqide.ml b/ide/coqide.ml index 2c9f116cc3..9cdfd0dc21 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -110,7 +110,13 @@ let make_coqtop_args fname = | None -> args | Some fname -> if List.exists (String.equal "-top") args then args - else "-topfile"::fname::args + else + (* We basically copy the code of Names.check_valid since it is not exported *) + (* to coqide. This is to prevent a possible failure of parsing "-topfile" *) + (* at initialization of coqtop (see #10286) *) + match Unicode.ident_refutation (Filename.chop_extension (Filename.basename fname)) with + | Some (_,x) -> output_string stderr (x^"\n"); exit 1 + | None -> "-topfile"::fname::args in proj, args @@ -878,10 +884,20 @@ let no_under = Util.String.map (fun x -> if x = '_' then '-' else x) let alpha_items menu_name item_name l = let mk_item text = let text' = - let last = String.length text - 1 in - if text.[last] = '.' - then text ^"\n" - else text ^" " + let len = String.length text in + let buf = Buffer.create (len + 1) in + let escaped = ref false in + String.iter (fun c -> + if !escaped then + let () = Buffer.add_char buf c in + escaped := false + else if c = '_' then escaped := true + else Buffer.add_char buf c + ) text; + if text.[len - 1] = '.' + then Buffer.add_char buf '\n' + else Buffer.add_char buf ' '; + Buffer.contents buf in let callback _ = on_current_term (fun sn -> sn.buffer#insert_interactive text') diff --git a/ide/idetop.ml b/ide/idetop.ml index 7c6fa8951b..7e55eb4d13 100644 --- a/ide/idetop.ml +++ b/ide/idetop.ml @@ -56,7 +56,7 @@ let coqide_known_option table = List.mem table [ ["Printing";"Unfocused"]; ["Diffs"]] -let is_known_option cmd = match Vernacprop.under_control cmd with +let is_known_option cmd = match cmd with | VernacSetOption (_, o, OptionSetTrue) | VernacSetOption (_, o, OptionSetString _) | VernacSetOption (_, o, OptionUnset) -> coqide_known_option o @@ -64,7 +64,7 @@ let is_known_option cmd = match Vernacprop.under_control cmd with (** Check whether a command is forbidden in the IDE *) -let ide_cmd_checks ~last_valid ({ CAst.loc; _ } as cmd) = +let ide_cmd_checks ~last_valid { CAst.loc; v } = let user_error s = try CErrors.user_err ?loc ~hdr:"IDE" (str s) with e -> @@ -72,14 +72,14 @@ let ide_cmd_checks ~last_valid ({ CAst.loc; _ } as cmd) = let info = Stateid.add info ~valid:last_valid Stateid.dummy in Exninfo.raise ~info e in - if is_debug cmd then + if is_debug v.expr then user_error "Debug mode not available in the IDE" -let ide_cmd_warns ~id ({ CAst.loc; _ } as cmd) = +let ide_cmd_warns ~id { CAst.loc; v } = let warn msg = Feedback.(feedback ~id (Message (Warning, loc, strbrk msg))) in - if is_known_option cmd then + if is_known_option v.expr then warn "Set this option from the IDE menu instead"; - if is_navigation_vernac cmd || is_undo cmd then + if is_navigation_vernac v.expr || is_undo v.expr then warn "Use IDE navigation instead" (** Interpretation (cf. [Ide_intf.interp]) *) diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index e4af0fcee0..49b9149675 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -10,7 +10,6 @@ open Names open Libnames -open Decl_kinds (** {6 Concrete syntax for terms } *) @@ -39,8 +38,8 @@ type explicitation = | ExplByName of Id.t type binder_kind = - | Default of binding_kind - | Generalized of binding_kind * bool + | Default of Glob_term.binding_kind + | Generalized of Glob_term.binding_kind * bool (** (Inner binding always Implicit) Outer bindings, typeclass-specific flag for implicit generalization of superclasses *) @@ -121,7 +120,7 @@ and constr_expr_r = | CSort of Glob_term.glob_sort | CCast of constr_expr * constr_expr Glob_term.cast_type | CNotation of notation * constr_notation_substitution - | CGeneralization of binding_kind * abstraction_kind option * constr_expr + | CGeneralization of Glob_term.binding_kind * abstraction_kind option * constr_expr | CPrim of prim_token | CDelimiters of string * constr_expr and constr_expr = constr_expr_r CAst.t diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 8fce24249c..b4798127f9 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -17,25 +17,19 @@ open Namegen open Glob_term open Constrexpr open Notation -open Decl_kinds (***********************) (* For binders parsing *) -let binding_kind_eq bk1 bk2 = match bk1, bk2 with -| Explicit, Explicit -> true -| Implicit, Implicit -> true -| _ -> false - let abstraction_kind_eq ak1 ak2 = match ak1, ak2 with | AbsLambda, AbsLambda -> true | AbsPi, AbsPi -> true | _ -> false let binder_kind_eq b1 b2 = match b1, b2 with -| Default bk1, Default bk2 -> binding_kind_eq bk1 bk2 +| Default bk1, Default bk2 -> Glob_ops.binding_kind_eq bk1 bk2 | Generalized (ck1, b1), Generalized (ck2, b2) -> - binding_kind_eq ck1 ck2 && + Glob_ops.binding_kind_eq ck1 ck2 && (if b1 then b2 else not b2) | _ -> false @@ -172,7 +166,7 @@ let rec constr_expr_eq e1 e2 = | CPrim i1, CPrim i2 -> prim_token_eq i1 i2 | CGeneralization (bk1, ak1, e1), CGeneralization (bk2, ak2, e2) -> - binding_kind_eq bk1 bk2 && + Glob_ops.binding_kind_eq bk1 bk2 && Option.equal abstraction_kind_eq ak1 ak2 && constr_expr_eq e1 e2 | CDelimiters(s1,e1), CDelimiters(s2,e2) -> @@ -631,7 +625,8 @@ let interp_univ_constraints env evd cstrs = let interp_univ_decl env decl = let open UState in let pl : lident list = decl.univdecl_instance in - let evd = Evd.from_ctx (UState.make_with_initial_binders (Environ.universes env) pl) in + let evd = Evd.from_ctx (UState.make_with_initial_binders ~lbound:(Environ.universes_lbound env) + (Environ.universes env) pl) in let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in let decl = { univdecl_instance = pl; univdecl_extensible_instance = decl.univdecl_extensible_instance; diff --git a/interp/constrexpr_ops.mli b/interp/constrexpr_ops.mli index 3ed240d356..a05a9cb999 100644 --- a/interp/constrexpr_ops.mli +++ b/interp/constrexpr_ops.mli @@ -26,9 +26,6 @@ val constr_expr_eq : constr_expr -> constr_expr -> bool val local_binder_eq : local_binder_expr -> local_binder_expr -> bool (** Equality on [local_binder_expr]. Same properties as [constr_expr_eq]. *) -val binding_kind_eq : Decl_kinds.binding_kind -> Decl_kinds.binding_kind -> bool -(** Equality on [binding_kind] *) - val binder_kind_eq : binder_kind -> binder_kind -> bool (** Equality on [binder_kind] *) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 96392edb11..217381d854 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -27,7 +27,6 @@ open Glob_ops open Pattern open Notation open Detyping -open Decl_kinds module NamedDecl = Context.Named.Declaration (*i*) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index f341071728..f2cb4ae5c7 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -31,7 +31,6 @@ open Notation_term open Notation_ops open Notation open Inductiveops -open Decl_kinds open Context.Rel.Declaration (** constr_expr -> glob_constr translation: diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 8d6a266c30..41d1da9694 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -20,31 +20,21 @@ let open_glob_file f = let close_glob_file () = close_out !glob_file -type glob_output_t = - | NoGlob - | StdOut - | MultFiles - | Feedback - | File of string +type glob_output = + | NoGlob + | Feedback + | MultFiles + | File of string let glob_output = ref NoGlob -let dump () = !glob_output != NoGlob +let dump () = !glob_output <> NoGlob -let noglob () = glob_output := NoGlob - -let dump_to_dotglob () = glob_output := MultFiles - -let dump_into_file f = - if String.equal f "stdout" then - (glob_output := StdOut; glob_file := stdout) - else - (glob_output := File f; open_glob_file f) - -let feedback_glob () = glob_output := Feedback +let set_glob_output mode = + glob_output := mode let dump_string s = - if dump () && !glob_output != Feedback then + if dump () && !glob_output != Feedback then output_string !glob_file s let start_dump_glob ~vfile ~vofile = @@ -57,13 +47,13 @@ let start_dump_glob ~vfile ~vofile = | File f -> open_glob_file f; output_string !glob_file "DIGEST NO\n" - | NoGlob | Feedback | StdOut -> + | NoGlob | Feedback -> () let end_dump_glob () = match !glob_output with | MultFiles | File _ -> close_glob_file () - | NoGlob | Feedback | StdOut -> () + | NoGlob | Feedback -> () let previous_state = ref MultFiles let pause () = previous_state := !glob_output; glob_output := NoGlob diff --git a/interp/dumpglob.mli b/interp/dumpglob.mli index 60d62a1cb2..2b6a116a01 100644 --- a/interp/dumpglob.mli +++ b/interp/dumpglob.mli @@ -8,19 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val open_glob_file : string -> unit -val close_glob_file : unit -> unit - val start_dump_glob : vfile:string -> vofile:string -> unit val end_dump_glob : unit -> unit val dump : unit -> bool -val noglob : unit -> unit -val dump_into_file : string -> unit (** special handling of "stdout" *) +type glob_output = + | NoGlob + | Feedback + | MultFiles (* one glob file per .v file *) + | File of string (* Single file for all coqc arguments *) -val dump_to_dotglob : unit -> unit -val feedback_glob : unit -> unit +(* Default "NoGlob" *) +val set_glob_output : glob_output -> unit val pause : unit -> unit val continue : unit -> unit diff --git a/interp/impargs.ml b/interp/impargs.ml index 0466efa991..5f41c2a366 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -15,7 +15,6 @@ open Names open Constr open Globnames open Declarations -open Decl_kinds open Lib open Libobject open EConstr @@ -486,12 +485,19 @@ let subst_implicits_decl subst (r,imps as o) = let subst_implicits (subst,(req,l)) = (ImplLocal,List.Smart.map (subst_implicits_decl subst) l) +(* This was moved out of lib.ml, however it is not stored with regular + implicit data *) +let sec_implicits = + Summary.ref Id.Map.empty ~name:"section-implicits" + let impls_of_context ctx = - let map (decl, impl) = match impl with - | Implicit -> Some (NamedDecl.get_id decl, Manual, (true, true)) - | _ -> None + let map decl = + let id = NamedDecl.get_id decl in + match Id.Map.get id !sec_implicits with + | Glob_term.Implicit -> Some (id, Manual, (true, true)) + | Glob_term.Explicit -> None in - List.rev_map map (List.filter (fst %> NamedDecl.is_local_assum) ctx) + List.rev_map map (List.filter (NamedDecl.is_local_assum) ctx) let adjust_side_condition p = function | LessArgsThan n -> LessArgsThan (n+p) @@ -577,9 +583,10 @@ let declare_implicits local ref = if is_local local ref then ImplLocal else ImplInteractive(flags,ImplAuto) in declare_implicits_gen req flags ref -let declare_var_implicits id = +let declare_var_implicits id ~impl = let flags = !implicit_args in - declare_implicits_gen ImplLocal flags (GlobRef.VarRef id) + sec_implicits := Id.Map.add id impl !sec_implicits; + declare_implicits_gen ImplLocal flags (GlobRef.VarRef id) let declare_constant_implicits con = let flags = !implicit_args in diff --git a/interp/impargs.mli b/interp/impargs.mli index 90a7944642..2751b9d40b 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -93,7 +93,7 @@ val compute_implicits_names : env -> Evd.evar_map -> types -> Name.t list (** {6 Computation of implicits (done using the global environment). } *) -val declare_var_implicits : variable -> unit +val declare_var_implicits : variable -> impl:Glob_term.binding_kind -> unit val declare_constant_implicits : Constant.t -> unit val declare_mib_implicits : MutInd.t -> unit diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 9f6281ae15..455471a472 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -11,7 +11,6 @@ (*i*) open Names open Context -open Decl_kinds open CErrors open Util open Glob_term diff --git a/interp/notation.ml b/interp/notation.ml index d88182241b..ea2173860d 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1205,7 +1205,7 @@ let interp_notation ?loc ntn local_scopes = let scopes = make_current_scopes local_scopes in try let (n,sc) = find_interpretation ntn (find_notation ntn) scopes in - Option.iter (fun d -> warn_deprecated_notation (ntn,d)) n.not_deprecation; + Option.iter (fun d -> warn_deprecated_notation ?loc (ntn,d)) n.not_deprecation; n.not_interp, (n.not_location, sc) with Not_found -> user_err ?loc @@ -1533,7 +1533,7 @@ let discharge_arguments_scope (_,(req,r,n,l,_)) = let n = try let vars = Lib.variable_section_segment_of_reference r in - vars |> List.map fst |> List.filter is_local_assum |> List.length + vars |> List.filter is_local_assum |> List.length with Not_found (* Not a ref defined in this section *) -> 0 in Some (req,r,n,l,[]) diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 2fa78bb9f3..f30a874426 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -15,7 +15,6 @@ open Names open Nameops open Constr open Globnames -open Decl_kinds open Namegen open Glob_term open Glob_ops diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 302bb6ece2..9dded8656c 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -100,7 +100,7 @@ let warn_deprecated_syntactic_definition = let search_syntactic_definition ?loc kn = let syndef = KNmap.find kn !syntax_table in let def = out_pat syndef.syndef_pattern in - Option.iter (fun d -> warn_deprecated_syntactic_definition (kn,d)) syndef.syndef_deprecation; + Option.iter (fun d -> warn_deprecated_syntactic_definition ?loc (kn,d)) syndef.syndef_deprecation; def let search_filtered_syntactic_definition ?loc filter kn = @@ -108,5 +108,5 @@ let search_filtered_syntactic_definition ?loc filter kn = let def = out_pat syndef.syndef_pattern in let res = filter def in if Option.has_some res then - Option.iter (fun d -> warn_deprecated_syntactic_definition (kn,d)) syndef.syndef_deprecation; + Option.iter (fun d -> warn_deprecated_syntactic_definition ?loc (kn,d)) syndef.syndef_deprecation; res diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index 1fdafc9d8f..9fbd3f83d8 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -111,51 +111,26 @@ value uint63_mulc(value x, value y, value* h) { #define le128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_leq(xl,yl))) #define maxuint63 ((uint64_t)0x7FFFFFFFFFFFFFFF) -/* precondition: y <> 0 */ -/* outputs r and sets ql to q % 2^63 s.t. x = q * y + r, r < y */ +/* precondition: xh < y */ +/* outputs r and sets ql to q s.t. x = q * y + r, r < y */ static value uint63_div21_aux(value xh, value xl, value y, value* ql) { - xh = uint63_of_value(xh); - xl = uint63_of_value(xl); + uint64_t nh = uint63_of_value(xh); + uint64_t nl = uint63_of_value(xl); y = uint63_of_value(y); - uint64_t maskh = 0; - uint64_t maskl = 1; - uint64_t dh = 0; - uint64_t dl = y; - int cmp = 1; - /* int n = 0 */ - /* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0, d < 2^(2*63) */ - while (!(dh >> (63 - 1)) && cmp) { - dh = (dh << 1) | (dl >> (63 - 1)); - dl = (dl << 1) & maxuint63; - maskh = (maskh << 1) | (maskl >> (63 - 1)); - maskl = (maskl << 1) & maxuint63; - /* ++n */ - cmp = lt128(dh,dl,xh,xl); + uint64_t q = 0; + for (int i = 0; i < 63; ++i) { + // invariants: 0 <= nh < y, nl = (xl*2^i) % 2^64, + // (q*y + nh) * 2^(63-i) + (xl % 2^(63-i)) = (xh%y) * 2^63 + xl + nl <<= 1; + nh = (nh << 1) | (nl >> 63); + q <<= 1; + if (nh >= y) { q |= 1; nh -= y; } } - uint64_t remh = xh; - uint64_t reml = xl; - /* uint64_t quotienth = 0; */ - uint64_t quotientl = 0; - /* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, - mask = floor(2^n), d = mask * y, n >= -1 */ - while (maskh | maskl) { - if (le128(dh,dl,remh,reml)) { /* if rem >= d, add one bit and subtract d */ - /* quotienth = quotienth | maskh */ - quotientl = quotientl | maskl; - remh = (uint63_lt(reml,dl)) ? (remh - dh - 1) : (remh - dh); - reml = reml - dl; - } - maskl = (maskl >> 1) | ((maskh << (63 - 1)) & maxuint63); - maskh = maskh >> 1; - dl = (dl >> 1) | ((dh << (63 - 1)) & maxuint63); - dh = dh >> 1; - /* decr n */ - } - *ql = Val_int(quotientl); - return Val_int(reml); + *ql = Val_int(q); + return Val_int(nh); } value uint63_div21(value xh, value xl, value y, value* ql) { - if (uint63_of_value(y) == 0) { + if (uint63_leq(y, xh)) { *ql = Val_int(0); return Val_int(0); } else { diff --git a/kernel/declarations.ml b/kernel/declarations.ml index dff19dee5e..44676c9da5 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -66,6 +66,10 @@ type typing_flags = { (** If [false] then fixed points and co-fixed points are assumed to be total. *) + check_positive : bool; + (** If [false] then inductive types are assumed positive and co-inductive + types are assumed productive. *) + check_universes : bool; (** If [false] universe constraints are not checked *) @@ -83,6 +87,11 @@ type typing_flags = { indices_matter: bool; (** The universe of an inductive type must be above that of its indices. *) + + check_template : bool; + (* If [false] then we don't check that the universes template-polymorphic + inductive parameterize on are necessarily local and unbounded from below. + This potentially introduces inconsistencies. *) } (* some contraints are in constant_constraints, some other may be in diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 7a553700e8..7225671a1e 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -19,12 +19,14 @@ module RelDecl = Context.Rel.Declaration let safe_flags oracle = { check_guarded = true; + check_positive = true; check_universes = true; conv_oracle = oracle; share_reduction = true; enable_VM = true; enable_native_compiler = true; indices_matter = true; + check_template = true; } (** {6 Arities } *) diff --git a/kernel/dune b/kernel/dune index 4038bf5638..5f7502ef6b 100644 --- a/kernel/dune +++ b/kernel/dune @@ -3,7 +3,7 @@ (synopsis "The Coq Kernel") (public_name coq.kernel) (wrapped false) - (modules (:standard \ genOpcodeFiles uint63_i386_31 uint63_amd64_63 write_uint63)) + (modules (:standard \ genOpcodeFiles uint63_31 uint63_63)) (libraries lib byterun dynlink)) (executable @@ -16,7 +16,7 @@ (rule (targets uint63.ml) - (deps (:gen-file uint63_%{ocaml-config:architecture}_%{ocaml-config:int_size}.ml)) + (deps (:gen-file uint63_%{ocaml-config:int_size}.ml)) (action (copy# %{gen-file} %{targets}))) (documentation diff --git a/kernel/environ.ml b/kernel/environ.ml index 9a75f0b682..4a2aeea22d 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -59,8 +59,9 @@ type globals = { type stratification = { env_universes : UGraph.t; - env_engagement : engagement; env_sprop_allowed : bool; + env_universes_lbound : Univ.Level.t; + env_engagement : engagement } type val_kind = @@ -119,9 +120,9 @@ let empty_env = { env_nb_rel = 0; env_stratification = { env_universes = UGraph.initial_universes; - env_engagement = PredicativeSet; env_sprop_allowed = false; - }; + env_universes_lbound = Univ.Level.set; + env_engagement = PredicativeSet }; env_typing_flags = Declareops.safe_flags Conv_oracle.empty; retroknowledge = Retroknowledge.empty; indirect_pterms = Opaqueproof.empty_opaquetab; @@ -216,6 +217,9 @@ let lookup_named_ctxt id ctxt = let fold_constants f env acc = Cmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.env_constants acc +let fold_inductives f env acc = + Mindmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.env_inductives acc + (* Global constants *) let lookup_constant_key kn env = @@ -259,8 +263,15 @@ let type_in_type env = not (typing_flags env).check_universes let deactivated_guard env = not (typing_flags env).check_guarded let indices_matter env = env.env_typing_flags.indices_matter +let check_template env = env.env_typing_flags.check_template let universes env = env.env_stratification.env_universes +let universes_lbound env = env.env_stratification.env_universes_lbound + +let set_universes_lbound env lbound = + let env_stratification = { env.env_stratification with env_universes_lbound = lbound } in + { env with env_stratification } + let named_context env = env.env_named_context.env_named_ctx let named_context_val env = env.env_named_context let rel_context env = env.env_rel_context.env_rel_ctx @@ -379,29 +390,30 @@ let check_constraints c env = let push_constraints_to_env (_,univs) env = add_constraints univs env -let add_universes strict ctx g = +let add_universes ~lbound ~strict ctx g = let g = Array.fold_left - (fun g v -> UGraph.add_universe v strict g) + (fun g v -> UGraph.add_universe ~lbound ~strict v g) g (Univ.Instance.to_array (Univ.UContext.instance ctx)) in UGraph.merge_constraints (Univ.UContext.constraints ctx) g let push_context ?(strict=false) ctx env = - map_universes (add_universes strict ctx) env + map_universes (add_universes ~lbound:(universes_lbound env) ~strict ctx) env -let add_universes_set strict ctx g = +let add_universes_set ~lbound ~strict ctx g = let g = Univ.LSet.fold (* Be lenient, module typing reintroduces universes and constraints due to includes *) - (fun v g -> try UGraph.add_universe v strict g with UGraph.AlreadyDeclared -> g) + (fun v g -> try UGraph.add_universe ~lbound ~strict v g with UGraph.AlreadyDeclared -> g) (Univ.ContextSet.levels ctx) g in UGraph.merge_constraints (Univ.ContextSet.constraints ctx) g let push_context_set ?(strict=false) ctx env = - map_universes (add_universes_set strict ctx) env + map_universes (add_universes_set ~lbound:(universes_lbound env) ~strict ctx) env let push_subgraph (levels,csts) env = + let lbound = universes_lbound env in let add_subgraph g = - let newg = Univ.LSet.fold (fun v g -> UGraph.add_universe v false g) levels g in + let newg = Univ.LSet.fold (fun v g -> UGraph.add_universe ~lbound ~strict:false v g) levels g in let newg = UGraph.merge_constraints csts newg in (if not (Univ.Constraint.is_empty csts) then let restricted = UGraph.constraints_for ~kept:(UGraph.domain g) newg in @@ -418,20 +430,24 @@ let set_engagement c env = (* Unsafe *) (* It's convenient to use [{flags with foo = bar}] so we're smart wrt to it. *) let same_flags { check_guarded; + check_positive; check_universes; conv_oracle; indices_matter; share_reduction; enable_VM; enable_native_compiler; + check_template; } alt = check_guarded == alt.check_guarded && + check_positive == alt.check_positive && check_universes == alt.check_universes && conv_oracle == alt.conv_oracle && indices_matter == alt.indices_matter && share_reduction == alt.share_reduction && enable_VM == alt.enable_VM && - enable_native_compiler == alt.enable_native_compiler + enable_native_compiler == alt.enable_native_compiler && + check_template == alt.check_template [@warning "+9"] let set_typing_flags c env = (* Unsafe *) @@ -563,11 +579,20 @@ let polymorphic_pind (ind,u) env = let type_in_type_ind (mind,_i) env = not (lookup_mind mind env).mind_typing_flags.check_universes +let template_checked_ind (mind,_i) env = + (lookup_mind mind env).mind_typing_flags.check_template + let template_polymorphic_ind (mind,i) env = match (lookup_mind mind env).mind_packets.(i).mind_arity with | TemplateArity _ -> true | RegularArity _ -> false +let template_polymorphic_variables (mind,i) env = + match (lookup_mind mind env).mind_packets.(i).mind_arity with + | TemplateArity { Declarations.template_param_levels = l; _ } -> + List.map_filter (fun level -> level) l + | RegularArity _ -> [] + let template_polymorphic_pind (ind,u) env = if not (Univ.Instance.is_empty u) then false else template_polymorphic_ind ind env @@ -757,6 +782,22 @@ let is_template_polymorphic env r = | IndRef ind -> template_polymorphic_ind ind env | ConstructRef cstr -> template_polymorphic_ind (inductive_of_constructor cstr) env +let get_template_polymorphic_variables env r = + let open Names.GlobRef in + match r with + | VarRef _id -> [] + | ConstRef _c -> [] + | IndRef ind -> template_polymorphic_variables ind env + | ConstructRef cstr -> template_polymorphic_variables (inductive_of_constructor cstr) env + +let is_template_checked env r = + let open Names.GlobRef in + match r with + | VarRef _id -> false + | ConstRef _c -> false + | IndRef ind -> template_checked_ind ind env + | ConstructRef cstr -> template_checked_ind (inductive_of_constructor cstr) env + let is_type_in_type env r = let open Names.GlobRef in match r with diff --git a/kernel/environ.mli b/kernel/environ.mli index 6cd4f96645..f7de98dcfb 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -51,8 +51,9 @@ type globals type stratification = { env_universes : UGraph.t; - env_engagement : engagement; env_sprop_allowed : bool; + env_universes_lbound : Univ.Level.t; + env_engagement : engagement } type named_context_val = private { @@ -85,6 +86,8 @@ val eq_named_context_val : named_context_val -> named_context_val -> bool val empty_env : env val universes : env -> UGraph.t +val universes_lbound : env -> Univ.Level.t +val set_universes_lbound : env -> Univ.Level.t -> env val rel_context : env -> Constr.rel_context val named_context : env -> Constr.named_context val named_context_val : env -> named_context_val @@ -99,6 +102,7 @@ val is_impredicative_set : env -> bool val type_in_type : env -> bool val deactivated_guard : env -> bool val indices_matter : env -> bool +val check_template : env -> bool val is_impredicative_sort : env -> Sorts.t -> bool val is_impredicative_univ : env -> Univ.Universe.t -> bool @@ -176,6 +180,7 @@ val pop_rel_context : int -> env -> env (** Useful for printing *) val fold_constants : (Constant.t -> Opaqueproof.opaque constant_body -> 'a -> 'a) -> env -> 'a -> 'a +val fold_inductives : (MutInd.t -> Declarations.mutual_inductive_body -> 'a -> 'a) -> env -> 'a -> 'a (** {5 Global constants } {6 Add entries to global environment } *) @@ -253,7 +258,9 @@ val type_in_type_ind : inductive -> env -> bool (** Old-style polymorphism *) val template_polymorphic_ind : inductive -> env -> bool +val template_polymorphic_variables : inductive -> env -> Univ.Level.t list val template_polymorphic_pind : pinductive -> env -> bool +val template_checked_ind : inductive -> env -> bool (** {5 Modules } *) @@ -345,6 +352,8 @@ val remove_hyps : Id.Set.t -> (Constr.named_declaration -> Constr.named_declarat val is_polymorphic : env -> Names.GlobRef.t -> bool val is_template_polymorphic : env -> GlobRef.t -> bool +val get_template_polymorphic_variables : env -> GlobRef.t -> Univ.Level.t list +val is_template_checked : env -> GlobRef.t -> bool val is_type_in_type : env -> GlobRef.t -> bool (** Native compiler *) diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index c8e04b9fee..06d2e1bb21 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -236,22 +236,53 @@ let allowed_sorts {ind_squashed;ind_univ;ind_min_univ=_;ind_has_relevant_arg=_} if not ind_squashed then InType else Sorts.family (Sorts.sort_of_univ ind_univ) +(* For a level to be template polymorphic, it must be introduced + by the definition (so have no constraint except lbound <= l) + and not to be constrained from below, so any universe l' <= l + can be used as an instance of l. All bounds from above, i.e. + l <=/< r will be valid for any l' <= l. *) +let unbounded_from_below u cstrs = + Univ.Constraint.for_all (fun (l, d, r) -> + match d with + | Eq -> not (Univ.Level.equal l u) && not (Univ.Level.equal r u) + | Lt | Le -> not (Univ.Level.equal r u)) + cstrs + (* Returns the list [x_1, ..., x_n] of levels contributing to template - polymorphism. The elements x_k is None if the k-th parameter (starting - from the most recent and ignoring let-definitions) is not contributing - or is Some u_k if its level is u_k and is contributing. *) -let param_ccls paramsctxt = + polymorphism. The elements x_k is None if the k-th parameter + (starting from the most recent and ignoring let-definitions) is not + contributing to the inductive type's sort or is Some u_k if its level + is u_k and is contributing. *) +let template_polymorphic_univs ~template_check uctx paramsctxt concl = + let check_level l = + if Univ.LSet.mem l (Univ.ContextSet.levels uctx) && + unbounded_from_below l (Univ.ContextSet.constraints uctx) then + Some l + else None + in + let univs = Univ.Universe.levels concl in + let univs = + if template_check then + Univ.LSet.filter (fun l -> Option.has_some (check_level l) || Univ.Level.is_prop l) univs + else univs (* Doesn't check the universes can be generalized *) + in let fold acc = function | (LocalAssum (_, p)) -> (let c = Term.strip_prod_assum p in match kind c with - | Sort (Type u) -> Univ.Universe.level u + | Sort (Type u) -> + if template_check then + (match Univ.Universe.level u with + | Some l -> if Univ.LSet.mem l univs && not (Univ.Level.is_prop l) then Some l else None + | None -> None) + else Univ.Universe.level u | _ -> None) :: acc | LocalDef _ -> acc in - List.fold_left fold [] paramsctxt + let params = List.fold_left fold [] paramsctxt in + params, univs -let abstract_packets univs usubst params ((arity,lc),(indices,splayed_lc),univ_info) = +let abstract_packets ~template_check univs usubst params ((arity,lc),(indices,splayed_lc),univ_info) = let arity = Vars.subst_univs_level_constr usubst arity in let lc = Array.map (Vars.subst_univs_level_constr usubst) lc in let indices = Vars.subst_univs_level_context usubst indices in @@ -264,14 +295,20 @@ let abstract_packets univs usubst params ((arity,lc),(indices,splayed_lc),univ_i let ind_univ = Univ.subst_univs_level_universe usubst univ_info.ind_univ in let arity = match univ_info.ind_min_univ with - | None -> RegularArity {mind_user_arity=arity;mind_sort=Sorts.sort_of_univ ind_univ} + | None -> RegularArity {mind_user_arity = arity; mind_sort = Sorts.sort_of_univ ind_univ} | Some min_univ -> - ((match univs with - | Monomorphic _ -> () + let ctx = match univs with + | Monomorphic ctx -> ctx | Polymorphic _ -> CErrors.anomaly ~label:"polymorphic_template_ind" - Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.")); - TemplateArity {template_param_levels=param_ccls params; template_level=min_univ}) + Pp.(strbrk "Template polymorphism and full polymorphism are incompatible.") in + let param_levels, concl_levels = template_polymorphic_univs ~template_check ctx params min_univ in + if template_check && List.for_all (fun x -> Option.is_empty x) param_levels + && Univ.LSet.is_empty concl_levels then + CErrors.anomaly ~label:"polymorphic_template_ind" + Pp.(strbrk "Ill-formed template inductive declaration: not polymorphic on any universe.") + else + TemplateArity {template_param_levels = param_levels; template_level = min_univ} in let kelim = allowed_sorts univ_info in @@ -286,10 +323,14 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = mind_check_names mie; assert (List.is_empty (Environ.rel_context env)); + let has_template_poly = List.exists (fun oie -> oie.mind_entry_template) mie.mind_entry_inds in + (* universes *) let env_univs = match mie.mind_entry_universes with - | Monomorphic_entry ctx -> push_context_set ctx env + | Monomorphic_entry ctx -> + let env = if has_template_poly then set_universes_lbound env Univ.Level.prop else env in + push_context_set ctx env | Polymorphic_entry (_, ctx) -> push_context ctx env in @@ -335,7 +376,8 @@ let typecheck_inductive env (mie:mutual_inductive_entry) = (* Abstract universes *) let usubst, univs = Declareops.abstract_universes mie.mind_entry_universes in let params = Vars.subst_univs_level_context usubst params in - let data = List.map (abstract_packets univs usubst params) data in + let template_check = Environ.check_template env in + let data = List.map (abstract_packets ~template_check univs usubst params) data in let env_ar_par = let ctx = Environ.rel_context env_ar_par in diff --git a/kernel/indTyping.mli b/kernel/indTyping.mli index aaa0d6a149..8da4e2885c 100644 --- a/kernel/indTyping.mli +++ b/kernel/indTyping.mli @@ -33,3 +33,12 @@ val typecheck_inductive : env -> mutual_inductive_entry -> (Constr.rel_context * (Constr.rel_context * Constr.types) array) * Sorts.family) array + +(* Utility function to compute the actual universe parameters + of a template polymorphic inductive *) +val template_polymorphic_univs : + template_check:bool -> + Univ.ContextSet.t -> + Constr.rel_context -> + Univ.Universe.t -> + Univ.Level.t option list * Univ.LSet.t diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index b0366d6ec0..aa3ef715db 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -546,7 +546,7 @@ let check_inductive env kn mie = (* First type-check the inductive definition *) let (env_ar_par, univs, variance, record, paramsctxt, inds) = IndTyping.typecheck_inductive env mie in (* Then check positivity conditions *) - let chkpos = (Environ.typing_flags env).check_guarded in + let chkpos = (Environ.typing_flags env).check_positive in let names = Array.map_of_list (fun entry -> entry.mind_entry_typename, entry.mind_entry_consnames) mie.mind_entry_inds in diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 9305a91731..ccc218771a 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -94,7 +94,8 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = c', Monomorphic Univ.ContextSet.empty, cst | Polymorphic uctx, Some ctx -> let () = - if not (UGraph.check_subtype (Environ.universes env) uctx ctx) then + if not (UGraph.check_subtype ~lbound:(Environ.universes_lbound env) + (Environ.universes env) uctx ctx) then error_incorrect_with_constraint lab in (** Terms are compared in a context with De Bruijn universe indices *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 53f228c618..327cb2efeb 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -777,7 +777,7 @@ let infer_cmp_universes env pb s0 s1 univs = | Prop, (Set | Type _) -> if not (is_cumul pb) then raise NotConvertible else univs | Set, Prop -> raise NotConvertible | Set, Type u -> infer_pb Univ.type0_univ u - | Type _u, Prop -> raise NotConvertible + | Type u, Prop -> infer_pb u Univ.type0m_univ | Type u, Set -> infer_pb u Univ.type0_univ | Type u0, Type u1 -> infer_pb u0 u1 diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index ea45f699ce..6970a11e72 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -194,6 +194,18 @@ let set_typing_flags c senv = if env == senv.env then senv else { senv with env } +let set_check_guarded b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with check_guarded = b } senv + +let set_check_positive b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with check_positive = b } senv + +let set_check_universes b senv = + let flags = Environ.typing_flags senv.env in + set_typing_flags { flags with check_universes = b } senv + let set_indices_matter indices_matter senv = set_typing_flags { (Environ.typing_flags senv.env) with indices_matter } senv diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 2406b6add1..fa53fa33fa 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -130,6 +130,9 @@ val set_engagement : Declarations.engagement -> safe_transformer0 val set_indices_matter : bool -> safe_transformer0 val set_typing_flags : Declarations.typing_flags -> safe_transformer0 val set_share_reduction : bool -> safe_transformer0 +val set_check_guarded : bool -> safe_transformer0 +val set_check_positive : bool -> safe_transformer0 +val set_check_universes : bool -> safe_transformer0 val set_VM : bool -> safe_transformer0 val set_native_compiler : bool -> safe_transformer0 val make_sprop_cumulative : safe_transformer0 diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index d47dc0c6e1..d22ec3b7ca 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -97,7 +97,8 @@ let check_universes error env u1 u2 = match u1, u2 with | Monomorphic _, Monomorphic _ -> env | Polymorphic auctx1, Polymorphic auctx2 -> - if not (UGraph.check_subtype (Environ.universes env) auctx2 auctx1) then + let lbound = Environ.universes_lbound env in + if not (UGraph.check_subtype ~lbound (Environ.universes env) auctx2 auctx1) then error (IncompatibleConstraints { got = auctx1; expect = auctx2; } ) else Environ.push_context ~strict:false (Univ.AUContext.repr auctx2) env diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 6fde6e9c5f..33336079bb 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -149,10 +149,10 @@ let enforce_leq_alg u v g = cg exception AlreadyDeclared = G.AlreadyDeclared -let add_universe u strict g = +let add_universe u ~lbound ~strict g = let graph = G.add u g.graph in let d = if strict then Lt else Le in - enforce_constraint (Level.set,d,u) {g with graph} + enforce_constraint (lbound,d,u) {g with graph} let add_universe_unconstrained u g = {g with graph=G.add u g.graph} @@ -164,11 +164,11 @@ let constraints_for ~kept g = G.constraints_for ~kept:(LSet.remove Level.sprop k (** Subtyping of polymorphic contexts *) -let check_subtype univs ctxT ctx = +let check_subtype ~lbound univs ctxT ctx = if AUContext.size ctxT == AUContext.size ctx then let (inst, cst) = UContext.dest (AUContext.repr ctx) in let cstT = UContext.constraints (AUContext.repr ctxT) in - let push accu v = add_universe v false accu in + let push accu v = add_universe v ~lbound ~strict:false accu in let univs = Array.fold_left push univs (Instance.to_array inst) in let univs = merge_constraints cstT univs in check_constraints cst univs diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index e1b5868d55..d90f01d8d1 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -48,7 +48,7 @@ val enforce_leq_alg : Universe.t -> Universe.t -> t -> Constraint.t * t exception AlreadyDeclared -val add_universe : Level.t -> bool -> t -> t +val add_universe : Level.t -> lbound:Level.t -> strict:bool -> t -> t (** Add a universe without (Prop,Set) <= u *) val add_universe_unconstrained : Level.t -> t -> t @@ -86,7 +86,7 @@ val constraints_for : kept:LSet.t -> t -> Constraint.t val domain : t -> LSet.t (** Known universes *) -val check_subtype : AUContext.t check_function +val check_subtype : lbound:Level.t -> AUContext.t check_function (** [check_subtype univ ctx1 ctx2] checks whether [ctx2] is an instance of [ctx1]. *) diff --git a/kernel/uint63.mli b/kernel/uint63.mli index 5542716af2..d22ba3468f 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + type t val uint_size : int diff --git a/kernel/uint63_i386_31.ml b/kernel/uint63_31.ml index 2a3fc75ec1..b8eccd19fb 100644 --- a/kernel/uint63_i386_31.ml +++ b/kernel/uint63_31.ml @@ -88,55 +88,28 @@ let diveucl x y = (div x y, rem x y) let addmuldiv p x y = l_or (l_sl x p) (l_sr y Int64.(sub (of_int uint_size) p)) -(* A few helper functions on 128 bits *) -let lt128 xh xl yh yl = - lt xh yh || (xh = yh && lt xl yl) - -let le128 xh xl yh yl = - lt xh yh || (xh = yh && le xl yl) - (* division of two numbers by one *) -(* precondition: y <> 0 *) -(* outputs: q % 2^63, r s.t. x = q * y + r, r < y *) +(* precondition: xh < y *) +(* outputs: q, r s.t. x = q * y + r, r < y *) let div21 xh xl y = - let maskh = ref zero in - let maskl = ref one in - let dh = ref zero in - let dl = ref y in - let cmp = ref true in - (* n = ref 0 *) - (* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0 *) - while Int64.equal (l_sr !dh (of_int (uint_size - 1))) zero && !cmp do - (* We don't use addmuldiv below to avoid checks on 1 *) - dh := l_or (l_sl !dh one) (l_sr !dl (of_int (uint_size - 1))); - dl := l_sl !dl one; - maskh := l_or (l_sl !maskh one) (l_sr !maskl (of_int (uint_size - 1))); - maskl := l_sl !maskl one; - (* incr n *) - cmp := lt128 !dh !dl xh xl; - done; (* mask = 2^n, d = 2^n * d, 2 * d > x *) - let remh = ref xh in - let reml = ref xl in - (* quotienth = ref 0 *) - let quotientl = ref zero in - (* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, - mask = floor(2^n), d = mask * y, n >= -1 *) - while not (Int64.equal (l_or !maskh !maskl) zero) do - if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) - (* quotienth := !quotienth lor !maskh *) - quotientl := l_or !quotientl !maskl; - remh := if lt !reml !dl then sub (sub !remh !dh) one else sub !remh !dh; - reml := sub !reml !dl - end; - maskl := l_or (l_sr !maskl one) (l_sl !maskh (of_int (uint_size - 1))); - maskh := l_sr !maskh one; - dl := l_or (l_sr !dl one) (l_sl !dh (of_int (uint_size - 1))); - dh := l_sr !dh one - (* decr n *) + let nh = ref xh in + let nl = ref xl in + let q = ref 0L in + for _i = 0 to 62 do + (* invariants: 0 <= nh < y, nl = (xl*2^i) % 2^64, + (q*y + nh) * 2^(63-i) + (xl % 2^(63-i)) = (xh%y) * 2^63 + xl *) + nl := Int64.shift_left !nl 1; + nh := Int64.logor (Int64.shift_left !nh 1) (Int64.shift_right_logical !nl 63); + q := Int64.shift_left !q 1; + (* TODO: use "Int64.unsigned_compare !nh y >= 0", + once OCaml 4.08 becomes the minimal required version *) + if Int64.compare !nh 0L < 0 || Int64.compare !nh y >= 0 then + begin q := Int64.logor !q 1L; nh := Int64.sub !nh y; end done; - !quotientl, !reml + !q, !nh -let div21 xh xl y = if Int64.equal y zero then zero, zero else div21 xh xl y +let div21 xh xl y = + if Int64.compare y xh <= 0 then zero, zero else div21 xh xl y (* exact multiplication *) let mulc x y = diff --git a/kernel/uint63_amd64_63.ml b/kernel/uint63_63.ml index d6b077a9f5..5c4028e1c8 100644 --- a/kernel/uint63_amd64_63.ml +++ b/kernel/uint63_63.ml @@ -96,55 +96,32 @@ let le (x : int) (y : int) = (x lxor 0x4000000000000000) <= (y lxor 0x4000000000000000) [@@ocaml.inline always] -(* A few helper functions on 128 bits *) -let lt128 xh xl yh yl = - lt xh yh || (xh = yh && lt xl yl) - -let le128 xh xl yh yl = - lt xh yh || (xh = yh && le xl yl) - (* division of two numbers by one *) -(* precondition: y <> 0 *) -(* outputs: q % 2^63, r s.t. x = q * y + r, r < y *) +(* precondition: xh < y *) +(* outputs: q, r s.t. x = q * y + r, r < y *) let div21 xh xl y = - let maskh = ref 0 in - let maskl = ref 1 in - let dh = ref 0 in - let dl = ref y in - let cmp = ref true in - (* n = ref 0 *) - (* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0 *) - while !dh >= 0 && !cmp do (* dh >= 0 tests that dh highest bit is zero *) - (* We don't use addmuldiv below to avoid checks on 1 *) - dh := (!dh lsl 1) lor (!dl lsr (uint_size - 1)); - dl := !dl lsl 1; - maskh := (!maskh lsl 1) lor (!maskl lsr (uint_size - 1)); - maskl := !maskl lsl 1; - (* incr n *) - cmp := lt128 !dh !dl xh xl; - done; (* mask = 2^n, d = 2^n * y, 2 * d > x *) - let remh = ref xh in - let reml = ref xl in - (* quotienth = ref 0 *) - let quotientl = ref 0 in - (* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, - mask = floor(2^n), d = mask * y, n >= -1 *) - while !maskh lor !maskl <> 0 do - if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) - (* quotienth := !quotienth lor !maskh *) - quotientl := !quotientl lor !maskl; - remh := if lt !reml !dl then !remh - !dh - 1 else !remh - !dh; - reml := !reml - !dl; - end; - maskl := (!maskl lsr 1) lor (!maskh lsl (uint_size - 1)); - maskh := !maskh lsr 1; - dl := (!dl lsr 1) lor (!dh lsl (uint_size - 1)); - dh := !dh lsr 1; - (* decr n *) + (* nh might temporarily grow as large as 2*y - 1 in the loop body, + so we store it as a 64-bit unsigned integer *) + let nh = ref xh in + let nl = ref xl in + let q = ref 0 in + for _i = 0 to 62 do + (* invariants: 0 <= nh < y, nl = (xl*2^i) % 2^63, + (q*y + nh) * 2^(63-i) + (xl % 2^(63-i)) = (xh%y) * 2^63 + xl *) + nh := Int64.logor (Int64.shift_left !nh 1) (Int64.of_int (!nl lsr 62)); + nl := !nl lsl 1; + q := !q lsl 1; + (* TODO: use "Int64.unsigned_compare !nh y >= 0", + once OCaml 4.08 becomes the minimal required version *) + if Int64.compare !nh 0L < 0 || Int64.compare !nh y >= 0 then + begin q := !q lor 1; nh := Int64.sub !nh y; end done; - !quotientl, !reml + !q, Int64.to_int !nh -let div21 xh xl y = if y = 0 then 0, 0 else div21 xh xl y +let div21 xh xl y = + let xh = to_uint64 xh in + let y = to_uint64 y in + if Int64.compare y xh <= 0 then 0, 0 else div21 xh xl y (* exact multiplication *) (* TODO: check that none of these additions could be a logical or *) diff --git a/kernel/write_uint63.ml b/kernel/write_uint63.ml deleted file mode 100644 index 57a170c8f5..0000000000 --- a/kernel/write_uint63.ml +++ /dev/null @@ -1,38 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Equivalent of rm -f *) -let safe_remove f = - try Unix.chmod f 0o644; Sys.remove f with _ -> () - -(** * Generate an implementation of 63-bit arithmetic *) -let ml_file_copy input output = - safe_remove output; - let i = open_in input in - let o = open_out output in - let pr s = Printf.fprintf o s in - pr "(* DO NOT EDIT THIS FILE: automatically generated by ./write_uint63.ml *)\n"; - pr "(* see uint63_amd64.ml and uint63_x86.ml *)\n"; - try - while true do - output_string o (input_line i); output_char o '\n' - done - with End_of_file -> - close_in i; - close_out o; - Unix.chmod output 0o444 - -let write_uint63 () = - ml_file_copy - (if max_int = 1073741823 (* 32-bits *) then "uint63_i386_31.ml" - else (* 64 bits *) "uint63_amd64_63.ml") - "uint63.ml" - -let () = write_uint63 () diff --git a/lib/aux_file.mli b/lib/aux_file.mli index 60c8fb4449..b241fdc6cc 100644 --- a/lib/aux_file.mli +++ b/lib/aux_file.mli @@ -21,7 +21,7 @@ val contents : aux_file -> string M.t H.t val aux_file_name_for : string -> string val start_aux_file : aux_file:string -> v_file:string -> unit -val stop_aux_file : unit -> unit +val stop_aux_file : unit -> unit val recording : unit -> bool val record_in_aux_at : ?loc:Loc.t -> string -> string -> unit diff --git a/lib/feedback.mli b/lib/feedback.mli index dc8449ed71..5375d97d57 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -74,13 +74,8 @@ val feedback : ?did:doc_id -> ?id:Stateid.t -> ?route:route_id -> feedback_conte (** [set_id_for_feedback route id] Set the defaults for feedback *) val set_id_for_feedback : ?route:route_id -> doc_id -> Stateid.t -> unit -(** {6 output functions} +(** {6 output functions} *) -[msg_notice] do not put any decoration on output by default. If -possible don't mix it with goal output (prefer msg_info or -msg_warning) so that interfaces can dispatch outputs easily. Once all -interfaces use the xml-like protocol this constraint can be -relaxed. *) (* Should we advertise these functions more? Should they be the ONLY allowed way to output something? *) diff --git a/lib/flags.ml b/lib/flags.ml index 190de5853d..f09dc48f5d 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -41,8 +41,6 @@ let with_options ol f x = let () = List.iter2 (:=) ol vl in Exninfo.iraise reraise -let record_aux_file = ref false - let async_proofs_worker_id = ref "master" let async_proofs_is_worker () = !async_proofs_worker_id <> "master" diff --git a/lib/flags.mli b/lib/flags.mli index 1c96796220..185a5f8425 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -31,10 +31,6 @@ (** Command-line flags *) -(** Set by coqtop to tell the kernel to output to the aux file; will - be eventually removed by cleanups such as PR#1103 *) -val record_aux_file : bool ref - (** Async-related flags *) val async_proofs_worker_id : string ref val async_proofs_is_worker : unit -> bool diff --git a/lib/future.ml b/lib/future.ml index 01fb7d0297..d3ea538549 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -98,7 +98,6 @@ let peek_val kx = let _, _, _, x = get kx in match !x with let uuid kx = let _, id, _, _ = get kx in id let from_val ?(fix_exn=id) v = create fix_exn (Val v) -let from_here ?(fix_exn=id) v = create fix_exn (Val v) let fix_exn_of ck = let _, _, fix_exn, _ = get ck in fix_exn @@ -168,8 +167,6 @@ let join kx = kx := Finished v; v -let sink kx = if is_val kx then ignore(join kx) - let split2 x = chain x (fun x -> fst x), chain x (fun x -> snd x) diff --git a/lib/future.mli b/lib/future.mli index 8e5f704837..c0fc91bcc3 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -55,10 +55,6 @@ val create : fix_exn -> (unit -> 'a) -> 'a computation argument should really be given *) val from_val : ?fix_exn:fix_exn -> 'a -> 'a computation -(* Like from_val, but also takes a snapshot of the global state. Morally - the value is not just the 'a but also the global system state *) -val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation - (* To get the fix_exn of a computation and build a Lemmas.declaration_hook. * When a future enters the environment a corresponding hook is run to perform * some work. If this fails, then its failure has to be annotated with the @@ -100,9 +96,6 @@ val compute : 'a computation -> 'a value * in a computation obtained by chaining on a joined future. *) val join : 'a computation -> 'a -(* Call this before stocking the future. If it is_val then it is joined *) -val sink : 'a computation -> unit - (*** Utility functions ************************************************* ***) val split2 : ('a * 'b) computation -> 'a computation * 'b computation diff --git a/lib/system.ml b/lib/system.ml index 46b358f825..8c333ec267 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -53,8 +53,14 @@ module StrSet = Set.Make(StrMod) let dirmap = ref StrMap.empty let make_dir_table dir = + let entries = + try + Sys.readdir dir + with Sys_error _ -> + warn_cannot_open_dir dir; + [||] in let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in - Array.fold_left filter_dotfiles StrSet.empty (Sys.readdir dir) + Array.fold_left filter_dotfiles StrSet.empty entries (** Don't trust in interactive mode (the default) *) let trust_file_cache = ref false @@ -294,13 +300,13 @@ let with_time ~batch ~header f x = let y = f x in let tend = get_time() in let msg2 = if batch then "" else " (successful)" in - Feedback.msg_info (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_notice (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); y with e -> let tend = get_time() in let msg = if batch then "" else "Finished failing transaction in " in let msg2 = if batch then "" else " (failure)" in - Feedback.msg_info (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_notice (header ++ str msg ++ fmt_time_difference tstart tend ++ str msg2); raise e (* We use argv.[0] as we don't want to resolve symlinks *) diff --git a/library/coqlib.ml b/library/coqlib.ml index b1e4ef2b00..11d053624c 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -104,8 +104,10 @@ let gen_reference_in_modules locstr dirs s = let check_required_library d = let dir = make_dir d in - if Library.library_is_loaded dir then () - else + try + let _ : Declarations.module_body = Global.lookup_module (ModPath.MPfile dir) in + () + with Not_found -> let in_current_dir = match Lib.current_mp () with | MPfile dp -> DirPath.equal dir dp | _ -> false diff --git a/library/global.ml b/library/global.ml index ca774dbd74..6bb4614aa4 100644 --- a/library/global.ml +++ b/library/global.ml @@ -89,6 +89,9 @@ let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) let set_engagement c = globalize0 (Safe_typing.set_engagement c) let set_indices_matter b = globalize0 (Safe_typing.set_indices_matter b) let set_typing_flags c = globalize0 (Safe_typing.set_typing_flags c) +let set_check_guarded c = globalize0 (Safe_typing.set_check_guarded c) +let set_check_positive c = globalize0 (Safe_typing.set_check_positive c) +let set_check_universes c = globalize0 (Safe_typing.set_check_universes c) let typing_flags () = Environ.typing_flags (env ()) let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) @@ -116,6 +119,7 @@ let add_module_parameter mbid mte inl = (** Queries on the global environment *) let universes () = universes (env()) +let universes_lbound () = universes_lbound (env()) let named_context () = named_context (env()) let named_context_val () = named_context_val (env()) @@ -178,6 +182,10 @@ let is_polymorphic r = Environ.is_polymorphic (env()) r let is_template_polymorphic r = is_template_polymorphic (env ()) r +let is_template_checked r = is_template_checked (env ()) r + +let get_template_polymorphic_variables r = get_template_polymorphic_variables (env ()) r + let is_type_in_type r = is_type_in_type (env ()) r let current_modpath () = diff --git a/library/global.mli b/library/global.mli index d034bc4208..d0bd556d70 100644 --- a/library/global.mli +++ b/library/global.mli @@ -22,6 +22,7 @@ val env : unit -> Environ.env val env_is_initial : unit -> bool val universes : unit -> UGraph.t +val universes_lbound : unit -> Univ.Level.t val named_context_val : unit -> Environ.named_context_val val named_context : unit -> Constr.named_context @@ -31,6 +32,9 @@ val named_context : unit -> Constr.named_context val set_engagement : Declarations.engagement -> unit val set_indices_matter : bool -> unit val set_typing_flags : Declarations.typing_flags -> unit +val set_check_guarded : bool -> unit +val set_check_positive : bool -> unit +val set_check_universes : bool -> unit val typing_flags : unit -> Declarations.typing_flags val make_sprop_cumulative : unit -> unit val set_allow_sprop : bool -> unit @@ -133,6 +137,8 @@ val is_joined_environment : unit -> bool val is_polymorphic : GlobRef.t -> bool val is_template_polymorphic : GlobRef.t -> bool +val is_template_checked : GlobRef.t -> bool +val get_template_polymorphic_variables : GlobRef.t -> Univ.Level.t list val is_type_in_type : GlobRef.t -> bool (** {6 Retroknowledge } *) diff --git a/library/goptions.ml b/library/goptions.ml index c7024ca81d..0973944fb5 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -398,9 +398,9 @@ let print_option_value key = let s = read () in match s with | BoolValue b -> - Feedback.msg_info (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) + Feedback.msg_notice (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) | _ -> - Feedback.msg_info (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) + Feedback.msg_notice (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) let get_tables () = let tables = !value_tab in diff --git a/library/lib.ml b/library/lib.ml index 59b55cc16b..3f51826315 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -413,11 +413,8 @@ let find_opening_node id = - the list of substitution to do at section closing *) -type variable_info = Constr.named_declaration * Decl_kinds.binding_kind - -type variable_context = variable_info list type abstr_info = { - abstr_ctx : variable_context; + abstr_ctx : Constr.named_context; abstr_subst : Univ.Instance.t; abstr_uctx : Univ.AUContext.t; } @@ -426,21 +423,17 @@ type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t type secentry = | Variable of { id:Names.Id.t; - kind:Decl_kinds.binding_kind; - univs:Univ.ContextSet.t; } | Context of Univ.ContextSet.t type section_data = { sec_entry : secentry list; - sec_workl : Opaqueproof.work_list; sec_abstr : abstr_list; sec_poly : bool; } let empty_section_data ~poly = { sec_entry = []; - sec_workl = (Names.Cmap.empty,Names.Mindmap.empty); sec_abstr = (Names.Cmap.empty,Names.Mindmap.empty); sec_poly = poly; } @@ -456,12 +449,12 @@ let add_section ~poly () = List.iter (fun tab -> check_same_poly poly tab) !sectab; sectab := empty_section_data ~poly :: !sectab -let add_section_variable ~name ~kind ~poly univs = +let add_section_variable ~name ~poly = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | s :: sl -> List.iter (fun tab -> check_same_poly poly tab) !sectab; - let s = { s with sec_entry = Variable {id=name;kind;univs} :: s.sec_entry } in + let s = { s with sec_entry = Variable {id=name} :: s.sec_entry } in sectab := s :: sl let add_section_context ctx = @@ -472,38 +465,45 @@ let add_section_context ctx = let s = { s with sec_entry = Context ctx :: s.sec_entry } in sectab := s :: sl -exception PolyFound of bool (* make this a let exception once possible *) +exception PolyFound (* make this a let exception once possible *) let is_polymorphic_univ u = try let open Univ in List.iter (fun s -> let vars = s.sec_entry in List.iter (function - | Variable {univs=(univs,_)} -> - if LSet.mem u univs then raise (PolyFound s.sec_poly) + | Variable _ -> () | Context (univs,_) -> - if LSet.mem u univs then raise (PolyFound true) + if LSet.mem u univs then raise PolyFound ) vars ) !sectab; false - with PolyFound b -> b + with PolyFound -> true let extract_hyps poly (secs,ohyps) = let rec aux = function - | (Variable {id;kind;univs}::idl, decl::hyps) when Names.Id.equal id (NamedDecl.get_id decl) -> + | (Variable {id}::idl, decl::hyps) when Names.Id.equal id (NamedDecl.get_id decl) -> let l, r = aux (idl,hyps) in - (decl,kind) :: l, if poly then Univ.ContextSet.union r univs else r - | (Variable {univs}::idl,hyps) -> + decl :: l, r + | (Variable _::idl,hyps) -> let l, r = aux (idl,hyps) in - l, if poly then Univ.ContextSet.union r univs else r + l, r | (Context ctx :: idl, hyps) -> + let () = assert poly in let l, r = aux (idl, hyps) in l, Univ.ContextSet.union r ctx | [], _ -> [],Univ.ContextSet.empty in aux (secs,ohyps) let instance_from_variable_context = - List.map fst %> List.filter is_local_assum %> List.map NamedDecl.get_id %> Array.of_list + List.rev %> List.filter is_local_assum %> List.map NamedDecl.get_id %> Array.of_list + +let extract_worklist info = + let args = instance_from_variable_context info.abstr_ctx in + info.abstr_subst, args + +let make_worklist (cmap, mmap) = + Cmap.map extract_worklist cmap, Mindmap.map extract_worklist mmap let name_instance inst = (* FIXME: this should probably be done at an upper level, by storing the @@ -522,37 +522,34 @@ let name_instance inst = in Array.map map (Univ.Instance.to_array inst) -let add_section_replacement f g poly hyps = +let add_section_replacement g poly hyps = match !sectab with | [] -> () | s :: sl -> let () = check_same_poly poly s in let sechyps,ctx = extract_hyps s.sec_poly (s.sec_entry, hyps) in let ctx = Univ.ContextSet.to_context ctx in - let inst = Univ.UContext.instance ctx in - let nas = name_instance inst in + let nas = name_instance (Univ.UContext.instance ctx) in let subst, ctx = Univ.abstract_universes nas ctx in - let args = instance_from_variable_context (List.rev sechyps) in let info = { abstr_ctx = sechyps; abstr_subst = subst; abstr_uctx = ctx; } in let s = { s with - sec_workl = f (inst, args) s.sec_workl; sec_abstr = g info s.sec_abstr; } in sectab := s :: sl let add_section_kn ~poly kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in - add_section_replacement f f poly + add_section_replacement f poly let add_section_constant ~poly kn = let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in - add_section_replacement f f poly + add_section_replacement f poly -let replacement_context () = (List.hd !sectab).sec_workl +let replacement_context () = make_worklist (List.hd !sectab).sec_abstr let section_segment_of_constant con = Names.Cmap.find con (fst (List.hd !sectab).sec_abstr) @@ -585,9 +582,11 @@ let section_instance = let open GlobRef in function then Univ.Instance.empty, [||] else raise Not_found | ConstRef con -> - Names.Cmap.find con (fst (List.hd !sectab).sec_workl) + let data = Names.Cmap.find con (fst (List.hd !sectab).sec_abstr) in + extract_worklist data | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - Names.Mindmap.find kn (snd (List.hd !sectab).sec_workl) + let data = Names.Mindmap.find kn (snd (List.hd !sectab).sec_abstr) in + extract_worklist data let is_in_section ref = try ignore (section_instance ref); true with Not_found -> false diff --git a/library/lib.mli b/library/lib.mli index fe6bf69ec4..9ffa69ef93 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -163,10 +163,8 @@ val drop_objects : frozen -> frozen val init : unit -> unit (** {6 Section management for discharge } *) -type variable_info = Constr.named_declaration * Decl_kinds.binding_kind -type variable_context = variable_info list type abstr_info = private { - abstr_ctx : variable_context; + abstr_ctx : Constr.named_context; (** Section variables of this prefix *) abstr_subst : Univ.Instance.t; (** Actual names of the abstracted variables *) @@ -174,18 +172,16 @@ type abstr_info = private { (** Universe quantification, same length as the substitution *) } -val instance_from_variable_context : variable_context -> Id.t array - val section_segment_of_constant : Constant.t -> abstr_info val section_segment_of_mutual_inductive: MutInd.t -> abstr_info val section_segment_of_reference : GlobRef.t -> abstr_info -val variable_section_segment_of_reference : GlobRef.t -> variable_context +val variable_section_segment_of_reference : GlobRef.t -> Constr.named_context val section_instance : GlobRef.t -> Univ.Instance.t * Id.t array val is_in_section : GlobRef.t -> bool -val add_section_variable : name:Id.t -> kind:Decl_kinds.binding_kind -> poly:bool -> Univ.ContextSet.t -> unit +val add_section_variable : name:Id.t -> poly:bool -> unit val add_section_context : Univ.ContextSet.t -> unit val add_section_constant : poly:bool -> Constant.t -> Constr.named_context -> unit val add_section_kn : poly:bool -> MutInd.t -> Constr.named_context -> unit diff --git a/library/library.mllib b/library/library.mllib index 35af5fa43b..c34d8911e8 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -1,4 +1,3 @@ -Decl_kinds Libnames Globnames Libobject @@ -7,9 +6,7 @@ Nametab Global Lib Declaremods -Library States Kindops Goptions -Keys Coqlib diff --git a/library/states.ml b/library/states.ml index a73f16957d..0be153d96a 100644 --- a/library/states.ml +++ b/library/states.ml @@ -9,7 +9,6 @@ (************************************************************************) open Util -open System type state = Lib.frozen * Summary.frozen @@ -25,13 +24,6 @@ let unfreeze (fl,fs) = Lib.unfreeze fl; Summary.unfreeze_summaries fs -let extern_state s = - System.extern_state Coq_config.state_magic_number s (freeze ~marshallable:true) - -let intern_state s = - unfreeze (with_magic_number_check (System.intern_state Coq_config.state_magic_number) s); - Library.overwrite_library_filenames s - (* Rollback. *) let with_state_protection f x = diff --git a/library/states.mli b/library/states.mli index c4f3eae49d..4870f48fc3 100644 --- a/library/states.mli +++ b/library/states.mli @@ -15,9 +15,6 @@ freezing the states of both [Lib] and [Summary]. We provide functions to write and restore state to and from a given file. *) -val intern_state : string -> unit -val extern_state : string -> unit - type state val freeze : marshallable:bool -> state val unfreeze : state -> unit diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index a27d6450b7..7f0d768d3f 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -436,7 +436,7 @@ let comment_stop ep = let bp = match !comment_begin with Some bp -> bp | None -> - Feedback.msg_notice + Feedback.msg_debug (str "No begin location for comment '" ++ str current_s ++str"' ending at " ++ int ep); @@ -785,12 +785,14 @@ let next_token ~diff_mode loc s = (* Location table system for creating tables associating a token count to its location in a char stream (the source) *) -let locerr () = invalid_arg "Lexer: location function" +let locerr i = + let m = "Lexer: location function called on token "^string_of_int i in + invalid_arg m let loct_create () = Hashtbl.create 207 let loct_func loct i = - try Hashtbl.find loct i with Not_found -> locerr () + try Hashtbl.find loct i with Not_found -> locerr i let loct_add loct i loc = Hashtbl.add loct i loc diff --git a/parsing/dune b/parsing/dune index 2bb8611e09..8a31434101 100644 --- a/parsing/dune +++ b/parsing/dune @@ -4,12 +4,4 @@ (wrapped false) (libraries coq.gramlib interp)) -(rule - (targets g_prim.ml) - (deps (:mlg-file g_prim.mlg)) - (action (run coqpp %{mlg-file}))) - -(rule - (targets g_constr.ml) - (deps (:mlg-file g_constr.mlg)) - (action (run coqpp %{mlg-file}))) +(coq.pp (modules g_prim g_constr)) diff --git a/parsing/extend.ml b/parsing/extend.ml index 63e121c0d1..ed6ebe5aed 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -79,8 +79,10 @@ type ('a,'b,'c) ty_user_symbol = (** {5 Type-safe grammar extension} *) -type norec = NoRec (* just two *) -type mayrec = MayRec (* incompatible types *) +(* Should be merged with gramlib's implementation *) + +type norec = Gramlib.Grammar.ty_norec +type mayrec = Gramlib.Grammar.ty_mayrec type ('self, 'trec, 'a) symbol = | Atoken : 'c Tok.p -> ('self, norec, 'c) symbol @@ -107,15 +109,3 @@ and 'a rules = type 'a production_rule = | Rule : ('a, _, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule - -type 'a single_extend_statement = - string option * - (* Level *) - Gramlib.Gramext.g_assoc option * - (* Associativity *) - 'a production_rule list - (* Symbol list with the interpretation function *) - -type 'a extend_statement = - Gramlib.Gramext.position option * - 'a single_extend_statement list diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 8fdec7d1a8..ea44e748c9 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -19,7 +19,6 @@ open Constrexpr_ops open Util open Tok open Namegen -open Decl_kinds open Pcoq open Pcoq.Prim @@ -84,7 +83,7 @@ let err () = raise Stream.Failure (* admissible notation "(x t)" *) let lpar_id_coloneq = Pcoq.Entry.of_parser "test_lpar_id_coloneq" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with @@ -99,7 +98,7 @@ let lpar_id_coloneq = let impl_ident_head = Pcoq.Entry.of_parser "impl_ident_head" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "{" -> (match stream_nth 1 strm with @@ -112,7 +111,7 @@ let impl_ident_head = let name_colon = Pcoq.Entry.of_parser "name_colon" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | IDENT s -> (match stream_nth 1 strm with diff --git a/parsing/g_prim.mlg b/parsing/g_prim.mlg index c1f52c5b39..020501aedf 100644 --- a/parsing/g_prim.mlg +++ b/parsing/g_prim.mlg @@ -31,10 +31,35 @@ let my_int_of_string loc s = with Failure _ -> CErrors.user_err ~loc (Pp.str "This number is too large.") -let check_nospace loc expected = - let (bp, ep) = Loc.unloc loc in - if ep = bp + String.length expected then () else - Gramlib.Ploc.raise loc (Stream.Error ("'" ^ expected ^ "' expected")) +let rec contiguous tok n m = + n == m + || + let (_, ep) = Loc.unloc (tok n) in + let (bp, _) = Loc.unloc (tok (n + 1)) in + Int.equal ep bp && contiguous tok (succ n) m + +let rec lookahead_kwds strm n = function + | [] -> () + | x :: xs -> + let toks = Stream.npeek (n+1) strm in + match List.nth toks n with + | Tok.KEYWORD y -> + if String.equal x y then lookahead_kwds strm (succ n) xs + else raise Stream.Failure + | _ -> raise Stream.Failure + | exception (Failure _) -> raise Stream.Failure + +(* [test_nospace m] fails if the next m tokens are not contiguous keywords *) +let test_nospace m = assert(m <> []); Pcoq.Entry.of_parser "test_nospace" + (fun tok strm -> + let n = Stream.count strm in + lookahead_kwds strm 0 m; + if contiguous tok n (n + List.length m - 1) then () + else raise Stream.Failure) + +let test_nospace_pipe_closedcurly = + test_nospace ["|"; "}"] + } @@ -130,6 +155,6 @@ GRAMMAR EXTEND Gram [ [ i = NUMERAL -> { check_int loc i } ] ] ; bar_cbrace: - [ [ "|"; "}" -> { check_nospace loc "|}" } ] ] + [ [ test_nospace_pipe_closedcurly; "|"; "}" -> { () } ] ] ; END diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 3aaba27579..e0d63a723e 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -131,73 +131,57 @@ end (** Binding general entry keys to symbol *) -type ('s, 'trec, 'a, 'r) casted_rule = -| CastedRNo : ('s, G.ty_norec, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, norec, 'a, 'r) casted_rule -| CastedRMay : ('s, G.ty_mayrec, 'b, 'r) G.ty_rule * ('a -> 'b) -> ('s, mayrec, 'a, 'r) casted_rule - -type ('s, 'trec, 'a) casted_symbol = -| CastedSNo : ('s, G.ty_norec, 'a) G.ty_symbol -> ('s, norec, 'a) casted_symbol -| CastedSMay : ('s, G.ty_mayrec, 'a) G.ty_symbol -> ('s, mayrec, 'a) casted_symbol - -let rec symbol_of_prod_entry_key : type s tr a. (s, tr, a) symbol -> (s, tr, a) casted_symbol = +let rec symbol_of_prod_entry_key : type s tr a. (s, tr, a) symbol -> (s, tr, a) G.ty_symbol = function -| Atoken t -> CastedSNo (G.s_token t) +| Atoken t -> G.s_token t | Alist1 s -> - begin match symbol_of_prod_entry_key s with - | CastedSNo s -> CastedSNo (G.s_list1 s) - | CastedSMay s -> CastedSMay (G.s_list1 s) end + let s = symbol_of_prod_entry_key s in + G.s_list1 s | Alist1sep (s,sep) -> - let CastedSNo sep = symbol_of_prod_entry_key sep in - begin match symbol_of_prod_entry_key s with - | CastedSNo s -> CastedSNo (G.s_list1sep s sep false) - | CastedSMay s -> CastedSMay (G.s_list1sep s sep false) end + let s = symbol_of_prod_entry_key s in + let sep = symbol_of_prod_entry_key sep in + G.s_list1sep s sep false | Alist0 s -> - begin match symbol_of_prod_entry_key s with - | CastedSNo s -> CastedSNo (G.s_list0 s) - | CastedSMay s -> CastedSMay (G.s_list0 s) end + let s = symbol_of_prod_entry_key s in + G.s_list0 s | Alist0sep (s,sep) -> - let CastedSNo sep = symbol_of_prod_entry_key sep in - begin match symbol_of_prod_entry_key s with - | CastedSNo s -> CastedSNo (G.s_list0sep s sep false) - | CastedSMay s -> CastedSMay (G.s_list0sep s sep false) end + let s = symbol_of_prod_entry_key s in + let sep = symbol_of_prod_entry_key sep in + G.s_list0sep s sep false | Aopt s -> - begin match symbol_of_prod_entry_key s with - | CastedSNo s -> CastedSNo (G.s_opt s) - | CastedSMay s -> CastedSMay (G.s_opt s) end -| Aself -> CastedSMay G.s_self -| Anext -> CastedSMay G.s_next -| Aentry e -> CastedSNo (G.s_nterm e) -| Aentryl (e, n) -> CastedSNo (G.s_nterml e n) + let s = symbol_of_prod_entry_key s in + G.s_opt s +| Aself -> G.s_self +| Anext -> G.s_next +| Aentry e -> G.s_nterm e +| Aentryl (e, n) -> G.s_nterml e n | Arules rs -> let warning msg = Feedback.msg_warning Pp.(str msg) in - CastedSNo (G.s_rules ~warning:(Some warning) (List.map symbol_of_rules rs)) + G.s_rules ~warning:(Some warning) (List.map symbol_of_rules rs) -and symbol_of_rule : type s tr a r. (s, tr, a, Loc.t -> r) Extend.rule -> (s, tr, a, Loc.t -> r) casted_rule = function -| Stop -> CastedRNo (G.r_stop, fun act loc -> act loc) +and symbol_of_rule : type s tr a r. (s, tr, a, Loc.t -> r) Extend.rule -> (s, tr, a, Loc.t -> r) G.ty_rule = function +| Stop -> + G.r_stop | Next (r, s) -> - begin match symbol_of_rule r, symbol_of_prod_entry_key s with - | CastedRNo (r, cast), CastedSNo s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) - | CastedRNo (r, cast), CastedSMay s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) - | CastedRMay (r, cast), CastedSNo s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) - | CastedRMay (r, cast), CastedSMay s -> CastedRMay (G.r_next r s, (fun act x -> cast (act x))) end + let r = symbol_of_rule r in + let s = symbol_of_prod_entry_key s in + G.r_next r s | NextNoRec (r, s) -> - let CastedRNo (r, cast) = symbol_of_rule r in - let CastedSNo s = symbol_of_prod_entry_key s in - CastedRNo (G.r_next_norec r s, (fun act x -> cast (act x))) + let r = symbol_of_rule r in + let s = symbol_of_prod_entry_key s in + G.r_next_norec r s and symbol_of_rules : type a. a Extend.rules -> a G.ty_rules = function | Rules (r, act) -> - let CastedRNo (symb, cast) = symbol_of_rule r in - G.rules (symb, cast act) + let symb = symbol_of_rule r in + G.rules (symb,act) (** FIXME: This is a hack around a deficient camlp5 API *) type 'a any_production = AnyProduction : ('a, 'tr, 'f, Loc.t -> 'a) G.ty_rule * 'f -> 'a any_production let of_coq_production_rule : type a. a Extend.production_rule -> a any_production = function | Rule (toks, act) -> - match symbol_of_rule toks with - | CastedRNo (symb, cast) -> AnyProduction (symb, cast act) - | CastedRMay (symb, cast) -> AnyProduction (symb, cast act) + AnyProduction (symbol_of_rule toks, act) let of_coq_single_extend_statement (lvl, assoc, rule) = (lvl, assoc, List.map of_coq_production_rule rule) @@ -215,6 +199,18 @@ let fix_extend_statement (pos, st) = (** Type of reinitialization data *) type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position +type 'a single_extend_statement = + string option * + (* Level *) + Gramlib.Gramext.g_assoc option * + (* Associativity *) + 'a production_rule list + (* Symbol list with the interpretation function *) + +type 'a extend_statement = + Gramlib.Gramext.position option * + 'a single_extend_statement list + type extend_rule = | ExtendRule : 'a G.Entry.e * gram_reinit option * 'a extend_statement -> extend_rule @@ -462,11 +458,10 @@ module Module = let module_expr = Entry.create "module_expr" let module_type = Entry.create "module_type" end + let epsilon_value (type s tr a) f (e : (s, tr, a) symbol) = - let r = - match symbol_of_prod_entry_key e with - | CastedSNo s -> G.production (G.r_next G.r_stop s, (fun x _ -> f x)) - | CastedSMay s -> G.production (G.r_next G.r_stop s, (fun x _ -> f x)) in + let s = symbol_of_prod_entry_key e in + let r = G.production (G.r_next G.r_stop s, (fun x _ -> f x)) in let ext = [None, None, [r]] in let entry = Gram.entry_create "epsilon" in let warning msg = Feedback.msg_warning Pp.(str msg) in diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index cde867d2ef..10f78a5a72 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -29,7 +29,7 @@ module Entry : sig val create : string -> 'a t val parse : 'a t -> Parsable.t -> 'a val print : Format.formatter -> 'a t -> unit - val of_parser : string -> (Tok.t Stream.t -> 'a) -> 'a t + val of_parser : string -> (Gramlib.Plexing.location_function -> Tok.t Stream.t -> 'a) -> 'a t val parse_token_stream : 'a t -> Tok.t Stream.t -> 'a val name : 'a t -> string end @@ -212,8 +212,19 @@ val epsilon_value : ('a -> 'self) -> ('self, _, 'a) Extend.symbol -> 'self optio type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position (** Type of reinitialization data *) -val grammar_extend : 'a Entry.t -> gram_reinit option -> - 'a Extend.extend_statement -> unit +type 'a single_extend_statement = + string option * + (* Level *) + Gramlib.Gramext.g_assoc option * + (* Associativity *) + 'a production_rule list + (* Symbol list with the interpretation function *) + +type 'a extend_statement = + Gramlib.Gramext.position option * + 'a single_extend_statement list + +val grammar_extend : 'a Entry.t -> gram_reinit option -> 'a extend_statement -> unit (** Extend the grammar of Coq, without synchronizing it with the backtracking mechanism. This means that grammar extensions defined this way will survive an undo. *) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 3ed843649e..b5be1cdd89 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -437,30 +437,25 @@ let cc_tactic depth additionnal_terms = let cstr=(get_constructor_info uf ipac.cnode).ci_constr in discriminate_tac cstr p | Incomplete -> - let open Glob_term in - let env = Proofview.Goal.env gl in - let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in - let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in - let pr_missing (c, missing) = - let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in - let holes = List.init missing (fun _ -> hole) in - Printer.pr_glob_constr_env env (DAst.make @@ GApp (c, holes)) - in - Feedback.msg_info - (Pp.str "Goal is solvable by congruence but some arguments are missing."); - Feedback.msg_info - (Pp.str " Try " ++ - hov 8 - begin - str "\"congruence with (" ++ - prlist_with_sep - (fun () -> str ")" ++ spc () ++ str "(") - pr_missing - terms_to_complete ++ - str ")\"," - end ++ - Pp.str " replacing metavariables by arbitrary terms."); - Tacticals.New.tclFAIL 0 (str "Incomplete") + let open Glob_term in + let env = Proofview.Goal.env gl in + let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in + let hole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) in + let pr_missing (c, missing) = + let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in + let holes = List.init missing (fun _ -> hole) in + Printer.pr_glob_constr_env env (DAst.make @@ GApp (c, holes)) + in + let msg = Pp.(str "Goal is solvable by congruence but some arguments are missing." + ++ fnl () ++ + str " Try " ++ + hov 8 + begin + str "\"congruence with (" ++ prlist_with_sep (fun () -> str ")" ++ spc () ++ str "(") + pr_missing terms_to_complete ++ str ")\"," + end ++ + str " replacing metavariables by arbitrary terms.") in + Tacticals.New.tclFAIL 0 msg | Contradiction dis -> let env = Proofview.Goal.env gl in let p=build_proof env sigma uf (`Prove (dis.lhs,dis.rhs)) in diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 78c6255c1e..cca212f332 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -754,18 +754,6 @@ and extract_cst_app env sg mle mlt kn args = let la = List.length args in (* The ml arguments, already expunged from known logical ones *) let mla = make_mlargs env sg mle s args metas in - let mla = - if magic1 || lang () != Ocaml then mla - else - try - (* for better optimisations later, we discard dependent args - of projections and replace them by fake args that will be - removed during final pretty-print. *) - let l,l' = List.chop (projection_arity (GlobRef.ConstRef kn)) mla in - if not (List.is_empty l') then (List.map (fun _ -> MLexn "Proj Args") l) @ l' - else mla - with e when CErrors.noncritical e -> mla - in (* For strict languages, purely logical signatures lead to a dummy lam (except when [Kill Ktype] everywhere). So a [MLdummy] is left accordingly. *) diff --git a/plugins/extraction/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index e222fbc808..4f077b08b6 100644 --- a/plugins/extraction/g_extraction.mlg +++ b/plugins/extraction/g_extraction.mlg @@ -128,7 +128,7 @@ END VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY | [ "Print" "Extraction" "Inline" ] - -> {Feedback. msg_info (print_extraction_inline ()) } + -> {Feedback.msg_notice (print_extraction_inline ()) } END VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF @@ -150,7 +150,7 @@ END VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY | [ "Print" "Extraction" "Blacklist" ] - -> { Feedback.msg_info (print_extraction_blacklist ()) } + -> { Feedback.msg_notice (print_extraction_blacklist ()) } END VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 2d5872718f..000df26858 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -779,7 +779,7 @@ let eta_red e = else e | _ -> e -(* Performs an eta-reduction when the core is atomic, +(* Performs an eta-reduction when the core is atomic and value, or otherwise returns None *) let atomic_eta_red e = @@ -789,7 +789,7 @@ let atomic_eta_red e = | MLapp (f,a) when test_eta_args_lift 0 n a -> (match f with | MLrel k when k>n -> Some (MLrel (k-n)) - | MLglob _ | MLexn _ | MLdummy _ -> Some f + | MLglob _ | MLdummy _ -> Some f | _ -> None) | _ -> None @@ -1547,6 +1547,7 @@ let inline r t = not (to_keep r) (* The user DOES want to keep it *) && not (is_inline_custom r) && (to_inline r (* The user DOES want to inline it *) - || (lang () != Haskell && not (is_projection r) && - (is_recursor r || manual_inline r || inline_test r t))) + || (lang () != Haskell && + (is_projection r || is_recursor r || + manual_inline r || inline_test r t))) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 75fb35192b..e7004fe9af 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -229,12 +229,7 @@ let rec pp_expr par env args = and pp_a1 = pp_expr false env [] a1 and pp_a2 = pp_expr (not par && expr_needs_par a2) env' [] a2 in hv 0 (apply2 (pp_letin pp_id pp_a1 pp_a2)) - | MLglob r -> - (try - let args = List.skipn (projection_arity r) args in - let record = List.hd args in - pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) - with e when CErrors.noncritical e -> apply (pp_global Term r)) + | MLglob r -> apply (pp_global Term r) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args @@ -324,10 +319,14 @@ and pp_record_proj par env typ t pv args = let n = List.length ids in let no_patvar a = not (List.exists (ast_occurs_itvl 1 n) a) in let rel_i,a = match body with - | MLrel i when i <= n -> i,[] - | MLapp(MLrel i, a) when i<=n && no_patvar a -> i,a + | MLrel i | MLmagic(MLrel i) when i <= n -> i,[] + | MLapp(MLrel i, a) | MLmagic(MLapp(MLrel i, a)) + | MLapp(MLmagic(MLrel i), a) when i<=n && no_patvar a -> i,a | _ -> raise Impossible in + let magic = + match body with MLmagic _ | MLapp(MLmagic _, _) -> true | _ -> false + in let rec lookup_rel i idx = function | Prel j :: l -> if Int.equal i j then idx else lookup_rel i (idx+1) l | Pwild :: l -> lookup_rel i (idx+1) l @@ -343,7 +342,10 @@ and pp_record_proj par env typ t pv args = let pp_args = (List.map (pp_expr true env' []) a) @ args in let pp_head = pp_expr true env [] t ++ str "." ++ pp_field r fields idx in - pp_apply pp_head par pp_args + if magic then + pp_apply (str "Obj.magic") par (pp_head :: pp_args) + else + pp_apply pp_head par pp_args and pp_record_pat (fields, args) = str "{ " ++ @@ -579,14 +581,10 @@ let pp_decl = function | Dterm (r, a, t) -> let def = if is_custom r then str (" = " ^ find_custom r) - else if is_projection r then - (prvect str (Array.make (projection_arity r) " _")) ++ - str " x = x." else pp_function (empty_env ()) a in let name = pp_global Term r in - let postdef = if is_projection r then name else mt () in - pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ postdef) + pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ mt ()) | Dfix (rv,defs,typs) -> pp_Dfix (rv,defs,typs) diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 8a5c32b8b5..35cd10a1ff 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -83,7 +83,7 @@ END VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY | [ "Print" "Firstorder" "Solver" ] -> { - Feedback.msg_info + Feedback.msg_notice (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) } END diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 08298bf02c..ca33e4e757 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -18,77 +18,6 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration -(* let msgnl = Pp.msgnl *) - -(* -let observe strm = - if do_observe () - then Pp.msg_debug strm - else () - -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 e = ExplainErr.process_vernac_interp_error e in - let goal = begin try (Printer.pr_goal g) with _ -> assert false end in - msg_debug (str "observation "++ s++str " raised exception " ++ - Errors.print e ++ str " on goal " ++ goal ); - raise e;; - -let observe_tac_stream s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g - -let observe_tac s tac g = observe_tac_stream (str s) tac g - *) - - -let debug_queue = Stack.create () - -let rec print_debug_queue e = - if not (Stack.is_empty debug_queue) - then - begin - let lmsg,goal = Stack.pop debug_queue in - let _ = - match e with - | Some e -> - Feedback.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) - | None -> - begin - Feedback.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal); - end in - print_debug_queue None ; - end - -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () - -let do_observe_tac s tac g = - let goal = Printer.pr_goal g in - let lmsg = (str "observation : ") ++ s in - Stack.push (lmsg,goal) debug_queue; - try - let v = tac g in - ignore(Stack.pop debug_queue); - v - with reraise -> - let reraise = CErrors.push reraise in - if not (Stack.is_empty debug_queue) - then print_debug_queue (Some (fst reraise)); - iraise reraise - -let observe_tac_stream s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g - -let observe_tac s = observe_tac_stream (str s) - - let list_chop ?(msg="") n l = try List.chop n l @@ -120,6 +49,7 @@ type 'a dynamic_info = type body_info = constr dynamic_info +let observe_tac s = observe_tac (fun _ _ -> Pp.str s) let finish_proof dynamic_infos g = observe_tac "finish" @@ -171,7 +101,7 @@ let is_incompatible_eq env sigma t = | _ -> false with e when CErrors.noncritical e -> false in - if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); + if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res let change_hyp_with_using msg hyp_id t tac : tactic = @@ -843,7 +773,8 @@ let build_proof | Rel _ -> anomaly (Pp.str "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_stream (str "build_proof with " ++ pr_leconstr_env (pf_env g) (project g) dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + Indfun_common.observe_tac (fun env sigma -> + str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g and build_proof_args env sigma do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in @@ -1010,7 +941,11 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try - let finfos = find_Function_infos (fst (destConst !evd f)) (*FIXME*) in + let finfos = + match find_Function_infos (fst (destConst !evd f)) (*FIXME*) with + | None -> raise Not_found + | Some finfos -> finfos + in mkConst (Option.get finfos.equation_lemma) with (Not_found | Option.IsNone as e) -> let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in @@ -1022,14 +957,18 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let _ = match e with | Option.IsNone -> - let finfos = find_Function_infos (fst (destConst !evd f)) in - update_Function - {finfos with - equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with - GlobRef.ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant.") - ) - } + let finfos = match find_Function_infos (fst (destConst !evd f)) with + | None -> raise Not_found + | Some finfos -> finfos + in + update_Function + {finfos with + equation_lemma = Some ( + match Nametab.locate (qualid_of_ident equation_lemma_id) with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") + ) + } | _ -> () in (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) @@ -1232,7 +1171,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam if this_fix_info.idx + 1 = 0 then tclIDTAC (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) else - observe_tac_stream (str "h_fix " ++ int (this_fix_info.idx +1) ) (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) + Indfun_common.observe_tac (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx +1)) + (Proofview.V82.of_tactic (fix this_fix_info.name (this_fix_info.idx +1))) else Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) other_fix_infos 0) @@ -1476,13 +1416,14 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = (observe_tac "finishing using" ( tclCOMPLETE( - Eauto.eauto_with_bases - (true,5) - [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [Hints.Hint_db.empty TransparentState.empty false] - ) - ) - ) + Proofview.V82.of_tactic @@ + Eauto.eauto_with_bases + (true,5) + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] + [Hints.Hint_db.empty TransparentState.empty false] + ) + ) + ) ] ) ] @@ -1538,7 +1479,9 @@ let prove_principle_for_gen let wf_tac = if is_mes then - (fun b -> Recdef.tclUSER_if_not_mes tclIDTAC b None) + (fun b -> + Proofview.V82.of_tactic @@ + Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None) else fun _ -> prove_with_tcc tcc_lemma_ref [] in let real_rec_arg_num = rec_arg_num - princ_info.nparams in diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index d34faa22fa..797d421c56 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -11,18 +11,15 @@ open Printer open CErrors open Term -open Sorts open Util open Constr open Context open Vars -open Namegen open Names open Pp open Tactics open Context.Rel.Declaration open Indfun_common -open Functional_principles_proofs module RelDecl = Context.Rel.Declaration @@ -258,449 +255,3 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = new_predicates) ) (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) - - - -let change_property_sort evd toSort princ princName = - let open Context.Rel.Declaration in - let princ = EConstr.of_constr princ in - let princ_info = compute_elim_sig evd princ in - let change_sort_in_predicate decl = - LocalAssum - (get_annot decl, - let args,ty = decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in - let s = destSort ty in - Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); - Term.compose_prod args (mkSort toSort) - ) - in - let evd,princName_as_constr = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in - let init = - let nargs = (princ_info.nparams + (List.length princ_info.predicates)) in - mkApp(EConstr.Unsafe.to_constr princName_as_constr, - Array.init nargs - (fun i -> mkRel (nargs - i ))) - in - evd, it_mkLambda_or_LetIn - (it_mkLambda_or_LetIn init - (List.map change_sort_in_predicate princ_info.predicates) - ) - (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.params) - -let build_functional_principle (evd:Evd.evar_map ref) 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 !evd (EConstr.of_constr old_princ_type)).nparams in - (* let time1 = System.get_time () in *) - let new_principle_type = - compute_new_princ_type_from_rel - (Array.map mkConstU funs) - sorts - old_princ_type - in - (* let time2 = System.get_time () in *) - (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) - let new_princ_name = - next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty - in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in - evd := sigma; - let hook = DeclareDef.Hook.make (hook new_principle_type) in - let lemma = - Lemmas.start_lemma - ~name:new_princ_name - ~poly:false - !evd - (EConstr.of_constr new_principle_type) - in - (* let _tim1 = System.get_time () in *) - let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let lemma,_ = Lemmas.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) lemma in - (* let _tim2 = System.get_time () in *) - (* begin *) - (* let dur1 = System.time_difference tim1 tim2 in *) - (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) - (* end; *) - - let open Proof_global in - let { name; entries } = Lemmas.pf_fold (close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x)) lemma in - match entries with - | [entry] -> - name, entry, hook - | _ -> - CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") - -let generate_functional_principle (evd: Evd.evar_map ref) - interactive_proof - old_princ_type sorts new_princ_name funs i proof_tac - = - try - - let f = funs.(i) in - let sigma, type_sort = Evd.fresh_sort_in_family !evd InType in - evd := sigma; - let new_sorts = - match sorts with - | None -> Array.make (Array.length funs) (type_sort) - | Some a -> a - in - let base_new_princ_name,new_princ_name = - match new_princ_name with - | Some (id) -> id,id - | None -> - let id_of_f = Label.to_id (Constant.label (fst f)) in - id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) - in - let names = ref [new_princ_name] in - let hook = - fun new_principle_type _ -> - if Option.is_empty sorts - then - (* let id_of_f = Label.to_id (con_label f) in *) - let register_with_sort fam_sort = - let evd' = Evd.from_env (Global.env ()) in - let evd',s = Evd.fresh_sort_in_family evd' fam_sort in - let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in - let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in - (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let univs = Evd.univ_entry ~poly:false evd' in - let ce = Declare.definition_entry ~univs value in - ignore( - Declare.declare_constant - ~name - ~kind:Decls.(IsDefinition Scheme) - (Declare.DefinitionEntry ce) - ); - Declare.definition_message name; - names := name :: !names - in - register_with_sort InProp; - register_with_sort InSet - in - let id,entry,hook = - build_functional_principle evd 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 !!!! - *) - let uctx = Evd.evar_universe_context sigma in - save new_princ_name entry ~hook uctx (DeclareDef.Global Declare.ImportDefaultBehavior) Decls.(IsProof Theorem) - with e when CErrors.noncritical e -> - raise (Defining_principle e) - -exception Not_Rec - -let get_funs_constant mp = - let get_funs_constant const e : (Names.Constant.t*int) array = - match Constr.kind ((strip_lam e)) with - | Fix((_,(na,_,_))) -> - Array.mapi - (fun i na -> - match na.binder_name with - | Name id -> - let const = Constant.make2 mp (Label.of_id id) in - const,i - | Anonymous -> - anomaly (Pp.str "Anonymous fix.") - ) - na - | _ -> [|const,0|] - in - function const -> - let find_constant_body const = - match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let body = Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - (Global.env ()) - (Evd.from_env (Global.env ())) - (EConstr.of_constr body) - in - let body = EConstr.Unsafe.to_constr body in - body - | None -> user_err Pp.(str ( "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 - to prevent Reset strange 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 parameters must be equal*) - let _check_params = - let first_params = List.hd l_params in - List.iter - (fun params -> - if not (List.equal (fun (n1, c1) (n2, c2) -> - eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) - then user_err Pp.(str "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 Constr.kind body with - | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) - | _ -> - if is_first && Int.equal (List.length l_bodies) 1 - then raise Not_Rec - else user_err Pp.(str "Not a mutal recursive block") - in - let first_infos = extract_info true (List.hd l_bodies) in - let check body = (* Hope this is correct *) - let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = - Array.equal Int.equal ia1 ia2 && Array.equal (eq_annot Name.equal) na1 na2 && - Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 - in - if not (eq_infos first_infos (extract_info false body)) - then user_err Pp.(str "Not a mutal recursive block") - in - List.iter check l_bodies - with Not_Rec -> () - in - l_const - -exception No_graph_found -exception Found_type of int - -let make_scheme evd (fas : (pconstant*Sorts.family) list) : Evd.side_effects Proof_global.proof_entry list = - let env = Global.env () in - let funs = List.map fst fas in - let first_fun = List.hd funs in - let funs_mp = KerName.modpath (Constant.canonical (fst first_fun)) in - let first_fun_kn = - try - fst (find_Function_infos (fst first_fun)).graph_ind - with Not_found -> raise No_graph_found - in - let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in - let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) 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 - List.map - (function cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) - funs - in - let ind_list = - List.map - (fun (idx) -> - let ind = first_fun_kn,idx in - (ind,snd first_fun),true,prop_sort - ) - funs_indexes - in - let sigma, schemes = - Indrec.build_mutual_induction_scheme env !evd ind_list - in - let _ = evd := sigma in - let l_schemes = - List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes - in - let i = ref (-1) in - let sorts = - List.rev_map (fun (_,x) -> - let sigma, fs = Evd.fresh_sort_in_family !evd x in - evd := sigma; fs - ) - fas - in - (* We create the first principle by tactic *) - let first_type,other_princ_types = - match l_schemes with - s::l_schemes -> s,l_schemes - | _ -> anomaly (Pp.str "") - in - let _,const,_ = - try - build_functional_principle evd false - first_type - (Array.of_list sorts) - this_block_funs - 0 - (prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) - (fun _ _ -> ()) - with e when CErrors.noncritical e -> - raise (Defining_principle e) - - in - incr i; - let opacity = - let finfos = find_Function_infos (fst first_fun) in - try - let equation = Option.get finfos.equation_lemma in - Declareops.is_opaque (Global.lookup_constant equation) - with Option.IsNone -> (* non recursive definition *) - false - in - let const = {const with Proof_global.proof_entry_opaque = opacity } in - (* The others are just deduced *) - if List.is_empty other_princ_types - then - [const] - else - let other_fun_princ_types = - let funs = Array.map mkConstU 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 open Proof_global in - let first_princ_body,first_princ_type = const.proof_entry_body, const.proof_entry_type in - let ctxt,fix = decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) - let (idxs,_),(_,ta,_ as decl) = destFix fix in - let other_result = - List.map (* we can now compute the other principles *) - (fun scheme_type -> - incr i; - observe (Printer.pr_lconstr_env env sigma 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 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 - let g = fst (decompose_app applied_g) in - if Constr.equal f g - then raise (Found_type j); - observe (Printer.pr_lconstr_env env sigma f ++ str " <> " ++ - Printer.pr_lconstr_env env sigma g) - - ) - ta; - (* If we reach this point, the two principle are not mutually recursive - We fall back to the previous method - *) - let _,const,_ = - build_functional_principle - evd - false - (List.nth other_princ_types (!i - 1)) - (Array.of_list sorts) - this_block_funs - !i - (prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) - (fun _ _ -> ()) - in - const - with Found_type i -> - let princ_body = - Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt - in - {const with - proof_entry_body = - (Future.from_val ((princ_body, Univ.ContextSet.empty), Evd.empty_side_effects)); - proof_entry_type = Some scheme_type - } - ) - other_fun_princ_types - in - const::other_result - -let build_scheme fas = - let evd = (ref (Evd.from_env (Global.env ()))) in - let pconstants = (List.map - (fun (_,f,sort) -> - let f_as_constant = - try - Smartlocate.global_with_alias f - with Not_found -> - user_err ~hdr:"FunInd.build_scheme" - (str "Cannot find " ++ Libnames.pr_qualid f) - in - let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in - let _ = evd := evd' in - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in - evd := sigma; - let c, u = - try EConstr.destConst !evd f - with DestKO -> - user_err Pp.(pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") - in - (c, EConstr.EInstance.kind !evd u), sort - ) - fas - ) in - let bodies_types = - make_scheme evd pconstants - in - - List.iter2 - (fun (princ_id,_,_) def_entry -> - ignore - (Declare.declare_constant - ~name:princ_id - ~kind:Decls.(IsProof Theorem) - (Declare.DefinitionEntry def_entry)); - Declare.definition_message princ_id - ) - fas - bodies_types - -let build_case_scheme fa = - let env = Global.env () - and sigma = (Evd.from_env (Global.env ())) in -(* let id_to_constr id = *) -(* Constrintern.global_reference id *) -(* in *) - let funs = - let (_,f,_) = fa in - try (let open GlobRef in - match Smartlocate.global_with_alias f with - | ConstRef c -> c - | IndRef _ | ConstructRef _ | VarRef _ -> assert false) - with Not_found -> - user_err ~hdr:"FunInd.build_case_scheme" - (str "Cannot find " ++ Libnames.pr_qualid f) in - let sigma, (_,u) = Evd.fresh_constant_instance env sigma funs in - let first_fun = funs in - let funs_mp = Constant.modpath first_fun in - let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in - let this_block_funs_indexes = get_funs_constant funs_mp first_fun in - let this_block_funs = Array.map (fun (c,_) -> (c,u)) 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 - List.assoc_f Constant.equal funs this_block_funs_indexes - in - let (ind, sf) = - let ind = first_fun_kn,funs_indexes in - (ind,Univ.Instance.empty)(*FIXME*),prop_sort - in - let (sigma, scheme) = - Indrec.build_case_analysis_scheme_default env sigma ind sf - in - let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in - let sorts = - (fun (_,_,x) -> - fst @@ UnivGen.fresh_sort_in_family x - ) - fa - in - let princ_name = (fun (x,_,_) -> x) fa in - 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 - ); - *) - generate_functional_principle - (ref (Evd.from_env (Global.env ()))) - false - scheme_type - (Some ([|sorts|])) - (Some princ_name) - this_block_funs - 0 - (prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|funs|]) - in - () - - diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 7cadd4396d..6f060b0146 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -8,35 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names -open Constr - -val generate_functional_principle : - Evd.evar_map ref -> - (* do we accept interactive proving *) - bool -> - (* induction principle on rel *) - types -> - (* *) - Sorts.t array option -> - (* Name of the new principle *) - (Id.t) option -> - (* the compute functions to use *) - pconstant array -> - (* We prove the nth- principle *) - int -> - (* The tactic to use to make the proof w.r - the number of params - *) - (EConstr.constr array -> int -> Tacmach.tactic) -> - unit - -exception No_graph_found - -val make_scheme - : Evd.evar_map ref - -> (pconstant*Sorts.family) list - -> Evd.side_effects Proof_global.proof_entry list - -val build_scheme : (Id.t*Libnames.qualid*Sorts.family) list -> unit -val build_case_scheme : (Id.t*Libnames.qualid*Sorts.family) -> unit +val compute_new_princ_type_from_rel + : Constr.constr array + -> Sorts.t array + -> Constr.t + -> Constr.types diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index 1b75d3d966..2b990400e3 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -64,7 +64,7 @@ END TACTIC EXTEND newfuninv | [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> { - Proofview.V82.tactic (Invfun.invfun hyp fname) + Invfun.invfun hyp fname } END @@ -91,7 +91,7 @@ END { let functional_induction b c x pat = - Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat)) + functional_induction true c x (Option.map out_disjunctive pat) } @@ -180,7 +180,7 @@ let is_proof_termination_interactively_checked recsl = let classify_as_Fixpoint recsl = Vernac_classifier.classify_vernac - (Vernacexpr.(CAst.make @@ VernacExpr([], VernacFixpoint(NoDischarge, List.map snd recsl)))) + (Vernacexpr.(CAst.make @@ { control = []; attrs = []; expr = VernacFixpoint(NoDischarge, List.map snd recsl)})) let classify_funind recsl = match classify_as_Fixpoint recsl with @@ -202,10 +202,10 @@ VERNAC COMMAND EXTEND Function STATE CUSTOM -> { if is_interactive recsl then Vernacextend.VtOpenProof (fun () -> - do_generate_principle_interactive (List.map snd recsl)) + Gen_principle.do_generate_principle_interactive (List.map snd recsl)) else Vernacextend.VtDefault (fun () -> - do_generate_principle (List.map snd recsl)) } + Gen_principle.do_generate_principle (List.map snd recsl)) } END { @@ -226,15 +226,15 @@ END let warning_error names e = match e with - | Building_graph e -> - let names = pr_enum Libnames.pr_qualid names in - let error = if do_observe () then (spc () ++ CErrors.print e) else mt () in - warn_cannot_define_graph (names,error) - | Defining_principle e -> - let names = pr_enum Libnames.pr_qualid names in - let error = if do_observe () then CErrors.print e else mt () in - warn_cannot_define_principle (names,error) - | _ -> raise e + | Building_graph e -> + let names = pr_enum Libnames.pr_qualid names in + let error = if do_observe () then (spc () ++ CErrors.print e) else mt () in + Gen_principle.warn_cannot_define_graph (names,error) + | Defining_principle e -> + let names = pr_enum Libnames.pr_qualid names in + let error = if do_observe () then CErrors.print e else mt () in + Gen_principle.warn_cannot_define_principle (names,error) + | _ -> raise e } @@ -244,17 +244,17 @@ VERNAC COMMAND EXTEND NewFunctionalScheme -> { begin try - Functional_principles_types.build_scheme fas + Gen_principle.build_scheme fas with - | Functional_principles_types.No_graph_found -> + | Gen_principle.No_graph_found -> begin match fas with | (_,fun_name,_)::_ -> begin - make_graph (Smartlocate.global_with_alias fun_name); - try Functional_principles_types.build_scheme fas + Gen_principle.make_graph (Smartlocate.global_with_alias fun_name); + try Gen_principle.build_scheme fas with - | Functional_principles_types.No_graph_found -> + | Gen_principle.No_graph_found -> CErrors.user_err Pp.(str "Cannot generate induction principle(s)") | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in @@ -273,11 +273,11 @@ END VERNAC COMMAND EXTEND NewFunctionalCase | ["Functional" "Case" fun_scheme_arg(fas) ] => { Vernacextend.(VtSideff([pi1 fas], VtLater)) } - -> { Functional_principles_types.build_case_scheme fas } + -> { Gen_principle.build_case_scheme fas } END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY | ["Generate" "graph" "for" reference(c)] -> - { make_graph (Smartlocate.global_with_alias c) } + { Gen_principle.make_graph (Smartlocate.global_with_alias c) } END diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml new file mode 100644 index 0000000000..570b72136c --- /dev/null +++ b/plugins/funind/gen_principle.ml @@ -0,0 +1,2099 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names + +open Indfun_common + +module RelDecl = Context.Rel.Declaration + +let observe_tac s = observe_tac (fun _ _ -> Pp.str s) + +(* + Construct a fixpoint as a Glob_term + and not as a constr +*) +let rec abstract_glob_constr c = function + | [] -> c + | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl) + | Constrexpr.CLocalAssum (idl,k,t)::bl -> + List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl + (abstract_glob_constr c bl) + | Constrexpr.CLocalPattern _::bl -> assert false + +let interp_casted_constr_with_implicits env sigma impls c = + Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls c + +let build_newrecursive lnameargsardef = + let env0 = Global.env() in + let sigma = Evd.from_env env0 in + let (rec_sign,rec_impls) = + List.fold_left + (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> + let arityc = Constrexpr_ops.mkCProdN binders rtype in + let arity,ctx = Constrintern.interp_type env0 sigma arityc in + let evd = Evd.from_env env0 in + let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in + let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in + let open Context.Named.Declaration in + let r = Sorts.Relevant in (* TODO relevance *) + (EConstr.push_named (LocalAssum (Context.make_annot recname r,arity)) env, Id.Map.add recname impl impls)) + (env0,Constrintern.empty_internalization_env) lnameargsardef in + let recdef = + (* Declare local notations *) + let f { Vernacexpr.binders; body_def } = + match body_def with + | Some body_def -> + let def = abstract_glob_constr body_def binders in + interp_casted_constr_with_implicits + rec_sign sigma rec_impls def + | None -> CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") + in + States.with_state_protection (List.map f) lnameargsardef + in + recdef,rec_impls + +(* Checks whether or not the mutual bloc is recursive *) +let is_rec names = + let open Glob_term in + let names = List.fold_right Id.Set.add names Id.Set.empty in + let check_id id names = Id.Set.mem id names in + let rec lookup names gt = match DAst.get gt with + | GVar(id) -> check_id id names + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ -> false + | GCast(b,_) -> lookup names b + | GRec _ -> CErrors.user_err (Pp.str "GRec not handled") + | GIf(b,_,lhs,rhs) -> + (lookup names b) || (lookup names lhs) || (lookup names rhs) + | GProd(na,_,t,b) | GLambda(na,_,t,b) -> + lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b + | GLetIn(na,b,t,c) -> + lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c + | GLetTuple(nal,_,t,b) -> lookup names t || + lookup + (List.fold_left + (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) + names + nal + ) + b + | GApp(f,args) -> List.exists (lookup names) (f::args) + | GCases(_,_,el,brl) -> + List.exists (fun (e,_) -> lookup names e) el || + List.exists (lookup_br names) brl + and lookup_br names {CAst.v=(idl,_,rt)} = + let new_names = List.fold_right Id.Set.remove idl names in + lookup new_names rt + in + lookup names + +let rec rebuild_bl aux bl typ = + let open Constrexpr in + match bl,typ with + | [], _ -> List.rev aux,typ + | (CLocalAssum(nal,bk,_))::bl',typ -> + rebuild_nal aux bk bl' nal typ + | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> + rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) + bl' typ' + | _ -> assert false +and rebuild_nal aux bk bl' nal typ = + let open Constrexpr in + match nal,typ with + | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ + | [], _ -> rebuild_bl aux bl' typ + | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> + if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v) + then + let assum = CLocalAssum([na],bk,nal't) in + let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in + rebuild_nal + (assum::aux) + bk + bl' + nal + (CAst.make @@ CProdN(new_rest,typ')) + else + let assum = CLocalAssum([na'],bk,nal't) in + let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in + rebuild_nal + (assum::aux) + bk + bl' + (na::nal) + (CAst.make @@ CProdN(new_rest,typ')) + | _ -> + assert false + +let rebuild_bl aux bl typ = rebuild_bl aux bl typ + +let recompute_binder_list fixpoint_exprl = + let fixl = + List.map (fun fix -> Vernacexpr.{ + fix + with rec_order = ComFixpoint.adjust_rec_order ~structonly:false fix.binders fix.rec_order }) fixpoint_exprl in + let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl in + let constr_expr_typel = + with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in + let fixpoint_exprl_with_new_bl = + List.map2 (fun ({ Vernacexpr.binders } as fp) fix_typ -> + let binders, rtype = rebuild_bl [] binders fix_typ in + { fp with Vernacexpr.binders; rtype } + ) fixpoint_exprl constr_expr_typel + in + fixpoint_exprl_with_new_bl + +let rec local_binders_length = function + (* Assume that no `{ ... } contexts occur *) + | [] -> 0 + | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl + | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl + | Constrexpr.CLocalPattern _::bl -> assert false + +let prepare_body { Vernacexpr.binders } rt = + let n = local_binders_length binders in + (* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) + let fun_args,rt' = chop_rlambda_n n rt in + (fun_args,rt') + +let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = + (* First we get the type of the old graph principle *) + let mutr_nparams = (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)).Tactics.nparams in + (* let time1 = System.get_time () in *) + let new_principle_type = + Functional_principles_types.compute_new_princ_type_from_rel + (Array.map Constr.mkConstU funs) + sorts + old_princ_type + in + (* let time2 = System.get_time () in *) + (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) + let new_princ_name = + Namegen.next_ident_away_in_goal (Id.of_string "___________princ_________") Id.Set.empty + in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd (EConstr.of_constr new_principle_type) in + evd := sigma; + let hook = DeclareDef.Hook.make (hook new_principle_type) in + let lemma = + Lemmas.start_lemma + ~name:new_princ_name + ~poly:false + !evd + (EConstr.of_constr new_principle_type) + in + (* let _tim1 = System.get_time () in *) + let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in + let lemma,_ = Lemmas.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) lemma in + (* let _tim2 = System.get_time () in *) + (* begin *) + (* let dur1 = System.time_difference tim1 tim2 in *) + (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) + (* end; *) + + let open Proof_global in + let { name; entries } = Lemmas.pf_fold (close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x)) lemma in + match entries with + | [entry] -> + entry, hook + | _ -> + CErrors.anomaly Pp.(str "[build_functional_principle] close_proof returned more than one proof term") + +let change_property_sort evd toSort princ princName = + let open Context.Rel.Declaration in + let princ = EConstr.of_constr princ in + let princ_info = Tactics.compute_elim_sig evd princ in + let change_sort_in_predicate decl = + LocalAssum + (get_annot decl, + let args,ty = Term.decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in + let s = Constr.destSort ty in + Global.add_constraints (Univ.enforce_leq (Sorts.univ_of_sort toSort) (Sorts.univ_of_sort s) Univ.Constraint.empty); + Term.compose_prod args (Constr.mkSort toSort) + ) + in + let evd,princName_as_constr = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident princName)) in + let init = + let nargs = (princ_info.Tactics.nparams + (List.length princ_info.Tactics.predicates)) in + Constr.mkApp(EConstr.Unsafe.to_constr princName_as_constr, + Array.init nargs + (fun i -> Constr.mkRel (nargs - i ))) + in + evd, Term.it_mkLambda_or_LetIn + (Term.it_mkLambda_or_LetIn init + (List.map change_sort_in_predicate princ_info.Tactics.predicates) + ) + (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) + +(* XXX: To be cleaned up soon in favor of common save path. *) +let save name const ?hook uctx scope kind = + let open Declare in + let open DeclareDef in + let fix_exn = Future.fix_exn_of const.Declare.proof_entry_body in + let r = match scope with + | Discharge -> + let c = SectionLocalDef const in + let () = declare_variable ~name ~kind c in + GlobRef.VarRef name + | Global local -> + let kn = declare_constant ~name ~kind ~local (DefinitionEntry const) in + GlobRef.ConstRef kn + in + DeclareDef.Hook.(call ?hook ~fix_exn { S.uctx; obls = []; scope; dref = r }); + definition_message name + +let generate_functional_principle (evd: Evd.evar_map ref) + interactive_proof + old_princ_type sorts new_princ_name funs i proof_tac + = + try + + let f = funs.(i) in + let sigma, type_sort = Evd.fresh_sort_in_family !evd Sorts.InType in + evd := sigma; + let new_sorts = + match sorts with + | None -> Array.make (Array.length funs) (type_sort) + | Some a -> a + in + let base_new_princ_name,new_princ_name = + match new_princ_name with + | Some (id) -> id,id + | None -> + let id_of_f = Label.to_id (Constant.label (fst f)) in + id_of_f,Indrec.make_elimination_ident id_of_f (Sorts.family type_sort) + in + let names = ref [new_princ_name] in + let hook = + fun new_principle_type _ -> + if Option.is_empty sorts + then + (* let id_of_f = Label.to_id (con_label f) in *) + let register_with_sort fam_sort = + let evd' = Evd.from_env (Global.env ()) in + let evd',s = Evd.fresh_sort_in_family evd' fam_sort in + let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in + let evd',value = change_property_sort evd' s new_principle_type new_princ_name in + let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in + (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) + let univs = Evd.univ_entry ~poly:false evd' in + let ce = Declare.definition_entry ~univs value in + ignore( + Declare.declare_constant + ~name + ~kind:Decls.(IsDefinition Scheme) + (Declare.DefinitionEntry ce) + ); + Declare.definition_message name; + names := name :: !names + in + register_with_sort Sorts.InProp; + register_with_sort Sorts.InSet + in + let entry, hook = + build_functional_principle evd 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 !!!! + *) + let uctx = Evd.evar_universe_context sigma in + save new_princ_name entry ~hook uctx (DeclareDef.Global Declare.ImportDefaultBehavior) Decls.(IsProof Theorem) + with e when CErrors.noncritical e -> + raise (Defining_principle e) + +let generate_principle (evd:Evd.evar_map ref) pconstants on_error + is_general do_built fix_rec_l recdefs interactive_proof + (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> + Tacmach.tactic) : unit = + let names = List.map (function { Vernacexpr.fname = {CAst.v=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 { Vernacexpr.rtype } -> rtype) fix_rec_l in + try + (* We then register the Inductive graphs of the functions *) + Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; + if do_built + then + begin + (*i The next call to mk_rel_id is valid since we have just construct the graph + Ensures by : do_built + i*) + let f_R_mut = Libnames.qualid_of_ident @@ mk_rel_id (List.nth names 0) in + let ind_kn = + fst (locate_with_msg + Pp.(Libnames.pr_qualid f_R_mut ++ str ": Not an inductive type!") + locate_ind + f_R_mut) + in + let fname_kn { Vernacexpr.fname } = + let f_ref = Libnames.qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in + locate_with_msg + Pp.(Libnames.pr_qualid f_ref++str ": Not an inductive type!") + locate_constant + f_ref + in + let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in + let _ = + List.map_i + (fun i x -> + let env = Global.env () in + let princ = Indrec.lookup_eliminator env (ind_kn,i) (Sorts.InProp) in + let evd = ref (Evd.from_env env) in + let evd',uprinc = Evd.fresh_global env !evd princ in + let _ = evd := evd' in + let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in + evd := sigma; + let princ_type = EConstr.Unsafe.to_constr princ_type in + generate_functional_principle + evd + interactive_proof + princ_type + None + None + (Array.of_list pconstants) + (* funs_kn *) + i + (continue_proof 0 [|funs_kn.(i)|]) + ) + 0 + fix_rec_l + in + Array.iter (add_Function is_general) funs_kn; + () + end + with e when CErrors.noncritical e -> + on_error names e + +let register_struct is_rec fixpoint_exprl = + let open EConstr in + match fixpoint_exprl with + | [{ Vernacexpr.fname; univs; binders; rtype; body_def }] when not is_rec -> + let body = + match body_def with + | Some body -> body + | None -> + CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in + ComDefinition.do_definition + ~program_mode:false + ~name:fname.CAst.v + ~poly:false + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:Decls.Definition univs + binders None body (Some rtype); + let evd,rev_pconstants = + List.fold_left + (fun (evd,l) { Vernacexpr.fname } -> + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in + let (cst, u) = destConst evd c in + let u = EInstance.kind evd u in + evd,((cst, u) :: l) + ) + (Evd.from_env (Global.env ()),[]) + fixpoint_exprl + in + None, evd,List.rev rev_pconstants + | _ -> + ComFixpoint.do_fixpoint ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; + let evd,rev_pconstants = + List.fold_left + (fun (evd,l) { Vernacexpr.fname } -> + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in + let (cst, u) = destConst evd c in + let u = EInstance.kind evd u in + evd,((cst, u) :: l) + ) + (Evd.from_env (Global.env ()),[]) + fixpoint_exprl + in + None,evd,List.rev rev_pconstants + +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.t array) (_:EConstr.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 + +(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] + (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. + + [generate_type true f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion + + [generate_type false f i] returns + \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, + res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion +*) + +let generate_type evd g_to_f f graph i = + let open Context.Rel.Declaration in + let open EConstr in + let open EConstr.Vars in + (*i we deduce the number of arguments of the function and its returned type from the graph i*) + let evd',graph = + Evd.fresh_global (Global.env ()) !evd (GlobRef.IndRef (fst (destInd !evd graph))) + in + evd:=evd'; + let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in + evd := sigma; + let ctxt,_ = decompose_prod_assum !evd graph_arity in + let fun_ctxt,res_type = + match ctxt with + | [] | [_] -> CErrors.anomaly (Pp.str "Not a valid context.") + | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl + in + let rec args_from_decl i accu = function + | [] -> accu + | LocalDef _ :: l -> + args_from_decl (succ i) accu l + | _ :: l -> + let t = mkRel i in + args_from_decl (succ i) (t :: accu) l + in + (*i We need to name the vars [res] and [fv] i*) + let filter = fun decl -> match RelDecl.get_name decl with + | Name id -> Some id + | Anonymous -> None + in + let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in + let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in + let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in + (*i we can then type the argument to be applied to the function [f] i*) + let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in + (*i + the hypothesis [res = fv] can then be computed + We will need to lift it by one in order to use it as a conclusion + i*) + let make_eq = make_eq () in + let res_eq_f_of_args = + mkApp(make_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 args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in + let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in + let graph_applied = 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 = + LocalAssum (Context.make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) :: + LocalDef (Context.make_annot (Name fv_id) Sorts.Relevant, mkApp (f,args_as_rels), res_type) :: fun_ctxt + in + (*i and we can return the solution depending on which lemma type we are defining i*) + if g_to_f + then LocalAssum (Context.make_annot Anonymous Sorts.Relevant,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph + else LocalAssum (Context.make_annot Anonymous Sorts.Relevant,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + +(** + [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 evd f = + let f_as_constant,u = match EConstr.kind !evd f with + | Constr.Const c' -> c' + | _ -> CErrors.user_err Pp.(str "Must be used with a function") + in + match find_Function_infos f_as_constant with + | None -> + raise Not_found + | Some infos -> + match infos.rect_lemma with + | None -> raise Not_found + | Some rect_lemma -> + let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in + let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in + evd:=evd'; + rect_lemma,typ + +(* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] + is the tactic used to prove correctness lemma. + + [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions + (resp. graphs of the functions and principles and correctness lemma types) to prove correct. + + [i] is the indice of the function to prove correct + + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + it looks like~: + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] + + + The sketch of the proof is the following one~: + \begin{enumerate} + \item intros until $x_n$ + \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) + \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the + apply the corresponding constructor of the corresponding graph inductive. + \end{enumerate} + +*) + +let rec generate_fresh_id x avoid i = + if i == 0 + then [] + else + let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in + id::(generate_fresh_id x (id::avoid) (pred i)) + +let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = + let open Constr in + let open EConstr in + let open Context.Rel.Declaration in + let open Tacmach in + let open Tactics in + let open Tacticals in + fun g -> + (* first of all we recreate the lemmas types to be used as predicates of the induction principle + that is~: + \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] + *) + (* we the get the definition of the graphs block *) + let graph_ind,u = destInd evd graphs_constr.(i) in + let kn = fst graph_ind in + let mib,_ = Global.lookup_inductive graph_ind in + (* and the principle to use in this lemma in $\zeta$ normal form *) + let f_principle,princ_type = schemes.(i) in + let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in + let princ_infos = Tactics.compute_elim_sig evd princ_type in + (* The number of args of the function is then easily computable *) + let nb_fun_args = Termops.nb_prod (project g) (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 functional principle is defined in the + environment and due to the bug #1174, we will need to pose the principle + using a name + *) + let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in + let ids = principle_id :: ids in + (* We get the branches of the principle *) + let branches = List.rev princ_infos.Tactics.branches in + (* and built the intro pattern for each of them *) + let intro_pats = + List.map + (fun decl -> + List.map + (fun id -> CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) + ) + branches + in + (* before building the full intro pattern for the principle *) + let eq_ind = make_eq () in + let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in + (* The next to referencies will be used to find out which constructor to apply in each branch *) + let ind_number = ref 0 + and min_constr_number = ref 0 in + (* The tactic to prove the ith branch of the principle *) + let prove_branche i g = + (* We get the identifiers of this branch *) + let pre_args = + List.fold_right + (fun {CAst.v=pat} acc -> + match pat with + | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id::acc + | _ -> CErrors.anomaly (Pp.str "Not an identifier.") + ) + (List.nth intro_pats (pred i)) + [] + in + (* and get the real args of the branch by unfolding the defined constant *) + (* + We can then recompute the arguments of the constructor. + For each [hid] introduced by this branch, if [hid] has type + $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are + [ fv (hid fv (refl_equal fv)) ]. + If [hid] has another type the corresponding argument of the constructor is [hid] + *) + let constructor_args g = + List.fold_right + (fun hid acc -> + let type_of_hid = pf_unsafe_type_of g (mkVar hid) in + let sigma = project g in + match EConstr.kind sigma type_of_hid with + | Prod(_,_,t') -> + begin + match EConstr.kind sigma t' with + | Prod(_,t'',t''') -> + begin + match EConstr.kind sigma t'',EConstr.kind sigma t''' with + | App(eq,args), App(graph',_) + when + (EConstr.eq_constr sigma eq eq_ind) && + Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> + (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) + ::acc) + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + end + | _ -> mkVar hid :: acc + ) pre_args [] + in + (* in fact we must also add the parameters to the constructor args *) + let constructor_args g = + let params_id = fst (List.chop princ_infos.Tactics.nparams args_names) in + (List.map mkVar params_id)@((constructor_args g)) + in + (* We then get the constructor corresponding to this branch and + modifies the references has needed i.e. + if the constructor is the last one of the current inductive then + add one the number of the inductive to take and add the number of constructor of the previous + graph to the minimal constructor number + *) + let constructor = + let constructor_num = i - !min_constr_number in + let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then + begin + (kn,!ind_number),constructor_num + end + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length ; + (kn,!ind_number),1 + end + in + (* we can then build the final proof term *) + let app_constructor g = applist((mkConstructU(constructor,u)),constructor_args g) in + (* an apply the tactic *) + let res,hres = + match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with + | [res;hres] -> res,hres + | _ -> assert false + in + (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) + ( + tclTHENLIST + [ + observe_tac ("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in + match l with + | [] -> tclIDTAC + | _ -> Proofview.V82.of_tactic (intro_patterns false l)); + (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false ; + Genredexpr.rConst = [] + } + ) + Locusops.onConcl); + observe_tac ("toto ") tclIDTAC; + + (* introducing the result of the graph and the equality hypothesis *) + observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); + (* replacing [res] with its value *) + observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); + (* Conclusion *) + observe_tac "exact" (fun g -> + Proofview.V82.of_tactic (exact_check (app_constructor g)) g) + ] + ) + g + in + (* end of branche proof *) + let lemmas = + Array.map + (fun ((_,(ctxt,concl))) -> + match ctxt with + | [] | [_] | [_;_] -> CErrors.anomaly (Pp.str "bad context.") + | hres::res::decl::ctxt -> + let res = EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres;res]) + (LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) :: ctxt) + in + res) + lemmas_types_infos + in + let param_names = fst (List.chop princ_infos.nparams args_names) in + let params = List.map mkVar param_names in + let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in + (* The bindings of the principle + that is the params of the principle and the different lemma types + *) + let bindings = + let params_bindings,avoid = + List.fold_left2 + (fun (bindings,avoid) decl p -> + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in + p::bindings,id::avoid + ) + ([],pf_ids_of_hyps g) + princ_infos.params + (List.rev params) + in + let lemmas_bindings = + List.rev (fst (List.fold_left2 + (fun (bindings,avoid) decl p -> + let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in + (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) + ([],avoid) + princ_infos.predicates + (lemmas))) + in + (params_bindings@lemmas_bindings) + in + tclTHENLIST + [ + observe_tac "principle" (Proofview.V82.of_tactic (assert_by + (Name principle_id) + princ_type + (exact_check f_principle))); + observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); + (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC; + tclTHEN_i + (observe_tac + "functional_induction" ( + (fun gl -> + let term = mkApp (mkVar principle_id,Array.of_list bindings) in + let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in + Proofview.V82.of_tactic (apply term) gl') + )) + (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) + ] + g + +(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] + is the tactic used to prove completeness lemma. + + [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions + (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. + + [i] is the indice of the function to prove complete + + The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is + it looks like~: + [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, + graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] + + + The sketch of the proof is the following one~: + \begin{enumerate} + \item intros until $H:graph\ x_1\ldots x_n\ res$ + \item $elim\ H$ using schemes.(i) + \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has + type [x=?] with [x] a variable, then subst [x], + if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else + if [h] is a match then destruct it, else do just introduce it, + after all intros, the conclusion should be a reflexive equality. + \end{enumerate} + +*) + +let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl + +(* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis + (unfolding, substituting, destructing cases \ldots) +*) +let tauto = + let open Ltac_plugin in + let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in + let mp = ModPath.MPfile (DirPath.make dp) in + let kn = KerName.make mp (Label.make "tauto") in + Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> + let body = Tacenv.interp_ltac kn in + Tacinterp.eval_tactic body + end + +(* [generalize_dependent_of x hyp g] + generalize every hypothesis which depends of [x] but [hyp] +*) +let generalize_dependent_of x hyp g = + let open Context.Named.Declaration in + let open Tacmach in + let open Tacticals in + tclMAP + (function + | LocalAssum ({Context.binder_name=id},t) when not (Id.equal id hyp) && + (Termops.occur_var (pf_env g) (project g) x t) -> + tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (thin [id]) + | _ -> tclIDTAC + ) + (pf_hyps g) + g + +let rec intros_with_rewrite g = + observe_tac "intros_with_rewrite" intros_with_rewrite_aux g +and intros_with_rewrite_aux : Tacmach.tactic = + let open Constr in + let open EConstr in + let open Tacmach in + let open Tactics in + let open Tacticals in + fun g -> + let eq_ind = make_eq () in + let sigma = project g in + match EConstr.kind sigma (pf_concl g) with + | Prod(_,t,t') -> + begin + match EConstr.kind sigma t with + | App(eq,args) when (EConstr.eq_constr sigma 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 + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g + else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) + then tclTHENLIST[ + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) + (pf_ids_of_hyps g); + intros_with_rewrite + ] g + else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) + then tclTHENLIST[ + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) + (pf_ids_of_hyps g); + intros_with_rewrite + ] g + else if isVar sigma args.(1) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); + generalize_dependent_of (destVar sigma args.(1)) id; + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); + intros_with_rewrite + ] + g + else if isVar sigma args.(2) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); + generalize_dependent_of (destVar sigma args.(2)) id; + tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); + intros_with_rewrite + ] + g + else + begin + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST[ + Proofview.V82.of_tactic (Simple.intro id); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); + intros_with_rewrite + ] g + end + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) -> + Proofview.V82.of_tactic tauto g + | Case(_,_,v,_) -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_case v); + intros_with_rewrite + ] g + | LetIn _ -> + tclTHENLIST[ + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; + }) + Locusops.onConcl) + ; + intros_with_rewrite + ] g + | _ -> + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g + end + | LetIn _ -> + tclTHENLIST[ + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; + }) + Locusops.onConcl) + ; + intros_with_rewrite + ] g + | _ -> tclIDTAC g + +let rec reflexivity_with_destruct_cases g = + let open Constr in + let open EConstr in + let open Tacmach in + let open Tactics in + let open Tacticals in + let destruct_case () = + try + match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with + | Case(_,_,v,_) -> + tclTHENLIST[ + Proofview.V82.of_tactic (simplest_case v); + Proofview.V82.of_tactic intros; + observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases + ] + | _ -> Proofview.V82.of_tactic reflexivity + with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity + in + let eq_ind = make_eq () in + let my_inj_flags = Some { + Equality.keep_proof_equalities = false; + injection_in_context = false; (* for compatibility, necessary *) + injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) + } in + let discr_inject = + Tacticals.onAllHypsAndConcl ( + fun sc g -> + match sc with + None -> tclIDTAC g + | Some id -> + match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with + | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> + if Equality.discriminable (pf_env g) (project g) t1 t2 + then Proofview.V82.of_tactic (Equality.discrHyp id) g + else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 + then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g + else tclIDTAC g + | _ -> tclIDTAC g + ) + in + (tclFIRST + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); + observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); + (* 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, + either at least an injectable one and we do the injection before continuing + *) + observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) + ]) + g + +let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tactic = + let open EConstr in + let open Tacmach in + let open Tactics in + let open Tacticals in + fun g -> + (* We compute the types of the different mutually recursive lemmas + in $\zeta$ normal form + *) + let lemmas = + Array.map + (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn 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 = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in + let princ_type = pf_unsafe_type_of g graph_principle in + let princ_infos = Tactics.compute_elim_sig (project g) 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 = Termops.nb_prod (project g) (pf_concl g) - 2 in + let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in + let ids = args_names@(pf_ids_of_hyps g) in + (* and fresh names for res H and the principle (cf bug bug #1174) *) + let res,hres,graph_principle_id = + match generate_fresh_id (Id.of_string "z") ids 3 with + | [res;hres;graph_principle_id] -> res,hres,graph_principle_id + | _ -> assert false + in + let ids = res::hres::graph_principle_id::ids in + (* we also compute fresh names for each hyptohesis of each branch + of the principle *) + let branches = List.rev princ_infos.branches in + let intro_pats = + List.map + (fun decl -> + List.map + (fun id -> id) + (generate_fresh_id (Id.of_string "y") ids (Termops.nb_prod (project g) (RelDecl.get_type decl))) + ) + 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 + *) + let rewrite_tac j ids : Tacmach.tactic = + let graph_def = graphs.(j) in + let infos = match find_Function_infos (fst (destConst (project g) funcs.(j))) with + | None -> + CErrors.user_err Pp.(str "No graph found") + | Some infos -> infos + in + if infos.is_general || Rtree.is_infinite Declareops.eq_recarg graph_def.Declarations.mind_recargs + then + let eq_lemma = + try Option.get (infos).equation_lemma + with Option.IsNone -> CErrors.anomaly (Pp.str "Cannot find equation lemma.") + in + tclTHENLIST[ + tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; + Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); + (* Don't forget to $\zeta$ normlize the term since the principles + have been $\zeta$-normalized *) + Proofview.V82.of_tactic (reduce + (Genredexpr.Cbv + {Redops.all_flags + with Genredexpr.rDelta = false; + }) + Locusops.onConcl) + ; + Proofview.V82.of_tactic (generalize (List.map mkVar ids)); + thin ids + ] + else + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) + in + (* The proof of each branche itself *) + let ind_number = ref 0 in + let min_constr_number = ref 0 in + let prove_branche i g = + (* we fist compute the inductive corresponding to the branch *) + let this_ind_number = + let constructor_num = i - !min_constr_number in + let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in + if constructor_num <= length + then !ind_number + else + begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end + in + let this_branche_ids = List.nth intro_pats (pred i) in + tclTHENLIST[ + (* we expand the definition of the function *) + observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); + (* introduce hypothesis with some rewrite *) + observe_tac "intros_with_rewrite (all)" intros_with_rewrite; + (* The proof is (almost) complete *) + observe_tac "reflexivity" (reflexivity_with_destruct_cases) + ] + g + in + let params_names = fst (List.chop princ_infos.nparams args_names) in + let open EConstr in + let params = List.map mkVar params_names in + tclTHENLIST + [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); + observe_tac "h_generalize" + (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); + Proofview.V82.of_tactic (Simple.intro graph_principle_id); + observe_tac "" (tclTHEN_i + (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres, Tactypes.NoBindings) + (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) + (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) + ] + g + +exception No_graph_found + +let get_funs_constant mp = + let open Constr in + let exception Not_Rec in + let get_funs_constant const e : (Names.Constant.t*int) array = + match Constr.kind (Term.strip_lam e) with + | Fix((_,(na,_,_))) -> + Array.mapi + (fun i na -> + match na.Context.binder_name with + | Name id -> + let const = Constant.make2 mp (Label.of_id id) in + const,i + | Anonymous -> + CErrors.anomaly (Pp.str "Anonymous fix.") + ) + na + | _ -> [|const,0|] + in + function const -> + let find_constant_body const = + match Global.body_of_constant Library.indirect_accessor const with + | Some (body, _, _) -> + let body = Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + (Global.env ()) + (Evd.from_env (Global.env ())) + (EConstr.of_constr body) + in + let body = EConstr.Unsafe.to_constr body in + body + | None -> + CErrors.user_err Pp.(str ( "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 + to prevent Reset strange 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 Term.decompose_lam l_bodies) in + (* all the parameters must be equal*) + let _check_params = + let first_params = List.hd l_params in + List.iter + (fun params -> + if not (List.equal (fun (n1, c1) (n2, c2) -> + Context.eq_annot Name.equal n1 n2 && Constr.equal c1 c2) first_params params) + then CErrors.user_err Pp.(str "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 Constr.kind body with + | Fix((idxs,_),(na,ta,ca)) -> (idxs,na,ta,ca) + | _ -> + if is_first && Int.equal (List.length l_bodies) 1 + then raise Not_Rec + else CErrors.user_err Pp.(str "Not a mutal recursive block") + in + let first_infos = extract_info true (List.hd l_bodies) in + let check body = (* Hope this is correct *) + let eq_infos (ia1, na1, ta1, ca1) (ia2, na2, ta2, ca2) = + Array.equal Int.equal ia1 ia2 && Array.equal (Context.eq_annot Name.equal) na1 na2 && + Array.equal Constr.equal ta1 ta2 && Array.equal Constr.equal ca1 ca2 + in + if not (eq_infos first_infos (extract_info false body)) + then CErrors.user_err Pp.(str "Not a mutal recursive block") + in + List.iter check l_bodies + with Not_Rec -> () + in + l_const + +let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_effects Declare.proof_entry list = + let exception Found_type of int in + let env = Global.env () in + let funs = List.map fst fas in + let first_fun = List.hd funs in + let funs_mp = KerName.modpath (Constant.canonical (fst first_fun)) in + let first_fun_kn = + match find_Function_infos (fst first_fun) with + | None -> raise No_graph_found + | Some finfos -> fst finfos.graph_ind + in + let this_block_funs_indexes = get_funs_constant funs_mp (fst first_fun) in + let this_block_funs = Array.map (fun (c,_) -> (c,snd first_fun)) this_block_funs_indexes in + let prop_sort = Sorts.InProp in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + List.map + (function cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) + funs + in + let ind_list = + List.map + (fun (idx) -> + let ind = first_fun_kn,idx in + (ind,snd first_fun),true,prop_sort + ) + funs_indexes + in + let sigma, schemes = + Indrec.build_mutual_induction_scheme env !evd ind_list + in + let _ = evd := sigma in + let l_schemes = + List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes + in + let i = ref (-1) in + let sorts = + List.rev_map (fun (_,x) -> + let sigma, fs = Evd.fresh_sort_in_family !evd x in + evd := sigma; fs + ) + fas + in + (* We create the first principle by tactic *) + let first_type,other_princ_types = + match l_schemes with + s::l_schemes -> s,l_schemes + | _ -> CErrors.anomaly (Pp.str "") + in + let opaque = + let finfos = + match find_Function_infos (fst first_fun) with + | None -> raise Not_found + | Some finfos -> finfos + in + let open Proof_global in + match finfos.equation_lemma with + | None -> Transparent (* non recursive definition *) + | Some equation -> + if Declareops.is_opaque (Global.lookup_constant equation) then Opaque else Transparent + in + let entry, _hook = + try + build_functional_principle ~opaque evd false + first_type + (Array.of_list sorts) + this_block_funs + 0 + (Functional_principles_proofs.prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) + (fun _ _ -> ()) + with e when CErrors.noncritical e -> + raise (Defining_principle e) + + in + incr i; + (* The others are just deduced *) + if List.is_empty other_princ_types + then [entry] + else + let other_fun_princ_types = + let funs = Array.map Constr.mkConstU this_block_funs in + let sorts = Array.of_list sorts in + List.map (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types + in + let first_princ_body,first_princ_type = Declare.(entry.proof_entry_body, entry.proof_entry_type) in + let ctxt,fix = Term.decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) + let (idxs,_),(_,ta,_ as decl) = Constr.destFix fix in + let other_result = + List.map (* we can now compute the other principles *) + (fun scheme_type -> + incr i; + observe (Printer.pr_lconstr_env env sigma scheme_type); + let type_concl = (Term.strip_prod_assum scheme_type) in + let applied_f = List.hd (List.rev (snd (Constr.decompose_app type_concl))) in + let f = fst (Constr.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 = (Term.strip_prod_assum t) in + let applied_g = List.hd (List.rev (snd (Constr.decompose_app t))) in + let g = fst (Constr.decompose_app applied_g) in + if Constr.equal f g + then raise (Found_type j); + observe Pp.(Printer.pr_lconstr_env env sigma f ++ str " <> " ++ + Printer.pr_lconstr_env env sigma g) + + ) + ta; + (* If we reach this point, the two principle are not mutually recursive + We fall back to the previous method + *) + let entry, _hook = + build_functional_principle + evd + false + (List.nth other_princ_types (!i - 1)) + (Array.of_list sorts) + this_block_funs + !i + (Functional_principles_proofs.prove_princ_for_struct evd false !i (Array.of_list (List.map fst funs))) + (fun _ _ -> ()) + in + entry + with Found_type i -> + let princ_body = + Termops.it_mkLambda_or_LetIn (Constr.mkFix((idxs,i),decl)) ctxt + in + Declare.definition_entry ~types:scheme_type princ_body + ) + other_fun_princ_types + in + entry::other_result + +(* [derive_correctness funs graphs] create correctness and completeness + lemmas for each function in [funs] w.r.t. [graphs] +*) + +let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = + let open EConstr in + assert (funs <> []); + assert (graphs <> []); + let funs = Array.of_list funs and graphs = Array.of_list graphs in + let map (c, u) = mkConstU (c, EInstance.make u) in + let funs_constr = Array.map map funs in + (* XXX STATE Why do we need this... why is the toplevel protection not enough *) + funind_purify + (fun () -> + let env = Global.env () in + let evd = ref (Evd.from_env env) in + 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,u = destConst f_constr in *) + let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = + generate_type evd false f_constr graph i + in + let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in + let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in + evd := sigma; + let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in + observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); + type_of_lemma,type_info + ) + funs_constr + graphs_constr + in + let schemes = + (* The functional induction schemes are computed and not saved if there is more that one function + if the block contains only one function we can safely reuse [f_rect] + *) + try + if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; + [| find_induction_principle evd funs_constr.(0) |] + with Not_found -> + ( + + Array.of_list + (List.map + (fun entry -> + (EConstr.of_constr (fst (fst (Future.force entry.Declare.proof_entry_body))), + EConstr.of_constr (Option.get entry.Declare.proof_entry_type )) + ) + (make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) + ) + ) + in + let proving_tac = + prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_correct_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_correct_id f_id in + let (typ,_) = lemmas_types_infos.(i) in + let info = Lemmas.Info.make + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:(Decls.(IsProof Theorem)) () in + let lemma = Lemmas.start_lemma + ~name:lem_id + ~poly:false + ~info + !evd + typ in + let lemma = fst @@ Lemmas.by + (Proofview.V82.tactic (proving_tac i)) lemma in + let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in + (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) + let _,lem_cst_constr = Evd.fresh_global + (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in + let (lem_cst,_) = EConstr.destConst !evd lem_cst_constr in + update_Function {finfo with correctness_lemma = Some lem_cst}; + + ) + funs; + let lemmas_types_infos = + Util.Array.map2_i + (fun i f_constr graph -> + let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = + generate_type evd true f_constr graph i + in + let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in + graphs_constr.(i) <- graph; + let type_of_lemma = + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + in + let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in + observe Pp.(str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); + type_of_lemma,type_info + ) + funs_constr + graphs_constr + in + + let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in + let mib,mip = Global.lookup_inductive graph_ind in + let sigma, scheme = + (Indrec.build_mutual_induction_scheme (Global.env ()) !evd + (Array.to_list + (Array.mapi + (fun i _ -> ((kn,i), EInstance.kind !evd u),true, Sorts.InType) + mib.Declarations.mind_packets + ) + ) + ) + in + let schemes = + Array.of_list scheme + in + let proving_tac = + prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos + in + Array.iteri + (fun i f_as_constant -> + let f_id = Label.to_id (Constant.label (fst f_as_constant)) in + (*i The next call to mk_complete_id is valid since we are constructing the lemma + Ensures by: obvious + i*) + let lem_id = mk_complete_id f_id in + let info = Lemmas.Info.make + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:Decls.(IsProof Theorem) () in + let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false ~info + sigma (fst lemmas_types_infos.(i)) in + let lemma = fst (Lemmas.by + (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") + (proving_tac i))) lemma) in + let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in + let finfo = + match find_Function_infos (fst f_as_constant) with + | None -> raise Not_found + | Some finfo -> finfo + in + let _,lem_cst_constr = Evd.fresh_global + (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in + let (lem_cst,_) = destConst !evd lem_cst_constr in + update_Function {finfo with completeness_lemma = Some lem_cst} + ) + funs) + () + +let warn_funind_cannot_build_inversion = + CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" + Pp.(fun e' -> strbrk "Cannot build inversion information" ++ + if do_observe () then (fnl() ++ CErrors.print e') else mt ()) + +let derive_inversion fix_names = + try + let evd' = Evd.from_env (Global.env ()) in + (* we first transform the fix_names identifier into their corresponding constant *) + let evd',fix_names_as_constant = + List.fold_right + (fun id (evd,l) -> + let evd,c = + Evd.fresh_global + (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in + let (cst, u) = EConstr.destConst evd c in + evd, (cst, EConstr.EInstance.kind evd u) :: l + ) + fix_names + (evd',[]) + 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 (fst c))) fix_names_as_constant ; + try + let evd', lind = + List.fold_right + (fun id (evd,l) -> + let evd,id = + Evd.fresh_global + (Global.env ()) evd + (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) + in + evd,(fst (EConstr.destInd evd id))::l + ) + fix_names + (evd',[]) + in + derive_correctness + fix_names_as_constant + lind; + with e when CErrors.noncritical e -> + warn_funind_cannot_build_inversion e + with e when CErrors.noncritical e -> + warn_funind_cannot_build_inversion e + +let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body + pre_hook + = + let type_of_f = Constrexpr_ops.mkCProdN args ret_type in + let rec_arg_num = + let names = + List.map + CAst.(with_val (fun x -> x)) + (Constrexpr_ops.names_of_local_assums args) + in + List.index Name.equal (Name wf_arg) names + in + let unbounded_eq = + let f_app_args = + CAst.make @@ Constrexpr.CAppExpl( + (None, Libnames.qualid_of_ident fname,None) , + (List.map + (function + | {CAst.v=Anonymous} -> assert false + | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e) + ) + (Constrexpr_ops.names_of_local_assums args) + ) + ) + in + CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (Libnames.qualid_of_string "Logic.eq")), + [(f_app_args,None);(body,None)]) + in + let eq = Constrexpr_ops.mkCProdN args unbounded_eq in + let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type + nb_args relation = + try + pre_hook [fconst] + (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 when CErrors.noncritical e -> + (* No proof done *) + () + in + Recdef.recursive_definition ~interactive_proof + ~is_mes fname rec_impls + type_of_f + wf_rel_expr + rec_arg_num + eq + hook + using_lemmas + +let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = + let wf_arg_type,wf_arg = + match wf_arg with + | None -> + begin + match args with + | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],k,t)] -> t,x + | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") + end + | Some wf_args -> + try + match + List.find + (function + | Constrexpr.CLocalAssum(l,k,t) -> + List.exists + (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) + l + | _ -> false + ) + args + with + | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args + | _ -> assert false + with Not_found -> assert false + in + let wf_rel_from_mes,is_mes = + match wf_rel_expr_opt with + | None -> + let ltof = + let make_dir l = DirPath.make (List.rev_map Id.of_string l) in + Libnames.qualid_of_path + (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) + in + let fun_from_mes = + let applied_mes = + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in + Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) + in + let wf_rel_from_mes = + Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) + in + wf_rel_from_mes,true + | Some wf_rel_expr -> + let wf_rel_with_mes = + let a = Names.Id.of_string "___a" in + let b = Names.Id.of_string "___b" in + Constrexpr_ops.mkLambdaC( + [CAst.make @@ Name a; CAst.make @@ Name b], + Constrexpr.Default Glob_term.Explicit, + wf_arg_type, + Constrexpr_ops.mkAppC(wf_rel_expr, + [ + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); + Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) + ]) + ) + in + wf_rel_with_mes,false + in + register_wf interactive_proof ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg + using_lemmas args ret_type body + +let do_generate_principle_aux pconstants on_error register_built interactive_proof fixpoint_exprl : Lemmas.t option = + List.iter (fun { Vernacexpr.notations } -> + if not (List.is_empty notations) + then CErrors.user_err (Pp.str "Function does not support notations for now")) fixpoint_exprl; + let lemma, _is_struct = + match fixpoint_exprl with + | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> + let { Vernacexpr.fname; univs; binders; rtype; body_def } as fixpoint_expr = + match recompute_binder_list [fixpoint_expr] with + | [e] -> e + | _ -> assert false + in + let fixpoint_exprl = [fixpoint_expr] in + let body = match body_def with | Some body -> body | None -> + CErrors.user_err ~hdr:"Function" (Pp.str "Body of Function must be given") in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let using_lemmas = [] in + let pre_hook pconstants = + generate_principle + (ref (Evd.from_env (Global.env ()))) + pconstants + on_error + true + register_built + fixpoint_exprl + recdefs + true + in + if register_built + then register_wf interactive_proof fname.CAst.v rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false + else None, false + | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> + let { Vernacexpr.fname; univs; binders; rtype; body_def} as fixpoint_expr = + match recompute_binder_list [fixpoint_expr] with + | [e] -> e + | _ -> assert false + in + let fixpoint_exprl = [fixpoint_expr] in + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let using_lemmas = [] in + let body = match body_def with + | Some body -> body + | None -> + CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in + let pre_hook pconstants = + generate_principle + (ref (Evd.from_env (Global.env ()))) + pconstants + on_error + true + register_built + fixpoint_exprl + recdefs + true + in + if register_built + then register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt + (Option.map (fun x -> x.CAst.v) wf_x) using_lemmas binders rtype body pre_hook, true + else None, true + | _ -> + List.iter (function { Vernacexpr.rec_order } -> + match rec_order with + | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> + CErrors.user_err + (Pp.str "Cannot use mutual definition with well-founded recursion or measure") + | _ -> () + ) + fixpoint_exprl; + let fixpoint_exprl = recompute_binder_list fixpoint_exprl in + let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in + (* ok all the expressions are structural *) + let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let is_rec = List.exists (is_rec fix_names) recdefs in + let lemma,evd,pconstants = + if register_built + then register_struct is_rec fixpoint_exprl + else None, Evd.from_env (Global.env ()), pconstants + in + let evd = ref evd in + generate_principle + (ref !evd) + pconstants + on_error + false + register_built + fixpoint_exprl + recdefs + interactive_proof + (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); + if register_built then + begin derive_inversion fix_names; end; + lemma, true + in + lemma + +let warn_cannot_define_graph = + CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" + (fun (names,error) -> + Pp.(strbrk "Cannot define graph(s) for " ++ + h 1 names ++ error)) + +let warn_cannot_define_principle = + CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind" + (fun (names,error) -> + Pp.(strbrk "Cannot define induction principle(s) for "++ + h 1 names ++ error)) + +let warning_error names e = + let e_explain e = + match e with + | ToShow e -> + Pp.(spc () ++ CErrors.print e) + | _ -> + if do_observe () + then Pp.(spc () ++ CErrors.print e) + else Pp.mt () + in + match e with + | Building_graph e -> + let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in + warn_cannot_define_graph (names,e_explain e) + | Defining_principle e -> + let names = Pp.(prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) in + warn_cannot_define_principle (names,e_explain e) + | _ -> raise e + +let error_error names e = + let e_explain e = + match e with + | ToShow e -> Pp.(spc () ++ CErrors.print e) + | _ -> if do_observe () then Pp.(spc () ++ CErrors.print e) else Pp.mt () + in + match e with + | Building_graph e -> + CErrors.user_err + Pp.(str "Cannot define graph(s) for " ++ + h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ + e_explain e) + | _ -> raise e + +(* [chop_n_arrow n t] chops the [n] first arrows in [t] + Acts on Constrexpr.constr_expr +*) +let rec chop_n_arrow n t = + let exception Stop of Constrexpr.constr_expr in + let open Constrexpr in + 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.CAst.v with + | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results 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 + than the number we need to chop and then we return the new type + *) + begin + try + let new_n = + let rec aux (n:int) = function + [] -> n + | CLocalAssum(nal,k,t'')::nal_ta' -> + let nal_l = List.length nal in + if n >= nal_l + then + aux (n - nal_l) nal_ta' + else + let new_t' = CAst.make @@ + Constrexpr.CProdN( + CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') + in + raise (Stop new_t') + | _ -> CErrors.anomaly (Pp.str "Not enough products.") + in + aux n nal_ta' + in + chop_n_arrow new_n t' + with Stop t -> t + end + | _ -> CErrors.anomaly (Pp.str "Not enough products.") + +let rec add_args id new_args = + let open Libnames in + let open Constrexpr in + CAst.map (function + | CRef (qid,_) as b -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl((None,qid,None),new_args) + else b + | CFix _ | CCoFix _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "todo.") + | CProdN(nal,b1) -> + CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) + | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, + add_args id new_args b1) + | CLambdaN(nal,b1) -> + CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) + | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) + | CLocalPattern _ -> + CErrors.user_err (Pp.str "pattern with quote not allowed here.")) nal, + add_args id new_args b1) + | CLetIn(na,b1,t,b2) -> + CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) + | CAppExpl((pf,qid,us),exprl) -> + if qualid_is_ident qid && Id.equal (qualid_basename qid) id then + CAppExpl((pf,qid,us),new_args@(List.map (add_args id new_args) exprl)) + else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) + | CApp((pf,b),bl) -> + CApp((pf,add_args id new_args b), + List.map (fun (e,o) -> add_args id new_args e,o) bl) + | CCases(sty,b_option,cel,cal) -> + CCases(sty,Option.map (add_args id new_args) b_option, + List.map (fun (b,na,b_option) -> + add_args id new_args b, + na, b_option) cel, + List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal + ) + | CLetTuple(nal,(na,b_option),b1,b2) -> + CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), + add_args id new_args b1, + add_args id new_args b2 + ) + + | CIf(b1,(na,b_option),b2,b3) -> + CIf(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 + ) + | CHole _ + | CPatVar _ + | CEvar _ + | CPrim _ + | CSort _ as b -> b + | CCast(b1,b2) -> + CCast(add_args id new_args b1, + Glob_ops.map_cast_type (add_args id new_args) b2) + | CRecord pars -> + CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) + | CNotation _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CNotation.") + | CGeneralization _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CGeneralization.") + | CDelimiters _ -> + CErrors.anomaly ~label:"add_args " (Pp.str "CDelimiters.") + ) + +let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = + let open Constrexpr in + match b.CAst.v with + | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> + begin + let n = List.length nal in + let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in + d :: nal_tas, b'',t'' + end + | Constrexpr.CLambdaN ([], b) -> [],b,t + | _ -> [],b,t + +let make_graph (f_ref : GlobRef.t) = + let open Constrexpr in + let env = Global.env() in + let sigma = Evd.from_env env in + let c,c_body = + match f_ref with + | GlobRef.ConstRef c -> + begin + try c,Global.lookup_constant c + with Not_found -> + CErrors.user_err Pp.(str "Cannot find " ++ Printer.pr_leconstr_env env sigma (EConstr.mkConst c)) + end + | _ -> + CErrors.user_err Pp.(str "Not a function reference") + in + (match Global.body_of_constant_body Library.indirect_accessor c_body with + | None -> + CErrors.user_err (Pp.str "Cannot build a graph over an axiom!") + | Some (body, _, _) -> + let env = Global.env () in + let extern_body,extern_type = + with_full_print (fun () -> + (Constrextern.extern_constr false env sigma (EConstr.of_constr body), + Constrextern.extern_type false env sigma + (EConstr.of_constr (*FIXME*) c_body.Declarations.const_type) + ) + ) + () + in + let (nal_tas,b,t) = get_args extern_body extern_type in + let expr_list = + match b.CAst.v with + | Constrexpr.CFix(l_id,fixexprl) -> + let l = + List.map + (fun (id,recexp,bl,t,b) -> + let { CAst.loc; v=rec_id } = match Option.get recexp with + | { CAst.v = CStructRec id } -> id + | { CAst.v = CWfRec (id,_) } -> id + | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid + in + let new_args = + List.flatten + (List.map + (function + | Constrexpr.CLocalDef (na,_,_)-> [] + | Constrexpr.CLocalAssum (nal,_,_) -> + List.map + (fun {CAst.loc;v=n} -> CAst.make ?loc @@ + CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) + nal + | Constrexpr.CLocalPattern _ -> assert false + ) + nal_tas + ) + in + let b' = add_args id.CAst.v new_args b in + { Vernacexpr.fname=id; univs=None + ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) + ; binders = nal_tas@bl; rtype=t; body_def=Some b'; notations = []} + ) + fixexprl + in + l + | _ -> + let fname = CAst.make (Label.to_id (Constant.label c)) in + [{ Vernacexpr.fname; univs=None; rec_order = None; binders=nal_tas; rtype=t; body_def=Some b; notations=[]}] + in + let mp = Constant.modpath c in + let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in + assert (Option.is_empty pstate); + (* We register the infos *) + List.iter + (fun { Vernacexpr.fname= {CAst.v=id} } -> + add_Function false (Constant.make2 mp (Label.of_id id))) + expr_list) + +(* *************** statically typed entrypoints ************************* *) + +let do_generate_principle_interactive fixl : Lemmas.t = + match + do_generate_principle_aux [] warning_error true true fixl + with + | Some lemma -> lemma + | None -> + CErrors.anomaly + (Pp.str"indfun: leaving no open proof in interactive mode") + +let do_generate_principle fixl : unit = + match do_generate_principle_aux [] warning_error true false fixl with + | Some _lemma -> + CErrors.anomaly + (Pp.str"indfun: leaving a goal open in non-interactive mode") + | None -> () + + +let build_scheme fas = + let evd = (ref (Evd.from_env (Global.env ()))) in + let pconstants = (List.map + (fun (_,f,sort) -> + let f_as_constant = + try + Smartlocate.global_with_alias f + with Not_found -> + CErrors.user_err ~hdr:"FunInd.build_scheme" + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) + in + let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in + let _ = evd := evd' in + let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd f in + evd := sigma; + let c, u = + try EConstr.destConst !evd f + with Constr.DestKO -> + CErrors.user_err Pp.(Printer.pr_econstr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function") + in + (c, EConstr.EInstance.kind !evd u), sort + ) + fas + ) in + let bodies_types = make_scheme evd pconstants in + + List.iter2 + (fun (princ_id,_,_) def_entry -> + ignore + (Declare.declare_constant + ~name:princ_id + ~kind:Decls.(IsProof Theorem) + (Declare.DefinitionEntry def_entry)); + Declare.definition_message princ_id + ) + fas + bodies_types + +let build_case_scheme fa = + let env = Global.env () + and sigma = (Evd.from_env (Global.env ())) in +(* let id_to_constr id = *) +(* Constrintern.global_reference id *) +(* in *) + let funs = + let (_,f,_) = fa in + try (let open GlobRef in + match Smartlocate.global_with_alias f with + | ConstRef c -> c + | IndRef _ | ConstructRef _ | VarRef _ -> assert false) + with Not_found -> + CErrors.user_err ~hdr:"FunInd.build_case_scheme" + Pp.(str "Cannot find " ++ Libnames.pr_qualid f) in + let sigma, (_,u) = Evd.fresh_constant_instance env sigma funs in + let first_fun = funs in + let funs_mp = Constant.modpath first_fun in + let first_fun_kn = + match find_Function_infos first_fun with + | None -> raise No_graph_found + | Some finfos -> fst finfos.graph_ind + in + let this_block_funs_indexes = get_funs_constant funs_mp first_fun in + let this_block_funs = Array.map (fun (c,_) -> (c,u)) this_block_funs_indexes in + let prop_sort = Sorts.InProp in + let funs_indexes = + let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + List.assoc_f Constant.equal funs this_block_funs_indexes + in + let (ind, sf) = + let ind = first_fun_kn,funs_indexes in + (ind,Univ.Instance.empty)(*FIXME*),prop_sort + in + let (sigma, scheme) = + Indrec.build_case_analysis_scheme_default env sigma ind sf + in + let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in + let sorts = + (fun (_,_,x) -> + fst @@ UnivGen.fresh_sort_in_family x + ) + fa + in + let princ_name = (fun (x,_,_) -> x) fa in + let _ : unit = + (* 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 + ); + *) + generate_functional_principle + (ref (Evd.from_env (Global.env ()))) + false + scheme_type + (Some ([|sorts|])) + (Some princ_name) + this_block_funs + 0 + (Functional_principles_proofs.prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|funs|]) + in + () diff --git a/library/decl_kinds.ml b/plugins/funind/gen_principle.mli index 17746645ee..7eb8ca3af1 100644 --- a/library/decl_kinds.ml +++ b/plugins/funind/gen_principle.mli @@ -8,4 +8,16 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type binding_kind = Explicit | Implicit +val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit +val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit + +val do_generate_principle_interactive : Vernacexpr.fixpoint_expr list -> Lemmas.t +val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit + +val make_graph : Names.GlobRef.t -> unit + +(* Can be thrown by build_{,case}_scheme *) +exception No_graph_found + +val build_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) list -> unit +val build_case_scheme : (Names.Id.t * Libnames.qualid * Sorts.family) -> unit diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 6dc01a9f8f..7c17ecdba0 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1252,7 +1252,7 @@ let rec compute_cst_params relnames params gt = DAst.with_val (function | GSort _ -> params | GHole _ -> params | GIf _ | GRec _ | GCast _ -> - raise (UserError(Some "compute_cst_params", str "Not handled case")) + CErrors.user_err ~hdr:"compute_cst_params" (str "Not handled case") ) gt and compute_cst_params_from_app acc (params,rtl) = let is_gid id c = match DAst.get c with GVar id' -> Id.equal id id' | _ -> false in @@ -1300,7 +1300,7 @@ let rec rebuild_return_type rt = | Constrexpr.CLetIn(na,v,t,t') -> CAst.make ?loc @@ Constrexpr.CLetIn(na,v,t,rebuild_return_type t') | _ -> CAst.make ?loc @@ Constrexpr.CProdN([Constrexpr.CLocalAssum ([CAst.make Anonymous], - Constrexpr.Default Decl_kinds.Explicit, rt)], + Constrexpr.Default Explicit, rt)], CAst.make @@ Constrexpr.CSort(UAnonymous {rigid=true})) let do_build_inductive @@ -1517,7 +1517,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Declarations.Finite,repacked_rel_inds)}) ++ fnl () ++ msg in @@ -1532,7 +1532,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac Vernacexpr.(CAst.make @@ VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds))) + Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Declarations.Finite,repacked_rel_inds)}) ++ fnl () ++ CErrors.print reraise in @@ -1554,5 +1554,3 @@ let build_inductive evd funconstants funsargs returned_types rtl = Detyping.print_universes := pu; Constrextern.print_universes := cu; raise (Building_graph e) - - diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index d36d86a65b..8abccabae6 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -1,10 +1,18 @@ -open Pp +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Constr open Glob_term open CErrors open Util open Names -open Decl_kinds (* Some basic functions to rebuild glob_constr @@ -434,7 +442,8 @@ let replace_var_by_term x_id term = replace_var_by_pattern lhs, replace_var_by_pattern rhs ) - | GRec _ -> raise (UserError(None,str "Not handled GRec")) + | GRec _ -> + CErrors.user_err (Pp.str "Not handled GRec") | GSort _ | GHole _ as rt -> rt | GInt _ as rt -> rt diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 24b3690138..70211a1860 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Names open Glob_term diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 1987677d7d..a205c0744a 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -8,20 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open CErrors -open Sorts +open Pp open Util +open CErrors open Names +open Sorts open Constr -open Context open EConstr -open Pp + +open Tacmach.New +open Tacticals.New +open Tactics + open Indfun_common -open Libnames -open Glob_term -open Declarations -open Tactypes -open Decl_kinds module RelDecl = Context.Rel.Declaration @@ -42,885 +41,107 @@ let choose_dest_or_ind scheme_info args = Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) let functional_induction with_clean c princl pat = - let res = - fun g -> - let sigma = Tacmach.project g in + let open Proofview.Notations in + Proofview.Goal.enter_one (fun gl -> + let sigma = project gl in let f,args = decompose_app sigma c in - let princ,bindings, princ_type,g' = - match princl with - | None -> (* No principle is given let's find the good one *) - begin - match EConstr.kind sigma f with - | Const (c',u) -> - let princ_option = - let finfo = (* we first try to find out a graph on f *) - try find_Function_infos c' - with Not_found -> - user_err (str "Cannot find induction information on "++ - Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) - in - match Tacticals.elimination_sort_of_goal g with - | InSProp -> finfo.sprop_lemma - | InProp -> finfo.prop_lemma - | InSet -> finfo.rec_lemma - | InType -> finfo.rect_lemma + match princl with + | None -> (* No principle is given let's find the good one *) + begin + match EConstr.kind sigma f with + | Const (c',u) -> + let princ_option = + let finfo = (* we first try to find out a graph on f *) + match find_Function_infos c' with + | Some finfo -> finfo + | None -> + user_err (str "Cannot find induction information on "++ + Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) + in + match elimination_sort_of_goal gl with + | InSProp -> finfo.sprop_lemma + | InProp -> finfo.prop_lemma + | InSet -> finfo.rec_lemma + | InType -> finfo.rect_lemma + in + let princ = (* then we get the principle *) + match princ_option with + | Some princ -> + let sigma, princ = Evd.fresh_global (pf_env gl) (project gl) (GlobRef.ConstRef princ) in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT princ + | None -> + (*i If there is not default lemma defined then, + we cross our finger and try to find a lemma named f_ind + (or f_rec, f_rect) i*) + let princ_name = + Indrec.make_elimination_ident + (Label.to_id (Constant.label c')) + (elimination_sort_of_goal gl) in - let princ,g' = (* then we get the principle *) + let princ_ref = try - let g',princ = - Tacmach.pf_eapply (Evd.fresh_global) g (GlobRef.ConstRef (Option.get princ_option )) in - princ,g' - 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 = - Indrec.make_elimination_ident - (Label.to_id (Constant.label c')) - (Tacticals.elimination_sort_of_goal g) - in - try - let princ_ref = const_of_id princ_name in - let (a,b) = Tacmach.pf_eapply (Evd.fresh_global) g princ_ref in - (b,a) - (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) - with Not_found -> (* This one is neither defined ! *) - user_err (str "Cannot find induction principle for " - ++ Printer.pr_leconstr_env (Tacmach.pf_env g) sigma (mkConst c') ) + Constrintern.locate_reference (Libnames.qualid_of_ident princ_name) + with + | Not_found -> + user_err (str "Cannot find induction principle for " + ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in - (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') - | _ -> raise (UserError(None,str "functional induction must be used with a function" )) - end - | Some ((princ,binding)) -> - princ,binding,Tacmach.pf_unsafe_type_of g princ,g - in - let sigma = Tacmach.project g' in - let princ_infos = Tactics.compute_elim_sig (Tacmach.project g') princ_type in - let args_as_induction_constr = - let c_list = - if princ_infos.Tactics.farg_in_concl - then [c] else [] - in - if List.length args + List.length c_list = 0 - then user_err Pp.(str "Cannot recognize a valid functional scheme" ); - let encoded_pat_as_patlist = - List.make (List.length args + List.length c_list - 1) None @ [pat] - in - List.map2 - (fun c pat -> - ((None, - Tactics.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))), - (None,pat), - None)) - (args@c_list) - encoded_pat_as_patlist - in - let princ' = Some (princ,bindings) in - let princ_vars = - List.fold_right - (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) - args - Id.Set.empty - in - let old_idl = List.fold_right Id.Set.add (Tacmach.pf_ids_of_hyps g) Id.Set.empty in - let old_idl = Id.Set.diff old_idl princ_vars in - let subst_and_reduce g = - if with_clean - then - let idl = - List.filter (fun id -> not (Id.Set.mem id old_idl)) - (Tacmach.pf_ids_of_hyps g) - in - let flag = - Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - } - in - Tacticals.tclTHEN - (Tacticals.tclMAP (fun id -> Tacticals.tclTRY (Proofview.V82.of_tactic (Equality.subst_gen (do_rewrite_dependent ()) [id]))) idl ) - (Proofview.V82.of_tactic (Tactics.reduce flag Locusops.allHypsAndConcl)) - g - else Tacticals.tclIDTAC g - in - Tacticals.tclTHEN - (Proofview.V82.of_tactic (choose_dest_or_ind - princ_infos - (args_as_induction_constr,princ'))) - subst_and_reduce - g' - in res - -let rec abstract_glob_constr c = function - | [] -> c - | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl) - | Constrexpr.CLocalAssum (idl,k,t)::bl -> - List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl - (abstract_glob_constr c bl) - | Constrexpr.CLocalPattern _::bl -> assert false - -let interp_casted_constr_with_implicits env sigma impls c = - Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls c - -(* - Construct a fixpoint as a Glob_term - and not as a constr -*) - -let build_newrecursive lnameargsardef = - let env0 = Global.env() in - let sigma = Evd.from_env env0 in - let (rec_sign,rec_impls) = - List.fold_left - (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> - let arityc = Constrexpr_ops.mkCProdN binders rtype in - let arity,ctx = Constrintern.interp_type env0 sigma arityc in - let evd = Evd.from_env env0 in - let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in - let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in - let open Context.Named.Declaration in - let r = Sorts.Relevant in (* TODO relevance *) - (EConstr.push_named (LocalAssum (make_annot recname r,arity)) env, Id.Map.add recname impl impls)) - (env0,Constrintern.empty_internalization_env) lnameargsardef in - let recdef = - (* Declare local notations *) - let f { Vernacexpr.binders; body_def } = - match body_def with - | Some body_def -> - let def = abstract_glob_constr body_def binders in - interp_casted_constr_with_implicits - rec_sign sigma rec_impls def - | None -> user_err ~hdr:"Function" (str "Body of Function must be given") - in - States.with_state_protection (List.map f) lnameargsardef - in - recdef,rec_impls - -let error msg = user_err Pp.(str msg) - -(* Checks whether or not the mutual bloc is recursive *) -let is_rec names = - let names = List.fold_right Id.Set.add names Id.Set.empty in - let check_id id names = Id.Set.mem id names in - let rec lookup names gt = match DAst.get gt with - | GVar(id) -> check_id id names - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ -> false - | GCast(b,_) -> lookup names b - | GRec _ -> error "GRec not handled" - | GIf(b,_,lhs,rhs) -> - (lookup names b) || (lookup names lhs) || (lookup names rhs) - | GProd(na,_,t,b) | GLambda(na,_,t,b) -> - lookup names t || lookup (Nameops.Name.fold_right Id.Set.remove na names) b - | GLetIn(na,b,t,c) -> - lookup names b || Option.cata (lookup names) true t || lookup (Nameops.Name.fold_right Id.Set.remove na names) c - | GLetTuple(nal,_,t,b) -> lookup names t || - lookup - (List.fold_left - (fun acc na -> Nameops.Name.fold_right Id.Set.remove na acc) - names - nal - ) - b - | GApp(f,args) -> List.exists (lookup names) (f::args) - | GCases(_,_,el,brl) -> - List.exists (fun (e,_) -> lookup names e) el || - List.exists (lookup_br names) brl - and lookup_br names {CAst.v=(idl,_,rt)} = - let new_names = List.fold_right Id.Set.remove idl names in - lookup new_names rt - in - lookup names - -let rec local_binders_length = function - (* Assume that no `{ ... } contexts occur *) - | [] -> 0 - | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl - | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl - | Constrexpr.CLocalPattern _::bl -> assert false - -let prepare_body { Vernacexpr.binders; rtype } rt = - let n = local_binders_length binders in -(* Pp.msgnl (str "nb lambda to chop : " ++ str (string_of_int n) ++ fnl () ++Printer.pr_glob_constr rt); *) - let fun_args,rt' = chop_rlambda_n n rt in - (fun_args,rt') - -let warn_funind_cannot_build_inversion = - CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" - (fun e' -> strbrk "Cannot build inversion information" ++ - if do_observe () then (fnl() ++ CErrors.print e') else mt ()) - -let derive_inversion fix_names = - try - let evd' = Evd.from_env (Global.env ()) in - (* we first transform the fix_names identifier into their corresponding constant *) - let evd',fix_names_as_constant = - List.fold_right - (fun id (evd,l) -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - let (cst, u) = destConst evd c in - evd, (cst, EInstance.kind evd u) :: l - ) - fix_names - (evd',[]) - 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 (fst c))) fix_names_as_constant ; - try - let evd', lind = - List.fold_right - (fun id (evd,l) -> - let evd,id = - Evd.fresh_global - (Global.env ()) evd - (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) - in - evd,(fst (destInd evd id))::l - ) - fix_names - (evd',[]) - in - Invfun.derive_correctness - fix_names_as_constant - lind; - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - with e when CErrors.noncritical e -> - warn_funind_cannot_build_inversion e - -let warn_cannot_define_graph = - CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" - (fun (names,error) -> strbrk "Cannot define graph(s) for " ++ - h 1 names ++ error) - -let warn_cannot_define_principle = - CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind" - (fun (names,error) -> strbrk "Cannot define induction principle(s) for "++ - h 1 names ++ error) - -let warning_error names e = - let e_explain e = - match e with - | ToShow e -> - spc () ++ CErrors.print e - | _ -> - if do_observe () - then (spc () ++ CErrors.print e) - else mt () - in - match e with - | Building_graph e -> - let names = prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names in - warn_cannot_define_graph (names,e_explain e) - | Defining_principle e -> - let names = prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names in - warn_cannot_define_principle (names,e_explain e) - | _ -> raise e - -let error_error names e = - let e_explain e = - match e with - | ToShow e -> spc () ++ CErrors.print e - | _ -> if do_observe () then (spc () ++ CErrors.print e) else mt () - in - match e with - | Building_graph e -> - user_err - (str "Cannot define graph(s) for " ++ - h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ - e_explain e) - | _ -> raise e - -let generate_principle (evd:Evd.evar_map ref) pconstants on_error - is_general do_built (fix_rec_l : Vernacexpr.fixpoint_expr list) recdefs interactive_proof - (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> - Tacmach.tactic) : unit = - let names = List.map (function { Vernacexpr.fname = {CAst.v=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 { Vernacexpr.rtype } -> rtype) fix_rec_l in - try - (* We then register the Inductive graphs of the functions *) - Glob_term_to_relation.build_inductive !evd pconstants funs_args funs_types recdefs; - if do_built - then - begin - (*i The next call to mk_rel_id is valid since we have just construct the graph - Ensures by : do_built - i*) - let f_R_mut = qualid_of_ident @@ mk_rel_id (List.nth names 0) in - let ind_kn = - fst (locate_with_msg - (pr_qualid f_R_mut++str ": Not an inductive type!") - locate_ind - f_R_mut) - in - let fname_kn { Vernacexpr.fname } = - let f_ref = qualid_of_ident ?loc:fname.CAst.loc fname.CAst.v in - locate_with_msg - (pr_qualid f_ref++str ": Not an inductive type!") - locate_constant - f_ref - in - let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in - let _ = - List.map_i - (fun i x -> - let env = Global.env () in - let princ = Indrec.lookup_eliminator env (ind_kn,i) (InProp) in - let evd = ref (Evd.from_env env) in - let evd',uprinc = Evd.fresh_global env !evd princ in - let _ = evd := evd' in - let sigma, princ_type = Typing.type_of ~refresh:true env !evd uprinc in - evd := sigma; - let princ_type = EConstr.Unsafe.to_constr princ_type in - Functional_principles_types.generate_functional_principle - evd - interactive_proof - princ_type - None - None - (Array.of_list pconstants) - (* funs_kn *) - i - (continue_proof 0 [|funs_kn.(i)|]) - ) - 0 - fix_rec_l - in - Array.iter (add_Function is_general) funs_kn; - () + let sigma, princ = Evd.fresh_global (pf_env gl) (project gl) princ_ref in + Proofview.Unsafe.tclEVARS sigma >>= fun () -> + Proofview.tclUNIT princ + in + princ >>= fun princ -> + (* We need to refresh gl due to the updated evar_map in princ *) + Proofview.Goal.enter_one (fun gl -> + Proofview.tclUNIT (princ, Tactypes.NoBindings, pf_unsafe_type_of gl princ, args)) + | _ -> + CErrors.user_err (str "functional induction must be used with a function" ) end - with e when CErrors.noncritical e -> - on_error names e - -let register_struct is_rec (fixpoint_exprl: Vernacexpr.fixpoint_expr list) = - match fixpoint_exprl with - | [ { Vernacexpr.fname; univs; binders; rtype; body_def } ] when not is_rec -> - let body = match body_def with - | Some body -> body - | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - ComDefinition.do_definition - ~program_mode:false - ~name:fname.CAst.v - ~poly:false - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.Definition univs - binders None body (Some rtype); - let evd,rev_pconstants = - List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) - fixpoint_exprl - in - None, evd,List.rev rev_pconstants - | _ -> - ComFixpoint.do_fixpoint ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; - let evd,rev_pconstants = - List.fold_left - (fun (evd,l) { Vernacexpr.fname } -> - let evd,c = - Evd.fresh_global - (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname.CAst.v)) in - let (cst, u) = destConst evd c in - let u = EInstance.kind evd u in - evd,((cst, u) :: l) - ) - (Evd.from_env (Global.env ()),[]) - fixpoint_exprl - in - None,evd,List.rev rev_pconstants - - -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.t array) (_:EConstr.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 interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body - pre_hook - = - let type_of_f = Constrexpr_ops.mkCProdN args ret_type in - let rec_arg_num = - let names = - List.map - CAst.(with_val (fun x -> x)) - (Constrexpr_ops.names_of_local_assums args) + | Some ((princ,binding)) -> + Proofview.tclUNIT (princ, binding, pf_unsafe_type_of gl princ, args) + ) >>= fun (princ, bindings, princ_type, args) -> + Proofview.Goal.enter (fun gl -> + let sigma = project gl in + let princ_infos = compute_elim_sig (project gl) princ_type in + let args_as_induction_constr = + let c_list = + if princ_infos.Tactics.farg_in_concl + then [c] else [] in - List.index Name.equal (Name wf_arg) names - in - let unbounded_eq = - let f_app_args = - CAst.make @@ Constrexpr.CAppExpl( - (None,qualid_of_ident fname.CAst.v,None) , - (List.map - (function - | {CAst.v=Anonymous} -> assert false - | {CAst.v=Name e} -> (Constrexpr_ops.mkIdentC e) - ) - (Constrexpr_ops.names_of_local_assums args) - ) - ) + if List.length args + List.length c_list = 0 + then user_err Pp.(str "Cannot recognize a valid functional scheme" ); + let encoded_pat_as_patlist = + List.make (List.length args + List.length c_list - 1) None @ [pat] in - CAst.make @@ Constrexpr.CApp ((None,Constrexpr_ops.mkRefC (qualid_of_string "Logic.eq")), - [(f_app_args,None);(body,None)]) - in - let eq = Constrexpr_ops.mkCProdN args unbounded_eq in - let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type - nb_args relation = - try - pre_hook [fconst] - (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.CAst.v] - with e when CErrors.noncritical e -> - (* No proof done *) - () - in - Recdef.recursive_definition ~interactive_proof - ~is_mes fname.CAst.v rec_impls - type_of_f - wf_rel_expr - rec_arg_num - eq - hook - using_lemmas - - -let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas args ret_type body = - let wf_arg_type,wf_arg = - match wf_arg with - | None -> - begin - match args with - | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],k,t)] -> t,x - | _ -> error "Recursive argument must be specified" - end - | Some wf_args -> - try - match - List.find - (function - | Constrexpr.CLocalAssum(l,k,t) -> - List.exists - (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) - l - | _ -> false - ) - args - with - | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args - | _ -> assert false - with Not_found -> assert false - in - let wf_rel_from_mes,is_mes = - match wf_rel_expr_opt with - | None -> - let ltof = - let make_dir l = DirPath.make (List.rev_map Id.of_string l) in - Libnames.qualid_of_path - (Libnames.make_path (make_dir ["Arith";"Wf_nat"]) (Id.of_string "ltof")) - in - let fun_from_mes = - let applied_mes = - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC wf_arg]) in - Constrexpr_ops.mkLambdaC ([CAst.make @@ Name wf_arg],Constrexpr_ops.default_binder_kind,wf_arg_type,applied_mes) - in - let wf_rel_from_mes = - Constrexpr_ops.mkAppC(Constrexpr_ops.mkRefC ltof,[wf_arg_type;fun_from_mes]) - in - wf_rel_from_mes,true - | Some wf_rel_expr -> - let wf_rel_with_mes = - let a = Names.Id.of_string "___a" in - let b = Names.Id.of_string "___b" in - Constrexpr_ops.mkLambdaC( - [CAst.make @@ Name a; CAst.make @@ Name b], - Constrexpr.Default Explicit, - wf_arg_type, - Constrexpr_ops.mkAppC(wf_rel_expr, - [ - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC a]); - Constrexpr_ops.mkAppC(wf_mes_expr,[Constrexpr_ops.mkIdentC b]) - ]) - ) - in - wf_rel_with_mes,false - in - register_wf interactive_proof ~is_mes:is_mes fname rec_impls wf_rel_from_mes wf_arg - using_lemmas args ret_type body - -let map_option f = function - | None -> None - | Some v -> Some (f v) - -open Constrexpr - -let rec rebuild_bl aux bl typ = - match bl,typ with - | [], _ -> List.rev aux,typ - | (CLocalAssum(nal,bk,_))::bl',typ -> - rebuild_nal aux bk bl' nal typ - | (CLocalDef(na,_,_))::bl',{ CAst.v = CLetIn(_,nat,ty,typ') } -> - rebuild_bl (Constrexpr.CLocalDef(na,nat,ty)::aux) - bl' typ' - | _ -> assert false -and rebuild_nal aux bk bl' nal typ = - match nal,typ with - | _,{ CAst.v = CProdN([],typ) } -> rebuild_nal aux bk bl' nal typ - | [], _ -> rebuild_bl aux bl' typ - | na::nal,{ CAst.v = CProdN(CLocalAssum(na'::nal',bk',nal't)::rest,typ') } -> - if Name.equal (na.CAst.v) (na'.CAst.v) || Name.is_anonymous (na'.CAst.v) - then - let assum = CLocalAssum([na],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - nal - (CAst.make @@ CProdN(new_rest,typ')) - else - let assum = CLocalAssum([na'],bk,nal't) in - let new_rest = if nal' = [] then rest else (CLocalAssum(nal',bk',nal't)::rest) in - rebuild_nal - (assum::aux) - bk - bl' - (na::nal) - (CAst.make @@ CProdN(new_rest,typ')) - | _ -> - assert false - -let rebuild_bl aux bl typ = rebuild_bl aux bl typ - -let recompute_binder_list fixpoint_exprl = - let fixl = - List.map (fun fix -> Vernacexpr.{ - fix - with rec_order = ComFixpoint.adjust_rec_order ~structonly:false fix.binders fix.rec_order }) fixpoint_exprl in - let ((_,_,_,typel),_,ctx,_) = ComFixpoint.interp_fixpoint ~cofix:false fixl in - let constr_expr_typel = - with_full_print (List.map (fun c -> Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx) (EConstr.of_constr c))) typel in - let fixpoint_exprl_with_new_bl = - List.map2 (fun ({ Vernacexpr.binders } as fp) fix_typ -> - let binders, rtype = rebuild_bl [] binders fix_typ in - { fp with Vernacexpr.binders; rtype } - ) fixpoint_exprl constr_expr_typel + List.map2 + (fun c pat -> + ((None, ElimOnConstr (fun env sigma -> (sigma,(c,Tactypes.NoBindings)))), + (None,pat), None)) + (args@c_list) + encoded_pat_as_patlist in - fixpoint_exprl_with_new_bl - - -let do_generate_principle_aux pconstants on_error register_built interactive_proof - (fixpoint_exprl : Vernacexpr.fixpoint_expr list) : Lemmas.t option = - List.iter (fun { Vernacexpr.notations } -> - if not (List.is_empty notations) - then error "Function does not support notations for now") fixpoint_exprl; - let lemma, _is_struct = - match fixpoint_exprl with - | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs; binders; rtype; body_def } as fixpoint_expr = - match recompute_binder_list [fixpoint_expr] with - | [e] -> e - | _ -> assert false - in - let fixpoint_exprl = [fixpoint_expr] in - let body = match body_def with - | Some body -> body - | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let using_lemmas = [] in - let pre_hook pconstants = - generate_principle - (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs - true - in - if register_built - then register_wf interactive_proof fname rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false - else None, false - |[{ Vernacexpr.rec_order=Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs; binders; rtype; body_def} as fixpoint_expr = - match recompute_binder_list [fixpoint_expr] with - | [e] -> e - | _ -> assert false - in - let fixpoint_exprl = [fixpoint_expr] in - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let using_lemmas = [] in - let body = match body_def with - | Some body -> body - | None -> user_err ~hdr:"Function" (str "Body of Function must be given") in - let pre_hook pconstants = - generate_principle - (ref (Evd.from_env (Global.env ()))) - pconstants - on_error - true - register_built - fixpoint_exprl - recdefs - true - in - if register_built - then register_mes interactive_proof fname rec_impls wf_mes wf_rel_opt (map_option (fun x -> x.CAst.v) wf_x) using_lemmas binders rtype body pre_hook, true - else None, true - | _ -> - List.iter (function { Vernacexpr.rec_order } -> - match rec_order with - | Some { CAst.v = (Constrexpr.CMeasureRec _ | Constrexpr.CWfRec _) } -> - error - ("Cannot use mutual definition with well-founded recursion or measure") - | _ -> () - ) - fixpoint_exprl; - let fixpoint_exprl = recompute_binder_list fixpoint_exprl in - let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in - (* ok all the expressions are structural *) - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in - let is_rec = List.exists (is_rec fix_names) recdefs in - let lemma,evd,pconstants = - if register_built - then register_struct is_rec fixpoint_exprl - else None, Evd.from_env (Global.env ()), pconstants - in - let evd = ref evd in - generate_principle - (ref !evd) - pconstants - on_error - false - register_built - fixpoint_exprl - recdefs - interactive_proof - (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); - if register_built then - begin derive_inversion fix_names; end; - lemma, true + let princ' = Some (princ,bindings) in + let princ_vars = + List.fold_right + (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) + args + Id.Set.empty in - lemma - -let rec add_args id new_args = CAst.map (function - | CRef (qid,_) as b -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((None,qid,None),new_args) - else b - | CFix _ | CCoFix _ -> anomaly ~label:"add_args " (Pp.str "todo.") - | CProdN(nal,b1) -> - CProdN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLambdaN(nal,b1) -> - CLambdaN(List.map (function CLocalAssum (nal,k,b2) -> CLocalAssum (nal,k,add_args id new_args b2) - | CLocalDef (na,b1,t) -> CLocalDef (na,add_args id new_args b1,Option.map (add_args id new_args) t) - | CLocalPattern _ -> user_err (Pp.str "pattern with quote not allowed here.")) nal, - add_args id new_args b1) - | CLetIn(na,b1,t,b2) -> - CLetIn(na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) - | CAppExpl((pf,qid,us),exprl) -> - if qualid_is_ident qid && Id.equal (qualid_basename qid) id then - CAppExpl((pf,qid,us),new_args@(List.map (add_args id new_args) exprl)) - else CAppExpl((pf,qid,us),List.map (add_args id new_args) exprl) - | CApp((pf,b),bl) -> - CApp((pf,add_args id new_args b), - List.map (fun (e,o) -> add_args id new_args e,o) bl) - | CCases(sty,b_option,cel,cal) -> - CCases(sty,Option.map (add_args id new_args) b_option, - List.map (fun (b,na,b_option) -> - add_args id new_args b, - na, b_option) cel, - List.map CAst.(map (fun (cpl,e) -> (cpl,add_args id new_args e))) cal - ) - | CLetTuple(nal,(na,b_option),b1,b2) -> - CLetTuple(nal,(na,Option.map (add_args id new_args) b_option), - add_args id new_args b1, - add_args id new_args b2 - ) - - | CIf(b1,(na,b_option),b2,b3) -> - CIf(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 - ) - | CHole _ - | CPatVar _ - | CEvar _ - | CPrim _ - | CSort _ as b -> b - | CCast(b1,b2) -> - CCast(add_args id new_args b1, - Glob_ops.map_cast_type (add_args id new_args) b2) - | CRecord pars -> - CRecord (List.map (fun (e,o) -> e, add_args id new_args o) pars) - | CNotation _ -> anomaly ~label:"add_args " (Pp.str "CNotation.") - | CGeneralization _ -> anomaly ~label:"add_args " (Pp.str "CGeneralization.") - | CDelimiters _ -> anomaly ~label:"add_args " (Pp.str "CDelimiters.") - ) -exception Stop of Constrexpr.constr_expr - - -(* [chop_n_arrow n t] chops the [n] first arrows in [t] - Acts on Constrexpr.constr_expr -*) -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.CAst.v with - | Constrexpr.CProdN(nal_ta',t') -> (* If we have a forall, two results 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 - than the number we need to chop and then we return the new type - *) - begin - try - let new_n = - let rec aux (n:int) = function - [] -> n - | CLocalAssum(nal,k,t'')::nal_ta' -> - let nal_l = List.length nal in - if n >= nal_l - then - aux (n - nal_l) nal_ta' - else - let new_t' = CAst.make @@ - Constrexpr.CProdN( - CLocalAssum((snd (List.chop n nal)),k,t'')::nal_ta',t') - in - raise (Stop new_t') - | _ -> anomaly (Pp.str "Not enough products.") - in - aux n nal_ta' - in - chop_n_arrow new_n t' - with Stop t -> t - end - | _ -> anomaly (Pp.str "Not enough products.") - - -let rec get_args b t : Constrexpr.local_binder_expr list * - Constrexpr.constr_expr * Constrexpr.constr_expr = - match b.CAst.v with - | Constrexpr.CLambdaN (CLocalAssum(nal,k,ta) as d::rest, b') -> - begin - let n = List.length nal in - let nal_tas,b'',t'' = get_args (CAst.make ?loc:b.CAst.loc @@ Constrexpr.CLambdaN (rest,b')) (chop_n_arrow n t) in - d :: nal_tas, b'',t'' - end - | Constrexpr.CLambdaN ([], b) -> [],b,t - | _ -> [],b,t - - -let make_graph (f_ref : GlobRef.t) = - let env = Global.env() in - let sigma = Evd.from_env env in - let c,c_body = - match f_ref with - | GlobRef.ConstRef c -> - begin try c,Global.lookup_constant c - with Not_found -> - raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr_env env sigma (mkConst c)) ) - end - | _ -> raise (UserError (None, str "Not a function reference") ) + let old_idl = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in + let old_idl = Id.Set.diff old_idl princ_vars in + let subst_and_reduce gl = + if with_clean + then + let idl = List.filter (fun id -> not (Id.Set.mem id old_idl))(pf_ids_of_hyps gl) in + let flag = Genredexpr.Cbv { Redops.all_flags with Genredexpr.rDelta = false } in + tclTHEN + (tclMAP (fun id -> tclTRY (Equality.subst_gen (do_rewrite_dependent ()) [id])) idl) + (reduce flag Locusops.allHypsAndConcl) + else tclIDTAC in - (match Global.body_of_constant_body Library.indirect_accessor c_body with - | None -> error "Cannot build a graph over an axiom!" - | Some (body, _, _) -> - let env = Global.env () in - let extern_body,extern_type = - with_full_print (fun () -> - (Constrextern.extern_constr false env sigma (EConstr.of_constr body), - Constrextern.extern_type false env sigma - (EConstr.of_constr (*FIXME*) c_body.const_type) - ) - ) () - in - let (nal_tas,b,t) = get_args extern_body extern_type in - let expr_list = - match b.CAst.v with - | Constrexpr.CFix(l_id,fixexprl) -> - let l = - List.map - (fun (id,recexp,bl,t,b) -> - let { CAst.loc; v=rec_id } = match Option.get recexp with - | { CAst.v = CStructRec id } -> id - | { CAst.v = CWfRec (id,_) } -> id - | { CAst.v = CMeasureRec (oid,_,_) } -> Option.get oid - in - let new_args = - List.flatten - (List.map - (function - | Constrexpr.CLocalDef (na,_,_)-> [] - | Constrexpr.CLocalAssum (nal,_,_) -> - List.map - (fun {CAst.loc;v=n} -> CAst.make ?loc @@ - CRef(Libnames.qualid_of_ident ?loc @@ Nameops.Name.get_id n,None)) - nal - | Constrexpr.CLocalPattern _ -> assert false - ) - nal_tas - ) - in - let b' = add_args id.CAst.v new_args b in - { Vernacexpr.fname=id; univs=None - ; rec_order = Some (CAst.make (CStructRec (CAst.make rec_id))) - ; binders = nal_tas@bl; rtype=t; body_def=Some b'; notations = []} - ) fixexprl in - l - | _ -> - let fname = CAst.make (Label.to_id (Constant.label c)) in - [{ Vernacexpr.fname; univs=None; rec_order = None; binders=nal_tas; rtype=t; body_def=Some b; notations=[]}] - in - let mp = Constant.modpath c in - let pstate = do_generate_principle_aux [c,Univ.Instance.empty] error_error false false expr_list in - assert (Option.is_empty pstate); - (* We register the infos *) - List.iter - (fun { Vernacexpr.fname= {CAst.v=id} } -> - add_Function false (Constant.make2 mp (Label.of_id id))) - expr_list) - -(* *************** statically typed entrypoints ************************* *) - -let do_generate_principle_interactive fixl : Lemmas.t = - match - do_generate_principle_aux [] warning_error true true fixl - with - | Some lemma -> lemma - | None -> - CErrors.anomaly - (Pp.str"indfun: leaving no open proof in interactive mode") - -let do_generate_principle fixl : unit = - match do_generate_principle_aux [] warning_error true false fixl with - | Some _lemma -> - CErrors.anomaly - (Pp.str"indfun: leaving a goal open in non-interactive mode") - | None -> () + tclTHEN + (choose_dest_or_ind + princ_infos + (args_as_induction_constr,princ')) + (Proofview.Goal.enter subst_and_reduce)) diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index bfc9686ae5..476d74b3f8 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -1,19 +1,16 @@ -open Names -open Tactypes +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) -val warn_cannot_define_graph : ?loc:Loc.t -> Pp.t * Pp.t -> unit - -val warn_cannot_define_principle : ?loc:Loc.t -> Pp.t * Pp.t -> unit - -val do_generate_principle : Vernacexpr.fixpoint_expr list -> unit - -val do_generate_principle_interactive : Vernacexpr.fixpoint_expr list -> Lemmas.t - -val functional_induction : - bool -> - EConstr.constr -> - (EConstr.constr * EConstr.constr bindings) option -> - Ltac_plugin.Tacexpr.or_and_intro_pattern option -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma - -val make_graph : GlobRef.t -> unit +val functional_induction + : bool + -> EConstr.constr + -> (EConstr.constr * EConstr.constr Tactypes.bindings) option + -> Ltac_plugin.Tacexpr.or_and_intro_pattern option + -> unit Proofview.tactic diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index a119586f7b..80fc64fe65 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -10,8 +10,7 @@ let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" -let msgnl m = - () +let msgnl m = () let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) @@ -41,7 +40,9 @@ let locate_constant ref = let locate_with_msg msg f x = try f x - with Not_found -> raise (CErrors.UserError(None, msg)) + with + | Not_found -> + CErrors.user_err msg let filter_map filter f = @@ -65,8 +66,7 @@ let chop_rlambda_n = | Glob_term.GLambda(name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b | Glob_term.GLetIn(name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b | _ -> - raise (CErrors.UserError(Some "chop_rlambda_n", - str "chop_rlambda_n: Not enough Lambdas")) + CErrors.user_err ~hdr:"chop_rlambda_n" (str "chop_rlambda_n: Not enough Lambdas") in chop_lambda_n [] @@ -77,7 +77,8 @@ let chop_rprod_n = else match DAst.get rt with | Glob_term.GProd(name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> raise (CErrors.UserError(Some "chop_rprod_n",str "chop_rprod_n: Not enough products")) + | _ -> + CErrors.user_err ~hdr:"chop_rprod_n" (str "chop_rprod_n: Not enough products") in chop_prod_n [] @@ -93,13 +94,6 @@ 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 = qualid_of_ident id in - try Constrintern.locate_reference princ_ref - with Not_found -> - CErrors.user_err ~hdr:"IndFun.const_of_id" - (str "cannot find " ++ Id.print id) - [@@@ocaml.warning "-3"] let coq_constant s = UnivGen.constr_of_monomorphic_global @@ @@ -113,29 +107,6 @@ let find_reference sl s = let eq = lazy(EConstr.of_constr (coq_constant "eq")) let refl_equal = lazy(EConstr.of_constr (coq_constant "eq_refl")) -(*****************************************************************) -(* Copy of the standard save mechanism but without the much too *) -(* slow reduction function *) -(*****************************************************************) -open Declare -open DeclareDef - -let definition_message = Declare.definition_message - -let save name const ?hook uctx scope kind = - let fix_exn = Future.fix_exn_of const.Proof_global.proof_entry_body in - let r = match scope with - | Discharge -> - let c = SectionLocalDef const in - let () = declare_variable ~name ~kind c in - GlobRef.VarRef name - | Global local -> - let kn = declare_constant ~name ~kind ~local (DefinitionEntry const) in - GlobRef.ConstRef kn - in - DeclareDef.Hook.(call ?hook ~fix_exn { S.uctx; obls = []; scope; dref = r }); - definition_message name - let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () @@ -302,20 +273,16 @@ let find_or_none id = ) with Not_found -> None - - let find_Function_infos f = - Cmap_env.find f !from_function - + Cmap_env.find_opt f !from_function let find_Function_of_graph ind = - Indmap.find ind !from_graph + Indmap.find_opt ind !from_graph 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 = Label.to_id (Constant.label f) in let equation_lemma = find_or_none (mk_equation_id f_id) @@ -378,7 +345,73 @@ let () = declare_bool_option function_debug_sig let do_observe () = !function_debug +let observe strm = + if do_observe () + then Feedback.msg_debug strm + else () + +let debug_queue = Stack.create () + +let print_debug_queue b e = + if not (Stack.is_empty debug_queue) + then + let lmsg,goal = Stack.pop debug_queue in + (if b then + Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) + else + Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)) + (* print_debug_queue false e; *) + ) +let do_observe_tac s tac g = + let goal = Printer.pr_goal g in + let s = s (pf_env g) (project g) in + let lmsg = (str "observation : ") ++ s in + Stack.push (lmsg,goal) debug_queue; + try + let v = tac g in + ignore(Stack.pop debug_queue); + v + with reraise -> + let reraise = CErrors.push reraise in + if not (Stack.is_empty debug_queue) + then print_debug_queue true (fst reraise); + Util.iraise reraise + +let observe_tac s tac g = + if do_observe () + then do_observe_tac s tac g + else tac g + +module New = struct + +let do_observe_tac ~header s tac = + let open Proofview.Notations in + let open Proofview in + Goal.enter begin fun gl -> + let goal = Printer.pr_goal (Goal.print gl) in + let env, sigma = Goal.env gl, Goal.sigma gl in + let s = s env sigma in + let lmsg = seq [header; str " : " ++ s] in + tclLIFT (NonLogical.make (fun () -> + Feedback.msg_debug (s++fnl()))) >>= fun () -> + tclOR ( + Stack.push (lmsg, goal) debug_queue; + tac >>= fun v -> + ignore(Stack.pop debug_queue); + Proofview.tclUNIT v) + (fun (exn, info) -> + if not (Stack.is_empty debug_queue) + then print_debug_queue true exn; + tclZERO ~info exn) + end + +let observe_tac ~header s tac = + if do_observe () + then do_observe_tac ~header s tac + else tac + +end let strict_tcc = ref false let is_strict_tcc () = !strict_tcc @@ -430,6 +463,10 @@ let well_founded_ltof () = EConstr.of_constr @@ UnivGen.constr_of_monomorphic_gl let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") +let make_eq () = + try EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) + with _ -> assert false + let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) match r with GlobRef.ConstRef sp -> EvalConstRef sp diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index a95b1242ac..cd5202a6c7 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -38,18 +38,9 @@ val chop_rprod_n : int -> Glob_term.glob_constr -> val eq : EConstr.constr Lazy.t val refl_equal : EConstr.constr Lazy.t -val const_of_id: Id.t -> GlobRef.t(* constantyes *) val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr - -val save - : Id.t - -> Evd.side_effects Proof_global.proof_entry - -> ?hook:DeclareDef.Hook.t - -> UState.t - -> DeclareDef.locality - -> Decls.logical_kind - -> unit +val make_eq : unit -> EConstr.constr (* [with_full_print f a] applies [f] to [a] in full printing environment. @@ -74,8 +65,8 @@ type function_info = is_general : bool; } -val find_Function_infos : Constant.t -> function_info -val find_Function_of_graph : inductive -> function_info +val find_Function_infos : Constant.t -> function_info option +val find_Function_of_graph : inductive -> function_info option (* WARNING: To be used just after the graph definition !!! *) val add_Function : bool -> Constant.t -> unit val update_Function : function_info -> unit @@ -84,7 +75,21 @@ val update_Function : function_info -> unit val pr_info : Environ.env -> Evd.evar_map -> function_info -> Pp.t val pr_table : Environ.env -> Evd.evar_map -> Pp.t +val observe_tac + : (Environ.env -> Evd.evar_map -> Pp.t) + -> Tacmach.tactic -> Tacmach.tactic + +module New : sig + + val observe_tac + : header:Pp.t + -> (Environ.env -> Evd.evar_map -> Pp.t) + -> unit Proofview.tactic -> unit Proofview.tactic + +end + (* val function_debug : bool ref *) +val observe : Pp.t -> unit val do_observe : unit -> bool val do_rewrite_dependent : unit -> bool diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index f6b5a06cac..d72319d078 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -8,880 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Ltac_plugin -open Declarations -open CErrors open Util open Names -open Term open Constr -open Context open EConstr -open Vars -open Pp -open Tacticals +open Tacmach.New open Tactics -open Indfun_common -open Tacmach -open Tactypes -open Termops -open Context.Rel.Declaration - -module RelDecl = Context.Rel.Declaration - -(* The local debugging mechanism *) -(* let msgnl = Pp.msgnl *) - -let observe strm = - if do_observe () - then Feedback.msg_debug strm - else () - -(*let observennl strm = - if do_observe () - then begin Pp.msg strm;Pp.pp_flush () end - else ()*) - - -let do_observe_tac s tac g = - let goal = - try Printer.pr_goal g - with e when CErrors.noncritical e -> assert false - in - try - let v = tac g in - msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v - with reraise -> - let reraise = CErrors.push reraise in - observe (hov 0 (str "observation "++ s++str " raised exception " ++ - CErrors.iprint reraise ++ str " on goal" ++ fnl() ++ goal )); - iraise reraise;; - -let observe_tac s tac g = - if do_observe () - then do_observe_tac (str s) tac g - else tac g - -let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl - -(* (\* [id_to_constr id] finds the term associated to [id] in the global environment *\) *) -(* let id_to_constr id = *) -(* try *) -(* Constrintern.global_reference id *) -(* with Not_found -> *) -(* raise (UserError ("",str "Cannot find " ++ Ppconstr.pr_id id)) *) - - -let make_eq () = - try - EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref "core.eq.type")) - with _ -> assert false - -(* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] - (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. - - [generate_type true f i] returns - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, - graph\ x_1\ldots x_n\ res \rightarrow res = fv \] decomposed as the context and the conclusion - - [generate_type false f i] returns - \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, - res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion - *) - -let generate_type evd 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 evd',graph = - Evd.fresh_global (Global.env ()) !evd (GlobRef.IndRef (fst (destInd !evd graph))) - in - evd:=evd'; - let sigma, graph_arity = Typing.type_of (Global.env ()) !evd graph in - evd := sigma; - let ctxt,_ = decompose_prod_assum !evd graph_arity in - let fun_ctxt,res_type = - match ctxt with - | [] | [_] -> anomaly (Pp.str "Not a valid context.") - | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl - in - let rec args_from_decl i accu = function - | [] -> accu - | LocalDef _ :: l -> - args_from_decl (succ i) accu l - | _ :: l -> - let t = mkRel i in - args_from_decl (succ i) (t :: accu) l - in - (*i We need to name the vars [res] and [fv] i*) - let filter = fun decl -> match RelDecl.get_name decl with - | Name id -> Some id - | Anonymous -> None - in - let named_ctxt = Id.Set.of_list (List.map_filter filter fun_ctxt) in - let res_id = Namegen.next_ident_away_in_goal (Id.of_string "_res") named_ctxt in - let fv_id = Namegen.next_ident_away_in_goal (Id.of_string "fv") (Id.Set.add res_id named_ctxt) in - (*i we can then type the argument to be applied to the function [f] i*) - let args_as_rels = Array.of_list (args_from_decl 1 [] fun_ctxt) in - (*i - the hypothesis [res = fv] can then be computed - We will need to lift it by one in order to use it as a conclusion - i*) - let make_eq = make_eq () - in - let res_eq_f_of_args = - mkApp(make_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 args_and_res_as_rels = Array.of_list (args_from_decl 3 [] fun_ctxt) in - let args_and_res_as_rels = Array.append args_and_res_as_rels [|mkRel 1|] in - let graph_applied = 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 = - LocalAssum (make_annot (Name res_id) Sorts.Relevant, lift 1 res_type) :: - LocalDef (make_annot (Name fv_id) Sorts.Relevant, mkApp (f,args_as_rels), res_type) :: fun_ctxt - in - (*i and we can return the solution depending on which lemma type we are defining i*) - if g_to_f - then LocalAssum (make_annot Anonymous Sorts.Relevant,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else LocalAssum (make_annot Anonymous Sorts.Relevant,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph - - -(* - [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 evd f = - let f_as_constant,u = match EConstr.kind !evd f with - | Const c' -> c' - | _ -> user_err Pp.(str "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 evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (GlobRef.ConstRef rect_lemma) in - let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in - evd:=evd'; - rect_lemma,typ - - -let rec generate_fresh_id x avoid i = - if i == 0 - then [] - else - let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in - id::(generate_fresh_id x (id::avoid) (pred i)) - - -(* [prove_fun_correct funs_constr graphs_constr schemes lemmas_types_infos i ] - is the tactic used to prove correctness lemma. - - [funs_constr], [graphs_constr] [schemes] [lemmas_types_infos] are the mutually recursive functions - (resp. graphs of the functions and principles and correctness lemma types) to prove correct. - - [i] is the indice of the function to prove correct - - The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is - it looks like~: - [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, - res = f x_1\ldots x_n in, \rightarrow graph\ x_1\ldots x_n\ res] - - - The sketch of the proof is the following one~: - \begin{enumerate} - \item intros until $x_n$ - \item $functional\ induction\ (f.(i)\ x_1\ldots x_n)$ using schemes.(i) - \item for each generated branch intro [res] and [hres :res = f x_1\ldots x_n], rewrite [hres] and the - apply the corresponding constructor of the corresponding graph inductive. - \end{enumerate} - -*) -let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = - fun g -> - (* first of all we recreate the lemmas types to be used as predicates of the induction principle - that is~: - \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] - *) - (* we the get the definition of the graphs block *) - let graph_ind,u = destInd evd graphs_constr.(i) in - let kn = fst graph_ind in - let mib,_ = Global.lookup_inductive graph_ind in - (* and the principle to use in this lemma in $\zeta$ normal form *) - let f_principle,princ_type = schemes.(i) in - let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in - let princ_infos = Tactics.compute_elim_sig evd princ_type in - (* The number of args of the function is then easily computable *) - let nb_fun_args = nb_prod (project g) (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 functional principle is defined in the - environment and due to the bug #1174, we will need to pose the principle - using a name - *) - let principle_id = Namegen.next_ident_away_in_goal (Id.of_string "princ") (Id.Set.of_list ids) in - let ids = principle_id :: ids in - (* We get the branches of the principle *) - let branches = List.rev princ_infos.branches in - (* and built the intro pattern for each of them *) - let intro_pats = - List.map - (fun decl -> - List.map - (fun id -> CAst.make @@ IntroNaming (Namegen.IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) - ) - branches - in - (* before building the full intro pattern for the principle *) - let eq_ind = make_eq () in - let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in - (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 - and min_constr_number = ref 0 in - (* The tactic to prove the ith branch of the principle *) - let prove_branche i g = - (* We get the identifiers of this branch *) - let pre_args = - List.fold_right - (fun {CAst.v=pat} acc -> - match pat with - | IntroNaming (Namegen.IntroIdentifier id) -> id::acc - | _ -> anomaly (Pp.str "Not an identifier.") - ) - (List.nth intro_pats (pred i)) - [] - in - (* and get the real args of the branch by unfolding the defined constant *) - (* - We can then recompute the arguments of the constructor. - For each [hid] introduced by this branch, if [hid] has type - $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are - [ fv (hid fv (refl_equal fv)) ]. - If [hid] has another type the corresponding argument of the constructor is [hid] - *) - let constructor_args g = - List.fold_right - (fun hid acc -> - let type_of_hid = pf_unsafe_type_of g (mkVar hid) in - let sigma = project g in - match EConstr.kind sigma type_of_hid with - | Prod(_,_,t') -> - begin - match EConstr.kind sigma t' with - | Prod(_,t'',t''') -> - begin - match EConstr.kind sigma t'',EConstr.kind sigma t''' with - | App(eq,args), App(graph',_) - when - (EConstr.eq_constr sigma eq eq_ind) && - Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> - (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) - ::acc) - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - end - | _ -> mkVar hid :: acc - ) pre_args [] - in - (* in fact we must also add the parameters to the constructor args *) - let constructor_args g = - let params_id = fst (List.chop princ_infos.nparams args_names) in - (List.map mkVar params_id)@((constructor_args g)) - in - (* We then get the constructor corresponding to this branch and - modifies the references has needed i.e. - if the constructor is the last one of the current inductive then - add one the number of the inductive to take and add the number of constructor of the previous - graph to the minimal constructor number - *) - let constructor = - let constructor_num = i - !min_constr_number in - let length = Array.length (mib.Declarations.mind_packets.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then - begin - (kn,!ind_number),constructor_num - end - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length ; - (kn,!ind_number),1 - end - in - (* we can then build the final proof term *) - let app_constructor g = applist((mkConstructU(constructor,u)),constructor_args g) in - (* an apply the tactic *) - let res,hres = - match generate_fresh_id (Id.of_string "z") (ids(* @this_branche_ids *)) 2 with - | [res;hres] -> res,hres - | _ -> assert false - in - (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) - ( - tclTHENLIST - [ - observe_tac("h_intro_patterns ") (let l = (List.nth intro_pats (pred i)) in - match l with - | [] -> tclIDTAC - | _ -> Proofview.V82.of_tactic (intro_patterns false l)); - (* unfolding of all the defined variables introduced by this branch *) - (* observe_tac "unfolding" pre_tac; *) - (* $zeta$ normalizing of the conclusion *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - { Redops.all_flags with - Genredexpr.rDelta = false ; - Genredexpr.rConst = [] - } - ) - Locusops.onConcl); - observe_tac ("toto ") tclIDTAC; - - (* introducing the result of the graph and the equality hypothesis *) - observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); - (* replacing [res] with its value *) - observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); - (* Conclusion *) - observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) - ] - ) - g - in - (* end of branche proof *) - let lemmas = - Array.map - (fun ((_,(ctxt,concl))) -> - match ctxt with - | [] | [_] | [_;_] -> anomaly (Pp.str "bad context.") - | hres::res::decl::ctxt -> - let res = EConstr.it_mkLambda_or_LetIn - (EConstr.it_mkProd_or_LetIn concl [hres;res]) - (LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) :: ctxt) - in - res) - lemmas_types_infos - in - let param_names = fst (List.chop princ_infos.nparams args_names) in - let params = List.map mkVar param_names in - let lemmas = Array.to_list (Array.map (fun c -> applist(c,params)) lemmas) in - (* The bindings of the principle - that is the params of the principle and the different lemma types - *) - let bindings = - let params_bindings,avoid = - List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - p::bindings,id::avoid - ) - ([],pf_ids_of_hyps g) - princ_infos.params - (List.rev params) - in - let lemmas_bindings = - List.rev (fst (List.fold_left2 - (fun (bindings,avoid) decl p -> - let id = Namegen.next_ident_away (Nameops.Name.get_id (RelDecl.get_name decl)) (Id.Set.of_list avoid) in - (Reductionops.nf_zeta (pf_env g) (project g) p)::bindings,id::avoid) - ([],avoid) - princ_infos.predicates - (lemmas))) - in - (params_bindings@lemmas_bindings) - in - tclTHENLIST - [ - observe_tac "principle" (Proofview.V82.of_tactic (assert_by - (Name principle_id) - princ_type - (exact_check f_principle))); - observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); - (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) - observe_tac "idtac" tclIDTAC; - tclTHEN_i - (observe_tac - "functional_induction" ( - (fun gl -> - let term = mkApp (mkVar principle_id,Array.of_list bindings) in - let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in - Proofview.V82.of_tactic (apply term) gl') - )) - (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) - ] - g - - +open Tacticals.New - -(* [generalize_dependent_of x hyp g] - generalize every hypothesis which depends of [x] but [hyp] -*) -let generalize_dependent_of x hyp g = - let open Context.Named.Declaration in - tclMAP - (function - | LocalAssum ({binder_name=id},t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) - | _ -> tclIDTAC - ) - (pf_hyps g) - g - - -(* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis - (unfolding, substituting, destructing cases \ldots) - *) -let tauto = - let dp = List.map Id.of_string ["Tauto" ; "Init"; "Coq"] in - let mp = ModPath.MPfile (DirPath.make dp) in - let kn = KerName.make mp (Label.make "tauto") in - Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> - let body = Tacenv.interp_ltac kn in - Tacinterp.eval_tactic body - end - -let rec intros_with_rewrite g = - observe_tac "intros_with_rewrite" intros_with_rewrite_aux g -and intros_with_rewrite_aux : Tacmach.tactic = - fun g -> - let eq_ind = make_eq () in - let sigma = project g in - match EConstr.kind sigma (pf_concl g) with - | Prod(_,t,t') -> - begin - match EConstr.kind sigma t with - | App(eq,args) when (EConstr.eq_constr sigma 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 - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g - else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) - then tclTHENLIST[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) - (pf_ids_of_hyps g); - intros_with_rewrite - ] g - else if isVar sigma args.(1) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(1)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] - g - else if isVar sigma args.(2) - then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar sigma args.(2)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); - intros_with_rewrite - ] - g - else - begin - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST[ - Proofview.V82.of_tactic (Simple.intro id); - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); - intros_with_rewrite - ] g - end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.False.type")) -> - Proofview.V82.of_tactic tauto g - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - intros_with_rewrite - ] g - | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g - | _ -> - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST [ Proofview.V82.of_tactic (Simple.intro id);intros_with_rewrite] g - end - | LetIn _ -> - tclTHENLIST[ - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - intros_with_rewrite - ] g - | _ -> tclIDTAC g - -let rec reflexivity_with_destruct_cases g = - let destruct_case () = - try - match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with - | Case(_,_,v,_) -> - tclTHENLIST[ - Proofview.V82.of_tactic (simplest_case v); - Proofview.V82.of_tactic intros; - observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases - ] - | _ -> Proofview.V82.of_tactic reflexivity - with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity - in - let eq_ind = make_eq () in - let my_inj_flags = Some { - Equality.keep_proof_equalities = false; - injection_in_context = false; (* for compatibility, necessary *) - injection_pattern_l2r_order = false; (* probably does not matter; except maybe with dependent hyps *) - } in - let discr_inject = - Tacticals.onAllHypsAndConcl ( - fun sc g -> - match sc with - None -> tclIDTAC g - | Some id -> - match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with - | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) t1 t2 - then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 - then tclTHENLIST [Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id);thin [id];intros_with_rewrite] g - else tclIDTAC g - | _ -> tclIDTAC g - ) - in - (tclFIRST - [ observe_tac "reflexivity_with_destruct_cases : reflexivity" (Proofview.V82.of_tactic reflexivity); - observe_tac "reflexivity_with_destruct_cases : destruct_case" ((destruct_case ())); - (* 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, - either at least an injectable one and we do the injection before continuing - *) - observe_tac "reflexivity_with_destruct_cases : others" (tclTHEN (tclPROGRESS discr_inject ) reflexivity_with_destruct_cases) - ]) - g - - -(* [prove_fun_complete funs graphs schemes lemmas_types_infos i] - is the tactic used to prove completeness lemma. - - [funcs], [graphs] [schemes] [lemmas_types_infos] are the mutually recursive functions - (resp. definitions of the graphs of the functions, principles and correctness lemma types) to prove correct. - - [i] is the indice of the function to prove complete - - The lemma to prove if suppose to have been generated by [generate_type] (in $\zeta$ normal form that is - it looks like~: - [\forall (x_1:t_1)\ldots(x_n:t_n), forall res, - graph\ x_1\ldots x_n\ res, \rightarrow res = f x_1\ldots x_n in] - - - The sketch of the proof is the following one~: - \begin{enumerate} - \item intros until $H:graph\ x_1\ldots x_n\ res$ - \item $elim\ H$ using schemes.(i) - \item for each generated branch, intro the news hyptohesis, for each such hyptohesis [h], if [h] has - type [x=?] with [x] a variable, then subst [x], - if [h] has type [t=?] with [t] not a variable then rewrite [t] in the subterms, else - if [h] is a match then destruct it, else do just introduce it, - after all intros, the conclusion should be a reflexive equality. - \end{enumerate} - -*) - - -let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tactic = - fun g -> - (* We compute the types of the different mutually recursive lemmas - in $\zeta$ normal form - *) - let lemmas = - Array.map - (fun (_,(ctxt,concl)) -> Reductionops.nf_zeta (pf_env g) (project g) (EConstr.it_mkLambda_or_LetIn 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 = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in - let princ_type = pf_unsafe_type_of g graph_principle in - let princ_infos = Tactics.compute_elim_sig (project g) 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 (project g) (pf_concl g) - 2 in - let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names@(pf_ids_of_hyps g) in - (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res,hres,graph_principle_id = - match generate_fresh_id (Id.of_string "z") ids 3 with - | [res;hres;graph_principle_id] -> res,hres,graph_principle_id - | _ -> assert false - in - let ids = res::hres::graph_principle_id::ids in - (* we also compute fresh names for each hyptohesis of each branch - of the principle *) - let branches = List.rev princ_infos.branches in - let intro_pats = - List.map - (fun decl -> - List.map - (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod (project g) (RelDecl.get_type decl))) - ) - 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 - *) - let rewrite_tac j ids : Tacmach.tactic = - let graph_def = graphs.(j) in - let infos = - try find_Function_infos (fst (destConst (project g) funcs.(j))) - with Not_found -> user_err Pp.(str "No graph found") - in - if infos.is_general - || Rtree.is_infinite Declareops.eq_recarg graph_def.mind_recargs - then - let eq_lemma = - try Option.get (infos).equation_lemma - with Option.IsNone -> anomaly (Pp.str "Cannot find equation lemma.") - in - tclTHENLIST[ - tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); - (* Don't forget to $\zeta$ normlize the term since the principles - have been $\zeta$-normalized *) - Proofview.V82.of_tactic (reduce - (Genredexpr.Cbv - {Redops.all_flags - with Genredexpr.rDelta = false; - }) - Locusops.onConcl) - ; - Proofview.V82.of_tactic (generalize (List.map mkVar ids)); - thin ids - ] - else - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) - in - (* The proof of each branche itself *) - let ind_number = ref 0 in - let min_constr_number = ref 0 in - let prove_branche i g = - (* we fist compute the inductive corresponding to the branch *) - let this_ind_number = - let constructor_num = i - !min_constr_number in - let length = Array.length (graphs.(!ind_number).Declarations.mind_consnames) in - if constructor_num <= length - then !ind_number - else - begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end - in - let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENLIST[ - (* we expand the definition of the function *) - observe_tac "rewrite_tac" (rewrite_tac this_ind_number this_branche_ids); - (* introduce hypothesis with some rewrite *) - observe_tac "intros_with_rewrite (all)" intros_with_rewrite; - (* The proof is (almost) complete *) - observe_tac "reflexivity" (reflexivity_with_destruct_cases) - ] - g - in - let params_names = fst (List.chop princ_infos.nparams args_names) in - let open EConstr in - let params = List.map mkVar params_names in - tclTHENLIST - [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); - observe_tac "h_generalize" - (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); - Proofview.V82.of_tactic (Simple.intro graph_principle_id); - observe_tac "" (tclTHEN_i - (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) - ] - g - - -(* [derive_correctness make_scheme funs graphs] create correctness and completeness - lemmas for each function in [funs] w.r.t. [graphs] -*) - -let derive_correctness (funs: pconstant list) (graphs:inductive list) = - assert (funs <> []); - assert (graphs <> []); - let funs = Array.of_list funs and graphs = Array.of_list graphs in - let map (c, u) = mkConstU (c, EInstance.make u) in - let funs_constr = Array.map map funs in - (* XXX STATE Why do we need this... why is the toplevel protection not enough *) - funind_purify - (fun () -> - let env = Global.env () in - let evd = ref (Evd.from_env env) in - 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,u = destConst f_constr in *) - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd false f_constr graph i - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let sigma, _ = Typing.type_of (Global.env ()) !evd type_of_lemma in - evd := sigma; - let type_of_lemma = Reductionops.nf_zeta (Global.env ()) !evd type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - let schemes = - (* The functional induction schemes are computed and not saved if there is more that one function - if the block contains only one function we can safely reuse [f_rect] - *) - try - if not (Int.equal (Array.length funs_constr) 1) then raise Not_found; - [| find_induction_principle evd funs_constr.(0) |] - with Not_found -> - ( - - Array.of_list - (List.map - (fun entry -> - (EConstr.of_constr (fst (fst(Future.force entry.Proof_global.proof_entry_body))), EConstr.of_constr (Option.get entry.Proof_global.proof_entry_type )) - ) - (Functional_principles_types.make_scheme evd (Array.map_to_list (fun const -> const,Sorts.InType) funs)) - ) - ) - in - let proving_tac = - prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_correct_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_correct_id f_id in - let (typ,_) = lemmas_types_infos.(i) in - let info = Lemmas.Info.make - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:(Decls.(IsProof Theorem)) () in - let lemma = Lemmas.start_lemma - ~name:lem_id - ~poly:false - ~info - !evd - typ in - let lemma = fst @@ Lemmas.by - (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") - (proving_tac i))) lemma in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = find_Function_infos (fst f_as_constant) in - (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst !evd lem_cst_constr in - update_Function {finfo with correctness_lemma = Some lem_cst}; - - ) - funs; - let lemmas_types_infos = - Util.Array.map2_i - (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd true f_constr graph i - in - let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in - graphs_constr.(i) <- graph; - let type_of_lemma = - EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt - in - let type_of_lemma = Reductionops.nf_zeta env !evd type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env env !evd type_of_lemma); - type_of_lemma,type_info - ) - funs_constr - graphs_constr - in - - let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in - let mib,mip = Global.lookup_inductive graph_ind in - let sigma, scheme = - (Indrec.build_mutual_induction_scheme (Global.env ()) !evd - (Array.to_list - (Array.mapi - (fun i _ -> ((kn,i), EInstance.kind !evd u),true,InType) - mib.Declarations.mind_packets - ) - ) - ) - in - let schemes = - Array.of_list scheme - in - let proving_tac = - prove_fun_complete funs_constr mib.Declarations.mind_packets schemes lemmas_types_infos - in - Array.iteri - (fun i f_as_constant -> - let f_id = Label.to_id (Constant.label (fst f_as_constant)) in - (*i The next call to mk_complete_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - let lem_id = mk_complete_id f_id in - let info = Lemmas.Info.make - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsProof Theorem) () in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false ~info - sigma (fst lemmas_types_infos.(i)) in - let lemma = fst (Lemmas.by - (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") - (proving_tac i))) lemma) in - let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in - let finfo = find_Function_infos (fst f_as_constant) in - let _,lem_cst_constr = Evd.fresh_global - (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst !evd lem_cst_constr in - update_Function {finfo with completeness_lemma = Some lem_cst} - ) - funs) - () +open Indfun_common (***********************************************) @@ -891,38 +26,36 @@ let derive_correctness (funs: pconstant list) (graphs:inductive list) = 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 sigma = project g in - let typ = pf_unsafe_type_of g (mkVar hid) in - match EConstr.kind sigma typ with - | App(i,args) when isInd sigma i -> - let ((kn',num) as ind'),u = destInd sigma i in - if MutInd.equal kn kn' - then (* We have generated a graph hypothesis so that we must change it if we can *) - let info = - try find_Function_of_graph ind' - with Not_found -> (* The graphs are mutually recursive but we cannot find one of them !*) - anomaly (Pp.str "Cannot retrieve infos about a mutual block.") - in - (* if we can find a completeness lemma for this function - then we can come back to the functional form. If not, we do nothing - *) - match info.completeness_lemma with - | None -> tclIDTAC g - | Some f_complete -> - let f_args,res = Array.chop (Array.length args - 1) args in - tclTHENLIST - [ - Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]); - thin [hid]; - Proofview.V82.of_tactic (Simple.intro hid); - post_tac hid - ] - g - - else tclIDTAC g - | _ -> tclIDTAC g - +let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> + let sigma = project gl in + let typ = pf_unsafe_type_of gl (mkVar hid) in + match EConstr.kind sigma typ with + | App(i,args) when isInd sigma i -> + let ((kn',num) as ind'),u = destInd sigma i in + if MutInd.equal kn kn' + then (* We have generated a graph hypothesis so that we must change it if we can *) + let info = match find_Function_of_graph ind' with + | Some info -> info + | None -> + (* The graphs are mutually recursive but we cannot find one of them !*) + CErrors.anomaly (Pp.str "Cannot retrieve infos about a mutual block.") + in + (* if we can find a completeness lemma for this function + then we can come back to the functional form. If not, we do nothing + *) + match info.completeness_lemma with + | None -> tclIDTAC + | Some f_complete -> + let f_args,res = Array.chop (Array.length args - 1) args in + tclTHENLIST + [ generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])] + ; clear [hid] + ; Simple.intro hid + ; post_tac hid + ] + else tclIDTAC + | _ -> tclIDTAC + ) (* [functional_inversion hid fconst f_correct ] is the functional version of [inversion] @@ -941,101 +74,95 @@ let revert_graph kn post_tac hid g = \end{enumerate} *) -let functional_inversion kn hid fconst f_correct : Tacmach.tactic = - fun g -> - let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in - let sigma = project g in - let type_of_h = pf_unsafe_type_of g (mkVar hid) in - match EConstr.kind sigma type_of_h with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - let pre_tac,f_args,res = - match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with - | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> - ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2)) - |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> - ((fun hid -> tclIDTAC),f_args,args.(1)) - | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) - in - tclTHENLIST [ - pre_tac hid; - Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]); - thin [hid]; - Proofview.V82.of_tactic (Simple.intro hid); - Proofview.V82.of_tactic (Inv.inv Inv.FullInversion None (NamedHyp hid)); - (fun g -> - let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in - tclMAP (revert_graph kn pre_tac) (hid::new_ids) g - ); - ] g - | _ -> tclFAIL 1 (mt ()) g - - -let error msg = user_err Pp.(str msg) +let functional_inversion kn hid fconst f_correct = Proofview.Goal.enter (fun gl -> + let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in + let sigma = project gl in + let type_of_h = pf_unsafe_type_of gl (mkVar hid) in + match EConstr.kind sigma type_of_h with + | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> + let pre_tac,f_args,res = + match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with + | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> + ((fun hid -> intros_symmetry (Locusops.onHyp hid))),f_args,args.(2) + |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> + ((fun hid -> tclIDTAC),f_args,args.(1)) + | _ -> (fun hid -> tclFAIL 1 Pp.(mt ())),[||],args.(2) + in + tclTHENLIST + [ pre_tac hid + ; generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])] + ; clear [hid] + ; Simple.intro hid + ; Inv.inv Inv.FullInversion None (Tactypes.NamedHyp hid) + ; Proofview.Goal.enter (fun gl -> + let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps gl) in + tclMAP (revert_graph kn pre_tac) (hid::new_ids) + ) + ] + | _ -> tclFAIL 1 Pp.(mt ()) + ) let invfun qhyp f = let f = match f with - | GlobRef.ConstRef f -> f - | _ -> raise (CErrors.UserError(None,str "Not a function")) + | GlobRef.ConstRef f -> f + | _ -> + CErrors.user_err Pp.(str "Not a function") in - try - let finfos = find_Function_infos f in - let f_correct = mkConst(Option.get finfos.correctness_lemma) - and kn = fst finfos.graph_ind - in - Proofview.V82.of_tactic ( - Tactics.try_intros_until (fun hid -> Proofview.V82.tactic (functional_inversion kn hid (mkConst f) f_correct)) qhyp - ) - with - | Not_found -> error "No graph found" - | Option.IsNone -> error "Cannot use equivalence with graph!" - -exception NoFunction -let invfun qhyp f g = - match f with - | Some f -> invfun qhyp f g + match find_Function_infos f with + | None -> + CErrors.user_err (Pp.str "No graph found") + | Some finfos -> + match finfos.correctness_lemma with | None -> - Proofview.V82.of_tactic begin - Tactics.try_intros_until - (fun hid -> Proofview.V82.tactic begin fun g -> - let sigma = project g in - let hyp_typ = pf_unsafe_type_of g (mkVar hid) in - match EConstr.kind sigma hyp_typ with - | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> - begin - let f1,_ = decompose_app sigma args.(1) in - try - if not (isConst sigma f1) then raise NoFunction; - let finfos = find_Function_infos (fst (destConst sigma 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 | NoFunction | Option.IsNone | Not_found -> - try - let f2,_ = decompose_app sigma args.(2) in - if not (isConst sigma f2) then raise NoFunction; - let finfos = find_Function_infos (fst (destConst sigma 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 - | NoFunction -> - user_err (str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") - | Option.IsNone -> - if do_observe () - then - error "Cannot use equivalence with graph for any side of the equality" - else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - | Not_found -> - if do_observe () - then - error "No graph found for any side of equality" - else user_err (str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) - end - | _ -> user_err (Ppconstr.pr_id hid ++ str " must be an equality ") - end) - qhyp - end - g + CErrors.user_err (Pp.str "Cannot use equivalence with graph!") + | Some f_correct -> + let f_correct = mkConst f_correct + and kn = fst finfos.graph_ind in + Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp + +let invfun qhyp f = + let exception NoFunction in + match f with + | Some f -> invfun qhyp f + | None -> + let tac_action hid gl = + let sigma = project gl in + let hyp_typ = pf_unsafe_type_of gl (mkVar hid) in + match EConstr.kind sigma hyp_typ with + | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> + begin + let f1,_ = decompose_app sigma args.(1) in + try + if not (isConst sigma f1) then raise NoFunction; + let finfos = Option.get (find_Function_infos (fst (destConst sigma 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 + with + | NoFunction | Option.IsNone -> + let f2,_ = decompose_app sigma args.(2) in + if isConst sigma f2 then + match find_Function_infos (fst (destConst sigma f2)) with + | None -> + if do_observe () + then CErrors.user_err (Pp.str "No graph found for any side of equality") + else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + | Some finfos -> + match finfos.correctness_lemma with + | None -> + if do_observe () + then CErrors.user_err (Pp.str "Cannot use equivalence with graph for any side of the equality") + else CErrors.user_err Pp.(str "Cannot find inversion information for hypothesis " ++ Ppconstr.pr_id hid) + | Some f_correct -> + let f_correct = mkConst f_correct + and kn = fst finfos.graph_ind + in + functional_inversion kn hid f2 f_correct + else (* NoFunction *) + CErrors.user_err Pp.(str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") + end + | _ -> CErrors.user_err Pp.(Ppconstr.pr_id hid ++ str " must be an equality ") + in + try_intros_until (tac_action %> Proofview.Goal.enter) qhyp diff --git a/plugins/funind/invfun.mli b/plugins/funind/invfun.mli index c7538fae9a..6b789e1bb2 100644 --- a/plugins/funind/invfun.mli +++ b/plugins/funind/invfun.mli @@ -8,12 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val invfun : - Tactypes.quantified_hypothesis -> - Names.GlobRef.t option -> - Evar.t Evd.sigma -> Evar.t list Evd.sigma - -val derive_correctness - : Constr.pconstant list - -> Names.inductive list - -> unit +val invfun + : Tactypes.quantified_hypothesis + -> Names.GlobRef.t option + -> unit Proofview.tactic diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 937118bf57..c62aa0cf6b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -199,54 +199,24 @@ let (declare_f : Id.t -> Decls.logical_kind -> Constr.t list -> GlobRef.t -> Glo fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; - - -(* Debugging mechanism *) -let debug_queue = Stack.create () - -let print_debug_queue b e = - if not (Stack.is_empty debug_queue) - then - begin - let lmsg,goal = Stack.pop debug_queue in - if b then - Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.iprint e) ++ str " on goal" ++ fnl() ++ goal)) - else - begin - Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)); - end; - (* print_debug_queue false e; *) - end - -let observe strm = +let observe_tclTHENLIST s tacl = if do_observe () - then Feedback.msg_debug strm - else () + then + let rec aux n = function + | [] -> tclIDTAC + | [tac] -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac + | tac::tacl -> observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) (tclTHEN tac (aux (succ n) tacl)) + in + aux 0 tacl + else tclTHENLIST tacl +module New = struct -let do_observe_tac s tac g = - let goal = Printer.pr_goal g in - let s = s (pf_env g) (project g) in - let lmsg = (str "recdef : ") ++ s in - observe (s++fnl()); - Stack.push (lmsg,goal) debug_queue; - try - let v = tac g in - ignore(Stack.pop debug_queue); - v - with reraise -> - let reraise = CErrors.push reraise in - if not (Stack.is_empty debug_queue) - then print_debug_queue true reraise; - iraise reraise - -let observe_tac s tac g = - if do_observe () - then do_observe_tac s tac g - else tac g + open Tacticals.New + let observe_tac = New.observe_tac ~header:(Pp.mt()) -let observe_tclTHENLIST s tacl = + let observe_tclTHENLIST s tacl = if do_observe () then let rec aux n = function @@ -257,38 +227,36 @@ let observe_tclTHENLIST s tacl = aux 0 tacl else tclTHENLIST tacl +end + (* Conclusion tactics *) (* 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 tclUSER tac is_mes l = + let open Tacticals.New in let clear_tac = match l with - | None -> tclIDTAC - | Some l -> tclMAP (fun id -> tclTRY (Proofview.V82.of_tactic (clear [id]))) (List.rev l) + | None -> tclIDTAC + | Some l -> tclMAP (fun id -> tclTRY (clear [id])) (List.rev l) in - observe_tclTHENLIST (fun _ _ -> str "tclUSER1") - [ - clear_tac; + New.observe_tclTHENLIST (fun _ _ -> str "tclUSER1") + [ clear_tac; if is_mes - then observe_tclTHENLIST (fun _ _ -> str "tclUSER2") - [ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference - (delayed_force Indfun_common.ltof_ref))]); - tac - ] + then + New.observe_tclTHENLIST (fun _ _ -> str "tclUSER2") + [ unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference + (delayed_force Indfun_common.ltof_ref))] + ; tac + ] else tac ] - g let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = if is_mes - then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (delayed_force well_founded_ltof)) gl) - else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) (tclUSER concl_tac is_mes names_to_suppress) - - - - + then Tacticals.New.tclCOMPLETE (Simple.apply (delayed_force well_founded_ltof)) + else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) + (tclUSER concl_tac is_mes names_to_suppress) (* Traveling term. Both definitions of [f_terminate] and [f_equation] use the same generic @@ -330,7 +298,7 @@ let check_not_nested env sigma forbidden e = (* ['a info] contains the local information for traveling *) type 'a infos = { nb_arg : int; (* function number of arguments *) - concl_tac : tactic; (* final tactic to finish proofs *) + concl_tac : unit Proofview.tactic; (* final tactic to finish proofs *) rec_arg_id : Id.t; (*name of the declared recursive argument *) is_mes : bool; (* type of recursion *) ih : Id.t; (* induction hypothesis name *) @@ -803,6 +771,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ g = expr_info.eqs ) ); + Proofview.V82.of_tactic @@ tclUSER expr_info.concl_tac true (Some ( expr_info.ih::expr_info.acc_id:: @@ -1153,7 +1122,7 @@ let rec instantiate_lambda sigma t l = let (_, _, body) = destLambda sigma t in instantiate_lambda sigma (subst1 a body) l -let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = +let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : tactic = begin fun g -> let sigma = project g in @@ -1195,7 +1164,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a is_final = true; (* and on leaf (more or less) *) f_terminate = delayed_force coq_O; nb_arg = nb_args; - concl_tac = concl_tac; + concl_tac; rec_arg_id = rec_arg_id; is_mes = is_mes; ih = hrec; @@ -1213,7 +1182,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a ) g ) - (tclUSER_if_not_mes concl_tac) + (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) g end @@ -1320,50 +1289,47 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in - let lemma = build_proof env (Evd.from_env env) - ( fun gls -> - let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in - observe_tclTHENLIST (fun _ _ -> str "") - [ - Proofview.V82.of_tactic (generalize [lemma]); - Proofview.V82.of_tactic (Simple.intro hid); - (fun g -> - let ids = pf_ids_of_hyps g in + let start_tac = + let open Tacmach.New in + let open Tacticals.New in + Proofview.Goal.enter (fun gl -> + let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gl) in + New.observe_tclTHENLIST (fun _ _ -> mt ()) + [ generalize [lemma] + ; Simple.intro hid + ; Proofview.Goal.enter (fun gl -> + let ids = pf_ids_of_hyps gl in tclTHEN - (Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid))) - (fun g -> - let ids' = pf_ids_of_hyps g in - lid := List.rev (List.subtract Id.equal ids' ids); - if List.is_empty !lid then lid := [hid]; - tclIDTAC g - ) - g - ); - ] gls) - (fun g -> - let sigma = project g in - match EConstr.kind sigma (pf_concl g) with - | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> - Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g - | _ -> - incr h_num; - (observe_tac (fun _ _ -> str "finishing using") - ( - tclCOMPLETE( - tclFIRST[ - tclTHEN - (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))) - (Proofview.V82.of_tactic e_assumption); - Eauto.eauto_with_bases - (true,5) - [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] - [Hints.Hint_db.empty TransparentState.empty false] + (Elim.h_decompose_and (mkVar hid)) + (Proofview.Goal.enter (fun gl -> + let ids' = pf_ids_of_hyps gl in + lid := List.rev (List.subtract Id.equal ids' ids); + if List.is_empty !lid then lid := [hid]; + tclIDTAC))) + ]) in + let end_tac = + let open Tacmach.New in + let open Tacticals.New in + Proofview.Goal.enter (fun gl -> + let sigma = project gl in + match EConstr.kind sigma (pf_concl gl) with + | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> + Auto.h_auto None [] (Some []) + | _ -> + incr h_num; + tclCOMPLETE( + tclFIRST + [ tclTHEN + (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings)) + e_assumption + ; Eauto.eauto_with_bases + (true,5) + [(fun _ sigma -> (sigma, (Lazy.force refl_equal)))] + [Hints.Hint_db.empty TransparentState.empty false ] - ) - ) - ) - g) - in + ] + )) in + let lemma = build_proof env (Evd.from_env env) start_tac end_tac in Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) @@ -1409,18 +1375,18 @@ let com_terminate thm_name using_lemmas nb_args ctx hook = - let start_proof env ctx (tac_start:tactic) (tac_end:tactic) = + let start_proof env ctx tac_start tac_end = let info = Lemmas.Info.make ~hook ~scope:(DeclareDef.Global ImportDefaultBehavior) ~kind:Decls.(IsProof Lemma) () in let lemma = Lemmas.start_lemma ~name:thm_name ~poly:false (*FIXME*) ~info ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) in - let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "starting_tac") tac_start)) lemma in + let lemma = fst @@ Lemmas.by (New.observe_tac (fun _ _ -> str "starting_tac") tac_start) lemma in fst @@ Lemmas.by (Proofview.V82.tactic (observe_tac (fun _ _ -> str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref input_type relation rec_arg_num ))) lemma in - let lemma = start_proof Global.(env ()) ctx tclIDTAC tclIDTAC in + let lemma = start_proof Global.(env ()) ctx Tacticals.New.tclIDTAC Tacticals.New.tclIDTAC in try let sigma, new_goal_type = build_new_goal_type lemma in let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in @@ -1469,7 +1435,7 @@ let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemm {nb_arg=nb_arg; f_terminate = EConstr.of_constr (constr_of_monomorphic_global terminate_ref); f_constr = EConstr.of_constr f_constr; - concl_tac = tclIDTAC; + concl_tac = Tacticals.New.tclIDTAC; func=functional_ref; info=(instantiate_lambda Evd.empty (EConstr.of_constr (def_of_const (constr_of_monomorphic_global functional_ref))) diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index e6aa452def..3225411c85 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -1,10 +1,10 @@ open Constr -val tclUSER_if_not_mes : - Tacmach.tactic -> - bool -> - Names.Id.t list option -> - Tacmach.tactic +val tclUSER_if_not_mes + : unit Proofview.tactic + -> bool + -> Names.Id.t list option + -> unit Proofview.tactic val recursive_definition : interactive_proof:bool diff --git a/plugins/funind/recdef_plugin.mlpack b/plugins/funind/recdef_plugin.mlpack index 755fa4f879..2adcfddd0a 100644 --- a/plugins/funind/recdef_plugin.mlpack +++ b/plugins/funind/recdef_plugin.mlpack @@ -6,4 +6,5 @@ Functional_principles_proofs Functional_principles_types Invfun Indfun +Gen_principle G_indfun diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index 2654729652..e6e6e29d4f 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -332,7 +332,7 @@ END let local_test_lpar_id_colon = let err () = raise Stream.Failure in Pcoq.Entry.of_parser "lpar_id_colon" - (fun strm -> + (fun _ strm -> match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> (match Util.stream_nth 1 strm with diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 1e2b23bf96..f7215a9d13 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -17,7 +17,6 @@ open Genarg open Stdarg open Tacarg open Extraargs -open Pcoq.Prim open Pltac open Mod_subst open Names @@ -258,19 +257,8 @@ END open Autorewrite -let pr_orient _prc _prlc _prt = function - | true -> Pp.mt () - | false -> Pp.str " <-" - -let pr_orient_string _prc _prlc _prt (orient, s) = - pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s - } -ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY { pr_orient_string } -| [ orient(r) preident(i) ] -> { r, i } -END - TACTIC EXTEND autorewrite | [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> { auto_multi_rewrite l ( cl) } @@ -1112,7 +1100,7 @@ VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF END VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY -| [ "Print" "Equivalent" "Keys" ] -> { Feedback.msg_info (Keys.pr_keys Printer.pr_global) } +| [ "Print" "Equivalent" "Keys" ] -> { Feedback.msg_notice (Keys.pr_keys Printer.pr_global) } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 5c84b35f1b..cab8ed0a55 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -64,7 +64,7 @@ let classic_proof_mode = Pvernac.register_proof_mode "Classic" tactic_mode (* Hack to parse "[ id" without dropping [ *) let test_bracket_ident = Pcoq.Entry.of_parser "test_bracket_ident" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "[" -> (match stream_nth 1 strm with diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index 455c8ab003..61cc77c42a 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -145,7 +145,7 @@ open Pp VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY | [ "Show" "Obligation" "Tactic" ] -> { - Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) } + Feedback.msg_notice (str"Program obligation tactic is " ++ print_default_tactic ()) } END VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY @@ -154,8 +154,8 @@ VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY END VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY -| [ "Preterm" "of" ident(name) ] -> { Feedback.msg_info (show_term (Some name)) } -| [ "Preterm" ] -> { Feedback.msg_info (show_term None) } +| [ "Preterm" "of" ident(name) ] -> { Feedback.msg_notice (show_term (Some name)) } +| [ "Preterm" ] -> { Feedback.msg_notice (show_term None) } END { diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 945a2dd613..9b52b710c1 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -24,7 +24,6 @@ open Tactypes open Tactics open Inv open Locus -open Decl_kinds open Pcoq @@ -40,7 +39,7 @@ let err () = raise Stream.Failure (* admissible notation "(x t)" *) let test_lpar_id_coloneq = Pcoq.Entry.of_parser "lpar_id_coloneq" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with @@ -54,7 +53,7 @@ let test_lpar_id_coloneq = (* Hack to recognize "(x)" *) let test_lpar_id_rpar = Pcoq.Entry.of_parser "lpar_id_coloneq" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with @@ -68,7 +67,7 @@ let test_lpar_id_rpar = (* idem for (x:=t) and (1:=t) *) let test_lpar_idnum_coloneq = Pcoq.Entry.of_parser "test_lpar_idnum_coloneq" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD "(" -> (match stream_nth 1 strm with @@ -85,7 +84,7 @@ open Extraargs (* idem for (x1..xn:t) [n^2 complexity but exceptional use] *) let check_for_coloneq = Pcoq.Entry.of_parser "lpar_id_colon" - (fun strm -> + (fun _ strm -> let rec skip_to_rpar p n = match List.last (Stream.npeek n strm) with | KEYWORD "(" -> skip_to_rpar (p+1) (n+1) @@ -109,7 +108,7 @@ let check_for_coloneq = let lookup_at_as_comma = Pcoq.Entry.of_parser "lookup_at_as_comma" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | KEYWORD (","|"at"|"as") -> () | _ -> err ()) @@ -450,9 +449,9 @@ GRAMMAR EXTEND Gram | -> { true } ] ] ; simple_binder: - [ [ na=name -> { ([na],Default Explicit, CAst.make ~loc @@ + [ [ na=name -> { ([na],Default Glob_term.Explicit, CAst.make ~loc @@ CHole (Some (Evar_kinds.BinderType na.CAst.v), IntroAnonymous, None)) } - | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> { (nal,Default Explicit,c) } + | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> { (nal,Default Glob_term.Explicit,c) } ] ] ; fixdecl: diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 0e38ce575b..6df068883c 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -20,7 +20,6 @@ open Stdarg open Notation_gram open Tactypes open Locus -open Decl_kinds open Genredexpr open Ppconstr open Pputils @@ -1097,7 +1096,7 @@ let pr_goal_selector ~toplevel s = let rec strip_ty acc n ty = if Int.equal n 0 then (List.rev acc, (ty,None)) else match DAst.get ty with - Glob_term.GProd(na,Explicit,a,b) -> + Glob_term.GProd(na,Glob_term.Explicit,a,b) -> strip_ty (([CAst.make na],(a,None))::acc) (n-1) b | _ -> user_err Pp.(str "Cannot translate fix tactic: not enough products") in strip_ty [] n ty diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 9d46bbc74e..fe5ebf1172 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -417,7 +417,7 @@ let get_timer name = let finish_timing ~prefix name = let tend = System.get_time () in let tstart = get_timer name in - Feedback.msg_info(str prefix ++ pr_opt str name ++ str " ran for " ++ + Feedback.msg_notice(str prefix ++ pr_opt str name ++ str " ran for " ++ System.fmt_time_difference tstart tend) (* ******************** *) @@ -431,7 +431,7 @@ let print_results_filter ~cutoff ~filter = let results = SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in let results = merge_roots results Local.(CList.last !stack) in - Feedback.msg_info (to_string ~cutoff ~filter results) + Feedback.msg_notice (to_string ~cutoff ~filter results) ;; let print_results ~cutoff = diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 726752a2bf..1493092f2f 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -546,7 +546,7 @@ let rewrite_core_unif_flags = { Unification.check_applied_meta_types = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; - Unification.frozen_evars = Evar.Set.empty; + Unification.allowed_evars = Unification.AllowAll; Unification.restrict_conv_on_strict_subterms = false; Unification.modulo_betaiota = false; Unification.modulo_eta = true; diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 94af4a3151..ba759441e5 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -189,31 +189,32 @@ let flatten_contravariant_disj _ ist = tclTHEN (tclTHENLIST tacs) tac0 | _ -> fail -let make_unfold name = - let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in - let const = Constant.make2 (ModPath.MPfile dir) (Label.make name) in - Locus.(AllOccurrences, ArgArg (EvalConstRef const, None)) +let evalglobref_of_globref = + function + | GlobRef.VarRef v -> EvalVarRef v + | GlobRef.ConstRef c -> EvalConstRef c + | GlobRef.IndRef _ | GlobRef.ConstructRef _ -> assert false -let u_not = make_unfold "not" +let make_unfold name = + let const = evalglobref_of_globref (Coqlib.lib_ref name) in + Locus.(AllOccurrences, ArgArg (const, None)) let reduction_not_iff _ ist = let make_reduce c = TacAtom (CAst.make @@ TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in let tac = match !negation_unfolding with - | true -> make_reduce [u_not] + | true -> make_reduce [make_unfold "core.not.type"] | false -> TacId [] in eval_tactic_ist ist tac -let coq_nnpp_path = - let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in - Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") - let apply_nnpp _ ist = + let nnpp = "core.nnpp.type" in Proofview.tclBIND (Proofview.tclUNIT ()) - begin fun () -> try - Tacticals.New.pf_constr_of_global (Nametab.global_of_path coq_nnpp_path) >>= apply - with Not_found -> tclFAIL 0 (Pp.mt ()) + begin fun () -> + if Coqlib.has_ref nnpp + then Tacticals.New.pf_constr_of_global (Coqlib.lib_ref nnpp) >>= apply + else tclFAIL 0 (Pp.mt ()) end (* This is the uniform mode dealing with ->, not, iff and types isomorphic to diff --git a/plugins/micromega/EnvRing.v b/plugins/micromega/EnvRing.v index 78bfe480b3..2762bb6b32 100644 --- a/plugins/micromega/EnvRing.v +++ b/plugins/micromega/EnvRing.v @@ -19,6 +19,47 @@ Require Export Ring_theory. Local Open Scope positive_scope. Import RingSyntax. +(** Definition of polynomial expressions *) +#[universes(template)] +Inductive PExpr {C} : Type := +| PEc : C -> PExpr +| PEX : positive -> PExpr +| PEadd : PExpr -> PExpr -> PExpr +| PEsub : PExpr -> PExpr -> PExpr +| PEmul : PExpr -> PExpr -> PExpr +| PEopp : PExpr -> PExpr +| PEpow : PExpr -> N -> PExpr. +Arguments PExpr : clear implicits. + + (* Definition of multivariable polynomials with coefficients in C : + Type [Pol] represents [X1 ... Xn]. + The representation is Horner's where a [n] variable polynomial + (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients + are polynomials with [n-1] variables (C[X2..Xn]). + There are several optimisations to make the repr compacter: + - [Pc c] is the constant polynomial of value c + == c*X1^0*..*Xn^0 + - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. + variable indices are shifted of j in Q. + == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} + - [PX P i Q] is an optimised Horner form of P*X^i + Q + with P not the null polynomial + == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} + + In addition: + - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden + since they can be represented by the simpler form (PX P (i+j) Q) + - (Pinj i (Pinj j P)) is (Pinj (i+j) P) + - (Pinj i (Pc c)) is (Pc c) + *) + +#[universes(template)] +Inductive Pol {C} : Type := +| Pc : C -> Pol +| Pinj : positive -> Pol -> Pol +| PX : Pol -> positive -> Pol -> Pol. +Arguments Pol : clear implicits. + Section MakeRingPol. (* Ring elements *) @@ -96,33 +137,11 @@ Section MakeRingPol. match goal with |- ?t == _ => mul_permut_rec t end). - (* Definition of multivariable polynomials with coefficients in C : - Type [Pol] represents [X1 ... Xn]. - The representation is Horner's where a [n] variable polynomial - (C[X1..Xn]) is seen as a polynomial on [X1] which coefficients - are polynomials with [n-1] variables (C[X2..Xn]). - There are several optimisations to make the repr compacter: - - [Pc c] is the constant polynomial of value c - == c*X1^0*..*Xn^0 - - [Pinj j Q] is a polynomial constant w.r.t the [j] first variables. - variable indices are shifted of j in Q. - == X1^0 *..* Xj^0 * Q{X1 <- Xj+1;..; Xn-j <- Xn} - - [PX P i Q] is an optimised Horner form of P*X^i + Q - with P not the null polynomial - == P * X1^i + Q{X1 <- X2; ..; Xn-1 <- Xn} + Notation PExpr := (PExpr C). + Notation Pol := (Pol C). - In addition: - - polynomials of the form (PX (PX P i (Pc 0)) j Q) are forbidden - since they can be represented by the simpler form (PX P (i+j) Q) - - (Pinj i (Pinj j P)) is (Pinj (i+j) P) - - (Pinj i (Pc c)) is (Pc c) - *) - - #[universes(template)] - Inductive Pol : Type := - | Pc : C -> Pol - | Pinj : positive -> Pol -> Pol - | PX : Pol -> positive -> Pol -> Pol. + Implicit Types pe : PExpr. + Implicit Types P : Pol. Definition P0 := Pc cO. Definition P1 := Pc cI. @@ -152,7 +171,7 @@ Section MakeRingPol. | _ => Pinj j P end. - Definition mkPinj_pred j P:= + Definition mkPinj_pred j P := match j with | xH => P | xO j => Pinj (Pos.pred_double j) P @@ -938,18 +957,6 @@ Qed. rewrite <- IHm; auto. Qed. - (** Definition of polynomial expressions *) - - #[universes(template)] - Inductive PExpr : Type := - | PEc : C -> PExpr - | PEX : positive -> PExpr - | PEadd : PExpr -> PExpr -> PExpr - | PEsub : PExpr -> PExpr -> PExpr - | PEmul : PExpr -> PExpr -> PExpr - | PEopp : PExpr -> PExpr - | PEpow : PExpr -> N -> PExpr. - (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index a99f21ad47..3c72d3268f 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -68,7 +68,7 @@ Require Import EnvRing. Fixpoint Qeval_expr (env: PolEnv Q) (e: PExpr Q) : Q := match e with | PEc c => c - | PEX _ j => env j + | PEX j => env j | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) @@ -80,7 +80,7 @@ Lemma Qeval_expr_simpl : forall env e, Qeval_expr env e = match e with | PEc c => c - | PEX _ j => env j + | PEX j => env j | PEadd pe1 pe2 => (Qeval_expr env pe1) + (Qeval_expr env pe2) | PEsub pe1 pe2 => (Qeval_expr env pe1) - (Qeval_expr env pe2) | PEmul pe1 pe2 => (Qeval_expr env pe1) * (Qeval_expr env pe2) diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 75801162a7..cddc140f51 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -289,7 +289,6 @@ destruct o' ; rewrite H1 ; now rewrite (Rplus_0_l sor). now apply (Rplus_nonneg_nonneg sor). Qed. -#[universes(template)] Inductive Psatz : Type := | PsatzIn : nat -> Psatz | PsatzSquare : PolC -> Psatz @@ -892,7 +891,7 @@ Fixpoint xdenorm (jmp : positive) (p: Pol C) : PExpr C := | Pc c => PEc c | Pinj j p => xdenorm (Pos.add j jmp ) p | PX p j q => PEadd - (PEmul (xdenorm jmp p) (PEpow (PEX _ jmp) (Npos j))) + (PEmul (xdenorm jmp p) (PEpow (PEX jmp) (Npos j))) (xdenorm (Pos.succ jmp) q) end. @@ -961,7 +960,7 @@ Variable phi_C_of_S : forall c, phiS c = phi (C_of_S c). Fixpoint map_PExpr (e : PExpr S) : PExpr C := match e with | PEc c => PEc (C_of_S c) - | PEX _ p => PEX _ p + | PEX p => PEX p | PEadd e1 e2 => PEadd (map_PExpr e1) (map_PExpr e2) | PEsub e1 e2 => PEsub (map_PExpr e1) (map_PExpr e2) | PEmul e1 e2 => PEmul (map_PExpr e1) (map_PExpr e2) diff --git a/plugins/micromega/Tauto.v b/plugins/micromega/Tauto.v index 56032befba..d6ccf582ae 100644 --- a/plugins/micromega/Tauto.v +++ b/plugins/micromega/Tauto.v @@ -27,7 +27,6 @@ Section S. Context {AA : Type}. (* type of annotations for atoms *) Context {AF : Type}. (* type of formulae identifiers *) - #[universes(template)] Inductive GFormula : Type := | TT : GFormula | FF : GFormula diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index 79cb6a3a3e..f93fe021f9 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -27,16 +27,18 @@ Set Implicit Arguments. * As a side note, by dropping the polymorphism, one gets small, yet noticeable, speed-up. *) +Inductive t {A} : Type := +| Empty : t +| Elt : A -> t +| Branch : t -> A -> t -> t . +Arguments t : clear implicits. + Section MakeVarMap. Variable A : Type. Variable default : A. - #[universes(template)] - Inductive t : Type := - | Empty : t - | Elt : A -> t - | Branch : t -> A -> t -> t . + Notation t := (t A). Fixpoint find (vm : t) (p:positive) {struct vm} : A := match vm with @@ -49,7 +51,6 @@ Section MakeVarMap. end end. - Fixpoint singleton (x:positive) (v : A) : t := match x with | xH => Elt v diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 3ea7635244..c0d22486b5 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -65,7 +65,7 @@ Qed. Fixpoint Zeval_expr (env : PolEnv Z) (e: PExpr Z) : Z := match e with | PEc c => c - | PEX _ x => env x + | PEX x => env x | PEadd e1 e2 => Zeval_expr env e1 + Zeval_expr env e2 | PEmul e1 e2 => Zeval_expr env e1 * Zeval_expr env e2 | PEpow e1 n => Z.pow (Zeval_expr env e1) (Z.of_N n) @@ -78,7 +78,7 @@ Definition eval_expr := eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x => x) (fun x Fixpoint Zeval_const (e: PExpr Z) : option Z := match e with | PEc c => Some c - | PEX _ x => None + | PEX x => None | PEadd e1 e2 => map_option2 (fun x y => Some (x + y)) (Zeval_const e1) (Zeval_const e2) | PEmul e1 e2 => map_option2 (fun x y => Some (x * y)) @@ -742,7 +742,7 @@ Module Vars. Fixpoint vars_of_pexpr (e : PExpr Z) : Vars.t := match e with | PEc _ => Vars.empty - | PEX _ x => Vars.singleton x + | PEX x => Vars.singleton x | PEadd e1 e2 | PEsub e1 e2 | PEmul e1 e2 => let v1 := vars_of_pexpr e1 in let v2 := vars_of_pexpr e2 in @@ -774,10 +774,10 @@ Fixpoint vars_of_bformula {TX : Type} {TG : Type} {ID : Type} end. Definition bound_var (v : positive) : Formula Z := - Build_Formula (PEX _ v) OpGe (PEc 0). + Build_Formula (PEX v) OpGe (PEc 0). Definition mk_eq_pos (x : positive) (y:positive) (t : positive) : Formula Z := - Build_Formula (PEX _ x) OpEq (PEsub (PEX _ y) (PEX _ t)). + Build_Formula (PEX x) OpEq (PEsub (PEX y) (PEX t)). Section BOUND. Context {TX TG ID : Type}. diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index a64a5a84b3..cd620bd4a9 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -556,6 +556,15 @@ let zeq_bool x y = | Eq -> true | _ -> false +type 'c pExpr = +| PEc of 'c +| PEX of positive +| PEadd of 'c pExpr * 'c pExpr +| PEsub of 'c pExpr * 'c pExpr +| PEmul of 'c pExpr * 'c pExpr +| PEopp of 'c pExpr +| PEpow of 'c pExpr * n + type 'c pol = | Pc of 'c | Pinj of positive * 'c pol @@ -868,15 +877,6 @@ let rec psquare cO cI cadd cmul ceqb = function let p3 = psquare cO cI cadd cmul ceqb p2 in mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb p3 i (p0 cO)) twoPQ) i q2 -type 'c pExpr = -| PEc of 'c -| PEX of positive -| PEadd of 'c pExpr * 'c pExpr -| PEsub of 'c pExpr * 'c pExpr -| PEmul of 'c pExpr * 'c pExpr -| PEopp of 'c pExpr -| PEpow of 'c pExpr * n - (** val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol **) let mk_X cO cI j = @@ -1568,14 +1568,6 @@ module PositiveSet = type q = { qnum : z; qden : positive } -(** val qnum : q -> z **) - -let qnum x = x.qnum - -(** val qden : q -> positive **) - -let qden x = x.qden - (** val qeq_bool : q -> q -> bool **) let qeq_bool x y = diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 64cb3a8355..6da0c754f4 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -446,10 +446,6 @@ module PositiveSet : type q = { qnum : z; qden : positive } -val qnum : q -> z - -val qden : q -> positive - val qeq_bool : q -> q -> bool val qle_bool : q -> q -> bool diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 0ca0d0c12d..6b92445326 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -77,20 +77,24 @@ Lget i (l ++ delta) = Some a. induction l;destruct i;simpl;try congruence;auto. Qed. -Section Store. - -Variable A:Type. - -#[universes(template)] -Inductive Poption : Type:= +Inductive Poption {A} : Type:= PSome : A -> Poption | PNone : Poption. +Arguments Poption : clear implicits. -#[universes(template)] -Inductive Tree : Type := +Inductive Tree {A} : Type := Tempty : Tree | Branch0 : Tree -> Tree -> Tree | Branch1 : A -> Tree -> Tree -> Tree. +Arguments Tree : clear implicits. + +Section Store. + +Variable A:Type. + +Notation Poption := (Poption A). +Notation Tree := (Tree A). + Fixpoint Tget (p:positive) (T:Tree) {struct p} : Poption := match T with @@ -179,7 +183,6 @@ 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. -#[universes(template)] Record Store : Type := mkStore {index:positive;contents:Tree}. @@ -194,7 +197,6 @@ Lemma get_empty : forall i, get i empty = PNone. intro i; case i; unfold empty,get; simpl;reflexivity. Qed. -#[universes(template)] Inductive Full : Store -> Type:= F_empty : Full empty | F_push : forall a S, Full S -> Full (push a S). diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index b4300da4d5..3736bc47a5 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -730,7 +730,6 @@ Qed. (* The input: syntax of a field expression *) -#[universes(template)] Inductive FExpr : Type := | FEO : FExpr | FEI : FExpr @@ -763,7 +762,6 @@ Strategy expand [FEeval]. (* The result of the normalisation *) -#[universes(template)] Record linear : Type := mk_linear { num : PExpr C; denum : PExpr C; @@ -946,7 +944,6 @@ induction e2; intros p1 p2; now rewrite <- PEpow_mul_r. Qed. -#[universes(template)] Record rsplit : Type := mk_rsplit { rsplit_left : PExpr C; rsplit_common : PExpr C; diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index b024f65988..a98a963207 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -740,7 +740,6 @@ Ltac abstract_ring_morphism set ext rspec := | _ => fail 1 "bad ring structure" end. -#[universes(template)] Record hypo : Type := mkhypo { hypo_type : Type; hypo_proof : hypo_type diff --git a/plugins/setoid_ring/Ncring_polynom.v b/plugins/setoid_ring/Ncring_polynom.v index 6a8c514a7b..048c8eecf9 100644 --- a/plugins/setoid_ring/Ncring_polynom.v +++ b/plugins/setoid_ring/Ncring_polynom.v @@ -32,7 +32,6 @@ Variable phiCR_comm: forall (c:C)(x:R), x * [c] == [c] * x. with coefficients in C : *) -#[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | PX : Pol -> positive -> positive -> Pol -> Pol. diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 9d56084fd4..092114ff0b 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -121,7 +121,6 @@ Section MakeRingPol. - (Pinj i (Pc c)) is (Pc c) *) - #[universes(template)] Inductive Pol : Type := | Pc : C -> Pol | Pinj : positive -> Pol -> Pol @@ -909,7 +908,6 @@ Section MakeRingPol. (** Definition of polynomial expressions *) - #[universes(template)] Inductive PExpr : Type := | PEO : PExpr | PEI : PExpr diff --git a/plugins/setoid_ring/Ring_theory.v b/plugins/setoid_ring/Ring_theory.v index 8f24b281c6..dc45853458 100644 --- a/plugins/setoid_ring/Ring_theory.v +++ b/plugins/setoid_ring/Ring_theory.v @@ -540,7 +540,6 @@ Section AddRing. Variable (rO rI : R) (radd rmul rsub: R->R->R) (ropp : R -> R). Variable req : R -> R -> Prop. *) -#[universes(template)] Inductive ring_kind : Type := | Abstract | Computational diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index eb75fca0a1..76c393450b 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -18,7 +18,6 @@ open EConstr open Vars open CClosure open Environ -open Libnames open Globnames open Glob_term open Locus @@ -151,7 +150,7 @@ let ic_unsafe c = (*FIXME remove *) let decl_constant na univs c = let open Constr in let vars = CVars.universes_of_constr c in - let univs = UState.restrict_universe_context univs vars in + let univs = UState.restrict_universe_context ~lbound:(Global.universes_lbound ()) univs vars in let () = Declare.declare_universe_context ~poly:false univs in let types = (Typeops.infer (Global.env ()) c).uj_type in let univs = Monomorphic_entry Univ.ContextSet.empty in @@ -326,19 +325,18 @@ let _ = add_map "ring" module Cmap = Map.Make(Constr) let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table" -let from_name = Summary.ref Spmap.empty ~name:"ring-tac-name-table" let print_rings () = Feedback.msg_notice (strbrk "The following ring structures have been declared:"); - Spmap.iter (fun fn fi -> + Cmap.iter (fun _carrier ring -> let env = Global.env () in let sigma = Evd.from_env env in Feedback.msg_notice (hov 2 - (Ppconstr.pr_id (Libnames.basename fn)++spc()++ - str"with carrier "++ pr_constr_env env sigma fi.ring_carrier++spc()++ - str"and equivalence relation "++ pr_constr_env env sigma fi.ring_req)) - ) !from_name + (Ppconstr.pr_id ring.ring_name ++ spc() ++ + str"with carrier "++ pr_constr_env env sigma ring.ring_carrier++spc()++ + str"and equivalence relation "++ pr_constr_env env sigma ring.ring_req)) + ) !from_carrier let ring_for_carrier r = Cmap.find r !from_carrier @@ -361,9 +359,7 @@ let find_ring_structure env sigma l = | [] -> assert false let add_entry (sp,_kn) e = - from_carrier := Cmap.add e.ring_carrier e !from_carrier; - from_name := Spmap.add sp e !from_name - + from_carrier := Cmap.add e.ring_carrier e !from_carrier let subst_th (subst,th) = let c' = subst_mps subst th.ring_carrier in @@ -391,7 +387,8 @@ let subst_th (subst,th) = pretac' == th.ring_pre_tac && posttac' == th.ring_post_tac then th else - { ring_carrier = c'; + { ring_name = th.ring_name; + ring_carrier = c'; ring_req = eq'; ring_setoid = set'; ring_ext = ext'; @@ -428,59 +425,6 @@ let op_morph r add mul opp req m1 m2 m3 = let op_smorph r add mul req m1 m2 = lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] -(* let default_ring_equality (r,add,mul,opp,req) = *) -(* let is_setoid = function *) -(* {rel_refl=Some _; rel_sym=Some _;rel_trans=Some _;rel_aeq=rel} -> *) -(* eq_constr_nounivs req rel (\* Qu: use conversion ? *\) *) -(* | _ -> false in *) -(* match default_relation_for_carrier ~filter:is_setoid r with *) -(* Leibniz _ -> *) -(* let setoid = lapp coq_eq_setoid [|r|] in *) -(* let op_morph = *) -(* match opp with *) -(* Some opp -> lapp coq_eq_morph [|r;add;mul;opp|] *) -(* | None -> lapp coq_eq_smorph [|r;add;mul|] in *) -(* (setoid,op_morph) *) -(* | Relation rel -> *) -(* let setoid = setoid_of_relation rel in *) -(* let is_endomorphism = function *) -(* { args=args } -> List.for_all *) -(* (function (var,Relation rel) -> *) -(* var=None && eq_constr_nounivs req rel *) -(* | _ -> false) args in *) -(* let add_m = *) -(* try default_morphism ~filter:is_endomorphism add *) -(* with Not_found -> *) -(* error "ring addition should be declared as a morphism" in *) -(* let mul_m = *) -(* try default_morphism ~filter:is_endomorphism mul *) -(* with Not_found -> *) -(* error "ring multiplication should be declared as a morphism" in *) -(* let op_morph = *) -(* match opp with *) -(* | Some opp -> *) -(* (let opp_m = *) -(* try default_morphism ~filter:is_endomorphism opp *) -(* with Not_found -> *) -(* 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 *) -(* msgnl *) -(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\""++spc()++ *) -(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) -(* str"\","++spc()++ str"\""++pr_constr mul_m.morphism_theory++ *) -(* str"\""++spc()++str"and \""++pr_constr opp_m.morphism_theory++ *) -(* str"\""); *) -(* op_morph) *) -(* | None -> *) -(* (msgnl *) -(* (str"Using setoid \""++pr_constr rel.rel_aeq++str"\"" ++ spc() ++ *) -(* str"and morphisms \""++pr_constr add_m.morphism_theory++ *) -(* str"\""++spc()++str"and \""++ *) -(* pr_constr mul_m.morphism_theory++str"\""); *) -(* op_smorph r add mul req add_m.lem mul_m.lem) in *) -(* (setoid,op_morph) *) - let ring_equality env evd (r,add,mul,opp,req) = match EConstr.kind !evd req with | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> @@ -657,7 +601,8 @@ let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div let _ = Lib.add_leaf name (theory_to_obj - { ring_carrier = r; + { ring_name = name; + ring_carrier = r; ring_req = req; ring_setoid = sth; ring_ext = params.(1); @@ -835,19 +780,18 @@ let dest_field env evd th_spec = | _ -> error "bad field structure" let field_from_carrier = Summary.ref Cmap.empty ~name:"field-tac-carrier-table" -let field_from_name = Summary.ref Spmap.empty ~name:"field-tac-name-table" let print_fields () = Feedback.msg_notice (strbrk "The following field structures have been declared:"); - Spmap.iter (fun fn fi -> + Cmap.iter (fun _carrier fi -> let env = Global.env () in let sigma = Evd.from_env env in Feedback.msg_notice (hov 2 - (Ppconstr.pr_id (Libnames.basename fn)++spc()++ + (Id.print fi.field_name ++ spc() ++ str"with carrier "++ pr_constr_env env sigma fi.field_carrier++spc()++ str"and equivalence relation "++ pr_constr_env env sigma fi.field_req)) - ) !field_from_name + ) !field_from_carrier let field_for_carrier r = Cmap.find r !field_from_carrier @@ -871,8 +815,7 @@ let find_field_structure env sigma l = | [] -> assert false let add_field_entry (sp,_kn) e = - field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier; - field_from_name := Spmap.add sp e !field_from_name + field_from_carrier := Cmap.add e.field_carrier e !field_from_carrier let subst_th (subst,th) = let c' = subst_mps subst th.field_carrier in @@ -898,7 +841,8 @@ let subst_th (subst,th) = pretac' == th.field_pre_tac && posttac' == th.field_post_tac then th else - { field_carrier = c'; + { field_name = th.field_name; + field_carrier = c'; field_req = eq'; field_cst_tac = tac'; field_pow_tac = pow_tac'; @@ -983,7 +927,8 @@ let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign od let _ = Lib.add_leaf name (ftheory_to_obj - { field_carrier = r; + { field_name = name; + field_carrier = r; field_req = req; field_cst_tac = cst_tac; field_pow_tac = pow_tac; diff --git a/plugins/setoid_ring/newring_ast.ml b/plugins/setoid_ring/newring_ast.ml index 0a3e7bd9ca..b81f5f7d14 100644 --- a/plugins/setoid_ring/newring_ast.ml +++ b/plugins/setoid_ring/newring_ast.ml @@ -40,7 +40,8 @@ type 'constr field_mod = | Inject of constr_expr type ring_info = - { ring_carrier : types; + { ring_name : Names.Id.t; + ring_carrier : types; ring_req : constr; ring_setoid : constr; ring_ext : constr; @@ -54,7 +55,8 @@ type ring_info = ring_post_tac : glob_tactic_expr } type field_info = - { field_carrier : types; + { field_name : Names.Id.t; + field_carrier : types; field_req : constr; field_cst_tac : glob_tactic_expr; field_pow_tac : glob_tactic_expr; diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/setoid_ring/newring_ast.mli index 0a3e7bd9ca..b81f5f7d14 100644 --- a/plugins/setoid_ring/newring_ast.mli +++ b/plugins/setoid_ring/newring_ast.mli @@ -40,7 +40,8 @@ type 'constr field_mod = | Inject of constr_expr type ring_info = - { ring_carrier : types; + { ring_name : Names.Id.t; + ring_carrier : types; ring_req : constr; ring_setoid : constr; ring_ext : constr; @@ -54,7 +55,8 @@ type ring_info = ring_post_tac : glob_tactic_expr } type field_info = - { field_carrier : types; + { field_name : Names.Id.t; + field_carrier : types; field_req : constr; field_cst_tac : glob_tactic_expr; field_pow_tac : glob_tactic_expr; diff --git a/plugins/ssr/ssrbool.v b/plugins/ssr/ssrbool.v index bf0761d3ae..376410658a 100644 --- a/plugins/ssr/ssrbool.v +++ b/plugins/ssr/ssrbool.v @@ -1323,7 +1323,6 @@ Proof. by move=> x y r2xy; apply/orP; right. Qed. (** Variant of simpl_pred specialised to the membership operator. **) -#[universes(template)] Variant mem_pred T := Mem of pred T. (** @@ -1464,7 +1463,6 @@ Implicit Types (mp : mem_pred T). Definition Acoll : collective_pred T := [pred x | ...]. as the collective_pred_of_simpl is _not_ convertible to pred_of_simpl. **) -#[universes(template)] Structure registered_applicative_pred p := RegisteredApplicativePred { applicative_pred_value :> pred T; _ : applicative_pred_value = p @@ -1473,21 +1471,18 @@ Definition ApplicativePred p := RegisteredApplicativePred (erefl p). Canonical applicative_pred_applicative sp := ApplicativePred (applicative_pred_of_simpl sp). -#[universes(template)] Structure manifest_simpl_pred p := ManifestSimplPred { simpl_pred_value :> simpl_pred T; _ : simpl_pred_value = SimplPred p }. Canonical expose_simpl_pred p := ManifestSimplPred (erefl (SimplPred p)). -#[universes(template)] Structure manifest_mem_pred p := ManifestMemPred { mem_pred_value :> mem_pred T; _ : mem_pred_value = Mem [eta p] }. Canonical expose_mem_pred p := ManifestMemPred (erefl (Mem [eta p])). -#[universes(template)] Structure applicative_mem_pred p := ApplicativeMemPred {applicative_mem_pred_value :> manifest_mem_pred p}. Canonical check_applicative_mem_pred p (ap : registered_applicative_pred p) := @@ -1538,7 +1533,6 @@ End PredicateSimplification. (** Qualifiers and keyed predicates. **) -#[universes(template)] Variant qualifier (q : nat) T := Qualifier of {pred T}. Coercion has_quality n T (q : qualifier n T) : {pred T} := @@ -1573,7 +1567,6 @@ Variable T : Type. Variant pred_key (p : {pred T}) := DefaultPredKey. Variable p : {pred T}. -#[universes(template)] Structure keyed_pred (k : pred_key p) := PackKeyedPred {unkey_pred :> {pred T}; _ : unkey_pred =i p}. @@ -1605,7 +1598,6 @@ Section KeyedQualifier. Variables (T : Type) (n : nat) (q : qualifier n T). -#[universes(template)] Structure keyed_qualifier (k : pred_key q) := PackKeyedQualifier {unkey_qualifier; _ : unkey_qualifier = q}. Definition KeyedQualifier k := PackKeyedQualifier k (erefl q). diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 33e9f871fd..dbb60e6712 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -181,7 +181,6 @@ let option_assert_get o msg = (** Constructors for rawconstr *) open Glob_term -open Decl_kinds let mkRHole = DAst.make @@ GHole (Evar_kinds.InternalHole, Namegen.IntroAnonymous, None) @@ -681,6 +680,10 @@ let pf_type_id gl t = Id.of_string (Namegen.hdchar (pf_env gl) (project gl) t) let pfe_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty +let pfe_new_type gl = + let sigma, env, it = project gl, pf_env gl, sig_it gl in + let sigma,t = Evarutil.new_Type sigma in + re_sig it sigma, t let pfe_type_relevance_of gl t = let gl, ty = pfe_type_of gl t in gl, ty, pf_apply Retyping.relevance_of_term gl t diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index e920bc318a..db1d2d456e 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -205,6 +205,7 @@ val pf_type_of : val pfe_type_of : Goal.goal Evd.sigma -> EConstr.t -> Goal.goal Evd.sigma * EConstr.types +val pfe_new_type : Goal.goal Evd.sigma -> Goal.goal Evd.sigma * EConstr.types val pfe_type_relevance_of : Goal.goal Evd.sigma -> EConstr.t -> Goal.goal Evd.sigma * EConstr.types * Sorts.relevance diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index 71abafc22f..9ebdf71329 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -209,7 +209,6 @@ Register abstract_key as plugins.ssreflect.abstract_key. Register abstract as plugins.ssreflect.abstract. (** Constants for tactic-views **) -#[universes(template)] Inductive external_view : Type := tactic_view of Type. (** diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index aa1316f15e..742890637a 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -109,6 +109,11 @@ let congrtac ((n, t), ty) ist gl = loop 1 in tclTHEN (refine_with cf) (tclTRY (Proofview.V82.of_tactic Tactics.reflexivity)) gl +let pf_typecheck t gl = + let it = sig_it gl in + let sigma,_ = pf_type_of gl t in + re_sig [it] sigma + let newssrcongrtac arg ist gl = ppdebug(lazy Pp.(str"===newcongr===")); ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); @@ -128,17 +133,23 @@ let newssrcongrtac arg ist gl = x, re_sig si sigma in let arr, gl = pf_mkSsrConst "ssr_congr_arrow" gl in let ssr_congr lr = EConstr.mkApp (arr, lr) in + let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in (* here the two cases: simple equality or arrow *) - let equality, _, eq_args, gl' = - let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in - pf_saturate gl (EConstr.of_constr eq) 3 in + let equality, _, eq_args, gl' = pf_saturate gl (EConstr.of_constr eq) 3 in tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) ty) ist) (fun () -> - let lhs, gl' = mk_evar gl EConstr.mkProp in let rhs, gl' = mk_evar gl' EConstr.mkProp in + let gl', t_lhs = pfe_new_type gl in + let gl', t_rhs = pfe_new_type gl' in + let lhs, gl' = mk_evar gl' t_lhs in + let rhs, gl' = mk_evar gl' t_rhs in let arrow = EConstr.mkArrow lhs Sorts.Relevant (EConstr.Vars.lift 1 rhs) in tclMATCH_GOAL (arrow, gl') (fun gl' -> [|fs gl' lhs;fs gl' rhs|]) - (fun lr -> tclTHEN (Proofview.V82.of_tactic (Tactics.apply (ssr_congr lr))) (congrtac (arg, mkRType) ist)) + (fun lr -> + let a = ssr_congr lr in + tclTHENLIST [ pf_typecheck a + ; Proofview.V82.of_tactic (Tactics.apply a) + ; congrtac (arg, mkRType) ist ]) (fun _ _ -> errorstrm Pp.(str"Conclusion is not an equality nor an arrow"))) gl @@ -336,17 +347,21 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ let sigma, p = (* The resulting goal *) Evarutil.new_evar env sigma (beta (EConstr.Vars.subst1 new_rdx pred)) in let pred = EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdx_ty pred in - let elim, gl = - let ((kn, i) as ind, _), unfolded_c_ty = pf_reduce_to_quantified_ind gl c_ty in + let sigma, elim = let sort = elimination_sort_of_goal gl in - let elim, gl = pf_fresh_global (Indrec.lookup_eliminator env ind sort) gl in - if dir = R2L then elim, gl else (* taken from Coq's rewrite *) - let elim, _ = destConst elim in - let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical elim)) in - let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in - let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make2 mp l')) in - mkConst c1', gl in - let elim = EConstr.of_constr elim in + match Equality.eq_elimination_ref (dir = L2R) sort with + | Some r -> Evd.fresh_global env sigma r + | None -> + let ((kn, i) as ind, _), unfolded_c_ty = Tacred.reduce_to_quantified_ind env sigma c_ty in + let sort = elimination_sort_of_goal gl in + let sigma, elim = Evd.fresh_global env sigma (Indrec.lookup_eliminator env ind sort) in + if dir = R2L then sigma, elim else + let elim, _ = EConstr.destConst sigma elim in + let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical elim)) in + let l' = Label.of_id (Nameops.add_suffix (Label.to_id l) "_r") in + let c1' = Global.constant_of_delta_kn (Constant.canonical (Constant.make2 mp l')) in + sigma, EConstr.of_constr (mkConst c1') + in let proof = EConstr.mkApp (elim, [| rdx_ty; new_rdx; pred; p; rdx; c |]) in (* We check the proof is well typed *) let sigma, proof_ty = @@ -491,7 +506,8 @@ let rwprocess_rule dir rule gl = | _ -> let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in EConstr.mkApp (pi2, ra), sigma in - if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.(lib_ref "core.True.type"))) then + let sigma,trty = Evd.fresh_global env sigma Coqlib.(lib_ref "core.True.type") in + if EConstr.eq_constr sigma a.(0) trty then let s, sigma = sr sigma 2 in loop (converse_dir d) sigma s a.(1) rs 0 else diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index 5e600362b4..0ce3752a51 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -391,19 +391,19 @@ Notation "@^~ x" := (fun f => f x) : fun_scope. Definitions and notation for explicit functions with simplification, i.e., which simpl and /= beta expand (this is complementary to nosimpl). **) +#[universes(template)] +Variant simpl_fun (aT rT : Type) := SimplFun of aT -> rT. + Section SimplFun. Variables aT rT : Type. -#[universes(template)] -Variant simpl_fun := SimplFun of aT -> rT. +Definition fun_of_simpl (f : simpl_fun aT rT) := fun x => let: SimplFun lam := f in lam x. -Definition fun_of_simpl f := fun x => let: SimplFun lam := f in lam x. +End SimplFun. Coercion fun_of_simpl : simpl_fun >-> Funclass. -End SimplFun. - Notation "[ 'fun' : T => E ]" := (SimplFun (fun _ : T => E)) : fun_scope. Notation "[ 'fun' x => E ]" := (SimplFun (fun x => E)) : fun_scope. Notation "[ 'fun' x y => E ]" := (fun x => [fun y => E]) : fun_scope. diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index c09250ade5..a1f707ffa8 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -32,7 +32,6 @@ open Ppconstr open Namegen open Tactypes -open Decl_kinds open Constrexpr open Constrexpr_ops @@ -235,7 +234,7 @@ let pr_ssrsimpl _ _ _ = pr_simpl let wit_ssrsimplrep = add_genarg "ssrsimplrep" (fun env sigma -> pr_simpl) -let test_ssrslashnum b1 b2 strm = +let test_ssrslashnum b1 b2 _ strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "/" -> (match Util.stream_nth 1 strm with @@ -276,8 +275,8 @@ let test_ssrslashnum11 = test_ssrslashnum true true let test_ssrslashnum01 = test_ssrslashnum false true let test_ssrslashnum00 = test_ssrslashnum false false -let negate_parser f x = - let rc = try Some (f x) with Stream.Failure -> None in +let negate_parser f tok x = + let rc = try Some (f tok x) with Stream.Failure -> None in match rc with | None -> () | Some _ -> raise Stream.Failure @@ -385,7 +384,6 @@ open Pltac ARGUMENT EXTEND ssrindex PRINTED BY { pr_ssrindex } INTERPRETED BY { interp_index } -| [ int_or_var(i) ] -> { mk_index ~loc i } END @@ -475,7 +473,7 @@ END (* Old kinds of terms *) -let input_ssrtermkind strm = match Util.stream_nth 0 strm with +let input_ssrtermkind _ strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> xInParens | Tok.KEYWORD "@" -> xWithAt | _ -> xNoFlag @@ -484,7 +482,7 @@ let ssrtermkind = Pcoq.Entry.of_parser "ssrtermkind" input_ssrtermkind (* New kinds of terms *) -let input_term_annotation strm = +let input_term_annotation _ strm = match Stream.npeek 2 strm with | Tok.KEYWORD "(" :: Tok.KEYWORD "(" :: _ -> `DoubleParens | Tok.KEYWORD "(" :: _ -> `Parens @@ -523,7 +521,6 @@ ARGUMENT EXTEND ssrterm GLOBALIZED BY { glob_ssrterm } SUBSTITUTED BY { subst_ssrterm } RAW_PRINTED BY { pr_ssrterm } GLOB_PRINTED BY { pr_ssrterm } -| [ "YouShouldNotTypeThis" constr(c) ] -> { mk_lterm c } END GRAMMAR EXTEND Gram @@ -570,7 +567,6 @@ let pr_ssrbwdview _ _ _ = pr_view ARGUMENT EXTEND ssrbwdview TYPED AS ssrterm list PRINTED BY { pr_ssrbwdview } -| [ "YouShouldNotTypeThis" ] -> { [] } END (* Pcoq *) @@ -594,7 +590,6 @@ let pr_ssrfwdview _ _ _ = pr_view2 ARGUMENT EXTEND ssrfwdview TYPED AS ast_closure_term list PRINTED BY { pr_ssrfwdview } -| [ "YouShouldNotTypeThis" ] -> { [] } END (* Pcoq *) @@ -751,7 +746,7 @@ let pushIPatNoop = function | pats :: orpat -> (IPatNoop :: pats) :: orpat | [] -> [] -let test_ident_no_do strm = +let test_ident_no_do _ strm = match Util.stream_nth 0 strm with | Tok.IDENT s when s <> "do" -> () | _ -> raise Stream.Failure @@ -762,7 +757,6 @@ let test_ident_no_do = } ARGUMENT EXTEND ident_no_do PRINTED BY { fun _ _ _ -> Names.Id.print } -| [ "YouShouldNotTypeThis" ident(id) ] -> { id } END @@ -830,7 +824,7 @@ END { -let reject_ssrhid strm = +let reject_ssrhid _ strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "[" -> (match Util.stream_nth 1 strm with @@ -840,13 +834,13 @@ let reject_ssrhid strm = let test_nohidden = Pcoq.Entry.of_parser "test_ssrhid" reject_ssrhid -let rec reject_binder crossed_paren k s = +let rec reject_binder crossed_paren k tok s = match try Some (Util.stream_nth k s) with Stream.Failure -> None with - | Some (Tok.KEYWORD "(") when not crossed_paren -> reject_binder true (k+1) s - | Some (Tok.IDENT _) when crossed_paren -> reject_binder true (k+1) s + | Some (Tok.KEYWORD "(") when not crossed_paren -> reject_binder true (k+1) tok s + | Some (Tok.IDENT _) when crossed_paren -> reject_binder true (k+1) tok s | Some (Tok.KEYWORD ":" | Tok.KEYWORD ":=") when crossed_paren -> raise Stream.Failure | Some (Tok.KEYWORD ")") when crossed_paren -> raise Stream.Failure @@ -857,7 +851,6 @@ let _test_nobinder = Pcoq.Entry.of_parser "test_nobinder" (reject_binder false 0 } ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY { pr_ssripat } - | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> { IPatCase(Regular x) } END (* Pcoq *) @@ -985,7 +978,6 @@ let pr_ssrintrosarg env sigma _ _ prt (tac, ipats) = ARGUMENT EXTEND ssrintrosarg TYPED AS (tactic * ssrintros) PRINTED BY { pr_ssrintrosarg env sigma } -| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> { arg, ipats } END { @@ -1013,7 +1005,7 @@ END { -let accept_ssrfwdid strm = +let accept_ssrfwdid _ strm = match stream_nth 0 strm with | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm | _ -> raise Stream.Failure @@ -1344,20 +1336,20 @@ ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinde | [ ssrbvar(bv) ] -> { let { CAst.loc=xloc } as x = bvar_lname bv in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) } + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Glob_term.Explicit,mkCHole xloc)],mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ")" ] -> { let { CAst.loc=xloc } as x = bvar_lname bv in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) } + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Glob_term.Explicit,mkCHole xloc)],mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> { let x = bvar_lname bv in (FwdPose, [BFdecl 1]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x], Default Explicit, t)], mkCHole (Some loc)) } + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x], Default Glob_term.Explicit, t)], mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> { let xs = List.map bvar_lname (bv :: bvs) in let n = List.length xs in (FwdPose, [BFdecl n]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum (xs, Default Explicit, t)], mkCHole (Some loc)) } + CAst.make ~loc @@ CLambdaN ([CLocalAssum (xs, Default Glob_term.Explicit, t)], mkCHole (Some loc)) } | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> { (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, Some t, mkCHole (Some loc)) } | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> @@ -1369,7 +1361,7 @@ GRAMMAR EXTEND Gram ssrbinder: [ [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> { (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Explicit,c)],mkCHole (Some loc)) } ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Glob_term.Explicit,c)],mkCHole (Some loc)) } ] ]; END @@ -1398,7 +1390,7 @@ let push_binders c2 bs = let rec fix_binders = let open CAst in function | (_, { v = CLambdaN ([CLocalAssum(xs, _, t)], _) } ) :: bs -> - CLocalAssum (xs, Default Explicit, t) :: fix_binders bs + CLocalAssum (xs, Default Glob_term.Explicit, t) :: fix_binders bs | (_, { v = CLetIn (x, v, oty, _) } ) :: bs -> CLocalDef (x, v, oty) :: fix_binders bs | _ -> [] @@ -1528,7 +1520,7 @@ let intro_id_to_binder = List.map (function | IPatId id -> let { CAst.loc=xloc } as x = bvar_lname (mkCVar id) in (FwdPose, [BFvar]), - CAst.make @@ CLambdaN ([CLocalAssum([x], Default Explicit, mkCHole xloc)], + CAst.make @@ CLambdaN ([CLocalAssum([x], Default Glob_term.Explicit, mkCHole xloc)], mkCHole None) | _ -> anomaly "non-id accepted as binder") @@ -1597,7 +1589,7 @@ END let sq_brace_tacnames = ["first"; "solve"; "do"; "rewrite"; "have"; "suffices"; "wlog"] (* "by" is a keyword *) -let accept_ssrseqvar strm = +let accept_ssrseqvar _ strm = match stream_nth 0 strm with | Tok.IDENT id when not (List.mem id sq_brace_tacnames) -> accept_before_syms_or_ids ["["] ["first";"last"] strm @@ -1691,7 +1683,7 @@ let ssr_id_of_string loc s = ^ "Scripts with explicit references to anonymous variables are fragile.")) end; Id.of_string s -let ssr_null_entry = Pcoq.Entry.of_parser "ssr_null" (fun _ -> ()) +let ssr_null_entry = Pcoq.Entry.of_parser "ssr_null" (fun _ _ -> ()) } @@ -1711,14 +1703,6 @@ let _ = add_internal_name (is_tagged perm_tag) (** Tactical extensions. *) -(* The TACTIC EXTEND facility can't be used for defining new user *) -(* tacticals, because: *) -(* - the concrete syntax must start with a fixed string *) -(* We use the following workaround: *) -(* - We use the (unparsable) "YouShouldNotTypeThis" token for tacticals that *) -(* don't start with a token, then redefine the grammar and *) -(* printer using GEXTEND and set_pr_ssrtac, respectively. *) - { type ssrargfmt = ArgSsr of string | ArgSep of string @@ -2002,7 +1986,7 @@ END { -let accept_ssreqid strm = +let accept_ssreqid _ strm = match Util.stream_nth 0 strm with | Tok.IDENT _ -> accept_before_syms [":"] strm | Tok.KEYWORD ":" -> () @@ -2243,8 +2227,6 @@ END (** The "congr" tactic *) -(* type ssrcongrarg = open_constr * (int * constr) *) - { let pr_ssrcongrarg _ _ _ ((n, f), dgens) = @@ -2423,7 +2405,7 @@ let lbrace = Char.chr 123 (** Workaround to a limitation of coqpp *) let test_ssr_rw_syntax = - let test strm = + let test _ strm = if not !ssr_rw_syntax then raise Stream.Failure else if is_ssr_loaded () then () else match Util.stream_nth 0 strm with @@ -2634,7 +2616,7 @@ END { -let accept_idcomma strm = +let accept_idcomma _ strm = match stream_nth 0 strm with | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm | _ -> raise Stream.Failure diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 0adabb0673..064ea0a3e3 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -27,7 +27,6 @@ open Notation_ops open Notation_term open Glob_term open Stdarg -open Decl_kinds open Pp open Ppconstr open Printer @@ -280,7 +279,7 @@ let interp_search_notation ?loc tag okey = Feedback.msg_warning (hov 4 (qtag "In" ++ str "also occurs in " ++ pr_ntns')) end; ntn | [ntn] -> - Feedback.msg_info (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn + Feedback.msg_notice (hov 4 (qtag "In" ++ str "is part of notation " ++ pr_ntn ntn)); ntn | ntns' -> let e = str "occurs in" ++ spc() ++ pr_and_list pr_ntn ntns' in err (hov 4 (str "ambiguous: " ++ qtag "in" ++ e)) in @@ -298,7 +297,7 @@ let interp_search_notation ?loc tag okey = let rbody = glob_constr_of_notation_constr ?loc body in let m_body = hov 0 (Constrextern.without_symbols prl_glob_constr rbody) in let m = m_sc ++ pr_ntn ntn_pat ++ spc () ++ str "denotes " ++ m_body in - Feedback.msg_info (hov 0 m) in + Feedback.msg_notice (hov 0 m) in if List.length !scs > 1 then let scs' = List.remove (=) sc !scs in let w = pr_ntn ntn ++ str " is also defined " ++ pr_scs scs' in @@ -465,7 +464,7 @@ let interp_modloc mr = let ssrdisplaysearch gr env t = let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in - Feedback.msg_info (hov 2 pr_res ++ fnl ()) + Feedback.msg_notice (hov 2 pr_res ++ fnl ()) } @@ -560,7 +559,7 @@ END let print_view_hints env sigma kind l = let pp_viewname = str "Hint View" ++ pr_viewpos (Some kind) ++ str " " in let pp_hints = pr_list spc (pr_rawhintref env sigma) l in - Feedback.msg_info (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) + Feedback.msg_notice (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) } diff --git a/plugins/ssrmatching/g_ssrmatching.mlg b/plugins/ssrmatching/g_ssrmatching.mlg index d920ea9a46..42b800b596 100644 --- a/plugins/ssrmatching/g_ssrmatching.mlg +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -66,7 +66,7 @@ END { -let input_ssrtermkind strm = match Util.stream_nth 0 strm with +let input_ssrtermkind _ strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> '(' | Tok.KEYWORD "@" -> '@' | _ -> ' ' diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 17db25660f..4d7a04f5ee 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -36,7 +36,6 @@ open Ppconstr open Printer open Globnames open Namegen -open Decl_kinds open Evar_kinds open Constrexpr open Constrexpr_ops diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml index a148a3bc73..9808c61255 100644 --- a/plugins/syntax/numeral.ml +++ b/plugins/syntax/numeral.ml @@ -112,7 +112,7 @@ let vernac_numeral_notation local ty f g scope opts = let cty = mkRefC ty in let app x y = mkAppC (x,[y]) in let arrow x y = - mkProdC ([CAst.make Anonymous],Default Decl_kinds.Explicit, x, y) + mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) in let opt r = app (mkRefC (q_option ())) r in let constructors = get_constructors tyc in diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 649b51cb0e..66db924051 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -101,10 +101,11 @@ let bigint_of_z c = match DAst.get c with let rdefinitions = ["Coq";"Reals";"Rdefinitions"] let r_modpath = MPfile (make_dir rdefinitions) +let r_base_modpath = MPdot (r_modpath, Label.make "RbaseSymbolsImpl") let r_path = make_path rdefinitions "R" let glob_IZR = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") -let glob_Rmult = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "Rmult") +let glob_Rmult = GlobRef.ConstRef (Constant.make2 r_base_modpath @@ Label.make "Rmult") let glob_Rdiv = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "Rdiv") let binintdef = ["Coq";"ZArith";"BinIntDef"] diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index 8c0f9a3339..c92acb0f55 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -61,7 +61,7 @@ let vernac_string_notation local ty f g scope = let of_ty = Smartlocate.global_with_alias g in let cty = cref ty in let arrow x y = - mkProdC ([CAst.make Anonymous],Default Decl_kinds.Explicit, x, y) + mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) in let constructors = get_constructors tyc in (* Check the type of f *) diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 534c0ca20b..a86d237164 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -47,7 +47,7 @@ let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) when not (isVarRef c && Lib.is_in_section c) -> (try let vars = Lib.variable_section_segment_of_reference c in - let var_names = List.map (fst %> NamedDecl.get_id %> Name.mk_name) vars in + let var_names = List.map (NamedDecl.get_id %> Name.mk_name) vars in let names' = var_names @ names in Some (ReqGlobal (c, names), (c, names')) with Not_found -> Some req) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 2061b41292..e8c83c7de9 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -25,7 +25,6 @@ open Namegen open Libnames open Globnames open Mod_subst -open Decl_kinds open Context.Named.Declaration open Ltac_pretype diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index cc9f520583..9eb014aa62 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -57,10 +57,10 @@ val detype_rel_context : 'a delay -> ?lax:bool -> constr option -> Id.Set.t -> ( val share_pattern_names : (Id.Set.t -> names_context -> 'c -> Pattern.constr_pattern -> 'a) -> int -> - (Name.t * Decl_kinds.binding_kind * 'b option * 'a) list -> + (Name.t * binding_kind * 'b option * 'a) list -> Id.Set.t -> names_context -> 'c -> Pattern.constr_pattern -> Pattern.constr_pattern -> - (Name.t * Decl_kinds.binding_kind * 'b option * 'a) list * 'a * 'a + (Name.t * binding_kind * 'b option * 'a) list * 'a * 'a val detype_closed_glob : ?lax:bool -> bool -> Id.Set.t -> env -> evar_map -> closed_glob_constr -> glob_constr diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index be21a3a60d..288a349b8b 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -773,7 +773,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (* Evar must be undefined since we have flushed evars *) let () = if !debug_unification then let open Pp in - Feedback.msg_notice (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in + Feedback.msg_debug (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in match (flex_kind_of_term flags env evd term1 sk1, flex_kind_of_term flags env evd term2 sk2) with | Flexible (sp1,al1), Flexible (sp2,al2) -> @@ -1569,7 +1569,7 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in let () = if !debug_unification then let open Pp in - Feedback.msg_notice (v 0 (str "Heuristic:" ++ spc () ++ + Feedback.msg_debug (v 0 (str "Heuristic:" ++ spc () ++ Termops.Internal.print_constr_env env evd t1 ++ cut () ++ Termops.Internal.print_constr_env env evd t2 ++ cut ())) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 6bde3dfd81..93f5923474 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -67,9 +67,9 @@ let glob_sort_eq u1 u2 = match u1, u2 with | (UNamed _ | UAnonymous _), _ -> false let binding_kind_eq bk1 bk2 = match bk1, bk2 with - | Decl_kinds.Explicit, Decl_kinds.Explicit -> true - | Decl_kinds.Implicit, Decl_kinds.Implicit -> true - | (Decl_kinds.Explicit | Decl_kinds.Implicit), _ -> false + | Explicit, Explicit -> true + | Implicit, Implicit -> true + | (Explicit | Implicit), _ -> false let case_style_eq s1 s2 = let open Constr in match s1, s2 with | LetStyle, LetStyle -> true diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 467b72e520..37aa31d094 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -48,6 +48,9 @@ val mkGApp : ?loc:Loc.t -> 'a glob_constr_g -> 'a glob_constr_g -> 'a glob_const val map_glob_constr : (glob_constr -> glob_constr) -> glob_constr -> glob_constr +(** Equality on [binding_kind] *) +val binding_kind_eq : binding_kind -> binding_kind -> bool + (** Ensure traversal from left to right *) val map_glob_constr_left_to_right : (glob_constr -> glob_constr) -> glob_constr -> glob_constr diff --git a/pretyping/glob_term.ml b/pretyping/glob_term.ml index 7c859a5332..10e9d60fd5 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -17,7 +17,6 @@ arguments and pattern-matching compilation are not. *) open Names -open Decl_kinds type existential_name = Id.t @@ -66,6 +65,8 @@ and 'a cases_pattern_g = ('a cases_pattern_r, 'a) DAst.t type cases_pattern = [ `any ] cases_pattern_g +type binding_kind = Explicit | Implicit + (** Representation of an internalized (or in other words globalized) term. *) type 'a glob_constr_r = | GRef of GlobRef.t * glob_level list option diff --git a/library/keys.ml b/pretyping/keys.ml index 9964992433..f8eecd80d4 100644 --- a/library/keys.ml +++ b/pretyping/keys.ml @@ -49,7 +49,7 @@ module KeyOrdered = struct | _, KGlob _ -> -1 | KGlob _, _ -> 1 | k, k' -> Int.compare (hash k) (hash k') - + let equal k1 k2 = match k1, k2 with | KGlob gr1, KGlob gr2 -> GlobRef.Ordered.equal gr1 gr2 @@ -69,7 +69,7 @@ let add_kv k v m = try Keymap.modify k (fun k' vs -> Keyset.add v vs) m with Not_found -> Keymap.add k (Keyset.singleton v) m -let add_keys k v = +let add_keys k v = keys := add_kv k v (add_kv v k !keys) let equiv_keys k k' = @@ -85,7 +85,7 @@ let load_keys _ (_,(ref,ref')) = let cache_keys o = load_keys 1 o -let subst_key subst k = +let subst_key subst k = match k with | KGlob gr -> KGlob (subst_global_reference subst gr) | _ -> k @@ -98,7 +98,7 @@ let discharge_key = function | x -> Some x let discharge_keys (_,(k,k')) = - match discharge_key k, discharge_key k' with + match discharge_key k, discharge_key k' with | Some x, Some y -> Some (x, y) | _ -> None @@ -124,7 +124,7 @@ let constr_key kind c = | App (f, _) -> aux f | Proj (p, _) -> KGlob (GlobRef.ConstRef (Projection.constant p)) | Cast (p, _, _) -> aux p - | Lambda _ -> KLam + | Lambda _ -> KLam | Prod _ -> KProd | Case _ -> KCase | Fix _ -> KFix @@ -132,7 +132,7 @@ let constr_key kind c = | Rel _ -> KRel | Meta _ -> raise Not_found | Evar _ -> raise Not_found - | Sort _ -> KSort + | Sort _ -> KSort | LetIn _ -> KLet | Int _ -> KInt in Some (aux c) @@ -152,10 +152,10 @@ let pr_key pr_global = function | KRel -> str"Rel" | KInt -> str"Int" -let pr_keyset pr_global v = +let pr_keyset pr_global v = prlist_with_sep spc (pr_key pr_global) (Keyset.elements v) -let pr_mapping pr_global k v = +let pr_mapping pr_global k v = pr_key pr_global k ++ str" <-> " ++ pr_keyset pr_global v let pr_keys pr_global = diff --git a/library/keys.mli b/pretyping/keys.mli index a7adf7791b..a7adf7791b 100644 --- a/library/keys.mli +++ b/pretyping/keys.mli diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 99e3c5025e..ccc3b6e83c 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -18,7 +18,6 @@ open Context open Glob_term open Pp open Mod_subst -open Decl_kinds open Pattern open Environ diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c28c3ab730..4fed526cfc 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -1193,7 +1193,7 @@ let path_convertible env sigma p q = let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in let mkGVar id = DAst.make @@ Glob_term.GVar(id) in let mkGApp(rt,rtl) = DAst.make @@ Glob_term.GApp(rt,rtl) in - let mkGLambda(n,t,b) = DAst.make @@ Glob_term.GLambda(n,Decl_kinds.Explicit,t,b) in + let mkGLambda(n,t,b) = DAst.make @@ Glob_term.GLambda(n,Explicit,t,b) in let mkGHole () = DAst.make @@ Glob_term.GHole(Evar_kinds.BinderType Anonymous,Namegen.IntroAnonymous,None) in let path_to_gterm p = match p with diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 34a6cecc95..0ca39f0404 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -35,4 +35,5 @@ Indrec GlobEnv Cases Pretyping +Keys Unification diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 7362955eb7..df161b747a 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -918,7 +918,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let () = if !debug_RAKAM then let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in - Feedback.msg_notice + Feedback.msg_debug (h 0 (str "<<" ++ pr x ++ str "|" ++ cut () ++ Cst_stack.pr env sigma cst_l ++ str "|" ++ cut () ++ Stack.pr pr stack ++ @@ -927,7 +927,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let c0 = EConstr.kind sigma x in let fold () = let () = if !debug_RAKAM then - let open Pp in Feedback.msg_notice (str "<><><><><>") in + let open Pp in Feedback.msg_debug (str "<><><><><>") in ((EConstr.of_kind c0, stack),cst_l) in match c0 with diff --git a/pretyping/unification.ml b/pretyping/unification.ml index a9eb43e573..4d34139ec0 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -254,6 +254,10 @@ let unify_r2l x = x let sort_eqns = unify_r2l *) +type allowed_evars = +| AllowAll +| AllowFun of (Evar.t -> bool) + type core_unify_flags = { modulo_conv_on_closed_terms : TransparentState.t option; (* What this flag controls was activated with all constants transparent, *) @@ -287,8 +291,8 @@ type core_unify_flags = { (* This allowed for instance to unify "forall x:?A, ?B x" with "A' -> B'" *) (* when ?B is a Meta. *) - frozen_evars : Evar.Set.t; - (* Evars of this set are considered axioms and never instantiated *) + allowed_evars : allowed_evars; + (* Evars that are allowed to be instantiated *) (* Useful e.g. for autorewrite *) restrict_conv_on_strict_subterms : bool; @@ -339,7 +343,7 @@ let default_core_unify_flags () = check_applied_meta_types = true; use_pattern_unification = true; use_meta_bound_pattern_unification = true; - frozen_evars = Evar.Set.empty; + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; modulo_betaiota = true; modulo_eta = true; @@ -417,6 +421,10 @@ let default_no_delta_unify_flags ts = resolve_evars = false } +let allow_new_evars sigma = + let undefined = Evd.undefined_map sigma in + AllowFun (fun evk -> not (Evar.Map.mem evk undefined)) + (* Default flags for looking for subterms in elimination tactics *) (* Not used in practice at the current date, to the exception of *) (* allow_K) because only closed terms are involved in *) @@ -424,9 +432,7 @@ let default_no_delta_unify_flags ts = (* call w_unify for induction/destruct/case/elim (13/6/2011) *) let elim_core_flags sigma = { (default_core_unify_flags ()) with modulo_betaiota = false; - frozen_evars = - fold_undefined (fun evk _ evars -> Evar.Set.add evk evars) - sigma Evar.Set.empty; + allowed_evars = allow_new_evars sigma; } let elim_flags_evars sigma = @@ -600,8 +606,12 @@ let do_reduce ts (env, nb) sigma c = Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state ts env sigma (c, Stack.empty)) +let is_evar_allowed flags evk = match flags.allowed_evars with +| AllowAll -> true +| AllowFun f -> f evk + let isAllowedEvar sigma flags c = match EConstr.kind sigma c with - | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) + | Evar (evk,_) -> is_evar_allowed flags evk | _ -> false @@ -749,7 +759,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e evarsubst) else error_cannot_unify_local curenv sigma (m,n,cM) | Evar (evk,_ as ev), Evar (evk',_) - when not (Evar.Set.mem evk flags.frozen_evars) + when is_evar_allowed flags evk && Evar.equal evk evk' -> begin match constr_cmp cv_pb env sigma flags cM cN with | Some sigma -> @@ -758,14 +768,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e sigma,metasubst,((curenv,ev,cN)::evarsubst) end | Evar (evk,_ as ev), _ - when not (Evar.Set.mem evk flags.frozen_evars) + when is_evar_allowed flags evk && not (occur_evar sigma evk cN) -> let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in if Int.Set.subset cnvars cmvars then sigma,metasubst,((curenv,ev,cN)::evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | _, Evar (evk,_ as ev) - when not (Evar.Set.mem evk flags.frozen_evars) + when is_evar_allowed flags evk && not (occur_evar sigma evk cM) -> let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in if Int.Set.subset cmvars cnvars then @@ -1554,7 +1564,7 @@ let default_matching_core_flags sigma = check_applied_meta_types = true; use_pattern_unification = false; use_meta_bound_pattern_unification = false; - frozen_evars = Evar.Map.domain (Evd.undefined_map sigma); + allowed_evars = allow_new_evars sigma; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = false; diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 0ee71246d8..d7ddbcb721 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -13,6 +13,10 @@ open EConstr open Environ open Evd +type allowed_evars = +| AllowAll +| AllowFun of (Evar.t -> bool) + type core_unify_flags = { modulo_conv_on_closed_terms : TransparentState.t option; use_metas_eagerly_in_conv_on_closed_terms : bool; @@ -22,7 +26,7 @@ type core_unify_flags = { check_applied_meta_types : bool; use_pattern_unification : bool; use_meta_bound_pattern_unification : bool; - frozen_evars : Evar.Set.t; + allowed_evars : allowed_evars; restrict_conv_on_strict_subterms : bool; modulo_betaiota : bool; modulo_eta : bool; diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index aea4f23205..5ed96dd5e3 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -21,7 +21,6 @@ open Glob_term open Constrexpr open Constrexpr_ops open Notation_gram -open Decl_kinds open Namegen (*i*) diff --git a/printing/prettyp.ml b/printing/prettyp.ml index f82b9cef68..fb0b1eca8d 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -35,14 +35,14 @@ module NamedDecl = Context.Named.Declaration type object_pr = { print_inductive : MutInd.t -> UnivNames.univ_name_list option -> Pp.t; - print_constant_with_infos : Constant.t -> UnivNames.univ_name_list option -> Pp.t; + print_constant_with_infos : Opaqueproof.indirect_accessor -> Constant.t -> UnivNames.univ_name_list option -> Pp.t; print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; print_syntactic_def : env -> KerName.t -> Pp.t; print_module : bool -> ModPath.t -> Pp.t; print_modtype : ModPath.t -> Pp.t; print_named_decl : env -> Evd.evar_map -> Constr.named_declaration -> Pp.t; - print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; - print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; + print_library_entry : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; + print_context : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } @@ -221,14 +221,22 @@ let print_if_is_coercion ref = (*******************) (* *) +let pr_template_variables = function + | [] -> mt () + | vars -> str "on " ++ prlist_with_sep spc UnivNames.pr_with_global_universes vars + let print_polymorphism ref = let poly = Global.is_polymorphic ref in let template_poly = Global.is_template_polymorphic ref in - [ pr_global ref ++ str " is " ++ str - (if poly then "universe polymorphic" + let template_checked = Global.is_template_checked ref in + let template_variables = Global.get_template_polymorphic_variables ref in + [ pr_global ref ++ str " is " ++ + (if poly then str "universe polymorphic" else if template_poly then - "template universe polymorphic" - else "not universe polymorphic") ] + (if not template_checked then str "assumed " else mt()) ++ + str "template universe polymorphic " + ++ h 0 (pr_template_variables template_variables) + else str "not universe polymorphic") ] let print_type_in_type ref = let unsafe = Global.is_type_in_type ref in @@ -552,10 +560,10 @@ let print_instance sigma cb = let inst = Univ.make_abstract_instance univs in pr_universe_instance sigma inst else mt() - -let print_constant with_values sep sp udecl = + +let print_constant indirect_accessor with_values sep sp udecl = let cb = Global.lookup_constant sp in - let val_0 = Global.body_of_constant_body Library.indirect_accessor cb in + let val_0 = Global.body_of_constant_body indirect_accessor cb in let typ = cb.const_type in let univs = let open Univ in @@ -563,7 +571,7 @@ let print_constant with_values sep sp udecl = match cb.const_body with | Undef _ | Def _ | Primitive _ -> cb.const_universes | OpaqueDef o -> - let body_uctxs = Opaqueproof.force_constraints Library.indirect_accessor otab o in + let body_uctxs = Opaqueproof.force_constraints indirect_accessor otab o in match cb.const_universes with | Monomorphic ctx -> Monomorphic (ContextSet.union body_uctxs ctx) @@ -593,8 +601,8 @@ let print_constant with_values sep sp udecl = (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++ Printer.pr_universes sigma univs ?priv) -let gallina_print_constant_with_infos sp udecl = - print_constant true " = " sp udecl ++ +let gallina_print_constant_with_infos indirect_accessor sp udecl = + print_constant indirect_accessor true " = " sp udecl ++ with_line_skip (print_name_infos (GlobRef.ConstRef sp)) let gallina_print_syntactic_def env kn = @@ -610,7 +618,7 @@ let gallina_print_syntactic_def env kn = Constrextern.without_specific_symbols [Notation.SynDefRule kn] (pr_glob_constr_env env) c) -let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = +let gallina_print_leaf_entry indirect_accessor env sigma with_values ((sp,kn as oname),lobj) = let sep = if with_values then " = " else " : " in match lobj with | AtomicObject o -> @@ -621,7 +629,7 @@ let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = constraints *) (try Some(print_named_decl env sigma (basename sp)) with Not_found -> None) | (_,"CONSTANT") -> - Some (print_constant with_values sep (Constant.make1 kn) None) + Some (print_constant indirect_accessor with_values sep (Constant.make1 kn) None) | (_,"INDUCTIVE") -> Some (gallina_print_inductive (MutInd.make1 kn) None) | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"| @@ -637,24 +645,24 @@ let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = Some (print_modtype (MPdot (mp,l))) | _ -> None -let gallina_print_library_entry env sigma with_values ent = +let gallina_print_library_entry indirect_accessor env sigma with_values ent = let pr_name (sp,_) = Id.print (basename sp) in match ent with | (oname,Lib.Leaf lobj) -> - gallina_print_leaf_entry env sigma with_values (oname,lobj) + gallina_print_leaf_entry indirect_accessor env sigma with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> - Some (str " >>>>>>> Section " ++ pr_name oname) + Some (str " >>>>>>> Section " ++ pr_name oname) | (_,Lib.CompilingLibrary { Nametab.obj_dir; _ }) -> - Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) + Some (str " >>>>>>> Library " ++ DirPath.print obj_dir) | (oname,Lib.OpenedModule _) -> - Some (str " >>>>>>> Module " ++ pr_name oname) + Some (str " >>>>>>> Module " ++ pr_name oname) -let gallina_print_context env sigma with_values = +let gallina_print_context indirect_accessor env sigma with_values = let rec prec n = function | h::rest when Option.is_empty n || Option.get n > 0 -> - (match gallina_print_library_entry env sigma with_values h with - | None -> prec n rest - | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) + (match gallina_print_library_entry indirect_accessor env sigma with_values h with + | None -> prec n rest + | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) | _ -> mt () in prec @@ -712,10 +720,10 @@ let print_safe_judgment env sigma j = (*********************) (* *) -let print_full_context env sigma = print_context env sigma true None (Lib.contents ()) -let print_full_context_typ env sigma = print_context env sigma false None (Lib.contents ()) +let print_full_context indirect_accessor env sigma = print_context indirect_accessor env sigma true None (Lib.contents ()) +let print_full_context_typ indirect_accessor env sigma = print_context indirect_accessor env sigma false None (Lib.contents ()) -let print_full_pure_context env sigma = +let print_full_pure_context ~library_accessor env sigma = let rec prec = function | ((_,kn),Lib.Leaf AtomicObject lobj)::rest -> let pp = match object_tag lobj with @@ -731,8 +739,8 @@ let print_full_pure_context env sigma = | OpaqueDef lc -> str "Theorem " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype_env env sigma typ ++ str "." ++ fnl () ++ - str "Proof " ++ pr_lconstr_env env sigma (fst (Opaqueproof.force_proof Library.indirect_accessor (Global.opaque_tables ()) lc)) - | Def c -> + str "Proof " ++ pr_lconstr_env env sigma (fst (Opaqueproof.force_proof library_accessor (Global.opaque_tables ()) lc)) + | Def c -> str "Definition " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype_env env sigma typ ++ cut () ++ str " := " ++ pr_lconstr_env env sigma (Mod_subst.force_constr c) @@ -779,11 +787,11 @@ let read_sec_context qid = let cxt = Lib.contents () in List.rev (get_cxt [] cxt) -let print_sec_context env sigma sec = - print_context env sigma true None (read_sec_context sec) +let print_sec_context indirect_accessor env sigma sec = + print_context indirect_accessor env sigma true None (read_sec_context sec) -let print_sec_context_typ env sigma sec = - print_context env sigma false None (read_sec_context sec) +let print_sec_context_typ indirect_accessor env sigma sec = + print_context indirect_accessor env sigma false None (read_sec_context sec) let maybe_error_reject_univ_decl na udecl = let open GlobRef in @@ -793,11 +801,11 @@ let maybe_error_reject_univ_decl na udecl = (* TODO Print na somehow *) user_err ~hdr:"reject_univ_decl" (str "This object does not support universe names.") -let print_any_name env sigma na udecl = +let print_any_name indirect_accessor env sigma na udecl = maybe_error_reject_univ_decl na udecl; let open GlobRef in match na with - | Term (ConstRef sp) -> print_constant_with_infos sp udecl + | Term (ConstRef sp) -> print_constant_with_infos indirect_accessor sp udecl | Term (IndRef (sp,_)) -> print_inductive sp udecl | Term (ConstructRef ((sp,_),_)) -> print_inductive sp udecl | Term (VarRef sp) -> print_section_variable env sigma sp @@ -816,34 +824,34 @@ let print_any_name env sigma na udecl = user_err ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") -let print_name env sigma na udecl = +let print_name indirect_accessor env sigma na udecl = match na with | {loc; v=Constrexpr.ByNotation (ntn,sc)} -> - print_any_name env sigma - (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) + print_any_name indirect_accessor env sigma + (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) - udecl + udecl | {loc; v=Constrexpr.AN ref} -> - print_any_name env sigma (locate_any_name ref) udecl + print_any_name indirect_accessor env sigma (locate_any_name ref) udecl -let print_opaque_name env sigma qid = +let print_opaque_name indirect_accessor env sigma qid = let open GlobRef in match Nametab.global qid with | ConstRef cst -> - let cb = Global.lookup_constant cst in - if Declareops.constant_has_body cb then - print_constant_with_infos cst None - else - user_err Pp.(str "Not a defined constant.") + let cb = Global.lookup_constant cst in + if Declareops.constant_has_body cb then + print_constant_with_infos indirect_accessor cst None + else + user_err Pp.(str "Not a defined constant.") | IndRef (sp,_) -> - print_inductive sp None + print_inductive sp None | ConstructRef cstr as gr -> - let ty, ctx = Typeops.type_of_global_in_context env gr in - let ty = EConstr.of_constr ty in - let open EConstr in - print_typed_value_in_env env sigma (mkConstruct cstr, ty) + let ty, ctx = Typeops.type_of_global_in_context env gr in + let ty = EConstr.of_constr ty in + let open EConstr in + print_typed_value_in_env env sigma (mkConstruct cstr, ty) | VarRef id -> - env |> lookup_named id |> print_named_decl env sigma + env |> lookup_named id |> print_named_decl env sigma let print_about_any ?loc env sigma k udecl = maybe_error_reject_univ_decl k udecl; @@ -880,9 +888,8 @@ let print_about env sigma na udecl = print_about_any ?loc env sigma (locate_any_name ref) udecl (* for debug *) -let inspect env sigma depth = - print_context env sigma false (Some depth) (Lib.contents ()) - +let inspect indirect_accessor env sigma depth = + print_context indirect_accessor env sigma false (Some depth) (Lib.contents ()) (*************************************************************************) (* Pretty-printing functions coming from classops.ml *) diff --git a/printing/prettyp.mli b/printing/prettyp.mli index 7485f4bd19..4299bcc880 100644 --- a/printing/prettyp.mli +++ b/printing/prettyp.mli @@ -18,22 +18,41 @@ open Libnames val assumptions_for_print : Name.t list -> Termops.names_context val print_closed_sections : bool ref -val print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t -val print_library_entry : env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option -val print_full_context : env -> Evd.evar_map -> Pp.t -val print_full_context_typ : env -> Evd.evar_map -> Pp.t -val print_full_pure_context : env -> Evd.evar_map -> Pp.t -val print_sec_context : env -> Evd.evar_map -> qualid -> Pp.t -val print_sec_context_typ : env -> Evd.evar_map -> qualid -> Pp.t +val print_context + : Opaqueproof.indirect_accessor + -> env -> Evd.evar_map + -> bool -> int option -> Lib.library_segment -> Pp.t +val print_library_entry + : Opaqueproof.indirect_accessor + -> env -> Evd.evar_map + -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option +val print_full_context + : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t +val print_full_context_typ + : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t + +val print_full_pure_context + : library_accessor:Opaqueproof.indirect_accessor + -> env + -> Evd.evar_map + -> Pp.t + +val print_sec_context + : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t +val print_sec_context_typ + : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t val print_judgment : env -> Evd.evar_map -> EConstr.unsafe_judgment -> Pp.t val print_safe_judgment : env -> Evd.evar_map -> Safe_typing.judgment -> Pp.t val print_eval : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t -val print_name : env -> Evd.evar_map -> qualid Constrexpr.or_by_notation -> - UnivNames.univ_name_list option -> Pp.t -val print_opaque_name : env -> Evd.evar_map -> qualid -> Pp.t +val print_name + : Opaqueproof.indirect_accessor + -> env -> Evd.evar_map -> qualid Constrexpr.or_by_notation + -> UnivNames.univ_name_list option -> Pp.t +val print_opaque_name + : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t val print_about : env -> Evd.evar_map -> qualid Constrexpr.or_by_notation -> UnivNames.univ_name_list option -> Pp.t val print_impargs : qualid Constrexpr.or_by_notation -> Pp.t @@ -50,7 +69,7 @@ val print_typeclasses : unit -> Pp.t val print_instances : GlobRef.t -> Pp.t val print_all_instances : unit -> Pp.t -val inspect : env -> Evd.evar_map -> int -> Pp.t +val inspect : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> int -> Pp.t (** {5 Locate} *) @@ -83,14 +102,14 @@ val print_located_other : string -> qualid -> Pp.t type object_pr = { print_inductive : MutInd.t -> UnivNames.univ_name_list option -> Pp.t; - print_constant_with_infos : Constant.t -> UnivNames.univ_name_list option -> Pp.t; + print_constant_with_infos : Opaqueproof.indirect_accessor -> Constant.t -> UnivNames.univ_name_list option -> Pp.t; print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; print_syntactic_def : env -> KerName.t -> Pp.t; print_module : bool -> ModPath.t -> Pp.t; print_modtype : ModPath.t -> Pp.t; print_named_decl : env -> Evd.evar_map -> Constr.named_declaration -> Pp.t; - print_library_entry : env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option; - print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; + print_library_entry : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option; + print_context : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } diff --git a/printing/printer.ml b/printing/printer.ml index ec1b9b8e49..328082fbc2 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -853,7 +853,10 @@ let pr_goal_emacs ~proof gid sid = type axiom = | Constant of Constant.t (* An axiom or a constant. *) | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *) - | Guarded of Constant.t (* a constant whose (co)fixpoints have been assumed to be guarded *) + | Guarded of GlobRef.t (* a constant whose (co)fixpoints have been assumed to be guarded *) + | TemplatePolymorphic of MutInd.t (* A mutually inductive definition whose template polymorphism + on parameter universes has not been checked. *) + | TypeInType of GlobRef.t (* a constant which relies on type in type *) type context_object = | Variable of Id.t (* A section variable or a Let definition *) @@ -872,10 +875,13 @@ struct Constant.CanOrd.compare k1 k2 | Positive m1 , Positive m2 -> MutInd.CanOrd.compare m1 m2 + | TemplatePolymorphic m1, TemplatePolymorphic m2 -> + MutInd.CanOrd.compare m1 m2 | Guarded k1 , Guarded k2 -> - Constant.CanOrd.compare k1 k2 + GlobRef.Ordered.compare k1 k2 | _ , Constant _ -> 1 | _ , Positive _ -> 1 + | _, TemplatePolymorphic _ -> 1 | _ -> -1 let compare x y = @@ -903,14 +909,20 @@ let pr_assumptionset env sigma s = let safe_pr_constant env kn = try pr_constant env kn with Not_found -> - (* FIXME? *) - let mp,lab = Constant.repr2 kn in - str (ModPath.to_string mp) ++ str "." ++ Label.print lab + Names.Constant.print kn + in + let safe_pr_global env gr = + try pr_global_env (Termops.vars_of_env env) gr + with Not_found -> + let open GlobRef in match gr with + | VarRef id -> Id.print id + | ConstRef con -> Constant.print con + | IndRef (mind,_) -> MutInd.print mind + | ConstructRef _ -> assert false in let safe_pr_inductive env kn = try pr_inductive env (kn,0) with Not_found -> - (* FIXME? *) MutInd.print kn in let safe_pr_ltype env sigma typ = @@ -927,9 +939,14 @@ let pr_assumptionset env sigma s = | Constant kn -> safe_pr_constant env kn ++ safe_pr_ltype env sigma typ | Positive m -> - hov 2 (safe_pr_inductive env m ++ spc () ++ strbrk"is positive.") - | Guarded kn -> - hov 2 (safe_pr_constant env kn ++ spc () ++ strbrk"is positive.") + hov 2 (safe_pr_inductive env m ++ spc () ++ strbrk"is assumed to be positive.") + | Guarded gr -> + hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"is assumed to be guarded.") + | TemplatePolymorphic m -> + hov 2 (safe_pr_inductive env m ++ spc () ++ + strbrk"is assumed template polymorphic on all its universe parameters.") + | TypeInType gr -> + hov 2 (safe_pr_global env gr ++ spc () ++ strbrk"relies on an unsafe hierarchy.") in let fold t typ accu = let (v, a, o, tr) = accu in @@ -1003,3 +1020,8 @@ let print_and_diff oldp newp = pr_open_subgoals ~proof in Feedback.msg_notice output;; + +let pr_typing_flags flags = + str "check_guarded: " ++ bool flags.check_guarded ++ fnl () + ++ str "check_positive: " ++ bool flags.check_positive ++ fnl () + ++ str "check_universes: " ++ bool flags.check_universes diff --git a/printing/printer.mli b/printing/printer.mli index a72f319636..d62d3789d3 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -191,7 +191,10 @@ val print_and_diff : Proof.t option -> Proof.t option -> unit type axiom = | Constant of Constant.t (* An axiom or a constant. *) | Positive of MutInd.t (* A mutually inductive definition which has been assumed positive. *) - | Guarded of Constant.t (* a constant whose (co)fixpoints have been assumed to be guarded *) + | Guarded of GlobRef.t (* a constant whose (co)fixpoints have been assumed to be guarded *) + | TemplatePolymorphic of MutInd.t (* A mutually inductive definition whose template polymorphism + on parameter universes has not been checked. *) + | TypeInType of GlobRef.t (* a constant which relies on type in type *) type context_object = | Variable of Id.t (* A section variable or a Let definition *) @@ -207,3 +210,5 @@ val pr_assumptionset : env -> evar_map -> types ContextObjectMap.t -> Pp.t val pr_goal_by_id : proof:Proof.t -> Id.t -> Pp.t val pr_goal_emacs : proof:Proof.t option -> int -> int -> Pp.t + +val pr_typing_flags : Declarations.typing_flags -> Pp.t diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 1904d9b112..8e7d1df29a 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -108,7 +108,7 @@ let fail_quick_core_unif_flags = { check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; (* ? *) - frozen_evars = Evar.Set.empty; + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; modulo_eta = true; diff --git a/proofs/goal.ml b/proofs/goal.ml index 888c4785df..f95a904a5f 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -91,7 +91,8 @@ module V82 = struct let weak_progress glss gls = match glss.Evd.it with - | [ g ] -> not (Proofview.Progress.goal_equal glss.Evd.sigma g gls.Evd.sigma gls.Evd.it) + | [ g ] -> not (Proofview.Progress.goal_equal ~evd:gls.Evd.sigma + ~extended_evd:glss.Evd.sigma gls.Evd.it g) | _ -> true let progress glss gls = diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 0ce726db25..756fef0511 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -6,9 +6,7 @@ Proof Logic Goal_select Proof_bullet -Proof_global Refiner Tacmach -Pfedit Clenv Clenvtac diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 129444c3b3..a487799b74 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -77,17 +77,18 @@ include Util (* ****************** - foo - bar - baz *********************************** *) let static_bullet ({ entry_point; prev_node } as view) = + let open Vernacexpr in assert (not (Vernacprop.has_Fail entry_point.ast)); - match Vernacprop.under_control entry_point.ast with - | Vernacexpr.VernacBullet b -> + match entry_point.ast.CAst.v.expr with + | VernacBullet b -> let base = entry_point.indentation in let last_tac = prev_node entry_point in crawl view ~init:last_tac (fun prev node -> if node.indentation < base then `Stop else if node.indentation > base then `Cont node else if Vernacprop.has_Fail node.ast then `Stop - else match Vernacprop.under_control node.ast with - | Vernacexpr.VernacBullet b' when b = b' -> + else match node.ast.CAst.v.expr with + | VernacBullet b' when b = b' -> `Found { block_stop = entry_point.id; block_start = prev.id; dynamic_switch = node.id; carry_on_data = of_bullet_val b } | _ -> `Stop) entry_point @@ -99,7 +100,7 @@ let dynamic_bullet doc { dynamic_switch = id; carry_on_data = b } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (CAst.make @@ Vernacexpr.VernacExpr([], Vernacexpr.VernacBullet (to_bullet_val b))) + recovery_command = Some (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacBullet (to_bullet_val b)}) } | `Not -> `Leaks @@ -109,16 +110,17 @@ let () = register_proof_block_delimiter (* ******************** { block } ***************************************** *) let static_curly_brace ({ entry_point; prev_node } as view) = - assert(Vernacprop.under_control entry_point.ast = Vernacexpr.VernacEndSubproof); + let open Vernacexpr in + assert(entry_point.ast.CAst.v.expr = VernacEndSubproof); crawl view (fun (nesting,prev) node -> if Vernacprop.has_Fail node.ast then `Cont (nesting,node) - else match Vernacprop.under_control node.ast with - | Vernacexpr.VernacSubproof _ when nesting = 0 -> + else match node.ast.CAst.v.expr with + | VernacSubproof _ when nesting = 0 -> `Found { block_stop = entry_point.id; block_start = prev.id; dynamic_switch = node.id; carry_on_data = unit_val } - | Vernacexpr.VernacSubproof _ -> + | VernacSubproof _ -> `Cont (nesting - 1,node) - | Vernacexpr.VernacEndSubproof -> + | VernacEndSubproof -> `Cont (nesting + 1,node) | _ -> `Cont (nesting,node)) (-1, entry_point) @@ -128,7 +130,7 @@ let dynamic_curly_brace doc { dynamic_switch = id } = `ValidBlock { base_state = id; goals_to_admit = focused; - recovery_command = Some (CAst.make @@ Vernacexpr.VernacExpr ([], Vernacexpr.VernacEndSubproof)) + recovery_command = Some (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacEndSubproof }) } | `Not -> `Leaks diff --git a/stm/stm.ml b/stm/stm.ml index 7f3e5ecb76..1042061021 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -571,7 +571,7 @@ end = struct (* {{{ *) vcs := rewrite_merge !vcs id ~ours ~theirs:Noop ~at branch let reachable id = reachable !vcs id let mk_branch_name { expr = x } = Branch.make - (match Vernacprop.under_control x with + (match x.CAst.v.Vernacexpr.expr with | VernacDefinition (_,({CAst.v=Name i},_),_) -> Id.to_string i | VernacStartTheoremProof (_,[({CAst.v=i},_),_]) -> Id.to_string i | VernacInstance (({CAst.v=Name i},_),_,_,_,_) -> Id.to_string i @@ -1054,9 +1054,9 @@ end = struct (* {{{ *) end (* }}} *) (* Wrapper for the proof-closing special path for Qed *) -let stm_qed_delay_proof ?route ~proof ~info ~id ~st ~loc pending : Vernacstate.t = +let stm_qed_delay_proof ?route ~proof ~info ~id ~st ~loc ~control pending : Vernacstate.t = set_id_for_feedback ?route dummy_doc id; - Vernacentries.interp_qed_delayed_proof ~proof ~info ~st ?loc:loc pending + Vernacentries.interp_qed_delayed_proof ~proof ~info ~st ~control (CAst.make ?loc pending) (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly @@ -1078,7 +1078,7 @@ let stm_vernac_interp ?route id st { verbose; expr } : Vernacstate.t = | _ -> false in (* XXX unsupported attributes *) - let cmd = Vernacprop.under_control expr in + let cmd = expr.CAst.v.expr in if is_filtered_command cmd then (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) else begin @@ -1141,7 +1141,7 @@ end = struct (* {{{ *) | { step = `Fork ((_,_,_,l),_) } -> l, false,0 | { step = `Cmd { cids = l; ctac } } -> l, ctac,0 | { step = `Alias (_,{ expr }) } when not (Vernacprop.has_Fail expr) -> - begin match Vernacprop.under_control expr with + begin match expr.CAst.v.expr with | VernacUndo n -> [], false, n | _ -> [],false,0 end @@ -1171,7 +1171,7 @@ end = struct (* {{{ *) if not (VCS.is_interactive ()) && !cur_opt.async_proofs_cache <> Some Force then undo_costly_in_batch_mode v; try - match Vernacprop.under_control v with + match v.CAst.v.expr with | VernacResetInitial -> Stateid.initial | VernacResetName {CAst.v=name} -> @@ -1532,7 +1532,7 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_qed_delay_proof ~st ~id:stop - ~proof:pobject ~info:(Lemmas.Info.make ()) ~loc (Proved (opaque,None))) in + ~proof:pobject ~info:(Lemmas.Info.make ()) ~loc ~control:[] (Proved (opaque,None))) in ignore(Future.join checked_proof); end; (* STATE: Restore the state XXX: handle exn *) @@ -1683,7 +1683,7 @@ end = struct (* {{{ *) *) (* STATE We use the state resulting from reaching start. *) let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_qed_delay_proof ~id:stop ~st ~proof ~info ~loc (Proved (opaque,None))); + ignore(stm_qed_delay_proof ~id:stop ~st ~proof ~info ~loc ~control:[] (Proved (opaque,None))); `OK proof end with e -> @@ -1977,13 +1977,14 @@ end = struct (* {{{ *) let vernac_interp ~solve ~abstract ~cancel_switch nworkers priority safe_id id { indentation; verbose; expr = e; strlen } : unit = - let e, time, batch, fail = - let rec find ~time ~batch ~fail v = CAst.with_loc_val (fun ?loc -> function - | VernacTime (batch,e) -> find ~time:true ~batch ~fail e - | VernacRedirect (_,e) -> find ~time ~batch ~fail e - | VernacFail e -> find ~time ~batch ~fail:true e - | e -> CAst.make ?loc e, time, batch, fail) v in - find ~time:false ~batch:false ~fail:false e in + let cl, time, batch, fail = + let rec find ~time ~batch ~fail cl = match cl with + | ControlTime batch :: cl -> find ~time:true ~batch ~fail cl + | ControlRedirect _ :: cl -> find ~time ~batch ~fail cl + | ControlFail :: cl -> find ~time ~batch ~fail:true cl + | cl -> cl, time, batch, fail in + find ~time:false ~batch:false ~fail:false e.CAst.v.control in + let e = CAst.map (fun cmd -> { cmd with control = cl }) e in let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> @@ -2151,14 +2152,14 @@ let collect_proof keep cur hd brkind id = | VernacEndProof (Proved (Proof_global.Transparent,_)) -> true | _ -> false in let is_defined = function - | _, { expr = e } -> is_defined_expr (Vernacprop.under_control e) + | _, { expr = e } -> is_defined_expr e.CAst.v.expr && (not (Vernacprop.has_Fail e)) in let proof_using_ast = function | VernacProof(_,Some _) -> true | _ -> false in let proof_using_ast = function - | Some (_, v) when proof_using_ast (Vernacprop.under_control v.expr) + | Some (_, v) when proof_using_ast v.expr.CAst.v.expr && (not (Vernacprop.has_Fail v.expr)) -> Some v | _ -> None in let has_proof_using x = proof_using_ast x <> None in @@ -2167,14 +2168,14 @@ let collect_proof keep cur hd brkind id = | _ -> assert false in let proof_no_using = function - | Some (_, v) -> proof_no_using (Vernacprop.under_control v.expr), v + | Some (_, v) -> proof_no_using v.expr.CAst.v.expr, v | _ -> assert false in let has_proof_no_using = function | VernacProof(_,None) -> true | _ -> false in let has_proof_no_using = function - | Some (_, v) -> has_proof_no_using (Vernacprop.under_control v.expr) + | Some (_, v) -> has_proof_no_using v.expr.CAst.v.expr && (not (Vernacprop.has_Fail v.expr)) | _ -> false in let too_complex_to_delegate = function @@ -2191,7 +2192,7 @@ let collect_proof keep cur hd brkind id = let view = VCS.visit id in match view.step with | (`Sideff (ReplayCommand x,_) | `Cmd { cast = x }) - when too_complex_to_delegate (Vernacprop.under_control x.expr) -> + when too_complex_to_delegate x.expr.CAst.v.expr -> `Sync(no_name,`Print) | `Cmd { cast = x } -> collect (Some (id,x)) (id::accn) view.next | `Sideff (ReplayCommand x,_) -> collect (Some (id,x)) (id::accn) view.next @@ -2212,7 +2213,7 @@ let collect_proof keep cur hd brkind id = (try let name, hint = name ids, get_hint_ctx loc in let t, v = proof_no_using last in - v.expr <- CAst.map (fun _ -> VernacExpr([], VernacProof(t, Some hint))) v.expr; + v.expr <- CAst.map (fun _ -> { control = []; attrs = []; expr = VernacProof(t, Some hint)}) v.expr; `ASync (parent last,accn,name,delegate name) with Not_found -> let name = name ids in @@ -2235,7 +2236,7 @@ let collect_proof keep cur hd brkind id = | _ -> false in match cur, (VCS.visit id).step, brkind with - | (parent, x), `Fork _, _ when is_vernac_exact (Vernacprop.under_control x.expr) + | (parent, x), `Fork _, _ when is_vernac_exact x.expr.CAst.v.expr && (not (Vernacprop.has_Fail x.expr)) -> `Sync (no_name,`Immediate) | _, _, { VCS.kind = `Edit _ } -> check_policy (collect (Some cur) [] id) @@ -2350,8 +2351,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = term.` could also fail in this case, however that'd be a bug I do believe as proof injection shouldn't happen here. *) let extract_pe (x : aast) = - match Vernacprop.under_control x.expr with - | VernacEndProof pe -> pe + match x.expr.CAst.v.expr with + | VernacEndProof pe -> x.expr.CAst.v.control, pe | _ -> CErrors.anomaly Pp.(str "Non-qed command classified incorrectly") in (* ugly functions to process nested lemmas, i.e. hard to reproduce @@ -2486,7 +2487,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_qed_delay_proof ~id ~st ~proof ~info ~loc (extract_pe x)); + let control, pe = extract_pe x in + ignore(stm_qed_delay_proof ~id ~st ~proof ~info ~loc ~control pe); feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; @@ -2526,7 +2528,8 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let _st = match proof with | None -> stm_vernac_interp id st x | Some (proof, info) -> - stm_qed_delay_proof ~id ~st ~proof ~info ~loc (extract_pe x) + let control, pe = extract_pe x in + stm_qed_delay_proof ~id ~st ~proof ~info ~loc ~control pe in let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc:x.expr.CAst.loc "proof_check_time" @@ -2870,7 +2873,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) let queue = if VCS.is_vio_doc () && VCS.((get_branch head).kind = `Master) && - may_pierce_opaque (Vernacprop.under_control x.expr) + may_pierce_opaque x.expr.CAst.v.expr then `SkipQueue else `MainQueue in VCS.commit id (mkTransCmd x [] false queue); @@ -2936,7 +2939,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) VCS.commit id (mkTransCmd x l true `MainQueue); (* We can't replay a Definition since universes may be differently * inferred. This holds in Coq >= 8.5 *) - let action = match Vernacprop.under_control x.expr with + let action = match x.expr.CAst.v.expr with | VernacDefinition(_, _, DefineBody _) -> CherryPickEnv | _ -> ReplayCommand x in VCS.propagate_sideff ~action diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 5af576dad2..8d600c2859 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -202,18 +202,17 @@ let classify_vernac e = try Vernacextend.get_vernac_classifier s l with Not_found -> anomaly(str"No classifier for"++spc()++str (fst s)++str".") in - let rec static_control_classifier v = v |> CAst.with_val (function - | VernacExpr (atts, e) -> - static_classifier ~atts e - | VernacTimeout (_,e) -> static_control_classifier e - | VernacTime (_,e) | VernacRedirect (_, e) -> - static_control_classifier e - | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) - (* XXX why is Fail not always Query? *) - (match static_control_classifier e with + let static_control_classifier ({ CAst.v ; _ } as cmd) = + (* Fail Qed or Fail Lemma must not join/fork the DAG *) + (* XXX why is Fail not always Query? *) + if Vernacprop.has_Fail cmd then + (match static_classifier ~atts:v.attrs v.expr with | VtQuery | VtProofStep _ | VtSideff _ | VtMeta as x -> x | VtQed _ -> VtProofStep { parallel = `No; proof_block_detection = None } - | VtStartProof _ | VtProofMode _ -> VtQuery)) + | VtStartProof _ | VtProofMode _ -> VtQuery) + else + static_classifier ~atts:v.attrs v.expr + in static_control_classifier e diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index fab6767beb..baa7b3570c 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -11,7 +11,6 @@ open Util let check_vio (ts,f_in) = - Dumpglob.noglob (); let _, _, _, tasks, _ = Library.load_library_todo f_in in Stm.set_compilation_hints f_in; List.fold_left (fun acc ids -> Stm.check_task f_in tasks ids && acc) true ts @@ -142,5 +141,3 @@ let schedule_vio_compilation j fs = List.iter (fun (f,_) -> Unix.utimes (Filename.chop_extension f^".vo") t t) all_jobs; end; exit !rc - - diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 09d7e0278a..edeb27ab88 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -69,7 +69,7 @@ let rec shrink ctx sign c t accu = | _ -> assert false let shrink_entry sign const = - let open Proof_global in + let open Declare in let typ = match const.proof_entry_type with | None -> assert false | Some t -> t @@ -151,7 +151,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = in let const, args = shrink_entry sign const in let args = List.map EConstr.of_constr args in - let cd = Declare.DefinitionEntry { const with Proof_global.proof_entry_opaque = opaque } in + let cd = Declare.DefinitionEntry { const with Declare.proof_entry_opaque = opaque } in let kind = if opaque then Decls.(IsProof Lemma) else Decls.(IsDefinition Definition) in let cst () = (* do not compute the implicit arguments, it may be costly *) @@ -160,20 +160,20 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = Declare.declare_private_constant ~local:Declare.ImportNeedQualified ~name ~kind cd in let cst, eff = Impargs.with_implicit_protection cst () in - let inst = match const.Proof_global.proof_entry_universes with + let inst = match const.Declare.proof_entry_universes with | Entries.Monomorphic_entry _ -> EInstance.empty | Entries.Polymorphic_entry (_, ctx) -> (* We mimic what the kernel does, that is ensuring that no additional constraints appear in the body of polymorphic constants. Ideally this should be enforced statically. *) - let (_, body_uctx), _ = Future.force const.Proof_global.proof_entry_body in + let (_, body_uctx), _ = Future.force const.Declare.proof_entry_body in let () = assert (Univ.ContextSet.is_empty body_uctx) in EInstance.make (Univ.UContext.instance ctx) in let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in let effs = Evd.concat_side_effects eff - Proof_global.(snd (Future.force const.proof_entry_body)) in + (snd (Future.force const.Declare.proof_entry_body)) in let solve = Proofview.tclEFFECTS effs <*> tacK lem args diff --git a/tactics/abstract.mli b/tactics/abstract.mli index e278729f89..96ddbea7b2 100644 --- a/tactics/abstract.mli +++ b/tactics/abstract.mli @@ -26,5 +26,5 @@ val tclABSTRACT : ?opaque:bool -> Id.t option -> unit Proofview.tactic -> unit P save path *) val shrink_entry : ('a, 'b) Context.Named.Declaration.pt list - -> 'c Proof_global.proof_entry - -> 'c Proof_global.proof_entry * Constr.t list + -> 'c Declare.proof_entry + -> 'c Declare.proof_entry * Constr.t list diff --git a/tactics/auto.ml b/tactics/auto.ml index 499e7a63d7..0b465418f2 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -49,7 +49,7 @@ let auto_core_unif_flags_of st1 st2 = { check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; - frozen_evars = Evar.Set.empty; + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; (* Compat *) modulo_betaiota = false; modulo_eta = true; @@ -220,13 +220,13 @@ let tclLOG (dbg,_,depth,trace) pp tac = tac >>= fun v -> tclENV >>= fun env -> tclEVARMAP >>= fun sigma -> - Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*success*)"); + Feedback.msg_notice (str s ++ spc () ++ pp env sigma ++ str ". (*success*)"); tclUNIT v ) tclUNIT (fun (exn, info) -> tclENV >>= fun env -> tclEVARMAP >>= fun sigma -> - Feedback.msg_debug (str s ++ spc () ++ pp env sigma ++ str ". (*fail*)"); + Feedback.msg_notice (str s ++ spc () ++ pp env sigma ++ str ". (*fail*)"); tclZERO ~info exn)) | Info -> (* For "info (trivial/auto)", we store a log trace *) @@ -260,19 +260,19 @@ let pr_info_atom env sigma (d,pp) = let pr_info_trace env sigma = function | (Info,_,_,{contents=(d,Some pp)::l}) -> - Feedback.msg_info (prlist_with_sep fnl (pr_info_atom env sigma) (cleanup_info_trace d [(d,pp)] l)) + Feedback.msg_notice (prlist_with_sep fnl (pr_info_atom env sigma) (cleanup_info_trace d [(d,pp)] l)) | _ -> () let pr_info_nop = function - | (Info,_,_,_) -> Feedback.msg_info (str "idtac.") + | (Info,_,_,_) -> Feedback.msg_notice (str "idtac.") | _ -> () let pr_dbg_header = function | (Off,_,_,_) -> () - | (Debug,ReportForTrivial,_,_) -> Feedback.msg_debug (str "(* debug trivial: *)") - | (Debug,ReportForAuto,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") - | (Info,ReportForTrivial,_,_) -> Feedback.msg_info (str "(* info trivial: *)") - | (Info,ReportForAuto,_,_) -> Feedback.msg_info (str "(* info auto: *)") + | (Debug,ReportForTrivial,_,_) -> Feedback.msg_notice (str "(* debug trivial: *)") + | (Debug,ReportForAuto,_,_) -> Feedback.msg_notice (str "(* debug auto: *)") + | (Info,ReportForTrivial,_,_) -> Feedback.msg_notice (str "(* info trivial: *)") + | (Info,ReportForAuto,_,_) -> Feedback.msg_notice (str "(* info auto: *)") let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 05f40d0570..cf5c64c3ae 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -151,7 +151,7 @@ let pr_ev evs ev = open Auto open Unification -let auto_core_unif_flags st freeze = { +let auto_core_unif_flags st allowed_evars = { modulo_conv_on_closed_terms = Some st; use_metas_eagerly_in_conv_on_closed_terms = true; use_evars_eagerly_in_conv_on_closed_terms = false; @@ -160,14 +160,14 @@ let auto_core_unif_flags st freeze = { check_applied_meta_types = false; use_pattern_unification = true; use_meta_bound_pattern_unification = true; - frozen_evars = freeze; + allowed_evars; restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = true; modulo_eta = false; } -let auto_unif_flags freeze st = - let fl = auto_core_unif_flags st freeze in +let auto_unif_flags ?(allowed_evars = AllowAll) st = + let fl = auto_core_unif_flags st allowed_evars in { core_unify_flags = fl; merge_unify_flags = fl; subterm_unify_flags = fl; @@ -357,23 +357,25 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm let open Proofview.Notations in let prods, concl = EConstr.decompose_prod_assum sigma concl in let nprods = List.length prods in - let freeze = + let allowed_evars = try match hdc with | Some (hd,_) when only_classes -> let cl = Typeclasses.class_info env sigma hd in if cl.cl_strict then - Evarutil.undefined_evars_of_term sigma concl - else Evar.Set.empty - | _ -> Evar.Set.empty - with e when CErrors.noncritical e -> Evar.Set.empty + let undefined = lazy (Evarutil.undefined_evars_of_term sigma concl) in + let allowed evk = not (Evar.Set.mem evk (Lazy.force undefined)) in + AllowFun allowed + else AllowAll + | _ -> AllowAll + with e when CErrors.noncritical e -> AllowAll in let hint_of_db = hintmap_of sigma hdc secvars concl in let hintl = List.map_append (fun db -> let tacs = hint_of_db db in - let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in + let flags = auto_unif_flags ~allowed_evars (Hint_db.transparent_state db) in List.map (fun x -> (flags, x)) tacs) (local_db::db_list) in @@ -1198,7 +1200,7 @@ let autoapply c i = let hintdb = try Hints.searchtable_map i with Not_found -> CErrors.user_err (Pp.str ("Unknown hint database " ^ i ^ ".")) in - let flags = auto_unif_flags Evar.Set.empty + let flags = auto_unif_flags (Hints.Hint_db.transparent_state hintdb) in let cty = Tacmach.New.pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in diff --git a/tactics/declare.ml b/tactics/declare.ml index b8ba62a5e5..3a02e5451a 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -55,8 +55,20 @@ type constant_obj = { cst_locl : import_status; } +type 'a proof_entry = { + proof_entry_body : 'a Entries.const_entry_body; + (* List of section variables *) + proof_entry_secctx : Constr.named_context option; + (* State id on which the completion of type checking is reported *) + proof_entry_feedback : Stateid.t option; + proof_entry_type : Constr.types option; + proof_entry_universes : Entries.universes_entry; + proof_entry_opaque : bool; + proof_entry_inline_code : bool; +} + type 'a constant_entry = - | DefinitionEntry of 'a Proof_global.proof_entry + | DefinitionEntry of 'a proof_entry | ParameterEntry of parameter_entry | PrimitiveEntry of primitive_entry @@ -71,8 +83,7 @@ let load_constant i ((sp,kn), obj) = let cooking_info segment = let modlist = replacement_context () in - let { abstr_ctx = hyps; abstr_subst = subst; abstr_uctx = uctx } = segment in - let named_ctx = List.map fst hyps in + let { abstr_ctx = named_ctx; abstr_subst = subst; abstr_uctx = uctx } = segment in let abstract = (named_ctx, subst, uctx) in { Opaqueproof.modlist; abstract } @@ -175,7 +186,6 @@ let record_aux env s_ty s_bo = let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) body = - let open Proof_global in { proof_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); proof_entry_secctx = None; proof_entry_type = types; @@ -185,7 +195,6 @@ let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types proof_entry_inline_code = inline} let cast_proof_entry e = - let open Proof_global in let (body, ctx), () = Future.force e.proof_entry_body in let univs = if Univ.ContextSet.is_empty ctx then e.proof_entry_universes @@ -206,7 +215,6 @@ let cast_proof_entry e = } let cast_opaque_proof_entry e = - let open Proof_global in let typ = match e.proof_entry_type with | None -> assert false | Some typ -> typ @@ -225,7 +233,7 @@ let cast_opaque_proof_entry e = let vars = global_vars_set env pf in ids_typ, vars in - let () = if !Flags.record_aux_file then record_aux env hyp_typ hyp_def in + let () = if Aux_file.recording () then record_aux env hyp_typ hyp_def in keep_hyps env (Id.Set.union hyp_typ hyp_def) | Some hyps -> hyps in @@ -244,11 +252,15 @@ let get_roles export eff = in List.map map export +let feedback_axiom () = Feedback.(feedback AddedAxiom) +let is_unsafe_typing_flags () = + let flags = Environ.typing_flags (Global.env()) in + not (flags.check_universes && flags.check_guarded && flags.check_positive) + let define_constant ~side_effect ~name cd = - let open Proof_global in (* Logically define the constant and its subproofs, no libobject tampering *) let in_section = Lib.sections_are_opened () in - let export, decl = match cd with + let export, decl, unsafe = match cd with | DefinitionEntry de -> (* We deal with side effects *) if not de.proof_entry_opaque then @@ -258,19 +270,20 @@ let define_constant ~side_effect ~name cd = let export = get_roles export eff in let de = { de with proof_entry_body = Future.from_val (body, ()) } in let cd = Entries.DefinitionEntry (cast_proof_entry de) in - export, ConstantEntry (PureEntry, cd) + export, ConstantEntry (PureEntry, cd), false else let map (body, eff) = body, eff.Evd.seff_private in let body = Future.chain de.proof_entry_body map in let de = { de with proof_entry_body = body } in let de = cast_opaque_proof_entry de in - [], ConstantEntry (EffectEntry, Entries.OpaqueEntry de) + [], ConstantEntry (EffectEntry, Entries.OpaqueEntry de), false | ParameterEntry e -> - [], ConstantEntry (PureEntry, Entries.ParameterEntry e) + [], ConstantEntry (PureEntry, Entries.ParameterEntry e), not (Lib.is_modtype_strict()) | PrimitiveEntry e -> - [], ConstantEntry (PureEntry, Entries.PrimitiveEntry e) + [], ConstantEntry (PureEntry, Entries.PrimitiveEntry e), false in let kn, eff = Global.add_constant ~side_effect ~in_section name decl in + if unsafe || is_unsafe_typing_flags() then feedback_axiom(); kn, eff, export let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = @@ -294,8 +307,8 @@ let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind (** Declaration of section variables and local definitions *) type variable_declaration = - | SectionLocalDef of Evd.side_effects Proof_global.proof_entry - | SectionLocalAssum of { typ:Constr.types; univs:Univ.ContextSet.t; poly:bool; impl:bool } + | SectionLocalDef of Evd.side_effects proof_entry + | SectionLocalAssum of { typ:Constr.types; univs:Univ.ContextSet.t; poly:bool; impl:Glob_term.binding_kind } (* This object is only for things which iterate over objects to find variables (only Prettyp.print_context AFAICT) *) @@ -308,16 +321,14 @@ let declare_variable ~name ~kind d = if Decls.variable_exists name then raise (AlreadyDeclared (None, name)); - let impl,opaque,poly,univs = match d with (* Fails if not well-typed *) + let impl,opaque,poly = match d with (* Fails if not well-typed *) | SectionLocalAssum {typ;univs;poly;impl} -> let () = declare_universe_context ~poly univs in let () = Global.push_named_assum (name,typ) in - let impl = if impl then Decl_kinds.Implicit else Decl_kinds.Explicit in - impl, true, poly, univs + impl, true, poly | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) - let open Proof_global in let (body, eff) = Future.force de.proof_entry_body in let ((body, uctx), export) = Global.export_private_constants ~in_section:true (body, eff.Evd.seff_private) in let eff = get_roles export eff in @@ -337,14 +348,14 @@ let declare_variable ~name ~kind d = secdef_type = de.proof_entry_type; } in let () = Global.push_named_def (name, se) in - Decl_kinds.Explicit, de.proof_entry_opaque, - poly, univs + Glob_term.Explicit, de.proof_entry_opaque, + poly in Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); - add_section_variable ~name ~kind:impl ~poly univs; + add_section_variable ~name ~poly; Decls.(add_variable_data name {opaque;kind}); add_anonymous_leaf (inVariable ()); - Impargs.declare_var_implicits name; + Impargs.declare_var_implicits ~impl name; Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) (** Declaration of inductive blocks *) @@ -490,6 +501,7 @@ let declare_mind mie = | ind::_ -> ind.mind_entry_typename | [] -> CErrors.anomaly (Pp.str "cannot declare an empty list of inductives.") in let (sp,kn as oname) = add_leaf id (inInductive mie) in + if is_unsafe_typing_flags() then feedback_axiom(); let mind = Global.mind_of_delta_kn kn in let isprim = declare_projections mie.mind_entry_universes mind in Impargs.declare_mib_implicits mind; diff --git a/tactics/declare.mli b/tactics/declare.mli index 89b41076f7..4cb876cecb 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -19,14 +19,27 @@ open Entries reset works properly --- and will fill some global tables such as [Nametab] and [Impargs]. *) +(** Proof entries *) +type 'a proof_entry = { + proof_entry_body : 'a Entries.const_entry_body; + (* List of section variables *) + proof_entry_secctx : Constr.named_context option; + (* State id on which the completion of type checking is reported *) + proof_entry_feedback : Stateid.t option; + proof_entry_type : Constr.types option; + proof_entry_universes : Entries.universes_entry; + proof_entry_opaque : bool; + proof_entry_inline_code : bool; +} + (** Declaration of local constructions (Variable/Hypothesis/Local) *) type variable_declaration = - | SectionLocalDef of Evd.side_effects Proof_global.proof_entry - | SectionLocalAssum of { typ:types; univs:Univ.ContextSet.t; poly:bool; impl:bool } + | SectionLocalDef of Evd.side_effects proof_entry + | SectionLocalAssum of { typ:types; univs:Univ.ContextSet.t; poly:bool; impl:Glob_term.binding_kind } type 'a constant_entry = - | DefinitionEntry of 'a Proof_global.proof_entry + | DefinitionEntry of 'a proof_entry | ParameterEntry of parameter_entry | PrimitiveEntry of primitive_entry @@ -43,7 +56,7 @@ val declare_variable val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool -> ?inline:bool -> ?types:types -> ?univs:Entries.universes_entry -> - ?eff:Evd.side_effects -> constr -> Evd.side_effects Proof_global.proof_entry + ?eff:Evd.side_effects -> constr -> Evd.side_effects proof_entry type import_status = ImportDefaultBehavior | ImportNeedQualified diff --git a/tactics/eauto.ml b/tactics/eauto.ml index cc3e78f3b8..2ce32b309a 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -351,13 +351,13 @@ let mk_eauto_dbg d = else Off let pr_info_nop = function - | Info -> Feedback.msg_info (str "idtac.") + | Info -> Feedback.msg_notice (str "idtac.") | _ -> () let pr_dbg_header = function | Off -> () - | Debug -> Feedback.msg_debug (str "(* debug eauto: *)") - | Info -> Feedback.msg_info (str "(* info eauto: *)") + | Debug -> Feedback.msg_notice (str "(* debug eauto: *)") + | Info -> Feedback.msg_notice (str "(* info eauto: *)") let pr_info dbg s = if dbg != Info then () @@ -368,7 +368,7 @@ let pr_info dbg s = | State sp -> let mindepth = loop sp in let indent = String.make (mindepth - sp.depth) ' ' in - Feedback.msg_info (str indent ++ Lazy.force s.last_tactic ++ str "."); + Feedback.msg_notice (str indent ++ Lazy.force s.last_tactic ++ str "."); mindepth in ignore (loop s) @@ -408,7 +408,7 @@ let e_search_auto debug (in_depth,p) lems db_list gl = (* let e_search_auto = CProfile.profile5 e_search_auto_key e_search_auto *) let eauto_with_bases ?(debug=Off) np lems db_list = - Proofview.V82.of_tactic (Hints.wrap_hint_warning (Proofview.V82.tactic (tclTRY (e_search_auto debug np lems db_list)))) + Hints.wrap_hint_warning (Proofview.V82.tactic (tclTRY (e_search_auto debug np lems db_list))) let eauto ?(debug=Off) np lems dbnames = let db_list = make_db_list dbnames in diff --git a/tactics/eauto.mli b/tactics/eauto.mli index ec99baef45..f9347b7b0f 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -26,7 +26,7 @@ val gen_eauto : ?debug:debug -> bool * int -> delayed_open_constr list -> val eauto_with_bases : ?debug:debug -> bool * int -> - delayed_open_constr list -> hint_db list -> Proofview.V82.tac + delayed_open_constr list -> hint_db list -> unit Proofview.tactic val autounfold : hint_db_name list -> Locus.clause -> unit Proofview.tactic val autounfold_tac : hint_db_name list option -> Locus.clause -> unit Proofview.tactic diff --git a/tactics/equality.ml b/tactics/equality.ml index 7c90c59f61..1f125a3c59 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -38,7 +38,6 @@ open Coqlib open Declarations open Indrec open Clenv -open Evd open Ind_tables open Eqschemes open Locus @@ -107,7 +106,7 @@ let rewrite_core_unif_flags = { check_applied_meta_types = true; use_pattern_unification = true; use_meta_bound_pattern_unification = true; - frozen_evars = Evar.Set.empty; + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = true; @@ -126,16 +125,17 @@ let freeze_initial_evars sigma flags clause = (* We take evars of the type: this may include old evars! For excluding *) (* all old evars, including the ones occurring in the rewriting lemma, *) (* we would have to take the clenv_value *) - let newevars = Evarutil.undefined_evars_of_term sigma (clenv_type clause) in - let evars = - fold_undefined (fun evk _ evars -> - if Evar.Set.mem evk newevars then evars - else Evar.Set.add evk evars) - sigma Evar.Set.empty in + let newevars = lazy (Evarutil.undefined_evars_of_term sigma (clenv_type clause)) in + let initial = Evd.undefined_map sigma in + let allowed evk = + if Evar.Map.mem evk initial then false + else Evar.Set.mem evk (Lazy.force newevars) + in + let allowed_evars = AllowFun allowed in {flags with - core_unify_flags = {flags.core_unify_flags with frozen_evars = evars}; - merge_unify_flags = {flags.merge_unify_flags with frozen_evars = evars}; - subterm_unify_flags = {flags.subterm_unify_flags with frozen_evars = evars}} + core_unify_flags = {flags.core_unify_flags with allowed_evars}; + merge_unify_flags = {flags.merge_unify_flags with allowed_evars}; + subterm_unify_flags = {flags.subterm_unify_flags with allowed_evars}} let make_flags frzevars sigma flags clause = if frzevars then freeze_initial_evars sigma flags clause else flags @@ -188,8 +188,7 @@ let rewrite_conv_closed_core_unif_flags = { use_meta_bound_pattern_unification = true; - frozen_evars = Evar.Set.empty; - (* This is set dynamically *) + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; @@ -223,8 +222,7 @@ let rewrite_keyed_core_unif_flags = { use_meta_bound_pattern_unification = true; - frozen_evars = Evar.Set.empty; - (* This is set dynamically *) + allowed_evars = AllowAll; restrict_conv_on_strict_subterms = false; modulo_betaiota = true; @@ -257,7 +255,9 @@ let tclNOTSAMEGOAL tac = Proofview.Goal.goals >>= fun gls -> let check accu gl' = gl' >>= fun gl' -> - let accu = accu || Proofview.Progress.goal_equal sigma ev (project gl') (goal gl') in + let accu = accu || Proofview.Progress.goal_equal + ~evd:sigma ~extended_evd:(project gl') ev (goal gl') + in Proofview.tclUNIT accu in Proofview.Monad.List.fold_left check false gls >>= fun has_same -> @@ -334,6 +334,21 @@ let jmeq_same_dom env sigma = function | _, [dom1; _; dom2;_] -> is_conv env sigma dom1 dom2 | _ -> false +let eq_elimination_ref l2r sort = + let name = + if l2r then + match sort with + | InProp -> "core.eq.ind_r" + | InSProp -> "core.eq.sind_r" + | InSet | InType -> "core.eq.rect_r" + else + match sort with + | InProp -> "core.eq.ind" + | InSProp -> "core.eq.sind" + | InSet | InType -> "core.eq.rect" + in + if Coqlib.has_ref name then Some (Coqlib.lib_ref name) else None + (* find_elim determines which elimination principle is necessary to eliminate lbeq on sort_of_gl. *) @@ -345,35 +360,35 @@ let find_elim hdcncl lft2rgt dep cls ot = in let inccl = Option.is_empty cls in let env = Proofview.Goal.env gl in - (* if (is_global Coqlib.glob_eq hdcncl || *) - (* (is_global Coqlib.glob_jmeq hdcncl && *) - (* jmeq_same_dom env sigma ot)) && not dep *) - if (is_global_exists "core.eq.type" hdcncl || - (is_global_exists "core.JMeq.type" hdcncl - && jmeq_same_dom env sigma ot)) && not dep + let is_eq = is_global_exists "core.eq.type" hdcncl in + let is_jmeq = is_global_exists "core.JMeq.type" hdcncl && jmeq_same_dom env sigma ot in + if (is_eq || is_jmeq) && not dep then + let sort = elimination_sort_of_clause cls gl in let c = match EConstr.kind sigma hdcncl with | Ind (ind_sp,u) -> - let pr1 = - lookup_eliminator env ind_sp (elimination_sort_of_clause cls gl) - in begin match lft2rgt, cls with | Some true, None | Some false, Some _ -> - let c1 = destConstRef pr1 in - let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical c1)) in - let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in - let c1' = Global.constant_of_delta_kn (KerName.make mp l') in - begin + begin match if is_eq then eq_elimination_ref true sort else None with + | Some r -> destConstRef r + | None -> + let c1 = destConstRef (lookup_eliminator env ind_sp sort) in + let mp,l = Constant.repr2 (Constant.make1 (Constant.canonical c1)) in + let l' = Label.of_id (add_suffix (Label.to_id l) "_r") in + let c1' = Global.constant_of_delta_kn (KerName.make mp l') in try - let _ = Global.lookup_constant c1' in - c1' + let _ = Global.lookup_constant c1' in c1' with Not_found -> user_err ~hdr:"Equality.find_elim" (str "Cannot find rewrite principle " ++ Label.print l' ++ str ".") end - | _ -> destConstRef pr1 + | _ -> + begin match if is_eq then eq_elimination_ref false sort else None with + | Some r -> destConstRef r + | None -> destConstRef (lookup_eliminator env ind_sp sort) + end end | _ -> (* cannot occur since we checked that we are in presence of diff --git a/tactics/equality.mli b/tactics/equality.mli index f8166bba2d..8225195ca7 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -29,6 +29,8 @@ type conditions = | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) +val eq_elimination_ref : orientation -> Sorts.family -> GlobRef.t option + val general_rewrite_bindings : orientation -> occurrences -> freeze_evars_flag -> dep_proof_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> evars_flag -> unit Proofview.tactic diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index a3a88df21e..61e0e41eb9 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -258,7 +258,6 @@ type equation_kind = exception NoEquationFound open Glob_term -open Decl_kinds open Evar_kinds let mkPattern c = snd (Patternops.pattern_of_glob_constr c) diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index e2ef05461b..54393dce00 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -124,17 +124,7 @@ let define internal role id c poly univs = let ctx = UState.minimize univs in let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in let univs = UState.univ_entry ~poly ctx in - let entry = { - Proof_global.proof_entry_body = - Future.from_val ((c,Univ.ContextSet.empty), - Evd.empty_side_effects); - proof_entry_secctx = None; - proof_entry_type = None; - proof_entry_universes = univs; - proof_entry_opaque = false; - proof_entry_inline_code = false; - proof_entry_feedback = None; - } in + let entry = Declare.definition_entry ~univs c in let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id (Declare.DefinitionEntry entry) in let () = match internal with | InternalTacticRequest -> () diff --git a/proofs/pfedit.ml b/tactics/pfedit.ml index 99a254652c..5be7b4fa28 100644 --- a/proofs/pfedit.ml +++ b/tactics/pfedit.ml @@ -124,7 +124,7 @@ let build_constant_by_tactic ~name ctx sign ~poly typ tac = let { entries; universes } = close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in match entries with | [entry] -> - let univs = UState.demote_seff_univs entry.Proof_global.proof_entry_universes universes in + let univs = UState.demote_seff_univs entry.Declare.proof_entry_universes universes in entry, status, univs | _ -> CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") @@ -136,7 +136,7 @@ let build_by_tactic ?(side_eff=true) env sigma ~poly typ tac = let name = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in let ce, status, univs = build_constant_by_tactic ~name sigma sign ~poly typ tac in - let body, eff = Future.force ce.Proof_global.proof_entry_body in + let body, eff = Future.force ce.Declare.proof_entry_body in let (cb, ctx) = if side_eff then Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) else body diff --git a/proofs/pfedit.mli b/tactics/pfedit.mli index 0626e40047..30514191fa 100644 --- a/proofs/pfedit.mli +++ b/tactics/pfedit.mli @@ -64,7 +64,7 @@ val build_constant_by_tactic -> poly:bool -> EConstr.types -> unit Proofview.tactic - -> Evd.side_effects Proof_global.proof_entry * bool * UState.t + -> Evd.side_effects Declare.proof_entry * bool * UState.t val build_by_tactic : ?side_eff:bool diff --git a/proofs/proof_global.ml b/tactics/proof_global.ml index 851a3d1135..a2929e45cd 100644 --- a/proofs/proof_global.ml +++ b/tactics/proof_global.ml @@ -24,21 +24,9 @@ module NamedDecl = Context.Named.Declaration (*** Proof Global Environment ***) -type 'a proof_entry = { - proof_entry_body : 'a Entries.const_entry_body; - (* List of section variables *) - proof_entry_secctx : Constr.named_context option; - (* State id on which the completion of type checking is reported *) - proof_entry_feedback : Stateid.t option; - proof_entry_type : Constr.types option; - proof_entry_universes : Entries.universes_entry; - proof_entry_opaque : bool; - proof_entry_inline_code : bool; -} - type proof_object = { name : Names.Id.t - ; entries : Evd.side_effects proof_entry list + ; entries : Evd.side_effects Declare.proof_entry list ; poly : bool ; universes: UState.t ; udecl : UState.universe_decl @@ -223,7 +211,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now let ctx = UState.restrict universes used_univs in let univs = UState.check_univ_decl ~poly ctx udecl in (univs, typ), ((body, Univ.ContextSet.empty), eff) - in + in fun t p -> Future.split2 (Future.chain p (make_body t)) else fun t p -> @@ -250,6 +238,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now let t = EConstr.Unsafe.to_constr t in let univstyp, body = make_body t p in let univs, typ = Future.force univstyp in + let open Declare in { proof_entry_body = body; proof_entry_secctx = section_vars; diff --git a/proofs/proof_global.mli b/tactics/proof_global.mli index 54d5c2087a..d15e23c2cc 100644 --- a/proofs/proof_global.mli +++ b/tactics/proof_global.mli @@ -27,29 +27,11 @@ val get_initial_euctx : t -> UState.t val compact_the_proof : t -> t -(** When a proof is closed, it is reified into a [proof_object], where - [id] is the name of the proof, [entries] the list of the proof terms - (in a form suitable for definitions). Together with the [terminator] - function which takes a [proof_object] together with a [proof_end] - (i.e. an proof ending command) and registers the appropriate - values. *) -type 'a proof_entry = { - proof_entry_body : 'a Entries.const_entry_body; - (* List of section variables *) - proof_entry_secctx : Constr.named_context option; - (* State id on which the completion of type checking is reported *) - proof_entry_feedback : Stateid.t option; - proof_entry_type : Constr.types option; - proof_entry_universes : Entries.universes_entry; - proof_entry_opaque : bool; - proof_entry_inline_code : bool; -} - (** When a proof is closed, it is reified into a [proof_object] *) type proof_object = { name : Names.Id.t (** name of the proof *) - ; entries : Evd.side_effects proof_entry list + ; entries : Evd.side_effects Declare.proof_entry list (** list of the proof terms (in a form suitable for definitions). *) ; poly : bool (** polymorphic status *) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 2d0806b2e0..b93c4a176f 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -546,7 +546,8 @@ module New = struct Proofview.tclOR (Proofview.tclTIMEOUT n t) begin function (e, info) -> match e with - | Proofview.Timeout as e -> Proofview.tclZERO (Refiner.FailError (0,lazy (CErrors.print e))) + | Logic_monad.Tac_Timeout as e -> + Proofview.tclZERO (Refiner.FailError (0,lazy (CErrors.print e))) | e -> Proofview.tclZERO ~info e end diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 6dd749aa0d..c5c7969a09 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -1,4 +1,6 @@ Declare +Proof_global +Pfedit Dnet Dn Btermdn diff --git a/test-suite/arithmetic/diveucl_21.v b/test-suite/arithmetic/diveucl_21.v index b888c97be3..b12dba429c 100644 --- a/test-suite/arithmetic/diveucl_21.v +++ b/test-suite/arithmetic/diveucl_21.v @@ -10,11 +10,11 @@ Check (eq_refl (4611686018427387904,1) <<: diveucl_21 1 1 2 = (46116860184273879 Definition compute1 := Eval compute in diveucl_21 1 1 2. Check (eq_refl compute1 : (4611686018427387904,1) = (4611686018427387904,1)). -Check (eq_refl : diveucl_21 3 1 2 = (4611686018427387904, 1)). -Check (eq_refl (4611686018427387904, 1) <: diveucl_21 3 1 2 = (4611686018427387904, 1)). -Check (eq_refl (4611686018427387904, 1) <<: diveucl_21 3 1 2 = (4611686018427387904, 1)). +Check (eq_refl : diveucl_21 3 1 2 = (0, 0)). +Check (eq_refl (0, 0) <: diveucl_21 3 1 2 = (0, 0)). +Check (eq_refl (0, 0) <<: diveucl_21 3 1 2 = (0, 0)). Definition compute2 := Eval compute in diveucl_21 3 1 2. -Check (eq_refl compute2 : (4611686018427387904, 1) = (4611686018427387904, 1)). +Check (eq_refl compute2 : (0, 0) = (0, 0)). Check (eq_refl : diveucl_21 1 1 0 = (0,0)). Check (eq_refl (0,0) <: diveucl_21 1 1 0 = (0,0)). @@ -23,3 +23,7 @@ Check (eq_refl (0,0) <<: diveucl_21 1 1 0 = (0,0)). Check (eq_refl : diveucl_21 9223372036854775807 0 1 = (0,0)). Check (eq_refl (0,0) <: diveucl_21 9223372036854775807 0 1 = (0,0)). Check (eq_refl (0,0) <<: diveucl_21 9223372036854775807 0 1 = (0,0)). + +Check (eq_refl : diveucl_21 9305446873517 1793572051078448654 4930380657631323783 = (17407905077428, 3068214991893055266)). +Check (eq_refl (17407905077428, 3068214991893055266) <: diveucl_21 9305446873517 1793572051078448654 4930380657631323783 = (17407905077428, 3068214991893055266)). +Check (eq_refl (17407905077428, 3068214991893055266) <<: diveucl_21 9305446873517 1793572051078448654 4930380657631323783 = (17407905077428, 3068214991893055266)). diff --git a/test-suite/bugs/closed/bug_10088.v b/test-suite/bugs/closed/bug_10088.v new file mode 100644 index 0000000000..3e17bfc12a --- /dev/null +++ b/test-suite/bugs/closed/bug_10088.v @@ -0,0 +1,6 @@ +Require Import ssreflect. +From Ltac2 Require Import Ltac2. + +Inductive nat_list := + Nil +| Cons of nat & nat_list. diff --git a/test-suite/bugs/closed/bug_9294.v b/test-suite/bugs/closed/bug_9294.v new file mode 100644 index 0000000000..a079d672d3 --- /dev/null +++ b/test-suite/bugs/closed/bug_9294.v @@ -0,0 +1,29 @@ +Set Printing Universes. + +Inductive Foo@{i} (A:Type@{i}) : Type := foo : (Set:Type@{i}) -> Foo A. +Arguments foo {_} _. +Print Universes Subgraph (Foo.i). +Definition bar : Foo True -> Set := fun '(foo x) => x. + +Definition foo_bar (n : Foo True) : foo (bar n) = n. +Proof. destruct n;reflexivity. Qed. + +Definition bar_foo (n : Set) : bar (foo n) = n. +Proof. reflexivity. Qed. + +Require Import Hurkens. + +Inductive box (A : Set) : Prop := Box : A -> box A. + +Definition Paradox : False. +Proof. +Fail unshelve refine ( + NoRetractFromSmallPropositionToProp.paradox + (Foo True) + (fun A => foo A) + (fun A => box (bar A)) + _ + _ + False +). +Abort. diff --git a/test-suite/coqchk/inductive_functor_template.v b/test-suite/coqchk/inductive_functor_template.v index bc5cd0fb68..4b6916af55 100644 --- a/test-suite/coqchk/inductive_functor_template.v +++ b/test-suite/coqchk/inductive_functor_template.v @@ -2,7 +2,7 @@ Module Type E. Parameter T : Type. End E. Module F (X:E). - #[universes(template)] Inductive foo := box : X.T -> foo. + Inductive foo := box : X.T -> foo. End F. Module ME. Definition T := nat. End ME. diff --git a/test-suite/failure/Template.v b/test-suite/failure/Template.v new file mode 100644 index 0000000000..75b2a56169 --- /dev/null +++ b/test-suite/failure/Template.v @@ -0,0 +1,32 @@ +(* +Module TestUnsetTemplateCheck. + Unset Template Check. + + Section Foo. + + Context (A : Type). + + Definition cstr := nat : ltac:(let ty := type of A in exact ty). + + Inductive myind := + | cons : A -> myind. + End Foo. + + (* Can only succeed if no template check is performed *) + Check myind True : Prop. + + Print Assumptions myind. + (* + Axioms: + myind is template polymorphic on all its universe parameters. + *) + About myind. +(* +myind : Type@{Top.60} -> Type@{Top.60} + +myind is assumed template universe polymorphic on Top.60 +Argument scope is [type_scope] +Expands to: Inductive Top.TestUnsetTemplateCheck.myind +*) +End TestUnsetTemplateCheck. +*) diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 4e949dcb04..a040b69b44 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -84,7 +84,6 @@ Print f. (* Was enhancement request #5142 (error message reported on the most general return clause heuristic) *) -#[universes(template)] Inductive gadt : Type -> Type := | gadtNat : nat -> gadt nat | gadtTy : forall T, T -> gadt T. diff --git a/test-suite/output/Coercions.v b/test-suite/output/Coercions.v index 6976f35a88..0e84bf3966 100644 --- a/test-suite/output/Coercions.v +++ b/test-suite/output/Coercions.v @@ -1,7 +1,7 @@ (* Submitted by Randy Pollack *) -#[universes(template)] Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. -#[universes(template)] Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. +Record pred (S : Set) : Type := {sp_pred :> S -> Prop}. +Record rel (S : Set) : Type := {sr_rel :> S -> S -> Prop}. Section testSection. Variables (S : Set) (P : pred S) (R : rel S) (x : S). diff --git a/test-suite/output/Emacs_and_diffs.out b/test-suite/output/Emacs_and_diffs.out new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/test-suite/output/Emacs_and_diffs.out diff --git a/test-suite/output/Emacs_and_diffs.v b/test-suite/output/Emacs_and_diffs.v new file mode 100644 index 0000000000..c35fd1a11b --- /dev/null +++ b/test-suite/output/Emacs_and_diffs.v @@ -0,0 +1,3 @@ +(* coq-prog-args: ("-emacs") *) +Set Diffs "on". +(* verify this does not produce an error message *) diff --git a/test-suite/output/Extraction_matchs_2413.v b/test-suite/output/Extraction_matchs_2413.v index f9398fdca9..1ecd9771eb 100644 --- a/test-suite/output/Extraction_matchs_2413.v +++ b/test-suite/output/Extraction_matchs_2413.v @@ -101,7 +101,7 @@ Section decoder_result. Variable inst : Type. - #[universes(template)] Inductive decoder_result : Type := + Inductive decoder_result : Type := | DecUndefined : decoder_result | DecUnpredictable : decoder_result | DecInst : inst -> decoder_result diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v index 9b25c2dbd3..61ae4edbd1 100644 --- a/test-suite/output/Fixpoint.v +++ b/test-suite/output/Fixpoint.v @@ -44,7 +44,7 @@ fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1). omega. Qed. -#[universes(template)] CoInductive Inf := S { projS : Inf }. +CoInductive Inf := S { projS : Inf }. Definition expand_Inf (x : Inf) := S (projS x). CoFixpoint inf := S inf. Eval compute in inf. diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 29614c032a..aeebc0f98b 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -123,7 +123,7 @@ Check fun n => foo4 n (fun x y z => (fun _ => y=0) z). (**********************************************************************) (* Test printing of #4932 *) -#[universes(template)] Inductive ftele : Type := +Inductive ftele : Type := | fb {T:Type} : T -> ftele | fr {T} : (T -> ftele) -> ftele. diff --git a/test-suite/output/PatternsInBinders.v b/test-suite/output/PatternsInBinders.v index 0c1b08f5a3..d671053c07 100644 --- a/test-suite/output/PatternsInBinders.v +++ b/test-suite/output/PatternsInBinders.v @@ -53,7 +53,7 @@ Module Suboptimal. (** This test shows an example which exposes the [let] introduced by the pattern notation in binders. *) -#[universes(template)] Inductive Fin (n:nat) := Z : Fin n. +Inductive Fin (n:nat) := Z : Fin n. Definition F '(n,p) : Type := (Fin n * Fin p)%type. Definition both_z '(n,p) : F (n,p) := (Z _,Z _). Print both_z. diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index ab4172711e..e788977fb7 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -1,6 +1,6 @@ existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} -existT is template universe polymorphic +existT is template universe polymorphic on sigT.u0 sigT.u1 Argument A is implicit Argument scopes are [type_scope function_scope _ _] Expands to: Constructor Coq.Init.Specif.existT diff --git a/test-suite/output/Projections.v b/test-suite/output/Projections.v index 35f36e87d7..14d63d39c4 100644 --- a/test-suite/output/Projections.v +++ b/test-suite/output/Projections.v @@ -6,7 +6,7 @@ Class HostFunction := host_func : Type. Section store. Context `{HostFunction}. - #[universes(template)] Record store := { store_funcs : host_func }. + Record store := { store_funcs : host_func }. End store. Check (fun (S:@store nat) => S.(store_funcs)). diff --git a/test-suite/output/Record.v b/test-suite/output/Record.v index 4fe7b051f8..d9a649fadc 100644 --- a/test-suite/output/Record.v +++ b/test-suite/output/Record.v @@ -20,12 +20,12 @@ Check {| field := 5 |}. Check build_r 5. Check build_c 5. -#[universes(template)] Record N := C { T : Type; _ : True }. +Record N := C { T : Type; _ : True }. Check fun x:N => let 'C _ p := x in p. Check fun x:N => let 'C T _ := x in T. Check fun x:N => let 'C T p := x in (T,p). -#[universes(template)] Record M := D { U : Type; a := 0; q : True }. +Record M := D { U : Type; a := 0; q : True }. Check fun x:M => let 'D T _ p := x in p. Check fun x:M => let 'D T _ p := x in T. Check fun x:M => let 'D T p := x in (T,p). diff --git a/test-suite/output/ShowMatch.v b/test-suite/output/ShowMatch.v index 99183f2064..9cf6ad35b8 100644 --- a/test-suite/output/ShowMatch.v +++ b/test-suite/output/ShowMatch.v @@ -3,12 +3,12 @@ *) Module A. - #[universes(template)] Inductive foo := f. + Inductive foo := f. Show Match foo. (* no need to disambiguate *) End A. Module B. - #[universes(template)] Inductive foo := f. + Inductive foo := f. (* local foo shadows A.foo, so constructor "f" needs disambiguation *) Show Match A.foo. End B. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index 222a808768..a89fd64999 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -68,9 +68,9 @@ mono The command has indeed failed with message: Universe u already exists. bobmorane = -let tt := Type@{UnivBinders.32} in -let ff := Type@{UnivBinders.34} in tt -> ff - : Type@{max(UnivBinders.31,UnivBinders.33)} +let tt := Type@{UnivBinders.33} in +let ff := Type@{UnivBinders.35} in tt -> ff + : Type@{max(UnivBinders.32,UnivBinders.34)} The command has indeed failed with message: Universe u already bound. foo@{E M N} = @@ -143,16 +143,16 @@ Applied.infunct@{u v} = inmod@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) -axfoo@{i UnivBinders.56 UnivBinders.57} : -Type@{UnivBinders.56} -> Type@{i} -(* i UnivBinders.56 UnivBinders.57 |= *) +axfoo@{i UnivBinders.57 UnivBinders.58} : +Type@{UnivBinders.57} -> Type@{i} +(* i UnivBinders.57 UnivBinders.58 |= *) axfoo is universe polymorphic Argument scope is [type_scope] Expands to: Constant UnivBinders.axfoo -axbar@{i UnivBinders.56 UnivBinders.57} : -Type@{UnivBinders.57} -> Type@{i} -(* i UnivBinders.56 UnivBinders.57 |= *) +axbar@{i UnivBinders.57 UnivBinders.58} : +Type@{UnivBinders.58} -> Type@{i} +(* i UnivBinders.57 UnivBinders.58 |= *) axbar is universe polymorphic Argument scope is [type_scope] diff --git a/test-suite/output/Warnings.v b/test-suite/output/Warnings.v index 0eb5db1733..7465442cab 100644 --- a/test-suite/output/Warnings.v +++ b/test-suite/output/Warnings.v @@ -1,5 +1,5 @@ (* Term in warning was not printed in the right environment at some time *) -#[universes(template)] Record A := { B:Type; b:B->B }. +Record A := { B:Type; b:B->B }. Definition a B := {| B:=B; b:=fun x => x |}. Canonical Structure a. diff --git a/test-suite/output/auto.out b/test-suite/output/auto.out index 2761b87b02..5e81b43504 100644 --- a/test-suite/output/auto.out +++ b/test-suite/output/auto.out @@ -2,18 +2,18 @@ simple apply or_intror (in core). intro. assumption. -Debug: (* debug auto: *) -Debug: * assumption. (*fail*) -Debug: * intro. (*fail*) -Debug: * simple apply or_intror (in core). (*success*) -Debug: ** assumption. (*fail*) -Debug: ** intro. (*success*) -Debug: ** assumption. (*success*) +(* debug auto: *) +* assumption. (*fail*) +* intro. (*fail*) +* simple apply or_intror (in core). (*success*) +** assumption. (*fail*) +** intro. (*success*) +** assumption. (*success*) (* info eauto: *) simple apply or_intror. intro. exact H. -Debug: (* debug eauto: *) +(* debug eauto: *) Debug: 1 depth=5 Debug: 1.1 depth=4 simple apply or_intror Debug: 1.1.1 depth=4 intro diff --git a/test-suite/output/bug7191.out b/test-suite/output/bug7191.out new file mode 100644 index 0000000000..005455e30c --- /dev/null +++ b/test-suite/output/bug7191.out @@ -0,0 +1,9 @@ + +type unit0 = +| Tt + +(** val f : unit0 -> unit0 **) + +let f _ = + assert false (* absurd case *) + diff --git a/test-suite/output/bug7191.v b/test-suite/output/bug7191.v new file mode 100644 index 0000000000..1aa4625b6c --- /dev/null +++ b/test-suite/output/bug7191.v @@ -0,0 +1,3 @@ +Require Extraction. +Definition f (x : False) : unit -> unit := match x with end. +Recursive Extraction f. diff --git a/test-suite/output/bug7348.out b/test-suite/output/bug7348.out new file mode 100644 index 0000000000..325ee95ae2 --- /dev/null +++ b/test-suite/output/bug7348.out @@ -0,0 +1,45 @@ +Extracted code successfully compiled + +type __ = Obj.t + +type unit0 = +| Tt + +type bool = +| True +| False + +module Case1 = + struct + type coq_rec = { f : bool } + + (** val f : bool -> coq_rec -> bool **) + + let f _ r = + r.f + + (** val silly : bool -> coq_rec -> __ **) + + let silly x b = + match x with + | True -> Obj.magic b.f + | False -> Obj.magic Tt + end + +module Case2 = + struct + type coq_rec = { f : (bool -> bool) } + + (** val f : bool -> coq_rec -> bool -> bool **) + + let f _ r = + r.f + + (** val silly : bool -> coq_rec -> __ **) + + let silly x b = + match x with + | True -> Obj.magic b.f False + | False -> Obj.magic Tt + end + diff --git a/test-suite/output/bug7348.v b/test-suite/output/bug7348.v new file mode 100644 index 0000000000..782b27ce96 --- /dev/null +++ b/test-suite/output/bug7348.v @@ -0,0 +1,25 @@ +Require Extraction. + +Extraction Language OCaml. +Set Extraction KeepSingleton. + +Module Case1. + +Record rec (x : bool) := { f : bool }. + +Definition silly x (b : rec x) := + if x return (if x then bool else unit) then f x b else tt. + +End Case1. + +Module Case2. + +Record rec (x : bool) := { f : bool -> bool }. + +Definition silly x (b : rec x) := + if x return (if x then bool else unit) then f x b false else tt. + +End Case2. + +Extraction TestCompile Case1.silly Case2.silly. +Recursive Extraction Case1.silly Case2.silly. diff --git a/test-suite/output/inference.v b/test-suite/output/inference.v index 209fedc343..57a4739e9f 100644 --- a/test-suite/output/inference.v +++ b/test-suite/output/inference.v @@ -21,6 +21,6 @@ Print P. (* Note: exact numbers of evars are not important... *) -#[universes(template)] Inductive T (n:nat) : Type := A : T n. +Inductive T (n:nat) : Type := A : T n. Check fun n (y:=A n:T n) => _ _ : T n. Check fun n => _ _ : T n. diff --git a/test-suite/ssr/bang_rewrite.v b/test-suite/ssr/bang_rewrite.v new file mode 100644 index 0000000000..30e6d57a7a --- /dev/null +++ b/test-suite/ssr/bang_rewrite.v @@ -0,0 +1,13 @@ +Set Universe Polymorphism. + +Require Import ssreflect. + +Axiom mult@{i} : nat -> nat -> nat. +Notation "m * n" := (mult m n). + +Axiom multA : forall a b c, (a * b) * c = a * (b * c). + +(* Previously the following gave a universe error: *) + +Lemma multAA a b c d : ((a * b) * c) * d = a * (b * (c * d)). +Proof. by rewrite !multA. Qed. diff --git a/test-suite/ssr/congr.v b/test-suite/ssr/congr.v index 026f7538e8..f85791b00b 100644 --- a/test-suite/ssr/congr.v +++ b/test-suite/ssr/congr.v @@ -32,3 +32,11 @@ Coercion f : nat >-> Equality.sort. Lemma test4 : forall a b : nat, b = a -> @eq S (b + b) (a + a). Proof. move=> a b Eba; congr (_ + _); exact: Eba. Qed. + +Open Scope type_scope. + +Lemma test5 : forall (P Q Q' : Type) (h : Q = Q'), P * Q = P * Q'. +Proof. move=>*; by congr (_ * _). Qed. + +Lemma test6 : forall (P Q Q' : Type) (h : Q = Q'), P * Q -> P * Q'. +Proof. move=> P Q Q' h; by congr (_ * _). Qed. diff --git a/test-suite/success/RewriteRegisteredElim.v b/test-suite/success/RewriteRegisteredElim.v new file mode 100644 index 0000000000..39b103747c --- /dev/null +++ b/test-suite/success/RewriteRegisteredElim.v @@ -0,0 +1,35 @@ + +Set Universe Polymorphism. + +Cumulative Inductive EQ {A} (x : A) : A -> Type + := EQ_refl : EQ x x. + +Register EQ as core.eq.type. + +Lemma renamed_EQ_rect {A} (x:A) (P : A -> Type) + (c : P x) (y : A) (e : EQ x y) : P y. +Proof. destruct e. assumption. Qed. + +Register renamed_EQ_rect as core.eq.rect. +Register renamed_EQ_rect as core.eq.ind. + +Lemma renamed_EQ_rect_r {A} (x:A) (P : A -> Type) + (c : P x) (y : A) (e : EQ y x) : P y. +Proof. destruct e. assumption. Qed. + +Register renamed_EQ_rect_r as core.eq.rect_r. +Register renamed_EQ_rect_r as core.eq.ind_r. + +Lemma EQ_sym1 {A} {x y : A} (e : EQ x y) : EQ y x. +Proof. rewrite e. reflexivity. Qed. + +Lemma EQ_sym2 {A} {x y : A} (e : EQ x y) : EQ y x. +Proof. rewrite <- e. reflexivity. Qed. + +Require Import ssreflect. + +Lemma ssr_EQ_sym1 {A} {x y : A} (e : EQ x y) : EQ y x. +Proof. rewrite e. reflexivity. Qed. + +Lemma ssr_EQ_sym2 {A} {x y : A} (e : EQ x y) : EQ y x. +Proof. rewrite -e. reflexivity. Qed. diff --git a/test-suite/success/Template.v b/test-suite/success/Template.v index cfc25c3346..656362b8fc 100644 --- a/test-suite/success/Template.v +++ b/test-suite/success/Template.v @@ -46,3 +46,129 @@ Module No. Definition j_lebox (A:Type@{j}) := Box A. Fail Definition box_lti A := Box A : Type@{i}. End No. + +Module DefaultProp. + Inductive identity (A : Type) (a : A) : A -> Type := id_refl : identity A a a. + + (* By default template polymorphism does not interact with inductives + which naturally fall in Prop *) + Check (identity nat 0 0 : Prop). +End DefaultProp. + +Module ExplicitTemplate. + #[universes(template)] + Inductive identity@{i} (A : Type@{i}) (a : A) : A -> Type@{i} := id_refl : identity A a a. + + (* Weird interaction of template polymorphism and inductive types + which naturally fall in Prop: this one is template polymorphic but not on i: + it just lives in any universe *) + Check (identity Type nat nat : Prop). +End ExplicitTemplate. + +Polymorphic Definition f@{i} : Type@{i} := nat. +Polymorphic Definition baz@{i} : Type@{i} -> Type@{i} := fun x => x. + +Section Foo. + Universe u. + Context (A : Type@{u}). + + Inductive Bar := + | bar : A -> Bar. + + Set Universe Minimization ToSet. + Inductive Baz := + | cbaz : A -> baz Baz -> Baz. + + Inductive Baz' := + | cbaz' : A -> baz@{Set} nat -> Baz'. + + (* 2 constructors, at least in Set *) + Inductive Bazset@{v} := + | cbaz1 : A -> baz@{v} Bazset -> Bazset + | cbaz2 : Bazset. + + Eval compute in ltac:(let T := type of A in exact T). + + Inductive Foo : Type := + | foo : A -> f -> Foo. + +End Foo. + +Set Printing Universes. +(* Cannot fall back to Prop or Set anymore as baz is no longer template-polymorphic *) +Fail Check Bar True : Prop. +Fail Check Bar nat : Set. +About Baz. + +Check cbaz True I. + +(** Neither can it be Set *) +Fail Check Baz nat : Set. + +(** No longer possible for Baz' which contains a type in Set *) +Fail Check Baz' True : Prop. +Fail Check Baz' nat : Set. + +Fail Check Bazset True : Prop. +Fail Check Bazset True : Set. + +(** We can force the universe instantiated in [baz Bazset] to be [u], so Bazset lives in max(Set, u). *) +Constraint u = Bazset.v. +(** As u is global it is already > Set, so: *) +Definition bazsetex@{i | i < u} : Type@{u} := Bazset Type@{i}. + +(* Bazset is closed for universes u = u0, cannot be instantiated with Prop *) +Definition bazseetpar (X : Type@{u}) : Type@{u} := Bazset X. + +(** Would otherwise break singleton elimination and extraction. *) +Fail Check Foo True : Prop. +Fail Check Foo True : Set. + +Definition foo_proj {A} (f : Foo A) : nat := + match f with foo _ _ n => n end. + +Definition ex : Foo True := foo _ I 0. +Check foo_proj ex. + +(** See failure/Template.v for a test of the unsafe Unset Template Check usage *) + +Module AutoTemplateTest. +Set Warnings "+auto-template". +Section Foo. + Universe u'. + Context (A : Type@{u'}). + + (* Not failing as Bar cannot be made template polymorphic at all *) + Inductive Bar := + | bar : A -> Bar. +End Foo. +End AutoTemplateTest. + +Module TestTemplateAttribute. + Section Foo. + Universe u. + Context (A : Type@{u}). + + (* Failing as Bar cannot be made template polymorphic at all *) + Fail #[universes(template)] Inductive Bar := + | bar : A -> Bar. + + End Foo. +End TestTemplateAttribute. + +Module SharingWithoutSection. +Inductive Foo A (S:= fun _ => Set : ltac:(let ty := type of A in exact ty)) + := foo : S A -> Foo A. +Fail Check Foo True : Prop. +End SharingWithoutSection. + +Module OkNotCovered. +(* Here it happens that box is safe but we don't see it *) +Section S. +Universe u. +Variable A : Type@{u}. +Inductive box (A:Type@{u}) := Box : A -> box A. +Definition B := Set : Type@{u}. +End S. +Fail Check box True : Prop. +End OkNotCovered. diff --git a/test-suite/success/typing_flags.v b/test-suite/success/typing_flags.v new file mode 100644 index 0000000000..bd20d9c804 --- /dev/null +++ b/test-suite/success/typing_flags.v @@ -0,0 +1,43 @@ + +Print Typing Flags. +Unset Guard Checking. +Fixpoint f' (n : nat) : nat := f' n. + +Fixpoint f (n : nat) : nat. +Proof. + exact (f n). +Defined. + +Fixpoint bla (A:Type) (n:nat) := match n with 0 =>0 | S n => n end. + +Print Typing Flags. + +Set Guard Checking. + +Print Assumptions f. + +Unset Universe Checking. + +Definition T := Type. +Fixpoint g (n : nat) : T := T. + +Print Typing Flags. +Set Universe Checking. + +Fail Definition g2 (n : nat) : T := T. + +Fail Definition e := fix e (n : nat) : nat := e n. + +Unset Positivity Checking. + +Inductive Cor := +| Over : Cor +| Next : ((Cor -> list nat) -> list nat) -> Cor. + +Set Positivity Checking. +Print Assumptions Cor. + +Inductive Box := +| box : forall n, f n = n -> g 2 -> Box. + +Print Assumptions Box. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 0c0a1897a8..296c253363 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -822,4 +822,4 @@ Defined. Lemma eqb_spec (b b' : bool) : reflect (b = b') (eqb b b'). Proof. destruct b, b'; now constructor. -Qed. +Defined. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 428af5fcfe..69bd1e6c96 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -286,7 +286,6 @@ Local Open Scope list_scope. (** A compact representation of non-dependent arities, with the codomain singled-out. *) (* Note, we do not use [list Type] because it imposes unnecessary universe constraints *) -#[universes(template)] Inductive Tlist : Type := Tnil : Tlist | Tcons : Type -> Tlist -> Tlist. Local Infix "::" := Tcons. diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 071810acdc..6858706cb3 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -27,7 +27,6 @@ Require Export Coq.Classes.Morphisms. (** A setoid wraps an equivalence. *) -#[universes(template)] Class Setoid A := { equiv : relation A ; setoid_equiv :> Equivalence equiv }. @@ -129,7 +128,6 @@ 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. *) -#[universes(template)] Class PartialSetoid (A : Type) := { pequiv : relation A ; pequiv_prf :> PER pequiv }. diff --git a/theories/Compat/Coq89.v b/theories/Compat/Coq89.v index 5025bce093..274cb4afd3 100644 --- a/theories/Compat/Coq89.v +++ b/theories/Compat/Coq89.v @@ -14,3 +14,6 @@ Local Set Warnings "-deprecated". Require Export Coq.Compat.Coq810. Unset Private Polymorphic Universes. + +(** Unsafe flag, can hide inconsistencies. *) +Global Unset Template Check. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 801be79ba4..8627ff7353 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -45,20 +45,23 @@ Hint Transparent key : core. (** * Trees *) -Section Elt. - -Variable elt : Type. - (** * Trees The fifth field of [Node] is the height of the tree *) #[universes(template)] -Inductive tree := +Inductive tree {elt : Type} := | Leaf : tree | Node : tree -> key -> elt -> tree -> int -> tree. +Arguments tree : clear implicits. -Notation t := tree. +Section Elt. + +Variable elt : Type. + +Notation t := (tree elt). + +Implicit Types m : t. (** * Basic functions on trees: height and cardinal *) @@ -76,7 +79,7 @@ Fixpoint cardinal (m : t) : nat := (** * Empty Map *) -Definition empty := Leaf. +Definition empty : t := Leaf. (** * Emptyness test *) @@ -236,7 +239,6 @@ Fixpoint join l : key -> elt -> t -> t := - [o] is the result of [find x m]. *) -#[universes(template)] Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). @@ -293,7 +295,6 @@ Variable cmp : elt->elt->bool. (** ** Enumeration of the elements of a tree *) -#[universes(template)] Inductive enumeration := | End : enumeration | More : key -> elt -> t -> enumeration -> enumeration. @@ -338,6 +339,9 @@ Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End). End Elt. Notation t := tree. +Arguments Leaf : clear implicits. +Arguments Node [elt]. + Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). Notation "t #o" := (t_opt t) (at level 9, format "t '#o'"). diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 2af6e5c6a4..b21d809059 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -1024,7 +1024,6 @@ Module E := X. Definition key := E.t. -#[universes(template)] Record slist (elt:Type) := {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. Definition t (elt:Type) : Type := slist elt. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 0c04437581..b9a8b0a73d 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -868,8 +868,6 @@ Module Make (X: DecidableType) <: WS with Module E:=X. Module E := X. Definition key := E.t. - -#[universes(template)] Record slist (elt:Type) := {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. Definition t (elt:Type) := slist elt. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 1639115cbd..3e0bf1d8ae 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -387,8 +387,10 @@ Proof. intros. apply CompareSpec2Type; assumption. Defined. (** [identity A a] is the family of datatypes on [A] whose sole non-empty member is the singleton datatype [identity A a a] whose sole inhabitant is denoted [identity_refl A a] *) +(** Beware: this inductive actually falls into [Prop], as the sole + constructor has no arguments and [-indices-matter] is not + activated in the standard library. *) -#[universes(template)] Inductive identity (A:Type) (a:A) : A -> Type := identity_refl : identity a a. Hint Resolve identity_refl: core. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 7f36edf5bb..38723e291f 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -536,6 +536,26 @@ Section Elts. simpl in *. apply IHn. auto with arith. Qed. + (** Results directly relating [nth] and [nth_error] *) + + Lemma nth_error_nth : forall (l : list A) (n : nat) (x d : A), + nth_error l n = Some x -> nth n l d = x. + Proof. + intros l n x d H. + apply nth_error_split in H. destruct H as [l1 [l2 [H H']]]. + subst. rewrite app_nth2; [|auto]. + rewrite Nat.sub_diag. reflexivity. + Qed. + + Lemma nth_error_nth' : forall (l : list A) (n : nat) (d : A), + n < length l -> nth_error l n = Some (nth n l d). + Proof. + intros l n d H. + apply nth_split with (d:=d) in H. destruct H as [l1 [l2 [H H']]]. + subst. rewrite H. rewrite nth_error_app2; [|auto]. + rewrite app_nth2; [| auto]. repeat (rewrite Nat.sub_diag). reflexivity. + Qed. + (*****************) (** ** Remove *) (*****************) @@ -1227,6 +1247,20 @@ End Fold_Right_Recursor. case_eq (f a); intros; simpl; intuition congruence. Qed. + Lemma filter_app (l l':list A) : + filter (l ++ l') = filter l ++ filter l'. + Proof. + induction l as [|x l IH]; simpl; trivial. + destruct (f x); simpl; now rewrite IH. + Qed. + + Lemma concat_filter_map : forall (l : list (list A)), + concat (map filter l) = filter (concat l). + Proof. + induction l as [| v l IHl]; [auto|]. + simpl. rewrite IHl. rewrite filter_app. reflexivity. + Qed. + (** [find] *) Fixpoint find (l:list A) : option A := @@ -1309,6 +1343,55 @@ End Fold_Right_Recursor. End Bool. + (*******************************) + (** ** Further filtering facts *) + (*******************************) + + Section Filtering. + Variables (A : Type). + + Lemma filter_map : forall (f g : A -> bool) (l : list A), + filter f l = filter g l <-> map f l = map g l. + Proof. + induction l as [| a l IHl]; [firstorder|]. + simpl. destruct (f a) eqn:Hfa; destruct (g a) eqn:Hga; split; intros H. + - inversion H. apply IHl in H1. rewrite H1. reflexivity. + - inversion H. apply IHl in H1. rewrite H1. reflexivity. + - assert (Ha : In a (filter g l)). { rewrite <- H. apply in_eq. } + apply filter_In in Ha. destruct Ha as [_ Hga']. rewrite Hga in Hga'. inversion Hga'. + - inversion H. + - assert (Ha : In a (filter f l)). { rewrite H. apply in_eq. } + apply filter_In in Ha. destruct Ha as [_ Hfa']. rewrite Hfa in Hfa'. inversion Hfa'. + - inversion H. + - rewrite IHl in H. rewrite H. reflexivity. + - inversion H. apply IHl. assumption. + Qed. + + Lemma filter_ext_in : forall (f g : A -> bool) (l : list A), + (forall a, In a l -> f a = g a) -> filter f l = filter g l. + Proof. + intros f g l H. rewrite filter_map. apply map_ext_in. auto. + Qed. + + Lemma ext_in_filter : forall (f g : A -> bool) (l : list A), + filter f l = filter g l -> (forall a, In a l -> f a = g a). + Proof. + intros f g l H. rewrite filter_map in H. apply ext_in_map. assumption. + Qed. + + Lemma filter_ext_in_iff : forall (f g : A -> bool) (l : list A), + filter f l = filter g l <-> (forall a, In a l -> f a = g a). + Proof. + split; [apply ext_in_filter | apply filter_ext_in]. + Qed. + + Lemma filter_ext : forall (f g : A -> bool), + (forall a, f a = g a) -> forall l, filter f l = filter g l. + Proof. + intros f g H l. rewrite filter_map. apply map_ext. assumption. + Qed. + + End Filtering. (******************************************************) @@ -1845,6 +1928,56 @@ Section Cutting. End Cutting. +(**************************************************************) +(** ** Combining pairs of lists of possibly-different lengths *) +(**************************************************************) + +Section Combining. + Variables (A B : Type). + + Lemma combine_nil : forall (l : list A), + combine l (@nil B) = @nil (A*B). + Proof. + intros l. + apply length_zero_iff_nil. + rewrite combine_length. simpl. rewrite Nat.min_0_r. + reflexivity. + Qed. + + Lemma combine_firstn_l : forall (l : list A) (l' : list B), + combine l l' = combine l (firstn (length l) l'). + Proof. + induction l as [| x l IHl]; intros l'; [reflexivity|]. + destruct l' as [| x' l']; [reflexivity|]. + simpl. specialize IHl with (l':=l'). rewrite <- IHl. + reflexivity. + Qed. + + Lemma combine_firstn_r : forall (l : list A) (l' : list B), + combine l l' = combine (firstn (length l') l) l'. + Proof. + intros l l'. generalize dependent l. + induction l' as [| x' l' IHl']; intros l. + - simpl. apply combine_nil. + - destruct l as [| x l]; [reflexivity|]. + simpl. specialize IHl' with (l:=l). rewrite <- IHl'. + reflexivity. + Qed. + + Lemma combine_firstn : forall (l : list A) (l' : list B) (n : nat), + firstn n (combine l l') = combine (firstn n l) (firstn n l'). + Proof. + induction l as [| x l IHl]; intros l' n. + - simpl. repeat (rewrite firstn_nil). reflexivity. + - destruct l' as [| x' l']. + + simpl. repeat (rewrite firstn_nil). rewrite combine_nil. reflexivity. + + simpl. destruct n as [| n]; [reflexivity|]. + repeat (rewrite firstn_cons). simpl. + rewrite IHl. reflexivity. + Qed. + +End Combining. + (**********************************************************************) (** ** Predicate for List addition/removal (no need for decidability) *) (**********************************************************************) @@ -1959,6 +2092,15 @@ Section ReDun. | x::xs => if in_dec decA x xs then nodup xs else x::(nodup xs) end. + Lemma nodup_fixed_point : forall (l : list A), + NoDup l -> nodup l = l. + Proof. + induction l as [| x l IHl]; [auto|]. intros H. + simpl. destruct (in_dec decA x l) as [Hx | Hx]; rewrite NoDup_cons_iff in H. + - destruct H as [H' _]. contradiction. + - destruct H as [_ H']. apply IHl in H'. rewrite -> H'. reflexivity. + Qed. + Lemma nodup_In l x : In x (nodup l) <-> In x l. Proof. induction l as [|a l' Hrec]; simpl. diff --git a/theories/Lists/StreamMemo.v b/theories/Lists/StreamMemo.v index c11a0941fa..4c6520feb3 100644 --- a/theories/Lists/StreamMemo.v +++ b/theories/Lists/StreamMemo.v @@ -73,14 +73,17 @@ End MemoFunction. reused thanks to a temporary hiding of the dependency in a "container" [memo_val]. *) +#[universes(template)] +Inductive memo_val {A : nat -> Type} : Type := + memo_mval: forall n, A n -> memo_val. +Arguments memo_val : clear implicits. + Section DependentMemoFunction. Variable A: nat -> Type. Variable f: forall n, A n. -#[universes(template)] -Inductive memo_val: Type := - memo_mval: forall n, A n -> memo_val. +Notation memo_val := (memo_val A). Fixpoint is_eq (n m : nat) : {n = m} + {True} := match n, m return {n = m} + {True} with diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 407a7ae45d..0daae0391c 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -12,13 +12,13 @@ Set Implicit Arguments. (** Streams *) -Section Streams. +CoInductive Stream (A : Type) := + Cons : A -> Stream A -> Stream A. -Variable A : Type. +Section Streams. + Variable A : Type. -#[universes(template)] -CoInductive Stream : Type := - Cons : A -> Stream -> Stream. + Notation Stream := (Stream A). Definition hd (x:Stream) := match x with diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index 6af7b1fe6e..9c47b73193 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -26,6 +26,8 @@ unfold not; intros; elim (classic p); auto. intro NP; elim (H NP). Qed. +Register NNPP as core.nnpp.type. + (** 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 *) diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index 4442108ffc..8a71158f4c 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -208,7 +208,6 @@ Definition concat s1 s2 := - [present] is [true] if and only if [s] contains [x]. *) -#[universes(template)] Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 37a169b02e..bf6336ae47 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -48,7 +48,6 @@ Module Type Ops (X:OrderedType)(Info:InfoTyp). Definition elt := X.t. Hint Transparent elt : core. -#[universes(template)] Inductive tree : Type := | Leaf : tree | Node : Info.t -> tree -> X.t -> tree -> tree. @@ -168,7 +167,6 @@ end. (** Enumeration of the elements of a tree. This corresponds to the "samefringe" notion in the literature. *) -#[universes(template)] Inductive enumeration := | End : enumeration | More : elt -> tree -> enumeration -> enumeration. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index 29c84d0d1a..33f6b1050c 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -439,7 +439,6 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. Definition elt := E.t. -#[universes(template)] Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. Definition t := t_. Arguments Mkt this {is_ok}. diff --git a/theories/MSets/MSetRBT.v b/theories/MSets/MSetRBT.v index a3e0ec5884..b5389e9121 100644 --- a/theories/MSets/MSetRBT.v +++ b/theories/MSets/MSetRBT.v @@ -1049,12 +1049,8 @@ Qed. (** ** Filter *) -Lemma filter_app A f (l l':list A) : - List.filter f (l ++ l') = List.filter f l ++ List.filter f l'. -Proof. - induction l as [|x l IH]; simpl; trivial. - destruct (f x); simpl; now rewrite IH. -Qed. +#[deprecated(since="8.11",note="Lemma filter_app has been moved to module List.")] +Notation filter_app := List.filter_app. Lemma filter_aux_elements s f acc : filter_aux f s acc = List.filter f (elements s) ++ acc. @@ -1062,7 +1058,7 @@ Proof. revert acc. induction s as [|c l IHl x r IHr]; trivial. intros acc. - rewrite elements_node, filter_app. simpl. + rewrite elements_node, List.filter_app. simpl. destruct (f x); now rewrite IHl, IHr, app_ass. Qed. diff --git a/theories/Numbers/Cyclic/Abstract/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v index 83e9c29b13..6e08378df4 100644 --- a/theories/Numbers/Cyclic/Abstract/DoubleType.v +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -18,46 +18,34 @@ Local Open Scope Z_scope. Definition base digits := Z.pow 2 (Zpos digits). Arguments base digits: simpl never. -Section Carry. +#[universes(template)] +Variant carry (A : Type) := +| C0 : A -> carry A +| C1 : A -> carry A. - Variable A : Type. - - #[universes(template)] - Variant carry := - | C0 : A -> carry - | C1 : A -> carry. - - Definition interp_carry (sign:Z)(B:Z)(interp:A -> Z) c := +Definition interp_carry {A} (sign:Z)(B:Z)(interp:A -> Z) c := match c with | C0 x => interp x | C1 x => sign*B + interp x end. -End Carry. - -Section Zn2Z. - - Variable znz : Type. - - (** 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. +(** 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. *) +#[universes(template)] +Variant zn2z {znz : Type} := +| W0 : zn2z +| WW : znz -> znz -> zn2z. +Arguments zn2z : clear implicits. - #[universes(template)] - Variant zn2z := - | W0 : zn2z - | WW : znz -> znz -> zn2z. - - Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) := +Definition zn2z_to_Z znz (wB:Z) (w_to_Z:znz->Z) (x:zn2z znz) := match x with | W0 => 0 | WW xh xl => w_to_Z xh * wB + w_to_Z xl end. -End Zn2Z. - Arguments W0 {znz}. (** From a cyclic representation [w], we iterate the [zn2z] construct diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index c81ba02230..9e9481341f 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -388,7 +388,7 @@ Axiom diveucl_def_spec : forall x y, diveucl x y = diveucl_def x y. Axiom diveucl_21_spec : forall a1 a2 b, let (q,r) := diveucl_21 a1 a2 b in let (q',r') := Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|] in - [|q|] = Z.modulo q' wB /\ [|r|] = r'. + [|a1|] < [|b|] -> [|q|] = q' /\ [|r|] = r'. Axiom addmuldiv_def_spec : forall p x y, addmuldiv p x y = addmuldiv_def p x y. @@ -1421,26 +1421,9 @@ Proof. generalize (Z_div_mod ([|a1|]*wB+[|a2|]) [|b|] H). revert W. destruct (diveucl_21 a1 a2 b); destruct (Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]). - intros (H', H''); rewrite H', H''; clear H' H''. + intros (H', H''); auto; rewrite H', H''; clear H' H''. intros (H', H''); split; [ |exact H'']. - rewrite H', Zmult_comm, Z.mod_small; [reflexivity| ]. - split. - { revert H'; case z; [now simpl..|intros p H']. - exfalso; apply (Z.lt_irrefl 0), (Z.le_lt_trans _ ([|a1|] * wB + [|a2|])). - { now apply Z.add_nonneg_nonneg; [apply Z.mul_nonneg_nonneg| ]. } - rewrite H'; apply (Zplus_lt_reg_r _ _ (- z0)); ring_simplify. - apply (Z.le_lt_trans _ (- [|b|])); [ |now auto with zarith]. - rewrite Z.opp_eq_mul_m1; apply Zmult_le_compat_l; [ |now apply Wb]. - rewrite <-!Pos2Z.opp_pos, <-Z.opp_le_mono. - now change 1 with (Z.succ 0); apply Zlt_le_succ. } - rewrite <-Z.nle_gt; intro Hz; revert H2; apply Zle_not_lt. - rewrite (Z.div_unique_pos (wB * [|a1|] + [|a2|]) wB [|a1|] [|a2|]); - [ |now simpl..]. - rewrite Z.mul_comm, H'. - rewrite (Z.div_unique_pos (wB * [|b|] + z0) wB [|b|] z0) at 1; - [ |split; [ |apply (Z.lt_trans _ [|b|])]; now simpl|reflexivity]. - apply Z_div_le; [now simpl| ]; rewrite Z.mul_comm; apply Zplus_le_compat_r. - now apply Zmult_le_compat_l. + now rewrite H', Zmult_comm. Qed. Lemma div2_phi ih il j: (2^62 <= [|j|] -> [|ih|] < [|j|] -> diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 28565b2fe3..2785e89c5d 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -648,40 +648,15 @@ Section ZModulo. apply two_power_pos_correct. Qed. - Definition head0 x := match [|x|] with + Definition head0 x := + match [| x |] with | Z0 => zdigits - | Zpos p => zdigits - log_inf p - 1 - | _ => 0 - end. + | Zneg _ => 0 + | (Zpos _) as p => zdigits - Z.log2 p - 1 + end. Lemma spec_head00: forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits. - Proof. - unfold head0; intros. - rewrite H; simpl. - apply spec_zdigits. - Qed. - - Lemma log_inf_bounded : forall x p, Zpos x < 2^p -> log_inf x < p. - Proof. - induction x; simpl; intros. - - assert (0 < p) by (destruct p; compute; auto with zarith; discriminate). - cut (log_inf x < p - 1); [omega| ]. - apply IHx. - change (Zpos x~1) with (2*(Zpos x)+1) in H. - replace p with (Z.succ (p-1)) in H; auto with zarith. - rewrite Z.pow_succ_r in H; auto with zarith. - - assert (0 < p) by (destruct p; compute; auto with zarith; discriminate). - cut (log_inf x < p - 1); [omega| ]. - apply IHx. - change (Zpos x~0) with (2*(Zpos x)) in H. - replace p with (Z.succ (p-1)) in H; auto with zarith. - rewrite Z.pow_succ_r in H; auto with zarith. - - simpl; intros; destruct p; compute; auto with zarith. - Qed. - + Proof. unfold head0; intros x ->; apply spec_zdigits. Qed. Lemma spec_head0 : forall x, 0 < [|x|] -> wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB. @@ -689,36 +664,35 @@ Section ZModulo. intros; unfold head0. generalize (spec_to_Z x). destruct [|x|]; try discriminate. + pose proof (Z.log2_nonneg (Zpos p)). + destruct (Z.log2_spec (Zpos p)); auto. intros. - destruct (log_inf_correct p). - rewrite 2 two_p_power2 in H2; auto with zarith. - assert (0 <= zdigits - log_inf p - 1 < wB). + assert (0 <= zdigits - Z.log2 (Zpos p) - 1 < wB) as Hrange. split. - cut (log_inf p < zdigits); try omega. + cut (Z.log2 (Zpos p) < zdigits). omega. unfold zdigits. unfold wB, base in *. - apply log_inf_bounded; auto with zarith. + apply Z.log2_lt_pow2; intuition. apply Z.lt_trans with zdigits. omega. unfold zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith. - unfold to_Z; rewrite (Zmod_small _ _ H3). - destruct H2. + unfold to_Z; rewrite (Zmod_small _ _ Hrange). split. - apply Z.le_trans with (2^(zdigits - log_inf p - 1)*(2^log_inf p)). + apply Z.le_trans with (2^(zdigits - Z.log2 (Zpos p) - 1)*(2^Z.log2 (Zpos p))). apply Zdiv_le_upper_bound; auto with zarith. rewrite <- Zpower_exp; auto with zarith. rewrite Z.mul_comm; rewrite <- Z.pow_succ_r; auto with zarith. - replace (Z.succ (zdigits - log_inf p -1 +log_inf p)) with zdigits + replace (Z.succ (zdigits - Z.log2 (Zpos p) -1 + Z.log2 (Zpos p))) with zdigits by ring. unfold wB, base, zdigits; auto with zarith. apply Z.mul_le_mono_nonneg; auto with zarith. apply Z.lt_le_trans - with (2^(zdigits - log_inf p - 1)*(2^(Z.succ (log_inf p)))). + with (2^(zdigits - Z.log2 (Zpos p) - 1)*(2^(Z.succ (Z.log2 (Zpos p))))). apply Z.mul_lt_mono_pos_l; auto with zarith. rewrite <- Zpower_exp; auto with zarith. - replace (zdigits - log_inf p -1 +Z.succ (log_inf p)) with zdigits + replace (zdigits - Z.log2 (Zpos p) -1 +Z.succ (Z.log2 (Zpos p))) with zdigits by ring. unfold wB, base, zdigits; auto with zarith. Qed. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 3a613c55ec..b60feb9256 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -562,6 +562,16 @@ Proof. apply Qdiv_mult_l; auto. Qed. +Lemma Qinv_plus_distr : forall a b c, ((a # c) + (b # c) == (a+b) # c)%Q. +Proof. + intros. unfold Qeq. simpl. rewrite Pos2Z.inj_mul. ring. +Qed. + +Lemma Qinv_minus_distr : forall a b c, (a # c) + - (b # c) == (a-b) # c. +Proof. + intros. unfold Qeq. simpl. rewrite Pos2Z.inj_mul. ring. +Qed. + (** Injectivity of Qmult (requires theory about Qinv above): *) Lemma Qmult_inj_r (x y z: Q): ~ z == 0 -> (x * z == y * z <-> x == y). @@ -716,6 +726,21 @@ Proof. exact (Z_lt_le_dec (Qnum x * QDen y) (Qnum y * QDen x)). Defined. +Lemma Qarchimedean : forall q : Q, { p : positive | q < Z.pos p # 1 }. +Proof. + intros. destruct q as [a b]. destruct a. + - exists xH. reflexivity. + - exists (p+1)%positive. apply (Z.lt_le_trans _ (Z.pos (p+1))). + simpl. rewrite Pos.mul_1_r. + apply Z.lt_succ_diag_r. simpl. rewrite Pos2Z.inj_mul. + rewrite <- (Zmult_1_r (Z.pos (p+1))). apply Z.mul_le_mono_nonneg. + discriminate. rewrite Zmult_1_r. apply Z.le_refl. discriminate. + apply Z2Nat.inj_le. discriminate. apply Pos2Z.is_nonneg. + apply Nat.le_succ_l. apply Nat2Z.inj_lt. + rewrite Z2Nat.id. apply Pos2Z.is_pos. apply Pos2Z.is_nonneg. + - exists xH. reflexivity. +Defined. + (** Compatibility of operations with respect to order. *) Lemma Qopp_le_compat : forall p q, p<=q -> -q <= -p. @@ -970,6 +995,21 @@ change (1/b < c). apply Qlt_shift_div_r; assumption. Qed. +Lemma Qinv_lt_contravar : forall a b : Q, + 0 < a -> 0 < b -> (a < b <-> /b < /a). +Proof. + intros. split. + - intro. rewrite <- Qmult_1_l. apply Qlt_shift_div_r. apply H0. + rewrite <- (Qmult_inv_r a). rewrite Qmult_comm. + apply Qmult_lt_l. apply Qinv_lt_0_compat. apply H. + apply H1. intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). + - intro. rewrite <- (Qinv_involutive b). rewrite <- (Qmult_1_l (// b)). + apply Qlt_shift_div_l. apply Qinv_lt_0_compat. apply H0. + rewrite <- (Qmult_inv_r a). apply Qmult_lt_l. apply H. + apply H1. intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). +Qed. + + (** * Rational to the n-th power *) Definition Qpower_positive : Q -> positive -> Q := diff --git a/theories/Reals/ConstructiveCauchyReals.v b/theories/Reals/ConstructiveCauchyReals.v new file mode 100644 index 0000000000..004854e751 --- /dev/null +++ b/theories/Reals/ConstructiveCauchyReals.v @@ -0,0 +1,2951 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +Require Import QArith. +Require Import Qabs. +Require Import Qround. +Require Import Logic.ConstructiveEpsilon. +Require CMorphisms. + +Open Scope Q. + +(* The constructive Cauchy real numbers, ie the Cauchy sequences + of rational numbers. This file is not supposed to be imported, + except in Rdefinitions.v, Raxioms.v, Rcomplete_constr.v + and ConstructiveRIneq.v. + + Constructive real numbers should be considered abstractly, + forgetting the fact that they are implemented as rational sequences. + All useful lemmas of this file are exposed in ConstructiveRIneq.v, + under more abstract names, like Rlt_asym instead of CRealLt_asym. + + + Cauchy reals are Cauchy sequences of rational numbers, + equipped with explicit moduli of convergence and + an equivalence relation (the difference converges to zero). + + Without convergence moduli, we would fail to prove that a Cauchy + sequence of constructive reals converges. + + Because of the Specker sequences (increasing, computable + and bounded sequences of rationals that do not converge + to a computable real number), constructive reals do not + follow the least upper bound principle. + + The double quantification on p q is needed to avoid + forall un, QSeqEquiv un (fun _ => un O) (fun q => O) + which says nothing about the limit of un. + *) +Definition QSeqEquiv (un vn : nat -> Q) (cvmod : positive -> nat) + : Prop + := forall (k : positive) (p q : nat), + le (cvmod k) p + -> le (cvmod k) q + -> Qlt (Qabs (un p - vn q)) (1 # k). + +(* A Cauchy sequence is a sequence equivalent to itself. + If sequences are equivalent, they are both Cauchy and have the same limit. *) +Definition QCauchySeq (un : nat -> Q) (cvmod : positive -> nat) : Prop + := QSeqEquiv un un cvmod. + +Lemma QSeqEquiv_sym : forall (un vn : nat -> Q) (cvmod : positive -> nat), + QSeqEquiv un vn cvmod + -> QSeqEquiv vn un cvmod. +Proof. + intros. intros k p q H0 H1. + rewrite Qabs_Qminus. apply H; assumption. +Qed. + +Lemma factorDenom : forall (a:Z) (b d:positive), (a # (d * b)) == (1#d) * (a#b). +Proof. + intros. unfold Qeq. simpl. destruct a; reflexivity. +Qed. + +Lemma QSeqEquiv_trans : forall (un vn wn : nat -> Q) + (cvmod cvmodw : positive -> nat), + QSeqEquiv un vn cvmod + -> QSeqEquiv vn wn cvmodw + -> QSeqEquiv un wn (fun q => max (cvmod (2 * q)%positive) (cvmodw (2 * q)%positive)). +Proof. + intros. intros k p q H1 H2. + setoid_replace (un p - wn q) with (un p - vn p + (vn p - wn q)). + apply (Qle_lt_trans + _ (Qabs (un p - vn p) + Qabs (vn p - wn q))). + apply Qabs_triangle. apply (Qlt_le_trans _ ((1 # (2*k)) + (1 # (2*k)))). + apply Qplus_lt_le_compat. + - assert ((cvmod (2 * k)%positive <= p)%nat). + { apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). + apply Nat.le_max_l. assumption. } + apply H. assumption. assumption. + - apply Qle_lteq. left. apply H0. + apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). + apply Nat.le_max_r. assumption. + apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). + apply Nat.le_max_r. assumption. + - rewrite (factorDenom _ _ 2). ring_simplify. apply Qle_refl. + - ring. +Qed. + +Definition QSeqEquivEx (un vn : nat -> Q) : Prop + := exists (cvmod : positive -> nat), QSeqEquiv un vn cvmod. + +Lemma QSeqEquivEx_sym : forall (un vn : nat -> Q), QSeqEquivEx un vn -> QSeqEquivEx vn un. +Proof. + intros. destruct H. exists x. apply QSeqEquiv_sym. apply H. +Qed. + +Lemma QSeqEquivEx_trans : forall un vn wn : nat -> Q, + QSeqEquivEx un vn + -> QSeqEquivEx vn wn + -> QSeqEquivEx un wn. +Proof. + intros. destruct H,H0. + exists (fun q => max (x (2 * q)%positive) (x0 (2 * q)%positive)). + apply (QSeqEquiv_trans un vn wn); assumption. +Qed. + +Lemma QSeqEquiv_cau_r : forall (un vn : nat -> Q) (cvmod : positive -> nat), + QSeqEquiv un vn cvmod + -> QCauchySeq vn (fun k => cvmod (2 * k)%positive). +Proof. + intros. intros k p q H0 H1. + setoid_replace (vn p - vn q) + with (vn p + - un (cvmod (2 * k)%positive) + + (un (cvmod (2 * k)%positive) - vn q)). + - apply (Qle_lt_trans + _ (Qabs (vn p + - un (cvmod (2 * k)%positive)) + + Qabs (un (cvmod (2 * k)%positive) - vn q))). + apply Qabs_triangle. + apply (Qlt_le_trans _ ((1 # (2 * k)) + (1 # (2 * k)))). + apply Qplus_lt_le_compat. + + rewrite Qabs_Qminus. apply H. apply le_refl. assumption. + + apply Qle_lteq. left. apply H. apply le_refl. assumption. + + rewrite (factorDenom _ _ 2). ring_simplify. apply Qle_refl. + - ring. +Qed. + +Fixpoint increasing_modulus (modulus : positive -> nat) (n : nat) + := match n with + | O => modulus xH + | S p => max (modulus (Pos.of_nat n)) (increasing_modulus modulus p) + end. + +Lemma increasing_modulus_inc : forall (modulus : positive -> nat) (n p : nat), + le (increasing_modulus modulus n) + (increasing_modulus modulus (p + n)). +Proof. + induction p. + - apply le_refl. + - apply (le_trans _ (increasing_modulus modulus (p + n))). + apply IHp. simpl. destruct (plus p n). apply Nat.le_max_r. apply Nat.le_max_r. +Qed. + +Lemma increasing_modulus_max : forall (modulus : positive -> nat) (p n : nat), + le n p -> le (modulus (Pos.of_nat n)) + (increasing_modulus modulus p). +Proof. + induction p. + - intros. inversion H. subst n. apply le_refl. + - intros. simpl. destruct p. simpl. + + destruct n. apply Nat.le_max_l. apply le_S_n in H. + inversion H. apply Nat.le_max_l. + + apply Nat.le_succ_r in H. destruct H. + apply (le_trans _ (increasing_modulus modulus (S p))). + 2: apply Nat.le_max_r. apply IHp. apply H. + subst n. apply (le_trans _ (modulus (Pos.succ (Pos.of_nat (S p))))). + apply le_refl. apply Nat.le_max_l. +Qed. + +(* Choice of a standard element in each QSeqEquiv class. *) +Lemma standard_modulus : forall (un : nat -> Q) (cvmod : positive -> nat), + QCauchySeq un cvmod + -> (QCauchySeq (fun n => un (increasing_modulus cvmod n)) Pos.to_nat + /\ QSeqEquiv un (fun n => un (increasing_modulus cvmod n)) + (fun p => max (cvmod p) (Pos.to_nat p))). +Proof. + intros. split. + - intros k p q H0 H1. apply H. + + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). + apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). + rewrite Pos2Nat.id. apply le_refl. + destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. + destruct (Nat.le_exists_sub (Pos.to_nat k) p H0) as [i [H2 H3]]. subst p. + apply increasing_modulus_inc. + + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). + apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). + rewrite Pos2Nat.id. apply le_refl. + destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. + destruct (Nat.le_exists_sub (Pos.to_nat k) q H1) as [i [H2 H3]]. subst q. + apply increasing_modulus_inc. + - intros k p q H0 H1. apply H. + + apply (le_trans _ (Init.Nat.max (cvmod k) (Pos.to_nat k))). + apply Nat.le_max_l. assumption. + + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). + apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). + rewrite Pos2Nat.id. apply le_refl. + destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. + assert (le (Pos.to_nat k) q). + { apply (le_trans _ (Init.Nat.max (cvmod k) (Pos.to_nat k))). + apply Nat.le_max_r. assumption. } + destruct (Nat.le_exists_sub (Pos.to_nat k) q H2) as [i [H3 H4]]. subst q. + apply increasing_modulus_inc. +Qed. + +(* A Cauchy real is a Cauchy sequence with the standard modulus *) +Definition CReal : Set + := { x : (nat -> Q) | QCauchySeq x Pos.to_nat }. + +Declare Scope CReal_scope. + +(* Declare Scope R_scope with Key R *) +Delimit Scope CReal_scope with CReal. + +(* Automatically open scope R_scope for arguments of type R *) +Bind Scope CReal_scope with CReal. + +Open Scope CReal_scope. + + +(* So QSeqEquiv is the equivalence relation of this constructive pre-order *) +Definition CRealLt (x y : CReal) : Set + := { n : positive | Qlt (2 # n) + (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)) }. + +Definition CRealLtProp (x y : CReal) : Prop + := exists n : positive, Qlt (2 # n) + (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)). + +Definition CRealGt (x y : CReal) := CRealLt y x. +Definition CReal_appart (x y : CReal) := sum (CRealLt x y) (CRealLt y x). + +Infix "<" := CRealLt : CReal_scope. +Infix ">" := CRealGt : CReal_scope. +Infix "#" := CReal_appart : CReal_scope. + +(* This Prop can be extracted as a sigma type *) +Lemma CRealLtEpsilon : forall x y : CReal, + CRealLtProp x y -> x < y. +Proof. + intros. + assert (exists n : nat, n <> O + /\ Qlt (2 # Pos.of_nat n) (proj1_sig y n - proj1_sig x n)). + { destruct H as [n maj]. exists (Pos.to_nat n). split. + intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. + inversion abs. rewrite Pos2Nat.id. apply maj. } + apply constructive_indefinite_ground_description_nat in H0. + destruct H0 as [n maj]. exists (Pos.of_nat n). + rewrite Nat2Pos.id. apply maj. apply maj. + intro n. destruct n. right. + intros [abs _]. exact (abs (eq_refl O)). + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) + (proj1_sig y (S n) - proj1_sig x (S n))). + left. split. discriminate. apply q. + right. intros [_ abs]. + apply (Qlt_not_le (2 # Pos.of_nat (S n)) + (proj1_sig y (S n) - proj1_sig x (S n))); assumption. +Qed. + +Lemma CRealLtForget : forall x y : CReal, + x < y -> CRealLtProp x y. +Proof. + intros. destruct H. exists x0. exact q. +Qed. + +(* CRealLt is decided by the LPO in Type, + which is a non-constructive oracle. *) +Lemma CRealLt_lpo_dec : forall x y : CReal, + (forall (P : nat -> Prop), (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}) + -> CRealLt x y + (CRealLt x y -> False). +Proof. + intros x y lpo. + destruct (lpo (fun n:nat => Qle (proj1_sig y (S n) - proj1_sig x (S n)) + (2 # Pos.of_nat (S n)))). + - intro n. destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) + (proj1_sig y (S n) - proj1_sig x (S n))). + right. apply Qlt_not_le. exact q. left. exact q. + - left. destruct s as [n nmaj]. exists (Pos.of_nat (S n)). + rewrite Nat2Pos.id. apply Qnot_le_lt. exact nmaj. discriminate. + - right. intro abs. destruct abs as [n majn]. + specialize (q (pred (Pos.to_nat n))). + replace (S (pred (Pos.to_nat n))) with (Pos.to_nat n) in q. + rewrite Pos2Nat.id in q. + pose proof (Qle_not_lt _ _ q). contradiction. + symmetry. apply Nat.succ_pred. intro abs. + pose proof (Pos2Nat.is_pos n). rewrite abs in H. inversion H. +Qed. + +(* Alias the quotient order equality *) +Definition CRealEq (x y : CReal) : Prop + := (CRealLt x y -> False) /\ (CRealLt y x -> False). + +Infix "==" := CRealEq : CReal_scope. + +(* Alias the large order *) +Definition CRealLe (x y : CReal) : Prop + := CRealLt y x -> False. + +Definition CRealGe (x y : CReal) := CRealLe y x. + +Infix "<=" := CRealLe : CReal_scope. +Infix ">=" := CRealGe : CReal_scope. + +Notation "x <= y <= z" := (x <= y /\ y <= z) : CReal_scope. +Notation "x <= y < z" := (prod (x <= y) (y < z)) : CReal_scope. +Notation "x < y < z" := (prod (x < y) (y < z)) : CReal_scope. +Notation "x < y <= z" := (prod (x < y) (y <= z)) : CReal_scope. + +Lemma CRealLe_not_lt : forall x y : CReal, + (forall n:positive, Qle (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n)) + (2 # n)) + <-> x <= y. +Proof. + intros. split. + - intros. intro H0. destruct H0 as [n H0]. specialize (H n). + apply (Qle_not_lt (2 # n) (2 # n)). apply Qle_refl. + apply (Qlt_le_trans _ (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))). + assumption. assumption. + - intros. + destruct (Qlt_le_dec (2 # n) (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))). + exfalso. apply H. exists n. assumption. assumption. +Qed. + +Lemma CRealEq_diff : forall (x y : CReal), + CRealEq x y + <-> forall n:positive, Qle (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) + (2 # n). +Proof. + intros. split. + - intros. destruct H. apply Qabs_case. intro. + pose proof (CRealLe_not_lt x y) as [_ H2]. apply H2. assumption. + intro. pose proof (CRealLe_not_lt y x) as [_ H2]. + setoid_replace (- (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) + with (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)). + apply H2. assumption. ring. + - intros. split. apply CRealLe_not_lt. intro n. specialize (H n). + rewrite Qabs_Qminus in H. + apply (Qle_trans _ (Qabs (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)))). + apply Qle_Qabs. apply H. + apply CRealLe_not_lt. intro n. specialize (H n). + apply (Qle_trans _ (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n)))). + apply Qle_Qabs. apply H. +Qed. + +(* The equality on Cauchy reals is just QSeqEquiv, + which is independant of the convergence modulus. *) +Lemma CRealEq_modindep : forall (x y : CReal), + QSeqEquivEx (proj1_sig x) (proj1_sig y) + <-> forall n:positive, + Qle (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) (2 # n). +Proof. + assert (forall x y: CReal, QSeqEquivEx (proj1_sig x) (proj1_sig y) -> x <= y ). + { intros [xn limx] [yn limy] [cvmod H] [n abs]. simpl in abs, H. + pose (xn (Pos.to_nat n) - yn (Pos.to_nat n) - (2#n)) as eps. + destruct (Qarchimedean (/eps)) as [k maj]. + remember (max (cvmod k) (Pos.to_nat n)) as p. + assert (le (cvmod k) p). + { rewrite Heqp. apply Nat.le_max_l. } + assert (Pos.to_nat n <= p)%nat. + { rewrite Heqp. apply Nat.le_max_r. } + specialize (H k p p H0 H0). + setoid_replace (Z.pos k #1)%Q with (/ (1#k)) in maj. 2: reflexivity. + apply Qinv_lt_contravar in maj. 2: reflexivity. unfold eps in maj. + clear abs. (* less precise majoration *) + apply (Qplus_lt_r _ _ (2#n)) in maj. ring_simplify in maj. + apply (Qlt_not_le _ _ maj). clear maj. + setoid_replace (xn (Pos.to_nat n) + -1 * yn (Pos.to_nat n)) + with (xn (Pos.to_nat n) - xn p + (xn p - yn p + (yn p - yn (Pos.to_nat n)))). + 2: ring. + setoid_replace (2 # n)%Q with ((1 # n) + (1#n)). + rewrite <- Qplus_assoc. + apply Qplus_le_compat. apply (Qle_trans _ _ _ (Qle_Qabs _)). + apply Qlt_le_weak. apply limx. apply le_refl. assumption. + rewrite (Qplus_comm (1#n)). + apply Qplus_le_compat. apply (Qle_trans _ _ _ (Qle_Qabs _)). + apply Qlt_le_weak. exact H. + apply (Qle_trans _ _ _ (Qle_Qabs _)). apply Qlt_le_weak. apply limy. + assumption. apply le_refl. ring_simplify. reflexivity. + unfold eps. unfold Qminus. rewrite <- Qlt_minus_iff. exact abs. } + split. + - rewrite <- CRealEq_diff. intros. split. + apply H, QSeqEquivEx_sym. exact H0. apply H. exact H0. + - clear H. intros. destruct x as [xn limx], y as [yn limy]. + exists (fun q => Pos.to_nat (2 * (3 * q))). intros k p q H0 H1. + unfold proj1_sig. specialize (H (2 * (3 * k))%positive). + assert ((Pos.to_nat (3 * k) <= Pos.to_nat (2 * (3 * k)))%nat). + { generalize (3 * k)%positive. intros. rewrite Pos2Nat.inj_mul. + rewrite <- (mult_1_l (Pos.to_nat p0)). apply Nat.mul_le_mono_nonneg. + auto. unfold Pos.to_nat. simpl. auto. + apply (le_trans 0 1). auto. apply Pos2Nat.is_pos. rewrite mult_1_l. + apply le_refl. } + setoid_replace (xn p - yn q) + with (xn p - xn (Pos.to_nat (2 * (3 * k))) + + (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k))) + + (yn (Pos.to_nat (2 * (3 * k))) - yn q))). + setoid_replace (1 # k)%Q with ((1 # 3 * k) + ((1 # 3 * k) + (1 # 3 * k))). + apply (Qle_lt_trans + _ (Qabs (xn p - xn (Pos.to_nat (2 * (3 * k)))) + + (Qabs (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k))) + + (yn (Pos.to_nat (2 * (3 * k))) - yn q))))). + apply Qabs_triangle. apply Qplus_lt_le_compat. + apply limx. apply (le_trans _ (Pos.to_nat (2 * (3 * k)))). assumption. assumption. + assumption. + apply (Qle_trans + _ (Qabs (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k)))) + + Qabs (yn (Pos.to_nat (2 * (3 * k))) - yn q))). + apply Qabs_triangle. apply Qplus_le_compat. + setoid_replace (1 # 3 * k)%Q with (2 # 2 * (3 * k))%Q. apply H. + rewrite (factorDenom _ _ 3). rewrite (factorDenom _ _ 2). rewrite (factorDenom _ _ 3). + rewrite Qmult_assoc. rewrite (Qmult_comm (1#2)). + rewrite <- Qmult_assoc. apply Qmult_comp. reflexivity. + unfold Qeq. reflexivity. + apply Qle_lteq. left. apply limy. assumption. + apply (le_trans _ (Pos.to_nat (2 * (3 * k)))). assumption. assumption. + rewrite (factorDenom _ _ 3). ring_simplify. reflexivity. field. +Qed. + +(* Extend separation to all indices above *) +Lemma CRealLt_aboveSig : forall (x y : CReal) (n : positive), + (Qlt (2 # n) + (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n))) + -> let (k, _) := Qarchimedean (/(proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n) - (2#n))) + in forall p:positive, + Pos.le (Pos.max n (2*k)) p + -> Qlt (2 # (Pos.max n (2*k))) + (proj1_sig y (Pos.to_nat p) - proj1_sig x (Pos.to_nat p)). +Proof. + intros [xn limx] [yn limy] n maj. + unfold proj1_sig; unfold proj1_sig in maj. + pose (yn (Pos.to_nat n) - xn (Pos.to_nat n)) as dn. + destruct (Qarchimedean (/(yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2#n)))) as [k kmaj]. + assert (0 < yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2 # n))%Q as H0. + { rewrite <- (Qplus_opp_r (2#n)). apply Qplus_lt_l. assumption. } + intros. + remember (yn (Pos.to_nat p) - xn (Pos.to_nat p)) as dp. + + rewrite <- (Qplus_0_r dp). rewrite <- (Qplus_opp_r dn). + rewrite (Qplus_comm dn). rewrite Qplus_assoc. + assert (Qlt (Qabs (dp - dn)) (2#n)). + { rewrite Heqdp. unfold dn. + setoid_replace (yn (Pos.to_nat p) - xn (Pos.to_nat p) - (yn (Pos.to_nat n) - xn (Pos.to_nat n))) + with (yn (Pos.to_nat p) - yn (Pos.to_nat n) + + (xn (Pos.to_nat n) - xn (Pos.to_nat p))). + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat p) - yn (Pos.to_nat n)) + + Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat p)))). + apply Qabs_triangle. + setoid_replace (2#n)%Q with ((1#n) + (1#n))%Q. + apply Qplus_lt_le_compat. apply limy. + apply Pos2Nat.inj_le. apply (Pos.le_trans _ (Pos.max n (2 * k))). + apply Pos.le_max_l. assumption. + apply le_refl. apply Qlt_le_weak. apply limx. apply le_refl. + apply Pos2Nat.inj_le. apply (Pos.le_trans _ (Pos.max n (2 * k))). + apply Pos.le_max_l. assumption. + rewrite Qinv_plus_distr. reflexivity. field. } + apply (Qle_lt_trans _ (-(2#n) + dn)). + rewrite Qplus_comm. unfold dn. apply Qlt_le_weak. + apply (Qle_lt_trans _ (2 # (2 * k))). apply Pos.le_max_r. + setoid_replace (2 # 2 * k)%Q with (1 # k)%Q. 2: reflexivity. + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. + apply Qinv_lt_contravar. reflexivity. apply H0. apply kmaj. + apply Qplus_lt_l. rewrite <- Qplus_0_r. rewrite <- (Qplus_opp_r dn). + rewrite Qplus_assoc. apply Qplus_lt_l. rewrite Qplus_comm. + rewrite <- (Qplus_0_r dp). rewrite <- (Qplus_opp_r (2#n)). + rewrite Qplus_assoc. apply Qplus_lt_l. + rewrite <- (Qplus_0_l dn). rewrite <- (Qplus_opp_r dp). + rewrite <- Qplus_assoc. apply Qplus_lt_r. rewrite Qplus_comm. + apply (Qle_lt_trans _ (Qabs (dp - dn))). rewrite Qabs_Qminus. + unfold Qminus. apply Qle_Qabs. assumption. +Qed. + +Lemma CRealLt_above : forall (x y : CReal), + CRealLt x y + -> { k : positive | forall p:positive, + Pos.le k p -> Qlt (2 # k) (proj1_sig y (Pos.to_nat p) - proj1_sig x (Pos.to_nat p)) }. +Proof. + intros x y [n maj]. + pose proof (CRealLt_aboveSig x y n maj). + destruct (Qarchimedean (/ (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n) - (2 # n)))) + as [k kmaj]. + exists (Pos.max n (2*k)). apply H. +Qed. + +(* The CRealLt index separates the Cauchy sequences *) +Lemma CRealLt_above_same : forall (x y : CReal) (n : positive), + Qlt (2 # n) + (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)) + -> forall p:positive, Pos.le n p + -> Qlt (proj1_sig x (Pos.to_nat p)) (proj1_sig y (Pos.to_nat p)). +Proof. + intros [xn limx] [yn limy] n inf p H. + simpl. simpl in inf. + apply (Qplus_lt_l _ _ (- xn (Pos.to_nat n))). + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat p) + - xn (Pos.to_nat n)))). + apply Qle_Qabs. apply (Qlt_trans _ (1#n)). + apply limx. apply Pos2Nat.inj_le. assumption. apply le_refl. + rewrite <- (Qplus_0_r (yn (Pos.to_nat p))). + rewrite <- (Qplus_opp_r (yn (Pos.to_nat n))). + rewrite (Qplus_comm (yn (Pos.to_nat n))). rewrite Qplus_assoc. + rewrite <- Qplus_assoc. + setoid_replace (1#n)%Q with (-(1#n) + (2#n))%Q. apply Qplus_lt_le_compat. + apply (Qplus_lt_l _ _ (1#n)). rewrite Qplus_opp_r. + apply (Qplus_lt_r _ _ (yn (Pos.to_nat n) + - yn (Pos.to_nat p))). + ring_simplify. + setoid_replace (yn (Pos.to_nat n) + (-1 # 1) * yn (Pos.to_nat p)) + with (yn (Pos.to_nat n) - yn (Pos.to_nat p)). + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat n) - yn (Pos.to_nat p)))). + apply Qle_Qabs. apply limy. apply le_refl. apply Pos2Nat.inj_le. assumption. + field. apply Qle_lteq. left. assumption. + rewrite Qplus_comm. rewrite Qinv_minus_distr. + reflexivity. +Qed. + +Lemma CRealLt_asym : forall x y : CReal, x < y -> x <= y. +Proof. + intros x y H [n q]. + apply CRealLt_above in H. destruct H as [p H]. + pose proof (CRealLt_above_same y x n q). + apply (Qlt_not_le (proj1_sig y (Pos.to_nat (Pos.max n p))) + (proj1_sig x (Pos.to_nat (Pos.max n p)))). + apply H0. apply Pos.le_max_l. + apply Qlt_le_weak. apply (Qplus_lt_l _ _ (-proj1_sig x (Pos.to_nat (Pos.max n p)))). + rewrite Qplus_opp_r. apply (Qlt_trans _ (2#p)). + unfold Qlt. simpl. unfold Z.lt. auto. apply H. apply Pos.le_max_r. +Qed. + +Lemma CRealLt_irrefl : forall x:CReal, x < x -> False. +Proof. + intros x abs. exact (CRealLt_asym x x abs abs). +Qed. + +Lemma CRealLe_refl : forall x : CReal, x <= x. +Proof. + intros. intro abs. + pose proof (CRealLt_asym x x abs). contradiction. +Qed. + +Lemma CRealEq_refl : forall x : CReal, x == x. +Proof. + intros. split; apply CRealLe_refl. +Qed. + +Lemma CRealEq_sym : forall x y : CReal, CRealEq x y -> CRealEq y x. +Proof. + intros. destruct H. split; intro abs; contradiction. +Qed. + +Lemma CRealLt_dec : forall x y z : CReal, + CRealLt x y -> CRealLt x z + CRealLt z y. +Proof. + intros [xn limx] [yn limy] [zn limz] clt. + destruct clt as [n inf]. + unfold proj1_sig in inf. + remember (yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2 # n)) as eps. + assert (Qlt 0 eps) as epsPos. + { subst eps. unfold Qminus. apply (Qlt_minus_iff (2#n)). assumption. } + assert (forall n p, Pos.to_nat n <= Pos.to_nat (Pos.max n p))%nat. + { intros. apply Pos2Nat.inj_le. unfold Pos.max. unfold Pos.le. + destruct (n0 ?= p)%positive eqn:des. + rewrite des. discriminate. rewrite des. discriminate. + unfold Pos.compare. rewrite Pos.compare_cont_refl. discriminate. } + destruct (Qarchimedean (/eps)) as [k kmaj]. + destruct (Qlt_le_dec ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2#1)) + (zn (Pos.to_nat (Pos.max n (4 * k))))) + as [decMiddle|decMiddle]. + - left. exists (Pos.max n (4 * k)). unfold proj1_sig. unfold Qminus. + rewrite <- (Qplus_0_r (zn (Pos.to_nat (Pos.max n (4 * k))))). + rewrite <- (Qplus_opp_r (xn (Pos.to_nat n))). + rewrite (Qplus_comm (xn (Pos.to_nat n))). rewrite Qplus_assoc. + rewrite <- Qplus_assoc. rewrite <- Qplus_0_r. + rewrite <- (Qplus_opp_r (1#n)). rewrite Qplus_assoc. + apply Qplus_lt_le_compat. + + apply (Qplus_lt_l _ _ (- xn (Pos.to_nat n))) in decMiddle. + apply (Qlt_trans _ ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1) + + - xn (Pos.to_nat n))). + setoid_replace ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1) + - xn (Pos.to_nat n)) + with ((yn (Pos.to_nat n) - xn (Pos.to_nat n)) / (2 # 1)). + apply Qlt_shift_div_l. unfold Qlt. simpl. unfold Z.lt. auto. + rewrite Qmult_plus_distr_l. + setoid_replace ((1 # n) * (2 # 1))%Q with (2#n)%Q. + apply (Qplus_lt_l _ _ (-(2#n))). rewrite <- Qplus_assoc. + rewrite Qplus_opp_r. unfold Qminus. unfold Qminus in Heqeps. + rewrite <- Heqeps. rewrite Qplus_0_r. + apply (Qle_lt_trans _ (1 # k)). unfold Qle. + simpl. rewrite Pos.mul_1_r. rewrite Pos2Z.inj_max. + apply Z.le_max_r. + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. + apply Qinv_lt_contravar. reflexivity. apply epsPos. apply kmaj. + unfold Qeq. simpl. rewrite Pos.mul_1_r. reflexivity. + field. assumption. + + setoid_replace (xn (Pos.to_nat n) + - xn (Pos.to_nat (Pos.max n (4 * k)))) + with (-(xn (Pos.to_nat (Pos.max n (4 * k))) - xn (Pos.to_nat n))). + apply Qopp_le_compat. + apply (Qle_trans _ (Qabs (xn (Pos.to_nat (Pos.max n (4 * k))) - xn (Pos.to_nat n)))). + apply Qle_Qabs. apply Qle_lteq. left. apply limx. apply H. + apply le_refl. field. + - right. exists (Pos.max n (4 * k)). unfold proj1_sig. unfold Qminus. + rewrite <- (Qplus_0_r (yn (Pos.to_nat (Pos.max n (4 * k))))). + rewrite <- (Qplus_opp_r (yn (Pos.to_nat n))). + rewrite (Qplus_comm (yn (Pos.to_nat n))). rewrite Qplus_assoc. + rewrite <- Qplus_assoc. rewrite <- Qplus_0_l. + rewrite <- (Qplus_opp_r (1#n)). rewrite (Qplus_comm (1#n)). + rewrite <- Qplus_assoc. apply Qplus_lt_le_compat. + + apply (Qplus_lt_r _ _ (yn (Pos.to_nat n) - yn (Pos.to_nat (Pos.max n (4 * k))) + (1#n))) + ; ring_simplify. + setoid_replace (-1 * yn (Pos.to_nat (Pos.max n (4 * k)))) + with (- yn (Pos.to_nat (Pos.max n (4 * k)))). 2: ring. + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat n) + - yn (Pos.to_nat (Pos.max n (4 * k)))))). + apply Qle_Qabs. apply limy. apply le_refl. apply H. + + apply Qopp_le_compat in decMiddle. + apply (Qplus_le_r _ _ (yn (Pos.to_nat n))) in decMiddle. + apply (Qle_trans _ (yn (Pos.to_nat n) + - ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1)))). + setoid_replace (yn (Pos.to_nat n) + - ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1))) + with ((yn (Pos.to_nat n) - xn (Pos.to_nat n)) / (2 # 1)). + apply Qle_shift_div_l. unfold Qlt. simpl. unfold Z.lt. auto. + rewrite Qmult_plus_distr_l. + setoid_replace ((1 # n) * (2 # 1))%Q with (2#n)%Q. + apply (Qplus_le_r _ _ (-(2#n))). rewrite Qplus_assoc. + rewrite Qplus_opp_r. rewrite Qplus_0_l. rewrite (Qplus_comm (-(2#n))). + unfold Qminus in Heqeps. unfold Qminus. rewrite <- Heqeps. + apply (Qle_trans _ (1 # k)). unfold Qle. + simpl. rewrite Pos.mul_1_r. rewrite Pos2Z.inj_max. + apply Z.le_max_r. apply Qle_lteq. left. + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. + apply Qinv_lt_contravar. reflexivity. apply epsPos. apply kmaj. + unfold Qeq. simpl. rewrite Pos.mul_1_r. reflexivity. + field. assumption. +Defined. + +Definition linear_order_T x y z := CRealLt_dec x z y. + +Lemma CRealLe_Lt_trans : forall x y z : CReal, + x <= y -> y < z -> x < z. +Proof. + intros. + destruct (linear_order_T y x z H0). contradiction. apply c. +Qed. + +Lemma CRealLt_Le_trans : forall x y z : CReal, + x < y -> y <= z -> x < z. +Proof. + intros. + destruct (linear_order_T x z y H). apply c. contradiction. +Qed. + +Lemma CRealLe_trans : forall x y z : CReal, + x <= y -> y <= z -> x <= z. +Proof. + intros. intro abs. apply H0. + apply (CRealLt_Le_trans _ x); assumption. +Qed. + +Lemma CRealLt_trans : forall x y z : CReal, + x < y -> y < z -> x < z. +Proof. + intros. apply (CRealLt_Le_trans _ y _ H). + apply CRealLt_asym. exact H0. +Qed. + +Lemma CRealEq_trans : forall x y z : CReal, + CRealEq x y -> CRealEq y z -> CRealEq x z. +Proof. + intros. destruct H,H0. split. + - intro abs. destruct (CRealLt_dec _ _ y abs); contradiction. + - intro abs. destruct (CRealLt_dec _ _ y abs); contradiction. +Qed. + +Add Parametric Relation : CReal CRealEq + reflexivity proved by CRealEq_refl + symmetry proved by CRealEq_sym + transitivity proved by CRealEq_trans + as CRealEq_rel. + +Instance CRealEq_relT : CRelationClasses.Equivalence CRealEq. +Proof. + split. exact CRealEq_refl. exact CRealEq_sym. exact CRealEq_trans. +Qed. + +Instance CRealLt_morph + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRelationClasses.iffT)) CRealLt. +Proof. + intros x y H x0 y0 H0. destruct H, H0. split. + - intro. destruct (CRealLt_dec x x0 y). assumption. + contradiction. destruct (CRealLt_dec y x0 y0). + assumption. assumption. contradiction. + - intro. destruct (CRealLt_dec y y0 x). assumption. + contradiction. destruct (CRealLt_dec x y0 x0). + assumption. assumption. contradiction. +Qed. + +Instance CRealGt_morph + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRelationClasses.iffT)) CRealGt. +Proof. + intros x y H x0 y0 H0. apply CRealLt_morph; assumption. +Qed. + +Instance CReal_appart_morph + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRelationClasses.iffT)) CReal_appart. +Proof. + split. + - intros. destruct H1. left. rewrite <- H0, <- H. exact c. + right. rewrite <- H0, <- H. exact c. + - intros. destruct H1. left. rewrite H0, H. exact c. + right. rewrite H0, H. exact c. +Qed. + +Add Parametric Morphism : CRealLe + with signature CRealEq ==> CRealEq ==> iff + as CRealLe_morph. +Proof. + intros. split. + - intros H1 H2. unfold CRealLe in H1. + rewrite <- H0 in H2. rewrite <- H in H2. contradiction. + - intros H1 H2. unfold CRealLe in H1. + rewrite H0 in H2. rewrite H in H2. contradiction. +Qed. + +Add Parametric Morphism : CRealGe + with signature CRealEq ==> CRealEq ==> iff + as CRealGe_morph. +Proof. + intros. unfold CRealGe. apply CRealLe_morph; assumption. +Qed. + +Lemma CRealLt_proper_l : forall x y z : CReal, + CRealEq x y + -> CRealLt x z -> CRealLt y z. +Proof. + intros. apply (CRealLt_morph x y H z z). + apply CRealEq_refl. apply H0. +Qed. + +Lemma CRealLt_proper_r : forall x y z : CReal, + CRealEq x y + -> CRealLt z x -> CRealLt z y. +Proof. + intros. apply (CRealLt_morph z z (CRealEq_refl z) x y). + apply H. apply H0. +Qed. + +Lemma CRealLe_proper_l : forall x y z : CReal, + CRealEq x y + -> CRealLe x z -> CRealLe y z. +Proof. + intros. apply (CRealLe_morph x y H z z). + apply CRealEq_refl. apply H0. +Qed. + +Lemma CRealLe_proper_r : forall x y z : CReal, + CRealEq x y + -> CRealLe z x -> CRealLe z y. +Proof. + intros. apply (CRealLe_morph z z (CRealEq_refl z) x y). + apply H. apply H0. +Qed. + + + +(* Injection of Q into CReal *) + +Lemma ConstCauchy : forall q : Q, + QCauchySeq (fun _ => q) Pos.to_nat. +Proof. + intros. intros k p r H H0. + unfold Qminus. rewrite Qplus_opp_r. unfold Qlt. simpl. + unfold Z.lt. auto. +Qed. + +Definition inject_Q : Q -> CReal. +Proof. + intro q. exists (fun n => q). apply ConstCauchy. +Defined. + +Notation "0" := (inject_Q 0) : CReal_scope. +Notation "1" := (inject_Q 1) : CReal_scope. + +Lemma CRealLt_0_1 : CRealLt (inject_Q 0) (inject_Q 1). +Proof. + exists 3%positive. reflexivity. +Qed. + +Lemma CReal_injectQPos : forall q : Q, + Qlt 0 q -> CRealLt (inject_Q 0) (inject_Q q). +Proof. + intros. destruct (Qarchimedean ((2#1) / q)). + exists x. simpl. unfold Qminus. rewrite Qplus_0_r. + apply (Qmult_lt_compat_r _ _ q) in q0. 2: apply H. + unfold Qdiv in q0. + rewrite <- Qmult_assoc in q0. rewrite <- (Qmult_comm q) in q0. + rewrite Qmult_inv_r in q0. rewrite Qmult_1_r in q0. + unfold Qlt; simpl. unfold Qlt in q0; simpl in q0. + rewrite Z.mul_1_r in q0. destruct q; simpl. simpl in q0. + destruct Qnum. apply q0. + rewrite <- Pos2Z.inj_mul. rewrite Pos.mul_comm. apply q0. + inversion H. intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). +Qed. + +(* A rational number has a constant Cauchy sequence realizing it + as a real number, which increases the precision of the majoration + by a factor 2. *) +Lemma CRealLtQ : forall (x : CReal) (q : Q), + CRealLt x (inject_Q q) + -> forall p:positive, Qlt (proj1_sig x (Pos.to_nat p)) (q + (1#p)). +Proof. + intros [xn cau] q maj p. simpl. + destruct (Qlt_le_dec (xn (Pos.to_nat p)) (q + (1 # p))). assumption. + exfalso. + apply CRealLt_above in maj. + destruct maj as [k maj]; simpl in maj. + specialize (maj (Pos.max k p) (Pos.le_max_l _ _)). + specialize (cau p (Pos.to_nat p) (Pos.to_nat (Pos.max k p)) (le_refl _)). + pose proof (Qplus_lt_le_compat (2#k) (q - xn (Pos.to_nat (Pos.max k p))) + (q + (1 # p)) (xn (Pos.to_nat p)) maj q0). + rewrite Qplus_comm in H. unfold Qminus in H. rewrite <- Qplus_assoc in H. + rewrite <- Qplus_assoc in H. apply Qplus_lt_r in H. + rewrite <- (Qplus_lt_r _ _ (xn (Pos.to_nat p))) in maj. + apply (Qlt_not_le (1#p) ((1 # p) + (2 # k))). + rewrite <- (Qplus_0_r (1#p)). rewrite <- Qplus_assoc. + apply Qplus_lt_r. reflexivity. + apply Qlt_le_weak. + apply (Qlt_trans _ (- xn (Pos.to_nat (Pos.max k p)) + xn (Pos.to_nat p)) _ H). + rewrite Qplus_comm. + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat p) - xn (Pos.to_nat (Pos.max k p))))). + apply Qle_Qabs. apply cau. apply Pos2Nat.inj_le. apply Pos.le_max_r. +Qed. + +Lemma CRealLtQopp : forall (x : CReal) (q : Q), + CRealLt (inject_Q q) x + -> forall p:positive, Qlt (q - (1#p)) (proj1_sig x (Pos.to_nat p)). +Proof. + intros [xn cau] q maj p. simpl. + destruct (Qlt_le_dec (q - (1 # p)) (xn (Pos.to_nat p))). assumption. + exfalso. + apply CRealLt_above in maj. + destruct maj as [k maj]; simpl in maj. + specialize (maj (Pos.max k p) (Pos.le_max_l _ _)). + specialize (cau p (Pos.to_nat (Pos.max k p)) (Pos.to_nat p)). + pose proof (Qplus_lt_le_compat (2#k) (xn (Pos.to_nat (Pos.max k p)) - q) + (xn (Pos.to_nat p)) (q - (1 # p)) maj q0). + unfold Qminus in H. rewrite <- Qplus_assoc in H. + rewrite (Qplus_assoc (-q)) in H. rewrite (Qplus_comm (-q)) in H. + rewrite Qplus_opp_r in H. rewrite Qplus_0_l in H. + apply (Qplus_lt_l _ _ (1#p)) in H. + rewrite <- (Qplus_assoc (xn (Pos.to_nat (Pos.max k p)))) in H. + rewrite (Qplus_comm (-(1#p))) in H. rewrite Qplus_opp_r in H. + rewrite Qplus_0_r in H. rewrite Qplus_comm in H. + rewrite Qplus_assoc in H. apply (Qplus_lt_l _ _ (- xn (Pos.to_nat p))) in H. + rewrite <- Qplus_assoc in H. rewrite Qplus_opp_r in H. rewrite Qplus_0_r in H. + apply (Qlt_not_le (1#p) ((1 # p) + (2 # k))). + rewrite <- (Qplus_0_r (1#p)). rewrite <- Qplus_assoc. + apply Qplus_lt_r. reflexivity. + apply Qlt_le_weak. + apply (Qlt_trans _ (xn (Pos.to_nat (Pos.max k p)) - xn (Pos.to_nat p)) _ H). + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max k p)) - xn (Pos.to_nat p)))). + apply Qle_Qabs. apply cau. apply Pos2Nat.inj_le. + apply Pos.le_max_r. apply le_refl. +Qed. + + +(* Algebraic operations *) + +Lemma CReal_plus_cauchy + : forall (xn yn zn : nat -> Q) (cvmod : positive -> nat), + QSeqEquiv xn yn cvmod + -> QCauchySeq zn Pos.to_nat + -> QSeqEquiv (fun n:nat => xn n + zn n) (fun n:nat => yn n + zn n) + (fun p => max (cvmod (2 * p)%positive) + (Pos.to_nat (2 * p)%positive)). +Proof. + intros. intros p n k H1 H2. + setoid_replace (xn n + zn n - (yn k + zn k)) + with (xn n - yn k + (zn n - zn k)). + 2: field. + apply (Qle_lt_trans _ (Qabs (xn n - yn k) + Qabs (zn n - zn k))). + apply Qabs_triangle. + setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. + apply Qplus_lt_le_compat. + - apply H. apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). + apply Nat.le_max_l. apply H1. + apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). + apply Nat.le_max_l. apply H2. + - apply Qle_lteq. left. apply H0. + apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). + apply Nat.le_max_r. apply H1. + apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). + apply Nat.le_max_r. apply H2. + - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Definition CReal_plus (x y : CReal) : CReal. +Proof. + destruct x as [xn limx], y as [yn limy]. + pose proof (CReal_plus_cauchy xn xn yn Pos.to_nat limx limy). + exists (fun n : nat => xn (2 * n)%nat + yn (2 * n)%nat). + intros p k n H0 H1. apply H. + - rewrite max_l. rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. apply le_0_n. apply le_refl. + apply le_0_n. apply H0. apply le_refl. + - rewrite Pos2Nat.inj_mul. rewrite max_l. + apply Nat.mul_le_mono_nonneg. apply le_0_n. apply le_refl. + apply le_0_n. apply H1. apply le_refl. +Defined. + +Infix "+" := CReal_plus : CReal_scope. + +Lemma CReal_plus_nth : forall (x y : CReal) (n : nat), + proj1_sig (x + y) n = Qplus (proj1_sig x (2*n)%nat) (proj1_sig y (2*n)%nat). +Proof. + intros. destruct x,y; reflexivity. +Qed. + +Lemma CReal_plus_unfold : forall (x y : CReal), + QSeqEquiv (proj1_sig (CReal_plus x y)) + (fun n : nat => proj1_sig x n + proj1_sig y n)%Q + (fun p => Pos.to_nat (2 * p)). +Proof. + intros [xn limx] [yn limy]. + unfold CReal_plus; simpl. + intros p n k H H0. + setoid_replace (xn (2 * n)%nat + yn (2 * n)%nat - (xn k + yn k))%Q + with (xn (2 * n)%nat - xn k + (yn (2 * n)%nat - yn k))%Q. + 2: field. + apply (Qle_lt_trans _ (Qabs (xn (2 * n)%nat - xn k) + Qabs (yn (2 * n)%nat - yn k))). + apply Qabs_triangle. + setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. + apply Qplus_lt_le_compat. + - apply limx. apply (le_trans _ n). apply H. + rewrite <- (mult_1_l n). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. simpl. auto. + apply le_0_n. apply le_refl. apply H0. + - apply Qlt_le_weak. apply limy. apply (le_trans _ n). apply H. + rewrite <- (mult_1_l n). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. simpl. auto. + apply le_0_n. apply le_refl. apply H0. + - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Definition CReal_opp (x : CReal) : CReal. +Proof. + destruct x as [xn limx]. + exists (fun n : nat => - xn n). + intros k p q H H0. unfold Qminus. rewrite Qopp_involutive. + rewrite Qplus_comm. apply limx; assumption. +Defined. + +Notation "- x" := (CReal_opp x) : CReal_scope. + +Definition CReal_minus (x y : CReal) : CReal + := CReal_plus x (CReal_opp y). + +Infix "-" := CReal_minus : CReal_scope. + +Lemma belowMultiple : forall n p : nat, lt 0 p -> le n (p * n). +Proof. + intros. rewrite <- (mult_1_l n). apply Nat.mul_le_mono_nonneg. + auto. assumption. apply le_0_n. rewrite mult_1_l. apply le_refl. +Qed. + +Lemma CReal_plus_assoc : forall (x y z : CReal), + CRealEq (CReal_plus (CReal_plus x y) z) + (CReal_plus x (CReal_plus y z)). +Proof. + intros. apply CRealEq_diff. intro n. + destruct x as [xn limx], y as [yn limy], z as [zn limz]. + unfold CReal_plus; unfold proj1_sig. + setoid_replace (xn (2 * (2 * Pos.to_nat n))%nat + yn (2 * (2 * Pos.to_nat n))%nat + + zn (2 * Pos.to_nat n)%nat + - (xn (2 * Pos.to_nat n)%nat + (yn (2 * (2 * Pos.to_nat n))%nat + + zn (2 * (2 * Pos.to_nat n))%nat)))%Q + with (xn (2 * (2 * Pos.to_nat n))%nat - xn (2 * Pos.to_nat n)%nat + + (zn (2 * Pos.to_nat n)%nat - zn (2 * (2 * Pos.to_nat n))%nat))%Q. + apply (Qle_trans _ (Qabs (xn (2 * (2 * Pos.to_nat n))%nat - xn (2 * Pos.to_nat n)%nat) + + Qabs (zn (2 * Pos.to_nat n)%nat - zn (2 * (2 * Pos.to_nat n))%nat))). + apply Qabs_triangle. + rewrite <- (Qinv_plus_distr 1 1 n). apply Qplus_le_compat. + apply Qle_lteq. left. apply limx. rewrite mult_assoc. + apply belowMultiple. simpl. auto. apply belowMultiple. auto. + apply Qle_lteq. left. apply limz. apply belowMultiple. auto. + rewrite mult_assoc. apply belowMultiple. simpl. auto. field. +Qed. + +Lemma CReal_plus_comm : forall x y : CReal, + x + y == y + x. +Proof. + intros [xn limx] [yn limy]. apply CRealEq_diff. intros. + unfold CReal_plus, proj1_sig. + setoid_replace (xn (2 * Pos.to_nat n)%nat + yn (2 * Pos.to_nat n)%nat + - (yn (2 * Pos.to_nat n)%nat + xn (2 * Pos.to_nat n)%nat))%Q + with 0%Q. + unfold Qle. simpl. unfold Z.le. intro absurd. inversion absurd. + field. +Qed. + +Lemma CReal_plus_0_l : forall r : CReal, + CRealEq (CReal_plus (inject_Q 0) r) r. +Proof. + intro r. assert (forall n:nat, le n (2 * n)). + { intro n. simpl. rewrite <- (plus_0_r n). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. } + split. + - intros [n maj]. destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. + rewrite Qplus_0_l in maj. + specialize (q n (Pos.to_nat n) (mult 2 (Pos.to_nat n)) (le_refl _)). + apply (Qlt_not_le (2#n) (xn (Pos.to_nat n) - xn (2 * Pos.to_nat n)%nat)). + assumption. + apply (Qle_trans _ (Qabs (xn (Pos.to_nat n) - xn (2 * Pos.to_nat n)%nat))). + apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Qlt_le_weak. apply q. + apply H. unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_xO. + apply H. + - intros [n maj]. destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. + rewrite Qplus_0_l in maj. + specialize (q n (Pos.to_nat n) (mult 2 (Pos.to_nat n)) (le_refl _)). + rewrite Qabs_Qminus in q. + apply (Qlt_not_le (2#n) (xn (mult 2 (Pos.to_nat n)) - xn (Pos.to_nat n))). + assumption. + apply (Qle_trans _ (Qabs (xn (mult 2 (Pos.to_nat n)) - xn (Pos.to_nat n)))). + apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Qlt_le_weak. apply q. + apply H. unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_xO. + apply H. +Qed. + +Lemma CReal_plus_0_r : forall r : CReal, + r + 0 == r. +Proof. + intro r. rewrite CReal_plus_comm. apply CReal_plus_0_l. +Qed. + +Lemma CReal_plus_lt_compat_l : + forall x y z : CReal, + CRealLt y z + -> CRealLt (CReal_plus x y) (CReal_plus x z). +Proof. + intros. + apply CRealLt_above in H. destruct H as [n maj]. + exists n. specialize (maj (xO n)). + rewrite Pos2Nat.inj_xO in maj. + setoid_replace (proj1_sig (CReal_plus x z) (Pos.to_nat n) + - proj1_sig (CReal_plus x y) (Pos.to_nat n))%Q + with (proj1_sig z (2 * Pos.to_nat n)%nat - proj1_sig y (2 * Pos.to_nat n)%nat)%Q. + apply maj. apply Pos2Nat.inj_le. + rewrite <- (plus_0_r (Pos.to_nat n)). rewrite Pos2Nat.inj_xO. + simpl. apply Nat.add_le_mono_l. apply le_0_n. + simpl. destruct x as [xn limx], y as [yn limy], z as [zn limz]. + simpl; ring. +Qed. + +Lemma CReal_plus_lt_reg_l : + forall x y z : CReal, x + y < x + z -> y < z. +Proof. + intros. destruct H as [n maj]. exists (2*n)%positive. + setoid_replace (proj1_sig z (Pos.to_nat (2 * n)) - proj1_sig y (Pos.to_nat (2 * n)))%Q + with (proj1_sig (CReal_plus x z) (Pos.to_nat n) - proj1_sig (CReal_plus x y) (Pos.to_nat n))%Q. + apply (Qle_lt_trans _ (2#n)). unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. + rewrite <- (plus_0_r (Pos.to_nat n~0)). rewrite (Pos2Nat.inj_xO (n~0)). + simpl. apply Nat.add_le_mono_l. apply le_0_n. + apply maj. rewrite Pos2Nat.inj_xO. + destruct x as [xn limx], y as [yn limy], z as [zn limz]. + simpl; ring. +Qed. + +Lemma CReal_plus_lt_reg_r : + forall x y z : CReal, y + x < z + x -> y < z. +Proof. + intros x y z H. rewrite (CReal_plus_comm y), (CReal_plus_comm z) in H. + apply CReal_plus_lt_reg_l in H. exact H. +Qed. + +Lemma CReal_plus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2. +Proof. + intros. intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. +Qed. + +Lemma CReal_plus_le_lt_compat : + forall r1 r2 r3 r4 : CReal, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4. +Proof. + intros; apply CRealLe_Lt_trans with (r2 + r3). + intro abs. rewrite CReal_plus_comm, (CReal_plus_comm r1) in abs. + apply CReal_plus_lt_reg_l in abs. contradiction. + apply CReal_plus_lt_compat_l; exact H0. +Qed. + +Lemma CReal_plus_opp_r : forall x : CReal, + x + - x == 0. +Proof. + intros [xn limx]. apply CRealEq_diff. intros. + unfold CReal_plus, CReal_opp, inject_Q, proj1_sig. + setoid_replace (xn (2 * Pos.to_nat n)%nat + - xn (2 * Pos.to_nat n)%nat - 0)%Q + with 0%Q. + unfold Qle. simpl. unfold Z.le. intro absurd. inversion absurd. field. +Qed. + +Lemma CReal_plus_opp_l : forall x : CReal, + - x + x == 0. +Proof. + intro x. rewrite CReal_plus_comm. apply CReal_plus_opp_r. +Qed. + +Lemma CReal_plus_proper_r : forall x y z : CReal, + CRealEq x y -> CRealEq (CReal_plus x z) (CReal_plus y z). +Proof. + intros. apply (CRealEq_trans _ (CReal_plus z x)). + apply CReal_plus_comm. apply (CRealEq_trans _ (CReal_plus z y)). + 2: apply CReal_plus_comm. + split. intro abs. apply CReal_plus_lt_reg_l in abs. + destruct H. contradiction. intro abs. apply CReal_plus_lt_reg_l in abs. + destruct H. contradiction. +Qed. + +Lemma CReal_plus_proper_l : forall x y z : CReal, + CRealEq x y -> CRealEq (CReal_plus z x) (CReal_plus z y). +Proof. + intros. split. intro abs. apply CReal_plus_lt_reg_l in abs. + destruct H. contradiction. intro abs. apply CReal_plus_lt_reg_l in abs. + destruct H. contradiction. +Qed. + +Add Parametric Morphism : CReal_plus + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_plus_morph. +Proof. + intros x y H z t H0. apply (CRealEq_trans _ (CReal_plus x t)). + - destruct H0. + split. intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. + intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. + - apply CReal_plus_proper_r. apply H. +Qed. + +Instance CReal_plus_morph_T + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_plus. +Proof. + intros x y H z t H0. apply (CRealEq_trans _ (CReal_plus x t)). + - destruct H0. + split. intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. + intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. + - apply CReal_plus_proper_r. apply H. +Qed. + +Lemma CReal_plus_eq_reg_l : forall (r r1 r2 : CReal), + CRealEq (CReal_plus r r1) (CReal_plus r r2) + -> CRealEq r1 r2. +Proof. + intros. destruct H. split. + - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. + - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. +Qed. + +Fixpoint BoundFromZero (qn : nat -> Q) (k : nat) (A : positive) { struct k } + : (forall n:nat, le k n -> Qlt (Qabs (qn n)) (Z.pos A # 1)) + -> { B : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos B # 1) }. +Proof. + intro H. destruct k. + - exists A. intros. apply H. apply le_0_n. + - destruct (Qarchimedean (Qabs (qn k))) as [a maj]. + apply (BoundFromZero qn k (Pos.max A a)). + intros n H0. destruct (Nat.le_gt_cases n k). + + pose proof (Nat.le_antisymm n k H1 H0). subst k. + apply (Qlt_le_trans _ (Z.pos a # 1)). apply maj. + unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. + apply Pos.le_max_r. + + apply (Qlt_le_trans _ (Z.pos A # 1)). apply H. + apply H1. unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. + apply Pos.le_max_l. +Qed. + +Lemma QCauchySeq_bounded (qn : nat -> Q) (cvmod : positive -> nat) + : QCauchySeq qn cvmod + -> { A : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos A # 1) }. +Proof. + intros. remember (Zplus (Qnum (Qabs (qn (cvmod xH)))) 1) as z. + assert (Z.lt 0 z) as zPos. + { subst z. assert (Qle 0 (Qabs (qn (cvmod 1%positive)))). + apply Qabs_nonneg. destruct (Qabs (qn (cvmod 1%positive))). simpl. + unfold Qle in H0. simpl in H0. rewrite Zmult_1_r in H0. + apply (Z.lt_le_trans 0 1). unfold Z.lt. auto. + rewrite <- (Zplus_0_l 1). rewrite Zplus_assoc. apply Zplus_le_compat_r. + rewrite Zplus_0_r. assumption. } + assert { A : positive | forall n:nat, + le (cvmod xH) n -> Qlt ((Qabs (qn n)) * (1#A)) 1 }. + destruct z eqn:des. + - exfalso. apply (Z.lt_irrefl 0). assumption. + - exists p. intros. specialize (H xH (cvmod xH) n (le_refl _) H0). + assert (Qlt (Qabs (qn n)) (Qabs (qn (cvmod 1%positive)) + 1)). + { apply (Qplus_lt_l _ _ (-Qabs (qn (cvmod 1%positive)))). + rewrite <- (Qplus_comm 1). rewrite <- Qplus_assoc. rewrite Qplus_opp_r. + rewrite Qplus_0_r. apply (Qle_lt_trans _ (Qabs (qn n - qn (cvmod 1%positive)))). + apply Qabs_triangle_reverse. rewrite Qabs_Qminus. assumption. } + apply (Qlt_le_trans _ ((Qabs (qn (cvmod 1%positive)) + 1) * (1#p))). + apply Qmult_lt_r. unfold Qlt. simpl. unfold Z.lt. auto. assumption. + unfold Qle. simpl. rewrite Zmult_1_r. rewrite Zmult_1_r. rewrite Zmult_1_r. + rewrite Pos.mul_1_r. rewrite Pos2Z.inj_mul. rewrite Heqz. + destruct (Qabs (qn (cvmod 1%positive))) eqn:desAbs. + rewrite Z.mul_add_distr_l. rewrite Zmult_1_r. + apply Zplus_le_compat_r. rewrite <- (Zmult_1_l (QArith_base.Qnum (Qnum # Qden))). + rewrite Zmult_assoc. apply Zmult_le_compat_r. rewrite Zmult_1_r. + simpl. unfold Z.le. rewrite <- Pos2Z.inj_compare. + unfold Pos.compare. destruct Qden; discriminate. + simpl. assert (Qle 0 (Qnum # Qden)). rewrite <- desAbs. + apply Qabs_nonneg. unfold Qle in H2. simpl in H2. rewrite Zmult_1_r in H2. + assumption. + - exfalso. inversion zPos. + - destruct H0. apply (BoundFromZero _ (cvmod xH) x). intros n H0. + specialize (q n H0). setoid_replace (Z.pos x # 1)%Q with (/(1#x))%Q. + rewrite <- (Qmult_1_l (/(1#x))). apply Qlt_shift_div_l. + reflexivity. apply q. reflexivity. +Qed. + +Lemma CReal_mult_cauchy + : forall (xn yn zn : nat -> Q) (Ay Az : positive) (cvmod : positive -> nat), + QSeqEquiv xn yn cvmod + -> QCauchySeq zn Pos.to_nat + -> (forall n:nat, Qlt (Qabs (yn n)) (Z.pos Ay # 1)) + -> (forall n:nat, Qlt (Qabs (zn n)) (Z.pos Az # 1)) + -> QSeqEquiv (fun n:nat => xn n * zn n) (fun n:nat => yn n * zn n) + (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) + (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). +Proof. + intros xn yn zn Ay Az cvmod limx limz majy majz. + remember (Pos.mul 2 (Pos.max Ay Az)) as z. + intros k p q H H0. + assert (Pos.to_nat k <> O) as kPos. + { intro absurd. pose proof (Pos2Nat.is_pos k). + rewrite absurd in H1. inversion H1. } + setoid_replace (xn p * zn p - yn q * zn q)%Q + with ((xn p - yn q) * zn p + yn q * (zn p - zn q))%Q. + 2: ring. + apply (Qle_lt_trans _ (Qabs ((xn p - yn q) * zn p) + + Qabs (yn q * (zn p - zn q)))). + apply Qabs_triangle. rewrite Qabs_Qmult. rewrite Qabs_Qmult. + setoid_replace (1#k)%Q with ((1#2*k) + (1#2*k))%Q. + apply Qplus_lt_le_compat. + - apply (Qle_lt_trans _ ((1#z * k) * Qabs (zn p)%nat)). + + apply Qmult_le_compat_r. apply Qle_lteq. left. apply limx. + apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). + apply Nat.le_max_l. assumption. + apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). + apply Nat.le_max_l. assumption. apply Qabs_nonneg. + + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). + rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. + rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. + apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. + apply (Qle_lt_trans _ (Qabs (zn p)%nat * (1 # Az))). + rewrite <- (Qmult_comm (1 # Az)). apply Qmult_le_compat_r. + unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_r. + apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Az)). + rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. + setoid_replace (/(1#Az))%Q with (Z.pos Az # 1)%Q. apply majz. + reflexivity. intro abs. inversion abs. + - apply (Qle_trans _ ((1 # z * k) * Qabs (yn q)%nat)). + + rewrite Qmult_comm. apply Qmult_le_compat_r. apply Qle_lteq. + left. apply limz. + apply (le_trans _ (max (cvmod (z * k)%positive) + (Pos.to_nat (z * k)%positive))). + apply Nat.le_max_r. assumption. + apply (le_trans _ (max (cvmod (z * k)%positive) + (Pos.to_nat (z * k)%positive))). + apply Nat.le_max_r. assumption. apply Qabs_nonneg. + + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). + rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. + rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. + apply Qle_lteq. left. + apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. + apply (Qle_lt_trans _ (Qabs (yn q)%nat * (1 # Ay))). + rewrite <- (Qmult_comm (1 # Ay)). apply Qmult_le_compat_r. + unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. + apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Ay)). + rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. + setoid_replace (/(1#Ay))%Q with (Z.pos Ay # 1)%Q. apply majy. + reflexivity. intro abs. inversion abs. + - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Lemma linear_max : forall (p Ax Ay : positive) (i : nat), + le (Pos.to_nat p) i + -> (Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) + (Pos.to_nat (2 * Pos.max Ax Ay * p)) <= Pos.to_nat (2 * Pos.max Ax Ay) * i)%nat. +Proof. + intros. rewrite max_l. 2: apply le_refl. + rewrite Pos2Nat.inj_mul. apply Nat.mul_le_mono_nonneg. + apply le_0_n. apply le_refl. apply le_0_n. apply H. +Qed. + +Definition CReal_mult (x y : CReal) : CReal. +Proof. + destruct x as [xn limx]. destruct y as [yn limy]. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + exists (fun n : nat => xn (Pos.to_nat (2 * Pos.max Ax Ay)* n)%nat + * yn (Pos.to_nat (2 * Pos.max Ax Ay) * n)%nat). + intros p n k H0 H1. + apply H; apply linear_max; assumption. +Defined. + +Infix "*" := CReal_mult : CReal_scope. + +Lemma CReal_mult_unfold : forall x y : CReal, + QSeqEquivEx (proj1_sig (CReal_mult x y)) + (fun n : nat => proj1_sig x n * proj1_sig y n)%Q. +Proof. + intros [xn limx] [yn limy]. unfold CReal_mult ; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + simpl. + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) + (Pos.to_nat (2 * Pos.max Ax Ay * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + apply H. apply linear_max. + apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). + rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. + apply le_0_n. apply le_refl. apply H0. rewrite max_l. + apply H1. apply le_refl. +Qed. + +Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : nat -> Q), + QSeqEquivEx xn yn (* both are Cauchy with same limit *) + -> QSeqEquiv zn zn Pos.to_nat + -> QSeqEquivEx (fun n => xn n * zn n)%Q (fun n => yn n * zn n)%Q. +Proof. + intros. destruct H as [cvmod cveq]. + destruct (QCauchySeq_bounded yn (fun k => cvmod (2 * k)%positive) + (QSeqEquiv_cau_r xn yn cvmod cveq)) + as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat H0) as [Az majz]. + exists (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) + (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). + apply CReal_mult_cauchy; assumption. +Qed. + +Lemma CReal_mult_assoc : forall x y z : CReal, + CRealEq (CReal_mult (CReal_mult x y) z) + (CReal_mult x (CReal_mult y z)). +Proof. + intros. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n * proj1_sig z n)%Q). + - apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n * proj1_sig z n)%Q). + apply CReal_mult_unfold. + destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + apply CReal_mult_assoc_bounded_r. 2: apply limz. + simpl. + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) + (Pos.to_nat (2 * Pos.max Ax Ay * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + apply H. apply linear_max. + apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). + rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. + apply le_0_n. apply le_refl. apply H0. rewrite max_l. + apply H1. apply le_refl. + - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig (CReal_mult y z) n)%Q). + 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. + destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + simpl. + pose proof (CReal_mult_assoc_bounded_r (fun n0 : nat => yn n0 * zn n0)%Q (fun n : nat => + yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat + * zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat)%Q xn) + as [cvmod cveq]. + + pose proof (CReal_mult_cauchy yn yn zn Ay Az Pos.to_nat limy limz majy majz). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Az * p)) + (Pos.to_nat (2 * Pos.max Ay Az * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + apply H. rewrite max_l. apply H0. apply le_refl. + apply linear_max. + apply (le_trans _ (Pos.to_nat (2 * Pos.max Ay Az * p))). + rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. + apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. + apply le_0_n. apply le_refl. apply H1. + apply limx. + exists cvmod. intros p k n H1 H2. specialize (cveq p k n H1 H2). + setoid_replace (xn k * yn k * zn k - + xn n * + (yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * + zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat))%Q + with ((fun n : nat => yn n * zn n * xn n) k - + (fun n : nat => + yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * + zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * + xn n) n)%Q. + apply cveq. ring. +Qed. + +Lemma CReal_mult_comm : forall x y : CReal, + CRealEq (CReal_mult x y) (CReal_mult y x). +Proof. + intros. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig y n * proj1_sig x n)%Q). + destruct x as [xn limx], y as [yn limy]; simpl. + 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]; simpl. + apply QSeqEquivEx_sym. + + pose proof (CReal_mult_cauchy yn yn xn Ay Ax Pos.to_nat limy limx majy majx). + exists (fun p : positive => + Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Ax * p)) + (Pos.to_nat (2 * Pos.max Ay Ax * p))). + intros p n k H0 H1. rewrite max_l in H0, H1. + 2: apply le_refl. 2: apply le_refl. + rewrite (Qmult_comm (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)). + apply (H p n). rewrite max_l. apply H0. apply le_refl. + rewrite max_l. apply (le_trans _ k). apply H1. + rewrite <- (mult_1_l k). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. + apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply le_refl. +Qed. + +(* Axiom Rmult_eq_compat_l *) +Lemma CReal_mult_proper_l : forall x y z : CReal, + CRealEq y z -> CRealEq (CReal_mult x y) (CReal_mult x z). +Proof. + intros. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n)%Q). + apply CReal_mult_unfold. + rewrite CRealEq_diff in H. rewrite <- CRealEq_modindep in H. + apply QSeqEquivEx_sym. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig z n)%Q). + apply CReal_mult_unfold. + destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. + destruct H. simpl in H. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + pose proof (CReal_mult_cauchy yn zn xn Az Ax x H limx majz majx). + apply QSeqEquivEx_sym. + exists (fun p : positive => + Init.Nat.max (x (2 * Pos.max Az Ax * p)%positive) + (Pos.to_nat (2 * Pos.max Az Ax * p))). + intros p n k H1 H2. specialize (H0 p n k H1 H2). + setoid_replace (xn n * yn n - xn k * zn k)%Q + with (yn n * xn n - zn k * xn k)%Q. + apply H0. ring. +Qed. + +Lemma CReal_mult_lt_0_compat : forall x y : CReal, + CRealLt (inject_Q 0) x + -> CRealLt (inject_Q 0) y + -> CRealLt (inject_Q 0) (CReal_mult x y). +Proof. + intros. destruct H as [x0 H], H0 as [x1 H0]. + pose proof (CRealLt_aboveSig (inject_Q 0) x x0 H). + pose proof (CRealLt_aboveSig (inject_Q 0) y x1 H0). + destruct x as [xn limx], y as [yn limy]. + simpl in H, H1, H2. simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (Qarchimedean (/ (xn (Pos.to_nat x0) - 0 - (2 # x0)))). + destruct (Qarchimedean (/ (yn (Pos.to_nat x1) - 0 - (2 # x1)))). + exists (Pos.max x0 x~0 * Pos.max x1 x2~0)%positive. + simpl. unfold Qminus. rewrite Qplus_0_r. + rewrite <- Pos2Nat.inj_mul. + unfold Qminus in H1, H2. + specialize (H1 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive). + assert (Pos.max x1 x2~0 <= (Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive. + { apply Pos2Nat.inj_le. + rewrite Pos.mul_assoc. rewrite Pos2Nat.inj_mul. + rewrite <- (mult_1_l (Pos.to_nat (Pos.max x1 x2~0))). + rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. + rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. + apply le_refl. } + specialize (H2 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive H3). + rewrite Qplus_0_r in H1, H2. + apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (2 # Pos.max x1 x2~0))). + unfold Qlt; simpl. assert (forall p : positive, (Z.pos p < Z.pos p~0)%Z). + intro p. rewrite <- (Z.mul_1_l (Z.pos p)). + replace (Z.pos p~0) with (2 * Z.pos p)%Z. apply Z.mul_lt_mono_pos_r. + apply Pos2Z.is_pos. reflexivity. reflexivity. + apply H4. + apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (yn (Pos.to_nat ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0)))))). + apply Qmult_lt_l. reflexivity. apply H2. apply Qmult_lt_r. + apply (Qlt_trans 0 (2 # Pos.max x1 x2~0)). reflexivity. apply H2. + apply H1. rewrite Pos.mul_comm. apply Pos2Nat.inj_le. + rewrite <- Pos.mul_assoc. rewrite Pos2Nat.inj_mul. + rewrite <- (mult_1_r (Pos.to_nat (Pos.max x0 x~0))). + rewrite <- mult_assoc. apply Nat.mul_le_mono_nonneg. + apply le_0_n. apply le_refl. auto. + rewrite mult_1_l. apply Pos2Nat.is_pos. +Qed. + +Lemma CReal_mult_plus_distr_l : forall r1 r2 r3 : CReal, + r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). +Proof. + intros x y z. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n + * (proj1_sig (CReal_plus y z) n))%Q). + apply CReal_mult_unfold. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n + + proj1_sig (CReal_mult x z) n))%Q. + 2: apply QSeqEquivEx_sym; exists (fun p => Pos.to_nat (2 * p)) + ; apply CReal_plus_unfold. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n + * (proj1_sig y n + proj1_sig z n))%Q). + - pose proof (CReal_plus_unfold y z). + destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl; simpl in H. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + pose proof (CReal_mult_cauchy (fun n => yn (n + (n + 0))%nat + zn (n + (n + 0))%nat)%Q + (fun n => yn n + zn n)%Q + xn (Ay + Az) Ax + (fun p => Pos.to_nat (2 * p)) H limx). + exists (fun p : positive => (Pos.to_nat (2 * (2 * Pos.max (Ay + Az) Ax * p)))). + intros p n k H1 H2. + setoid_replace (xn n * (yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) - xn k * (yn k + zn k))%Q + with ((yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) * xn n - (yn k + zn k) * xn k)%Q. + 2: ring. + assert (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p) <= + Pos.to_nat 2 * Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))%nat. + { rewrite (Pos2Nat.inj_mul 2). + rewrite <- (mult_1_l (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))). + rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. + simpl. auto. apply le_0_n. apply le_refl. } + apply H0. intro n0. apply (Qle_lt_trans _ (Qabs (yn n0) + Qabs (zn n0))). + apply Qabs_triangle. rewrite Pos2Z.inj_add. + rewrite <- Qinv_plus_distr. apply Qplus_lt_le_compat. + apply majy. apply Qlt_le_weak. apply majz. + apply majx. rewrite max_l. + apply H1. rewrite (Pos2Nat.inj_mul 2). apply H3. + rewrite max_l. apply H2. rewrite (Pos2Nat.inj_mul 2). + apply H3. + - destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. + destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. + destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. + destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. + simpl. + exists (fun p : positive => (Pos.to_nat (2 * (Pos.max (Pos.max Ax Ay) Az) * (2 * p)))). + intros p n k H H0. + setoid_replace (xn n * (yn n + zn n) - + (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * + yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat + + xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * + zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q + with (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * + yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat) + + (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * + zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q. + 2: ring. + apply (Qle_lt_trans _ (Qabs (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * + yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)) + + Qabs (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * + zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))). + apply Qabs_triangle. + setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. + apply Qplus_lt_le_compat. + + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy). + apply H1. apply majx. apply majy. rewrite max_l. + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H. apply le_refl. + rewrite max_l. apply (le_trans _ k). + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H0. + rewrite <- (mult_1_l k). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. + rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. + apply le_refl. apply le_refl. + + apply Qlt_le_weak. + pose proof (CReal_mult_cauchy xn xn zn Ax Az Pos.to_nat limx limz). + apply H1. apply majx. apply majz. rewrite max_l. 2: apply le_refl. + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). + rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H. + rewrite max_l. apply (le_trans _ k). + apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). + rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. + rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). + rewrite <- Pos.mul_assoc. + rewrite Pos2Nat.inj_mul. + rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). + apply Nat.mul_le_mono_nonneg. apply le_0_n. + rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). + rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. + apply le_0_n. apply le_refl. apply H0. + rewrite <- (mult_1_l k). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. + rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. + apply le_refl. apply le_refl. + + rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Lemma CReal_mult_plus_distr_r : forall r1 r2 r3 : CReal, + (r2 + r3) * r1 == (r2 * r1) + (r3 * r1). +Proof. + intros. + rewrite CReal_mult_comm, CReal_mult_plus_distr_l, + <- (CReal_mult_comm r1), <- (CReal_mult_comm r1). + reflexivity. +Qed. + +Lemma CReal_mult_1_l : forall r: CReal, 1 * r == r. +Proof. + intros [rn limr]. split. + - intros [m maj]. simpl in maj. + destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). + destruct (QCauchySeq_bounded rn Pos.to_nat limr). + simpl in maj. rewrite Qmult_1_l in maj. + specialize (limr m). + apply (Qlt_not_le (2 # m) (1 # m)). + apply (Qlt_trans _ (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat)). + apply maj. + apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat))). + apply Qle_Qabs. apply limr. apply le_refl. + rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. + apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply Z.mul_le_mono_nonneg. discriminate. discriminate. + discriminate. apply Z.le_refl. + - intros [m maj]. simpl in maj. + destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). + destruct (QCauchySeq_bounded rn Pos.to_nat limr). + simpl in maj. rewrite Qmult_1_l in maj. + specialize (limr m). + apply (Qlt_not_le (2 # m) (1 # m)). + apply (Qlt_trans _ (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m))). + apply maj. + apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m)))). + apply Qle_Qabs. apply limr. + rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. + apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply le_refl. apply Z.mul_le_mono_nonneg. discriminate. discriminate. + discriminate. apply Z.le_refl. +Qed. + +Lemma CReal_isRingExt : ring_eq_ext CReal_plus CReal_mult CReal_opp CRealEq. +Proof. + split. + - intros x y H z t H0. apply CReal_plus_morph; assumption. + - intros x y H z t H0. apply (CRealEq_trans _ (CReal_mult x t)). + apply CReal_mult_proper_l. apply H0. + apply (CRealEq_trans _ (CReal_mult t x)). apply CReal_mult_comm. + apply (CRealEq_trans _ (CReal_mult t y)). + apply CReal_mult_proper_l. apply H. apply CReal_mult_comm. + - intros x y H. apply (CReal_plus_eq_reg_l x). + apply (CRealEq_trans _ (inject_Q 0)). apply CReal_plus_opp_r. + apply (CRealEq_trans _ (CReal_plus y (CReal_opp y))). + apply CRealEq_sym. apply CReal_plus_opp_r. + apply CReal_plus_proper_r. apply CRealEq_sym. apply H. +Qed. + +Lemma CReal_isRing : ring_theory (inject_Q 0) (inject_Q 1) + CReal_plus CReal_mult + CReal_minus CReal_opp + CRealEq. +Proof. + intros. split. + - apply CReal_plus_0_l. + - apply CReal_plus_comm. + - intros x y z. symmetry. apply CReal_plus_assoc. + - apply CReal_mult_1_l. + - apply CReal_mult_comm. + - intros x y z. symmetry. apply CReal_mult_assoc. + - intros x y z. rewrite <- (CReal_mult_comm z). + rewrite CReal_mult_plus_distr_l. + apply (CRealEq_trans _ (CReal_plus (CReal_mult x z) (CReal_mult z y))). + apply CReal_plus_proper_r. apply CReal_mult_comm. + apply CReal_plus_proper_l. apply CReal_mult_comm. + - intros x y. apply CRealEq_refl. + - apply CReal_plus_opp_r. +Qed. + +Add Parametric Morphism : CReal_mult + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_mult_morph. +Proof. + apply CReal_isRingExt. +Qed. + +Instance CReal_mult_morph_T + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_mult. +Proof. + apply CReal_isRingExt. +Qed. + +Add Parametric Morphism : CReal_opp + with signature CRealEq ==> CRealEq + as CReal_opp_morph. +Proof. + apply (Ropp_ext CReal_isRingExt). +Qed. + +Instance CReal_opp_morph_T + : CMorphisms.Proper + (CMorphisms.respectful CRealEq CRealEq) CReal_opp. +Proof. + apply CReal_isRingExt. +Qed. + +Add Parametric Morphism : CReal_minus + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_minus_morph. +Proof. + intros. unfold CReal_minus. rewrite H,H0. reflexivity. +Qed. + +Instance CReal_minus_morph_T + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_minus. +Proof. + intros x y exy z t ezt. unfold CReal_minus. rewrite exy,ezt. reflexivity. +Qed. + +Add Ring CRealRing : CReal_isRing. + +Lemma CReal_opp_0 : -0 == 0. +Proof. + ring. +Qed. + +Lemma CReal_opp_plus_distr : forall r1 r2, - (r1 + r2) == - r1 + - r2. +Proof. + intros; ring. +Qed. + +Lemma CReal_opp_involutive : forall x:CReal, --x == x. +Proof. + intro x. ring. +Qed. + +Lemma CReal_opp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. +Proof. + unfold CRealGt; intros. + apply (CReal_plus_lt_reg_l (r2 + r1)). + setoid_replace (r2 + r1 + - r1) with r2 by ring. + setoid_replace (r2 + r1 + - r2) with r1 by ring. + exact H. +Qed. + +(**********) +Lemma CReal_mult_0_l : forall r, 0 * r == 0. +Proof. + intro; ring. +Qed. + +Lemma CReal_mult_0_r : forall r, r * 0 == 0. +Proof. + intro; ring. +Qed. + +(**********) +Lemma CReal_mult_1_r : forall r, r * 1 == r. +Proof. + intro; ring. +Qed. + +Lemma CReal_opp_mult_distr_l + : forall r1 r2 : CReal, CRealEq (CReal_opp (CReal_mult r1 r2)) + (CReal_mult (CReal_opp r1) r2). +Proof. + intros. ring. +Qed. + +Lemma CReal_mult_lt_compat_l : forall x y z : CReal, + 0 < x -> y < z -> x*y < x*z. +Proof. + intros. apply (CReal_plus_lt_reg_l + (CReal_opp (CReal_mult x y))). + rewrite CReal_plus_comm. pose proof CReal_plus_opp_r. + unfold CReal_minus in H1. rewrite H1. + rewrite CReal_mult_comm, CReal_opp_mult_distr_l, CReal_mult_comm. + rewrite <- CReal_mult_plus_distr_l. + apply CReal_mult_lt_0_compat. exact H. + apply (CReal_plus_lt_reg_l y). + rewrite CReal_plus_comm, CReal_plus_0_l. + rewrite <- CReal_plus_assoc, H1, CReal_plus_0_l. exact H0. +Qed. + +Lemma CReal_mult_lt_compat_r : forall x y z : CReal, + 0 < x -> y < z -> y*x < z*x. +Proof. + intros. rewrite <- (CReal_mult_comm x), <- (CReal_mult_comm x). + apply (CReal_mult_lt_compat_l x); assumption. +Qed. + +Lemma CReal_mult_eq_reg_l : forall (r r1 r2 : CReal), + r # 0 + -> CRealEq (CReal_mult r r1) (CReal_mult r r2) + -> CRealEq r1 r2. +Proof. + intros. destruct H; split. + - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. + rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. + exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). + rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. + - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. + rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. + exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). + rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. + - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. + exact (CRealLt_irrefl _ abs). exact c. + - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. + exact (CRealLt_irrefl _ abs). exact c. +Qed. + + + +(*********************************************************) +(** * Field *) +(*********************************************************) + +(**********) +Fixpoint INR (n:nat) : CReal := + match n with + | O => 0 + | S O => 1 + | S n => INR n + 1 + end. +Arguments INR n%nat. + +(* compact representation for 2*p *) +Fixpoint IPR_2 (p:positive) : CReal := + match p with + | xH => 1 + 1 + | xO p => IPR_2 p + IPR_2 p + | xI p => (1 + IPR_2 p) + (1 + IPR_2 p) + end. + +Definition IPR (p:positive) : CReal := + match p with + | xH => 1 + | xO p => IPR_2 p + | xI p => 1 + IPR_2 p + end. +Arguments IPR p%positive : simpl never. + +(**********) +Definition IZR (z:Z) : CReal := + match z with + | Z0 => 0 + | Zpos n => IPR n + | Zneg n => - IPR n + end. +Arguments IZR z%Z : simpl never. + +Notation "2" := (IZR 2) : CReal_scope. + +(**********) +Lemma S_INR : forall n:nat, INR (S n) == INR n + 1. +Proof. + intro; destruct n. rewrite CReal_plus_0_l. reflexivity. reflexivity. +Qed. + +Lemma le_succ_r_T : forall n m : nat, (n <= S m)%nat -> {(n <= m)%nat} + {n = S m}. +Proof. + intros. destruct (le_lt_dec n m). left. exact l. + right. apply Nat.le_succ_r in H. destruct H. + exfalso. apply (le_not_lt n m); assumption. exact H. +Qed. + +Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. +Proof. + induction m. + - intros. exfalso. inversion H. + - intros. unfold lt in H. apply le_S_n in H. destruct m. + assert (n = 0)%nat. + { inversion H. reflexivity. } + subst n. apply CRealLt_0_1. apply le_succ_r_T in H. destruct H. + rewrite S_INR. apply (CRealLt_trans _ (INR (S m) + 0)). + rewrite CReal_plus_comm, CReal_plus_0_l. apply IHm. + apply le_n_S. exact l. + apply CReal_plus_lt_compat_l. exact CRealLt_0_1. + subst n. rewrite (S_INR (S m)). rewrite <- (CReal_plus_0_l). + rewrite (CReal_plus_comm 0), CReal_plus_assoc. + apply CReal_plus_lt_compat_l. rewrite CReal_plus_0_l. + exact CRealLt_0_1. +Qed. + +(**********) +Lemma S_O_plus_INR : forall n:nat, INR (1 + n) == INR 1 + INR n. +Proof. + intros; destruct n. + - rewrite CReal_plus_comm, CReal_plus_0_l. reflexivity. + - rewrite CReal_plus_comm. reflexivity. +Qed. + +(**********) +Lemma plus_INR : forall n m:nat, INR (n + m) == INR n + INR m. +Proof. + intros n m; induction n as [| n Hrecn]. + - rewrite CReal_plus_0_l. reflexivity. + - replace (S n + m)%nat with (S (n + m)); auto with arith. + repeat rewrite S_INR. + rewrite Hrecn; ring. +Qed. + +(**********) +Lemma minus_INR : forall n m:nat, (m <= n)%nat -> INR (n - m) == INR n - INR m. +Proof. + intros n m le; pattern m, n; apply le_elim_rel. + intros. rewrite <- minus_n_O. unfold CReal_minus. + unfold INR. ring. + intros; repeat rewrite S_INR; simpl. + unfold CReal_minus. rewrite H0. ring. exact le. +Qed. + +(*********) +Lemma mult_INR : forall n m:nat, INR (n * m) == INR n * INR m. +Proof. + intros n m; induction n as [| n Hrecn]. + - rewrite CReal_mult_0_l. reflexivity. + - intros; repeat rewrite S_INR; simpl. + rewrite plus_INR. rewrite Hrecn; ring. +Qed. + +(**********) +Lemma IZN : forall n:Z, (0 <= n)%Z -> { m : nat | n = Z.of_nat m }. +Proof. + intros. exists (Z.to_nat n). rewrite Z2Nat.id. reflexivity. assumption. +Qed. + +Lemma INR_IPR : forall p, INR (Pos.to_nat p) == IPR p. +Proof. + assert (H: forall p, INR (Pos.to_nat p) + INR (Pos.to_nat p) == IPR_2 p). + { induction p as [p|p|]. + - unfold IPR_2; rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp. + setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. + - unfold IPR_2; rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. + setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. + - reflexivity. } + intros [p|p|] ; unfold IPR. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. + setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. + rewrite Pos2Nat.inj_xO, mult_INR, <- H. + setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. + easy. +Qed. + +(* This is stronger than Req to injectQ, because it + concerns all the rational sequence, not only its limit. *) +Lemma FinjectP2_CReal : forall (p:positive) (k:nat), + (proj1_sig (IPR_2 p) k == Z.pos p~0 # 1)%Q. +Proof. + induction p. + - intros. replace (IPR_2 p~1) with (1 + IPR_2 p + (1+ IPR_2 p)). + 2: reflexivity. do 2 rewrite CReal_plus_nth. rewrite IHp. + simpl. rewrite Pos2Z.inj_xO, (Pos2Z.inj_xO (p~1)), Pos2Z.inj_xI. + generalize (2*Z.pos p)%Z. intro z. + do 2 rewrite Qinv_plus_distr. apply f_equal2. + 2: reflexivity. unfold Qnum. ring. + - intros. replace (IPR_2 p~0) with (IPR_2 p + IPR_2 p). + 2: reflexivity. rewrite CReal_plus_nth, IHp. + rewrite Qinv_plus_distr. apply f_equal2. 2: reflexivity. + unfold Qnum. rewrite (Pos2Z.inj_xO (p~0)). ring. + - intros. reflexivity. +Qed. + +Lemma FinjectP_CReal : forall (p:positive) (k:nat), + (proj1_sig (IPR p) k == Z.pos p # 1)%Q. +Proof. + destruct p. + - intros. unfold IPR. + rewrite CReal_plus_nth, FinjectP2_CReal. unfold Qeq; simpl. + rewrite Pos.mul_1_r. reflexivity. + - intros. unfold IPR. rewrite FinjectP2_CReal. reflexivity. + - intros. reflexivity. +Qed. + +(* Inside this Cauchy real implementation, we can give + an instantaneous witness of this inequality, because + we know a priori that it will work. *) +Lemma IPR_pos : forall p:positive, 0 < IPR p. +Proof. + intro p. exists 3%positive. simpl. + rewrite FinjectP_CReal. apply (Qlt_le_trans _ 1). reflexivity. + unfold Qle; simpl. + rewrite <- (Zpos_max_1 (p*1*1)). apply Z.le_max_l. +Defined. + +Lemma IPR_double : forall p:positive, IPR (2*p) == 2 * IPR p. +Proof. + intro p. + destruct p; rewrite (CReal_mult_plus_distr_r _ 1 1), CReal_mult_1_l; reflexivity. +Qed. + +(**********) +Lemma INR_IZR_INZ : forall n:nat, INR n == IZR (Z.of_nat n). +Proof. + intros [|n]. + easy. + simpl Z.of_nat. unfold IZR. + now rewrite <- INR_IPR, SuccNat2Pos.id_succ. +Qed. + +Lemma plus_IZR_NEG_POS : + forall p q:positive, IZR (Zpos p + Zneg q) == IZR (Zpos p) + IZR (Zneg q). +Proof. + intros p q; simpl. rewrite Z.pos_sub_spec. + case Pos.compare_spec; intros H; unfold IZR. + subst. ring. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub. + rewrite minus_INR. + 2: (now apply lt_le_weak, Pos2Nat.inj_lt). + ring. + trivial. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub. + rewrite minus_INR. + 2: (now apply lt_le_weak, Pos2Nat.inj_lt). + ring. trivial. +Qed. + +Lemma plus_IPR : forall n m:positive, IPR (n + m) == IPR n + IPR m. +Proof. + intros. repeat rewrite <- INR_IPR. + rewrite Pos2Nat.inj_add. apply plus_INR. +Qed. + +(**********) +Lemma plus_IZR : forall n m:Z, IZR (n + m) == IZR n + IZR m. +Proof. + intro z; destruct z; intro t; destruct t; intros. + - rewrite CReal_plus_0_l. reflexivity. + - rewrite CReal_plus_0_l. rewrite Z.add_0_l. reflexivity. + - rewrite CReal_plus_0_l. reflexivity. + - rewrite CReal_plus_comm,CReal_plus_0_l. reflexivity. + - rewrite <- Pos2Z.inj_add. unfold IZR. apply plus_IPR. + - apply plus_IZR_NEG_POS. + - rewrite CReal_plus_comm,CReal_plus_0_l, Z.add_0_r. reflexivity. + - rewrite Z.add_comm; rewrite CReal_plus_comm; apply plus_IZR_NEG_POS. + - simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR. + ring. +Qed. + +Lemma mult_IPR : forall n m:positive, IPR (n * m) == IPR n * IPR m. +Proof. + intros. repeat rewrite <- INR_IPR. + rewrite Pos2Nat.inj_mul. apply mult_INR. +Qed. + +Lemma mult_IZR : forall n m:Z, IZR (n * m) == IZR n * IZR m. +Proof. + intros n m. destruct n. + - rewrite CReal_mult_0_l. rewrite Z.mul_0_l. reflexivity. + - destruct m. rewrite Z.mul_0_r, CReal_mult_0_r. reflexivity. + simpl; unfold IZR. apply mult_IPR. + simpl. unfold IZR. rewrite mult_IPR. ring. + - destruct m. rewrite Z.mul_0_r, CReal_mult_0_r. reflexivity. + simpl. unfold IZR. rewrite mult_IPR. ring. + simpl. unfold IZR. rewrite mult_IPR. ring. +Qed. + +Lemma opp_IZR : forall n:Z, IZR (- n) == - IZR n. +Proof. + intros [|z|z]; unfold IZR. rewrite CReal_opp_0. reflexivity. + reflexivity. rewrite CReal_opp_involutive. reflexivity. +Qed. + +Lemma minus_IZR : forall n m:Z, IZR (n - m) == IZR n - IZR m. +Proof. + intros; unfold Z.sub, CReal_minus. + rewrite <- opp_IZR. + apply plus_IZR. +Qed. + +Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m. +Proof. + assert (forall n:Z, Z.lt 0 n -> 0 < IZR n) as posCase. + { intros. destruct (IZN n). apply Z.lt_le_incl. apply H. + subst n. rewrite <- INR_IZR_INZ. apply (lt_INR 0). + apply Nat2Z.inj_lt. apply H. } + intros. apply (CReal_plus_lt_reg_r (-(IZR n))). + pose proof minus_IZR. unfold CReal_minus in H0. + repeat rewrite <- H0. unfold Zminus. + rewrite Z.add_opp_diag_r. apply posCase. + rewrite (Z.add_lt_mono_l _ _ n). ring_simplify. apply H. +Qed. + +Lemma Z_R_minus : forall n m:Z, IZR n - IZR m == IZR (n - m). +Proof. + intros z1 z2; unfold CReal_minus; unfold Z.sub. + rewrite plus_IZR, opp_IZR. reflexivity. +Qed. + +Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. +Proof. + intro z; case z; simpl; intros. + elim (CRealLt_irrefl _ H). + easy. exfalso. + apply (CRealLt_asym 0 (IZR (Z.neg p))). exact H. + apply (IZR_lt (Z.neg p) 0). reflexivity. +Qed. + +Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z. +Proof. + intros z1 z2 H; apply Z.lt_0_sub. + apply lt_0_IZR. + rewrite <- Z_R_minus. apply (CReal_plus_lt_reg_l (IZR z1)). + ring_simplify. exact H. +Qed. + +Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m. +Proof. + intros m n H. intro abs. apply (lt_IZR n m) in abs. omega. +Qed. + +Lemma CReal_iterate_one : forall (n : nat), + IZR (Z.of_nat n) == inject_Q (Z.of_nat n # 1). +Proof. + induction n. + - apply CRealEq_refl. + - replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z. + rewrite plus_IZR. + rewrite IHn. clear IHn. apply CRealEq_diff. intro k. simpl. + rewrite Z.mul_1_r. rewrite Z.mul_1_r. rewrite Z.mul_1_r. + rewrite Z.add_opp_diag_r. discriminate. + replace (S n) with (1 + n)%nat. 2: reflexivity. + rewrite (Nat2Z.inj_add 1 n). reflexivity. +Qed. + +(* The constant sequences of rationals are CRealEq to + the rational operations on the unity. *) +Lemma FinjectZ_CReal : forall z : Z, + IZR z == inject_Q (z # 1). +Proof. + intros. destruct z. + - apply CRealEq_refl. + - simpl. pose proof (CReal_iterate_one (Pos.to_nat p)). + rewrite positive_nat_Z in H. apply H. + - simpl. apply (CReal_plus_eq_reg_l (IZR (Z.pos p))). + pose proof CReal_plus_opp_r. rewrite H. + pose proof (CReal_iterate_one (Pos.to_nat p)). + rewrite positive_nat_Z in H0. rewrite H0. + apply CRealEq_diff. intro n. simpl. rewrite Z.pos_sub_diag. + discriminate. +Qed. + + +(* Axiom Rarchimed_constr *) +Lemma Rarchimedean + : forall x:CReal, + { n:Z & x < IZR n < x+2 }. +Proof. + (* Locate x within 1/4 and pick the first integer above this interval. *) + intros [xn limx]. + pose proof (Qlt_floor (xn 4%nat + (1#4))). unfold inject_Z in H. + pose proof (Qfloor_le (xn 4%nat + (1#4))). unfold inject_Z in H0. + remember (Qfloor (xn 4%nat + (1#4)))%Z as n. + exists (n+1)%Z. split. + - rewrite FinjectZ_CReal. + assert (Qlt 0 ((n + 1 # 1) - (xn 4%nat + (1 # 4)))) as epsPos. + { unfold Qminus. rewrite <- Qlt_minus_iff. exact H. } + destruct (Qarchimedean (/((1#2)*((n + 1 # 1) - (xn 4%nat + (1 # 4)))))) as [k kmaj]. + exists (Pos.max 4 k). simpl. + apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%nat + (1 # 4)))). + + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. + rewrite <- Qinv_lt_contravar in kmaj. 2: reflexivity. + apply (Qle_lt_trans _ (2#k)). + rewrite <- (Qmult_le_l _ _ (1#2)). + setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. 2: reflexivity. + setoid_replace ((1 # 2) * (2 # Pos.max 4 k))%Q with (1#Pos.max 4 k)%Q. 2: reflexivity. + unfold Qle; simpl. apply Pos2Z.pos_le_pos. apply Pos.le_max_r. + reflexivity. + rewrite <- (Qmult_lt_l _ _ (1#2)). + setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. exact kmaj. + reflexivity. reflexivity. rewrite <- (Qmult_0_r (1#2)). + rewrite Qmult_lt_l. exact epsPos. reflexivity. + + rewrite <- (Qplus_lt_r _ _ (xn (Pos.to_nat (Pos.max 4 k)) - (n + 1 # 1) + (1#4))). + ring_simplify. + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max 4 k)) - xn 4%nat))). + apply Qle_Qabs. apply limx. + rewrite Pos2Nat.inj_max. apply Nat.le_max_l. apply le_refl. + - apply (CReal_plus_lt_reg_l (-IZR 2)). ring_simplify. + do 2 rewrite FinjectZ_CReal. + exists 4%positive. simpl. + rewrite <- Qinv_plus_distr. + rewrite <- (Qplus_lt_r _ _ ((n#1) - (1#2))). ring_simplify. + apply (Qle_lt_trans _ (xn 4%nat + (1 # 4)) _ H0). + unfold Pos.to_nat; simpl. + rewrite <- (Qplus_lt_r _ _ (-xn 4%nat)). ring_simplify. + reflexivity. +Qed. + +Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal, + (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b + CRealLt c d. +Proof. + intros. + assert (exists n : nat, n <> O /\ + (Qlt (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n) + \/ Qlt (2 # Pos.of_nat n) (proj1_sig d n - proj1_sig c n))). + { destruct H. destruct H as [n maj]. exists (Pos.to_nat n). split. + intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. + inversion abs. left. rewrite Pos2Nat.id. apply maj. + destruct H as [n maj]. exists (Pos.to_nat n). split. + intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. + inversion abs. right. rewrite Pos2Nat.id. apply maj. } + apply constructive_indefinite_ground_description_nat in H0. + - destruct H0 as [n [nPos maj]]. + destruct (Qlt_le_dec (2 # Pos.of_nat n) + (proj1_sig b n - proj1_sig a n)). + left. exists (Pos.of_nat n). rewrite Nat2Pos.id. apply q. apply nPos. + assert (2 # Pos.of_nat n < proj1_sig d n - proj1_sig c n)%Q. + destruct maj. exfalso. + apply (Qlt_not_le (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n)); assumption. + assumption. clear maj. right. exists (Pos.of_nat n). rewrite Nat2Pos.id. + apply H0. apply nPos. + - clear H0. clear H. intro n. destruct n. right. + intros [abs _]. exact (abs (eq_refl O)). + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig b (S n) - proj1_sig a (S n))). + left. split. discriminate. left. apply q. + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig d (S n) - proj1_sig c (S n))). + left. split. discriminate. right. apply q0. + right. intros [_ [abs|abs]]. + apply (Qlt_not_le (2 # Pos.of_nat (S n)) + (proj1_sig b (S n) - proj1_sig a (S n))); assumption. + apply (Qlt_not_le (2 # Pos.of_nat (S n)) + (proj1_sig d (S n) - proj1_sig c (S n))); assumption. +Qed. + +Lemma CRealShiftReal : forall (x : CReal) (k : nat), + QCauchySeq (fun n => proj1_sig x (plus n k)) Pos.to_nat. +Proof. + intros x k n p q H H0. + destruct x as [xn cau]; unfold proj1_sig. + destruct k. rewrite plus_0_r. rewrite plus_0_r. apply cau; assumption. + specialize (cau (n + Pos.of_nat (S k))%positive (p + S k)%nat (q + S k)%nat). + apply (Qlt_trans _ (1 # n + Pos.of_nat (S k))). + apply cau. rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. + apply Nat.add_le_mono_r. apply H. discriminate. + rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. + apply Nat.add_le_mono_r. apply H0. discriminate. + apply Pos2Nat.inj_lt; simpl. rewrite Pos2Nat.inj_add. + rewrite <- (plus_0_r (Pos.to_nat n)). rewrite <- plus_assoc. + apply Nat.add_lt_mono_l. apply Pos2Nat.is_pos. +Qed. + +Lemma CRealShiftEqual : forall (x : CReal) (k : nat), + CRealEq x (exist _ (fun n => proj1_sig x (plus n k)) (CRealShiftReal x k)). +Proof. + intros. split. + - intros [n maj]. destruct x as [xn cau]; simpl in maj. + specialize (cau n (Pos.to_nat n + k)%nat (Pos.to_nat n)). + apply Qlt_not_le in maj. apply maj. clear maj. + apply (Qle_trans _ (Qabs (xn (Pos.to_nat n + k)%nat - xn (Pos.to_nat n)))). + apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. + apply cau. rewrite <- (plus_0_r (Pos.to_nat n)). + rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. + apply le_refl. apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. + discriminate. + - intros [n maj]. destruct x as [xn cau]; simpl in maj. + specialize (cau n (Pos.to_nat n) (Pos.to_nat n + k)%nat). + apply Qlt_not_le in maj. apply maj. clear maj. + apply (Qle_trans _ (Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat n + k)%nat))). + apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. + apply cau. apply le_refl. rewrite <- (plus_0_r (Pos.to_nat n)). + rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. + apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. discriminate. +Qed. + +(* Find an equal negative real number, which rational sequence + stays below 0, so that it can be inversed. *) +Definition CRealNegShift (x : CReal) + : CRealLt x (inject_Q 0) + -> { y : prod positive CReal | CRealEq x (snd y) + /\ forall n:nat, Qlt (proj1_sig (snd y) n) (-1 # fst y) }. +Proof. + intro xNeg. + pose proof (CRealLt_aboveSig x (inject_Q 0)). + pose proof (CRealShiftReal x). + pose proof (CRealShiftEqual x). + destruct xNeg as [n maj], x as [xn cau]; simpl in maj. + specialize (H n maj); simpl in H. + destruct (Qarchimedean (/ (0 - xn (Pos.to_nat n) - (2 # n)))) as [a _]. + remember (Pos.max n a~0) as k. + clear Heqk. clear maj. clear n. + exists (pair k + (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). + split. apply H1. intro n. simpl. apply Qlt_minus_iff. + destruct n. + - specialize (H k). + unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. + unfold Qminus. rewrite Qplus_comm. + apply (Qlt_trans _ (- xn (Pos.to_nat k)%nat - (2 #k))). apply H. + unfold Qminus. simpl. apply Qplus_lt_r. + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. apply Pos.le_refl. + - apply (Qlt_trans _ (-(2 # k) - xn (S n + Pos.to_nat k)%nat)). + rewrite <- (Nat2Pos.id (S n)). rewrite <- Pos2Nat.inj_add. + specialize (H (Pos.of_nat (S n) + k)%positive). + unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. + unfold Qminus. rewrite Qplus_comm. apply H. apply Pos2Nat.inj_le. + rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. + apply Nat.add_le_mono_r. apply le_0_n. discriminate. + apply Qplus_lt_l. + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. +Qed. + +Definition CRealPosShift (x : CReal) + : CRealLt (inject_Q 0) x + -> { y : prod positive CReal | CRealEq x (snd y) + /\ forall n:nat, Qlt (1 # fst y) (proj1_sig (snd y) n) }. +Proof. + intro xPos. + pose proof (CRealLt_aboveSig (inject_Q 0) x). + pose proof (CRealShiftReal x). + pose proof (CRealShiftEqual x). + destruct xPos as [n maj], x as [xn cau]; simpl in maj. + simpl in H. specialize (H n). + destruct (Qarchimedean (/ (xn (Pos.to_nat n) - 0 - (2 # n)))) as [a _]. + specialize (H maj); simpl in H. + remember (Pos.max n a~0) as k. + clear Heqk. clear maj. clear n. + exists (pair k + (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). + split. apply H1. intro n. simpl. apply Qlt_minus_iff. + destruct n. + - specialize (H k). + unfold Qminus in H. rewrite Qplus_0_r in H. + simpl. rewrite <- Qlt_minus_iff. + apply (Qlt_trans _ (2 #k)). + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. apply H. apply Pos.le_refl. + - rewrite <- Qlt_minus_iff. apply (Qlt_trans _ (2 # k)). + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. specialize (H (Pos.of_nat (S n) + k)%positive). + unfold Qminus in H. rewrite Qplus_0_r in H. + rewrite Pos2Nat.inj_add in H. rewrite Nat2Pos.id in H. + apply H. apply Pos2Nat.inj_le. + rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. + apply Nat.add_le_mono_r. apply le_0_n. discriminate. +Qed. + +Lemma CReal_inv_neg : forall (yn : nat -> Q) (k : positive), + (QCauchySeq yn Pos.to_nat) + -> (forall n : nat, yn n < -1 # k)%Q + -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. +Proof. + (* Prove the inverse sequence is Cauchy *) + intros yn k cau maj n p q H0 H1. + setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - + / yn (Pos.to_nat k ^ 2 * q)%nat)%Q + with ((yn (Pos.to_nat k ^ 2 * q)%nat - + yn (Pos.to_nat k ^ 2 * p)%nat) + / (yn (Pos.to_nat k ^ 2 * q)%nat * + yn (Pos.to_nat k ^ 2 * p)%nat)). + + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat + - yn (Pos.to_nat k ^ 2 * p)%nat) + / (1 # (k^2)))). + assert (1 # k ^ 2 + < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. + { rewrite Qabs_Qmult. unfold "^"%positive; simpl. + rewrite factorDenom. rewrite Pos.mul_1_r. + apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). + apply Qmult_lt_l. reflexivity. rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply Qlt_minus_iff in maj. apply Qlt_minus_iff. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. + reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + apply maj. discriminate. + apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. + rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply Qlt_minus_iff in maj. apply Qlt_minus_iff. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. + reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + apply maj. discriminate. + rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + apply Qlt_minus_iff in maj. apply Qlt_minus_iff. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. + reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + apply maj. discriminate. } + unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. + rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). + apply Qmult_le_compat_r. apply Qlt_le_weak. + rewrite <- Qmult_1_l. apply Qlt_shift_div_r. + apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. + rewrite Qmult_comm. apply Qlt_shift_div_l. + reflexivity. rewrite Qmult_1_l. apply H. + apply Qabs_nonneg. simpl in maj. + specialize (cau (n * (k^2))%positive + (Pos.to_nat k ^ 2 * q)%nat + (Pos.to_nat k ^ 2 * p)%nat). + apply Qlt_shift_div_r. reflexivity. + apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite factorDenom. apply Qle_refl. + + field. split. intro abs. + specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + rewrite abs in maj. inversion maj. + intro abs. + specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + rewrite abs in maj. inversion maj. +Qed. + +Lemma CReal_inv_pos : forall (yn : nat -> Q) (k : positive), + (QCauchySeq yn Pos.to_nat) + -> (forall n : nat, 1 # k < yn n)%Q + -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. +Proof. + intros yn k cau maj n p q H0 H1. + setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - + / yn (Pos.to_nat k ^ 2 * q)%nat)%Q + with ((yn (Pos.to_nat k ^ 2 * q)%nat - + yn (Pos.to_nat k ^ 2 * p)%nat) + / (yn (Pos.to_nat k ^ 2 * q)%nat * + yn (Pos.to_nat k ^ 2 * p)%nat)). + + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat + - yn (Pos.to_nat k ^ 2 * p)%nat) + / (1 # (k^2)))). + assert (1 # k ^ 2 + < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. + { rewrite Qabs_Qmult. unfold "^"%positive; simpl. + rewrite factorDenom. rewrite Pos.mul_1_r. + apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). + apply Qmult_lt_l. reflexivity. rewrite Qabs_pos. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply maj. apply (Qle_trans _ (1 # k)). + discriminate. apply Zlt_le_weak. apply maj. + apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. + rewrite Qabs_pos. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + apply maj. apply (Qle_trans _ (1 # k)). discriminate. + apply Zlt_le_weak. apply maj. + rewrite Qabs_pos. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + apply maj. apply (Qle_trans _ (1 # k)). discriminate. + apply Zlt_le_weak. apply maj. } + unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. + rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). + apply Qmult_le_compat_r. apply Qlt_le_weak. + rewrite <- Qmult_1_l. apply Qlt_shift_div_r. + apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. + rewrite Qmult_comm. apply Qlt_shift_div_l. + reflexivity. rewrite Qmult_1_l. apply H. + apply Qabs_nonneg. simpl in maj. + specialize (cau (n * (k^2))%positive + (Pos.to_nat k ^ 2 * q)%nat + (Pos.to_nat k ^ 2 * p)%nat). + apply Qlt_shift_div_r. reflexivity. + apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite Pos2Nat.inj_mul. rewrite mult_comm. + unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. + rewrite <- mult_assoc. rewrite <- mult_assoc. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + rewrite (mult_1_r). rewrite Pos.mul_1_r. + apply Nat.mul_le_mono_nonneg_l. apply le_0_n. + apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. + rewrite plus_0_r. apply le_refl. + rewrite factorDenom. apply Qle_refl. + + field. split. intro abs. + specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + rewrite abs in maj. inversion maj. + intro abs. + specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + rewrite abs in maj. inversion maj. +Qed. + +Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal. +Proof. + destruct xnz as [xNeg | xPos]. + - destruct (CRealNegShift x xNeg) as [[k y] [_ maj]]. + destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. + exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). + apply (CReal_inv_neg yn). apply cau. apply maj. + - destruct (CRealPosShift x xPos) as [[k y] [_ maj]]. + destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. + exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). + apply (CReal_inv_pos yn). apply cau. apply maj. +Defined. + +Notation "/ x" := (CReal_inv x) (at level 35, right associativity) : CReal_scope. + +Lemma CReal_inv_0_lt_compat + : forall (r : CReal) (rnz : r # 0), + 0 < r -> 0 < ((/ r) rnz). +Proof. + intros. unfold CReal_inv. simpl. + destruct rnz. + - exfalso. apply CRealLt_asym in H. contradiction. + - destruct (CRealPosShift r c) as [[k rpos] [req maj]]. + clear req. destruct rpos as [rn cau]; simpl in maj. + unfold CRealLt; simpl. + destruct (Qarchimedean (rn 1%nat)) as [A majA]. + exists (2 * (A + 1))%positive. unfold Qminus. rewrite Qplus_0_r. + rewrite <- (Qmult_1_l (Qinv (rn (Pos.to_nat k * (Pos.to_nat k * 1) * Pos.to_nat (2 * (A + 1)))%nat))). + apply Qlt_shift_div_l. apply (Qlt_trans 0 (1#k)). reflexivity. + apply maj. rewrite <- (Qmult_inv_r (Z.pos A + 1 # 1)). + setoid_replace (2 # 2 * (A + 1))%Q with (Qinv (Z.pos A + 1 # 1)). + 2: reflexivity. + rewrite Qmult_comm. apply Qmult_lt_r. reflexivity. + rewrite mult_1_r. rewrite <- Pos2Nat.inj_mul. rewrite <- Pos2Nat.inj_mul. + rewrite <- (Qplus_lt_l _ _ (- rn 1%nat)). + apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (k * k * (2 * (A + 1)))) + - rn 1%nat))). + apply Qle_Qabs. apply (Qlt_le_trans _ 1). apply cau. + apply Pos2Nat.is_pos. apply le_refl. + rewrite <- Qinv_plus_distr. rewrite <- (Qplus_comm 1). + rewrite <- Qplus_0_r. rewrite <- Qplus_assoc. rewrite <- Qplus_assoc. + rewrite Qplus_le_r. rewrite Qplus_0_l. apply Qlt_le_weak. + apply Qlt_minus_iff in majA. apply majA. + intro abs. inversion abs. +Qed. + +Lemma CReal_linear_shift : forall (x : CReal) (k : nat), + le 1 k -> QCauchySeq (fun n => proj1_sig x (k * n)%nat) Pos.to_nat. +Proof. + intros [xn limx] k lek p n m H H0. unfold proj1_sig. + apply limx. apply (le_trans _ n). apply H. + rewrite <- (mult_1_l n). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg_r. apply le_0_n. + rewrite mult_1_r. apply lek. apply (le_trans _ m). apply H0. + rewrite <- (mult_1_l m). rewrite mult_assoc. + apply Nat.mul_le_mono_nonneg_r. apply le_0_n. + rewrite mult_1_r. apply lek. +Qed. + +Lemma CReal_linear_shift_eq : forall (x : CReal) (k : nat) (kPos : le 1 k), + CRealEq x + (exist (fun n : nat -> Q => QCauchySeq n Pos.to_nat) + (fun n : nat => proj1_sig x (k * n)%nat) (CReal_linear_shift x k kPos)). +Proof. + intros. apply CRealEq_diff. intro n. + destruct x as [xn limx]; unfold proj1_sig. + specialize (limx n (Pos.to_nat n) (k * Pos.to_nat n)%nat). + apply (Qle_trans _ (1 # n)). apply Qlt_le_weak. apply limx. + apply le_refl. rewrite <- (mult_1_l (Pos.to_nat n)). + rewrite mult_assoc. apply Nat.mul_le_mono_nonneg_r. apply le_0_n. + rewrite mult_1_r. apply kPos. apply Z.mul_le_mono_nonneg_r. + discriminate. discriminate. +Qed. + +Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), + ((/ r) rnz) * r == 1. +Proof. + intros. unfold CReal_inv; simpl. + destruct rnz. + - (* r < 0 *) destruct (CRealNegShift r c) as [[k rneg] [req maj]]. + simpl in req. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in + fun maj0 : forall n : nat, yn n < -1 # k => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n))%nat) + (CReal_inv_neg yn k cau maj0)) maj) rneg)))%Q. + + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply req. + + assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. + rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in + fun maj0 : forall n : nat, yn n < -1 # k => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + (CReal_inv_neg yn k cau maj0)) maj) + (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply CReal_linear_shift_eq. + destruct r as [rn limr], rneg as [rnn limneg]; simpl. + destruct (QCauchySeq_bounded + (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + Pos.to_nat (CReal_inv_neg rnn k limneg maj)). + destruct (QCauchySeq_bounded + (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) + Pos.to_nat + (CReal_linear_shift + (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) + (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. + exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. + rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. + reflexivity. intro abs. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) + * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). + simpl in maj. rewrite abs in maj. inversion maj. + - (* r > 0 *) destruct (CRealPosShift r c) as [[k rneg] [req maj]]. + simpl in req. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in + fun maj0 : forall n : nat, 1 # k < yn n => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + (CReal_inv_pos yn k cau maj0)) maj) rneg)))%Q. + + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply req. + + assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. + rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. + apply (QSeqEquivEx_trans _ + (proj1_sig (CReal_mult ((let + (yn, cau) as s + return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in + fun maj0 : forall n : nat, 1 # k < yn n => + exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) + (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + (CReal_inv_pos yn k cau maj0)) maj) + (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. + apply CRealEq_modindep. apply CRealEq_diff. + apply CReal_mult_proper_l. apply CReal_linear_shift_eq. + destruct r as [rn limr], rneg as [rnn limneg]; simpl. + destruct (QCauchySeq_bounded + (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + Pos.to_nat (CReal_inv_pos rnn k limneg maj)). + destruct (QCauchySeq_bounded + (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) + Pos.to_nat + (CReal_linear_shift + (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) + (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. + exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. + rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. + reflexivity. intro abs. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) + * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). + simpl in maj. rewrite abs in maj. inversion maj. +Qed. + +Lemma CReal_inv_r : forall (r:CReal) (rnz : r # 0), + r * ((/ r) rnz) == 1. +Proof. + intros. rewrite CReal_mult_comm, CReal_inv_l. + reflexivity. +Qed. + +Lemma CReal_inv_1 : forall nz : 1 # 0, (/ 1) nz == 1. +Proof. + intros. rewrite <- (CReal_mult_1_l ((/1) nz)). rewrite CReal_inv_r. + reflexivity. +Qed. + +Lemma CReal_inv_mult_distr : + forall r1 r2 (r1nz : r1 # 0) (r2nz : r2 # 0) (rmnz : (r1*r2) # 0), + (/ (r1 * r2)) rmnz == (/ r1) r1nz * (/ r2) r2nz. +Proof. + intros. apply (CReal_mult_eq_reg_l r1). exact r1nz. + rewrite <- CReal_mult_assoc. rewrite CReal_inv_r. rewrite CReal_mult_1_l. + apply (CReal_mult_eq_reg_l r2). exact r2nz. + rewrite CReal_inv_r. rewrite <- CReal_mult_assoc. + rewrite (CReal_mult_comm r2 r1). rewrite CReal_inv_r. + reflexivity. +Qed. + +Lemma Rinv_eq_compat : forall x y (rxnz : x # 0) (rynz : y # 0), + x == y + -> (/ x) rxnz == (/ y) rynz. +Proof. + intros. apply (CReal_mult_eq_reg_l x). exact rxnz. + rewrite CReal_inv_r, H, CReal_inv_r. reflexivity. +Qed. + +Lemma CReal_mult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. +Proof. + intros z x y H H0. + apply (CReal_mult_lt_compat_l ((/z) (inr H))) in H0. + repeat rewrite <- CReal_mult_assoc in H0. rewrite CReal_inv_l in H0. + repeat rewrite CReal_mult_1_l in H0. apply H0. + apply CReal_inv_0_lt_compat. exact H. +Qed. + +Lemma CReal_mult_lt_reg_r : forall r r1 r2, 0 < r -> r1 * r < r2 * r -> r1 < r2. +Proof. + intros. + apply CReal_mult_lt_reg_l with r. + exact H. + now rewrite 2!(CReal_mult_comm r). +Qed. + +Lemma CReal_mult_eq_reg_r : forall r r1 r2, r1 * r == r2 * r -> r # 0 -> r1 == r2. +Proof. + intros. apply (CReal_mult_eq_reg_l r). exact H0. + now rewrite 2!(CReal_mult_comm r). +Qed. + +Lemma CReal_mult_eq_compat_l : forall r r1 r2, r1 == r2 -> r * r1 == r * r2. +Proof. + intros. rewrite H. reflexivity. +Qed. + +Lemma CReal_mult_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 * r == r2 * r. +Proof. + intros. rewrite H. reflexivity. +Qed. + +Fixpoint pow (r:CReal) (n:nat) : CReal := + match n with + | O => 1 + | S n => r * (pow r n) + end. + + +(**********) +Definition IQR (q:Q) : CReal := + match q with + | Qmake a b => IZR a * (CReal_inv (IPR b)) (inr (IPR_pos b)) + end. +Arguments IQR q%Q : simpl never. + +Lemma mult_IPR_IZR : forall (n:positive) (m:Z), IZR (Z.pos n * m) == IPR n * IZR m. +Proof. + intros. rewrite mult_IZR. apply CReal_mult_eq_compat_r. reflexivity. +Qed. + +Lemma plus_IQR : forall n m:Q, IQR (n + m) == IQR n + IQR m. +Proof. + intros. destruct n,m; unfold Qplus,IQR; simpl. + rewrite plus_IZR. repeat rewrite mult_IZR. + setoid_replace ((/ IPR (Qden * Qden0)) (inr (IPR_pos (Qden * Qden0)))) + with ((/ IPR Qden) (inr (IPR_pos Qden)) + * (/ IPR Qden0) (inr (IPR_pos Qden0))). + rewrite CReal_mult_plus_distr_r. + repeat rewrite CReal_mult_assoc. rewrite <- (CReal_mult_assoc (IZR (Z.pos Qden))). + rewrite CReal_inv_r, CReal_mult_1_l. + rewrite (CReal_mult_comm ((/IPR Qden) (inr (IPR_pos Qden)))). + rewrite <- (CReal_mult_assoc (IZR (Z.pos Qden0))). + rewrite CReal_inv_r, CReal_mult_1_l. reflexivity. unfold IZR. + rewrite <- (CReal_inv_mult_distr + _ _ _ _ (inr (CReal_mult_lt_0_compat _ _ (IPR_pos _) (IPR_pos _)))). + apply Rinv_eq_compat. apply mult_IPR. +Qed. + +Lemma IQR_pos : forall q:Q, Qlt 0 q -> 0 < IQR q. +Proof. + intros. destruct q; unfold IQR. + apply CReal_mult_lt_0_compat. apply (IZR_lt 0). + unfold Qlt in H; simpl in H. + rewrite Z.mul_1_r in H. apply H. + apply CReal_inv_0_lt_compat. apply IPR_pos. +Qed. + +Lemma opp_IQR : forall q:Q, IQR (- q) == - IQR q. +Proof. + intros [a b]; unfold IQR; simpl. + rewrite CReal_opp_mult_distr_l. + rewrite opp_IZR. reflexivity. +Qed. + +Lemma lt_IQR : forall n m:Q, IQR n < IQR m -> (n < m)%Q. +Proof. + intros. destruct n,m; unfold IQR in H. + unfold Qlt; simpl. apply (CReal_mult_lt_compat_r (IPR Qden)) in H. + rewrite CReal_mult_assoc in H. rewrite CReal_inv_l in H. + rewrite CReal_mult_1_r in H. rewrite (CReal_mult_comm (IZR Qnum0)) in H. + apply (CReal_mult_lt_compat_l (IPR Qden0)) in H. + do 2 rewrite <- CReal_mult_assoc in H. rewrite CReal_inv_r in H. + rewrite CReal_mult_1_l in H. + rewrite (CReal_mult_comm (IZR Qnum0)) in H. + do 2 rewrite <- mult_IPR_IZR in H. apply lt_IZR in H. + rewrite Z.mul_comm. rewrite (Z.mul_comm Qnum0). + apply H. apply IPR_pos. apply IPR_pos. +Qed. + +Lemma CReal_mult_le_compat_l_half : forall r r1 r2, + 0 < r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. intro abs. apply (CReal_mult_lt_reg_l) in abs. + contradiction. apply H. +Qed. + +Lemma IQR_lt : forall n m:Q, Qlt n m -> IQR n < IQR m. +Proof. + intros. apply (CReal_plus_lt_reg_r (-IQR n)). + rewrite CReal_plus_opp_r. rewrite <- opp_IQR. rewrite <- plus_IQR. + apply IQR_pos. apply (Qplus_lt_l _ _ n). + ring_simplify. apply H. +Qed. + +Lemma IQR_nonneg : forall q:Q, Qle 0 q -> 0 <= (IQR q). +Proof. + intros [a b] H. unfold IQR. + apply (CRealLe_trans _ ((/ IPR b) (inr (IPR_pos b)) * 0)). + rewrite CReal_mult_0_r. apply CRealLe_refl. + rewrite (CReal_mult_comm (IZR a)). apply CReal_mult_le_compat_l_half. + apply CReal_inv_0_lt_compat. apply IPR_pos. + apply (IZR_le 0 a). unfold Qle in H; simpl in H. + rewrite Z.mul_1_r in H. apply H. +Qed. + +Lemma IQR_le : forall n m:Q, Qle n m -> IQR n <= IQR m. +Proof. + intros. intro abs. apply (CReal_plus_lt_compat_l (-IQR n)) in abs. + rewrite CReal_plus_opp_l, <- opp_IQR, <- plus_IQR in abs. + apply IQR_nonneg in abs. contradiction. apply (Qplus_le_l _ _ n). + ring_simplify. apply H. +Qed. + +Add Parametric Morphism : IQR + with signature Qeq ==> CRealEq + as IQR_morph. +Proof. + intros. destruct x,y; unfold IQR. + unfold Qeq in H; simpl in H. + apply (CReal_mult_eq_reg_r (IZR (Z.pos Qden))). + 2: right; apply IPR_pos. + rewrite CReal_mult_assoc. rewrite CReal_inv_l. rewrite CReal_mult_1_r. + rewrite (CReal_mult_comm (IZR Qnum0)). + apply (CReal_mult_eq_reg_l (IZR (Z.pos Qden0))). + right; apply IPR_pos. + rewrite <- CReal_mult_assoc, <- CReal_mult_assoc, CReal_inv_r. + rewrite CReal_mult_1_l. + repeat rewrite <- mult_IZR. + rewrite <- H. rewrite Zmult_comm. reflexivity. +Qed. + +Instance IQR_morph_T + : CMorphisms.Proper + (CMorphisms.respectful Qeq CRealEq) IQR. +Proof. + intros x y H. destruct x,y; unfold IQR. + unfold Qeq in H; simpl in H. + apply (CReal_mult_eq_reg_r (IZR (Z.pos Qden))). + 2: right; apply IPR_pos. + rewrite CReal_mult_assoc. rewrite CReal_inv_l. rewrite CReal_mult_1_r. + rewrite (CReal_mult_comm (IZR Qnum0)). + apply (CReal_mult_eq_reg_l (IZR (Z.pos Qden0))). + right; apply IPR_pos. + rewrite <- CReal_mult_assoc, <- CReal_mult_assoc, CReal_inv_r. + rewrite CReal_mult_1_l. + repeat rewrite <- mult_IZR. + rewrite <- H. rewrite Zmult_comm. reflexivity. +Qed. + +Lemma CReal_invQ : forall (b : positive) (pos : Qlt 0 (Z.pos b # 1)), + CRealEq (CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos))) + (inject_Q (1 # b)). +Proof. + intros. + apply (CReal_mult_eq_reg_l (inject_Q (Z.pos b # 1))). + - right. apply CReal_injectQPos. exact pos. + - rewrite CReal_mult_comm, CReal_inv_l. + apply CRealEq_diff. intro n. simpl; + destruct (QCauchySeq_bounded (fun _ : nat => 1 # b)%Q Pos.to_nat (ConstCauchy (1 # b))), + (QCauchySeq_bounded (fun _ : nat => Z.pos b # 1)%Q Pos.to_nat (ConstCauchy (Z.pos b # 1))); simpl. + do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag. discriminate. +Qed. + +(* The constant sequences of rationals are CRealEq to + the rational operations on the unity. *) +Lemma FinjectQ_CReal : forall q : Q, + IQR q == inject_Q q. +Proof. + intros [a b]. unfold IQR. + pose proof (CReal_iterate_one (Pos.to_nat b)). + rewrite positive_nat_Z in H. simpl in H. + assert (0 < Z.pos b # 1)%Q as pos. reflexivity. + apply (CRealEq_trans _ (CReal_mult (IZR a) + (CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos))))). + - apply CReal_mult_proper_l. + apply (CReal_mult_eq_reg_l (IPR b)). + right. apply IPR_pos. + rewrite CReal_mult_comm, CReal_inv_l, H, CReal_mult_comm, CReal_inv_l. reflexivity. + - rewrite FinjectZ_CReal. rewrite CReal_invQ. apply CRealEq_diff. intro n. + simpl; + destruct (QCauchySeq_bounded (fun _ : nat => a # 1)%Q Pos.to_nat (ConstCauchy (a # 1))), + (QCauchySeq_bounded (fun _ : nat => 1 # b)%Q Pos.to_nat (ConstCauchy (1 # b))); simpl. + rewrite Z.mul_1_r. rewrite <- Z.mul_add_distr_r. + rewrite Z.add_opp_diag_r. rewrite Z.mul_0_l. simpl. + discriminate. +Qed. + +Lemma CReal_gen_inject : forall (n : nat), + gen_phiZ (inject_Q 0) (inject_Q 1) CReal_plus CReal_mult CReal_opp + (Z.of_nat n) + == inject_Q (Z.of_nat n # 1). +Proof. + induction n. + - apply CRealEq_refl. + - replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z. + rewrite (gen_phiZ_add CRealEq_rel CReal_isRingExt CReal_isRing). + rewrite IHn. clear IHn. apply CRealEq_diff. intro k. simpl. + rewrite Z.mul_1_r. rewrite Z.mul_1_r. rewrite Z.mul_1_r. + rewrite Z.add_opp_diag_r. discriminate. + replace (S n) with (1 + n)%nat. 2: reflexivity. + rewrite (Nat2Z.inj_add 1 n). reflexivity. +Qed. + +Lemma CRealArchimedean + : forall x:CReal, { n:Z & CRealLt x (gen_phiZ (inject_Q 0) (inject_Q 1) CReal_plus + CReal_mult CReal_opp n) }. +Proof. + intros [xn limx]. destruct (Qarchimedean (xn 1%nat)) as [k kmaj]. + exists (Z.pos (2 + k)). rewrite <- (positive_nat_Z (2 + k)). + rewrite CReal_gen_inject. rewrite (positive_nat_Z (2 + k)). + exists xH. + setoid_replace (2 # 1)%Q with + ((Z.pos (2 + k) # 1) - (Z.pos k # 1))%Q. + - apply Qplus_lt_r. apply Qlt_minus_iff. rewrite Qopp_involutive. + apply Qlt_minus_iff in kmaj. rewrite Qplus_comm. apply kmaj. + - unfold Qminus. setoid_replace (- (Z.pos k # 1))%Q with (-Z.pos k # 1)%Q. + 2: reflexivity. rewrite Qinv_plus_distr. + rewrite Pos2Z.inj_add. rewrite <- Zplus_assoc. + rewrite Zplus_opp_r. reflexivity. +Qed. + + +Close Scope CReal_scope. + +Close Scope Q. diff --git a/theories/Reals/ConstructiveRIneq.v b/theories/Reals/ConstructiveRIneq.v new file mode 100644 index 0000000000..b53436be55 --- /dev/null +++ b/theories/Reals/ConstructiveRIneq.v @@ -0,0 +1,2816 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +(*********************************************************) +(** * Basic lemmas for the contructive real numbers *) +(*********************************************************) + +(* Implement interface ConstructiveReals opaquely with + Cauchy reals and prove basic results. + Those are therefore true for any implementation of + ConstructiveReals (for example with Dedekind reals). + + This file is the recommended import for working with + constructive reals, do not use ConstructiveCauchyReals + directly. *) + +Require Import ConstructiveCauchyReals. +Require Import ConstructiveRcomplete. +Require Import ConstructiveRealsLUB. +Require Export ConstructiveReals. +Require Import Zpower. +Require Export ZArithRing. +Require Import Omega. +Require Import QArith_base. +Require Import Qring. + +Declare Scope R_scope_constr. + +Local Open Scope Z_scope. +Local Open Scope R_scope_constr. + +Definition CR : ConstructiveReals. +Proof. + assert (isLinearOrder CReal CRealLt) as lin. + { repeat split. exact CRealLt_asym. + exact CRealLt_trans. + intros. destruct (CRealLt_dec x z y H). + left. exact c. right. exact c. } + apply (Build_ConstructiveReals + CReal CRealLt lin CRealLtProp + CRealLtEpsilon CRealLtForget CRealLtDisjunctEpsilon + (inject_Q 0) (inject_Q 1) + CReal_plus CReal_opp CReal_mult + CReal_isRing CReal_isRingExt CRealLt_0_1 + CReal_plus_lt_compat_l CReal_plus_lt_reg_l + CReal_mult_lt_0_compat + CReal_inv CReal_inv_l CReal_inv_0_lt_compat + CRealArchimedean). + - intros. destruct (Rcauchy_complete xn) as [l cv]. + intro n. apply (H (IQR (1#n))). apply IQR_pos. reflexivity. + exists l. intros eps epsPos. + destruct (Rup_nat ((/eps) (inr epsPos))) as [n nmaj]. + specialize (cv (Pos.of_nat (S n))) as [p pmaj]. + exists p. intros. specialize (pmaj i H0). unfold absSmall in pmaj. + apply (CReal_mult_lt_compat_l eps) in nmaj. + rewrite CReal_inv_r, CReal_mult_comm in nmaj. + 2: apply epsPos. split. + + apply (CRealLt_trans _ (-IQR (1 # Pos.of_nat (S n)))). + 2: apply pmaj. clear pmaj. + apply CReal_opp_gt_lt_contravar. unfold CRealGt, IQR. + rewrite CReal_mult_1_l. apply (CReal_mult_lt_reg_l (IPR (Pos.of_nat (S n)))). + apply IPR_pos. rewrite CReal_inv_r, <- INR_IPR, Nat2Pos.id. + 2: discriminate. apply (CRealLt_trans _ (INR n * eps) _ nmaj). + apply CReal_mult_lt_compat_r. exact epsPos. apply lt_INR, le_refl. + + apply (CRealLt_trans _ (IQR (1 # Pos.of_nat (S n)))). + apply pmaj. unfold IQR. rewrite CReal_mult_1_l. + apply (CReal_mult_lt_reg_l (IPR (Pos.of_nat (S n)))). + apply IPR_pos. rewrite CReal_inv_r, <- INR_IPR, Nat2Pos.id. + 2: discriminate. apply (CRealLt_trans _ (INR n * eps) _ nmaj). + apply CReal_mult_lt_compat_r. exact epsPos. apply lt_INR, le_refl. + - exact sig_lub. +Qed. (* Keep it opaque to possibly change the implementation later *) + +Definition R := CRcarrier CR. + +Definition Req := orderEq R (CRlt CR). +Definition Rle (x y : R) := CRlt CR y x -> False. +Definition Rge (x y : R) := CRlt CR x y -> False. +Definition Rlt := CRlt CR. +Definition RltProp := CRltProp CR. +Definition Rgt (x y : R) := CRlt CR y x. +Definition Rappart := orderAppart R (CRlt CR). + +Infix "==" := Req : R_scope_constr. +Infix "#" := Rappart : R_scope_constr. +Infix "<" := Rlt : R_scope_constr. +Infix ">" := Rgt : R_scope_constr. +Infix "<=" := Rle : R_scope_constr. +Infix ">=" := Rge : R_scope_constr. + +Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope_constr. +Notation "x <= y < z" := (prod (x <= y) (y < z)) : R_scope_constr. +Notation "x < y < z" := (prod (x < y) (y < z)) : R_scope_constr. +Notation "x < y <= z" := (prod (x < y) (y <= z)) : R_scope_constr. + +Lemma Rlt_epsilon : forall x y : R, RltProp x y -> x < y. +Proof. + exact (CRltEpsilon CR). +Qed. + +Lemma Rlt_forget : forall x y : R, x < y -> RltProp x y. +Proof. + exact (CRltForget CR). +Qed. + +Lemma Rle_refl : forall x : R, x <= x. +Proof. + intros. intro abs. + destruct (CRltLinear CR), p. + exact (f x x abs abs). +Qed. +Hint Immediate Rle_refl: rorders. + +Lemma Req_refl : forall x : R, x == x. +Proof. + intros. split; apply Rle_refl. +Qed. + +Lemma Req_sym : forall x y : R, x == y -> y == x. +Proof. + intros. destruct H. split; intro abs; contradiction. +Qed. + +Lemma Req_trans : forall x y z : R, x == y -> y == z -> x == z. +Proof. + intros. destruct H,H0. destruct (CRltLinear CR), p. split. + - intro abs. destruct (s _ y _ abs); contradiction. + - intro abs. destruct (s _ y _ abs); contradiction. +Qed. + +Add Parametric Relation : R Req + reflexivity proved by Req_refl + symmetry proved by Req_sym + transitivity proved by Req_trans + as Req_rel. + +Instance Req_relT : CRelationClasses.Equivalence Req. +Proof. + split. exact Req_refl. exact Req_sym. exact Req_trans. +Qed. + +Lemma linear_order_T : forall x y z : R, + x < z -> (x < y) + (y < z). +Proof. + intros. destruct (CRltLinear CR). apply s. exact H. +Qed. + +Instance Rlt_morph + : CMorphisms.Proper + (CMorphisms.respectful Req (CMorphisms.respectful Req CRelationClasses.iffT)) Rlt. +Proof. + intros x y H x0 y0 H0. destruct H, H0. split. + - intro. destruct (linear_order_T x y x0). assumption. + contradiction. destruct (linear_order_T y y0 x0). + assumption. assumption. contradiction. + - intro. destruct (linear_order_T y x y0). assumption. + contradiction. destruct (linear_order_T x x0 y0). + assumption. assumption. contradiction. +Qed. + +Instance RltProp_morph + : Morphisms.Proper + (Morphisms.respectful Req (Morphisms.respectful Req iff)) RltProp. +Proof. + intros x y H x0 y0 H0. destruct H, H0. split. + - intro. destruct (linear_order_T x y x0). + apply Rlt_epsilon. assumption. + contradiction. destruct (linear_order_T y y0 x0). + assumption. apply Rlt_forget. assumption. contradiction. + - intro. destruct (linear_order_T y x y0). + apply Rlt_epsilon. assumption. + contradiction. destruct (linear_order_T x x0 y0). + assumption. apply Rlt_forget. assumption. contradiction. +Qed. + +Instance Rgt_morph + : CMorphisms.Proper + (CMorphisms.respectful Req (CMorphisms.respectful Req CRelationClasses.iffT)) Rgt. +Proof. + intros x y H x0 y0 H0. unfold Rgt. apply Rlt_morph; assumption. +Qed. + +Instance Rappart_morph + : CMorphisms.Proper + (CMorphisms.respectful Req (CMorphisms.respectful Req CRelationClasses.iffT)) Rappart. +Proof. + split. + - intros. destruct H1. left. rewrite <- H0, <- H. exact c. + right. rewrite <- H0, <- H. exact c. + - intros. destruct H1. left. rewrite H0, H. exact c. + right. rewrite H0, H. exact c. +Qed. + +Add Parametric Morphism : Rle + with signature Req ==> Req ==> iff + as Rle_morph. +Proof. + intros. split. + - intros H1 H2. unfold CRealLe in H1. + rewrite <- H0 in H2. rewrite <- H in H2. contradiction. + - intros H1 H2. unfold CRealLe in H1. + rewrite H0 in H2. rewrite H in H2. contradiction. +Qed. + +Add Parametric Morphism : Rge + with signature Req ==> Req ==> iff + as Rge_morph. +Proof. + intros. unfold Rge. apply Rle_morph; assumption. +Qed. + + +Definition Rplus := CRplus CR. +Definition Rmult := CRmult CR. +Definition Rinv := CRinv CR. +Definition Ropp := CRopp CR. + +Add Parametric Morphism : Rplus + with signature Req ==> Req ==> Req + as Rplus_morph. +Proof. + apply CRisRingExt. +Qed. + +Instance Rplus_morph_T + : CMorphisms.Proper + (CMorphisms.respectful Req (CMorphisms.respectful Req Req)) Rplus. +Proof. + apply CRisRingExt. +Qed. + +Add Parametric Morphism : Rmult + with signature Req ==> Req ==> Req + as Rmult_morph. +Proof. + apply CRisRingExt. +Qed. + +Instance Rmult_morph_T + : CMorphisms.Proper + (CMorphisms.respectful Req (CMorphisms.respectful Req Req)) Rmult. +Proof. + apply CRisRingExt. +Qed. + +Add Parametric Morphism : Ropp + with signature Req ==> Req + as Ropp_morph. +Proof. + apply CRisRingExt. +Qed. + +Instance Ropp_morph_T + : CMorphisms.Proper + (CMorphisms.respectful Req Req) Ropp. +Proof. + apply CRisRingExt. +Qed. + +Infix "+" := Rplus : R_scope_constr. +Notation "- x" := (Ropp x) : R_scope_constr. +Definition Rminus (r1 r2:R) : R := r1 + - r2. +Infix "-" := Rminus : R_scope_constr. +Infix "*" := Rmult : R_scope_constr. +Notation "/ x" := (CRinv CR x) (at level 35, right associativity) : R_scope_constr. + +Notation "0" := (CRzero CR) : R_scope_constr. +Notation "1" := (CRone CR) : R_scope_constr. + +Add Parametric Morphism : Rminus + with signature Req ==> Req ==> Req + as Rminus_morph. +Proof. + intros. unfold Rminus, CRminus. rewrite H,H0. reflexivity. +Qed. + + +(* Help Add Ring to find the correct equality *) +Lemma RisRing : ring_theory 0 1 + Rplus Rmult + Rminus Ropp + Req. +Proof. + exact (CRisRing CR). +Qed. + +Add Ring CRealRing : RisRing. + +Lemma Rplus_comm : forall x y:R, x + y == y + x. +Proof. intros. ring. Qed. + +Lemma Rplus_assoc : forall x y z:R, (x + y) + z == x + (y + z). +Proof. intros. ring. Qed. + +Lemma Rplus_opp_r : forall x:R, x + -x == 0. +Proof. intros. ring. Qed. + +Lemma Rplus_0_l : forall x:R, 0 + x == x. +Proof. intros. ring. Qed. + +Lemma Rmult_0_l : forall x:R, 0 * x == 0. +Proof. intros. ring. Qed. + +Lemma Rmult_1_l : forall x:R, 1 * x == x. +Proof. intros. ring. Qed. + +Lemma Rmult_comm : forall x y:R, x * y == y * x. +Proof. intros. ring. Qed. + +Lemma Rmult_assoc : forall x y z:R, (x * y) * z == x * (y * z). +Proof. intros. ring. Qed. + +Definition Rinv_l := CRinv_l CR. + +Lemma Rmult_plus_distr_l : forall r1 r2 r3 : R, + r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). +Proof. intros. ring. Qed. + +Definition Rlt_0_1 := CRzero_lt_one CR. + +Lemma Rlt_asym : forall x y :R, x < y -> y < x -> False. +Proof. + intros. destruct (CRltLinear CR), p. + apply (f x y); assumption. +Qed. + +Lemma Rlt_trans : forall x y z : R, x < y -> y < z -> x < z. +Proof. + intros. destruct (CRltLinear CR), p. + apply (c x y); assumption. +Qed. + +Lemma Rplus_lt_compat_l : forall x y z : R, + y < z -> x + y < x + z. +Proof. + intros. apply CRplus_lt_compat_l. exact H. +Qed. + +Lemma Ropp_mult_distr_l + : forall r1 r2 : R, -(r1 * r2) == (- r1) * r2. +Proof. + intros. ring. +Qed. + +Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. +Proof. + intros. apply CRplus_lt_reg_l in H. exact H. +Qed. + +Lemma Rmult_lt_compat_l : forall x y z : R, + 0 < x -> y < z -> x * y < x * z. +Proof. + intros. apply (CRplus_lt_reg_l CR (- (x * y))). + rewrite Rplus_comm. pose proof Rplus_opp_r. + rewrite H1. + rewrite Rmult_comm, Ropp_mult_distr_l, Rmult_comm. + rewrite <- Rmult_plus_distr_l. + apply CRmult_lt_0_compat. exact H. + apply (Rplus_lt_reg_l y). + rewrite Rplus_comm, Rplus_0_l. + rewrite <- Rplus_assoc, H1, Rplus_0_l. exact H0. +Qed. + +Hint Resolve Rplus_comm Rplus_assoc Rplus_opp_r Rplus_0_l + Rmult_comm Rmult_assoc Rinv_l Rmult_1_l Rmult_plus_distr_l + Rlt_0_1 Rlt_asym Rlt_trans Rplus_lt_compat_l Rmult_lt_compat_l + Rmult_0_l : creal. + +Fixpoint INR (n:nat) : R := + match n with + | O => 0 + | S O => 1 + | S n => INR n + 1 + end. +Arguments INR n%nat. + +(* compact representation for 2*p *) +Fixpoint IPR_2 (p:positive) : R := + match p with + | xH => 1 + 1 + | xO p => (1 + 1) * IPR_2 p + | xI p => (1 + 1) * (1 + IPR_2 p) + end. + +Definition IPR (p:positive) : R := + match p with + | xH => 1 + | xO p => IPR_2 p + | xI p => 1 + IPR_2 p + end. +Arguments IPR p%positive : simpl never. + +(**********) +Definition IZR (z:Z) : R := + match z with + | Z0 => 0 + | Zpos n => IPR n + | Zneg n => - IPR n + end. +Arguments IZR z%Z : simpl never. + +Notation "2" := (IZR 2) : R_scope_constr. + + +(*********************************************************) +(** ** Relation between orders and equality *) +(*********************************************************) + +Lemma Rge_refl : forall r, r <= r. +Proof. exact Rle_refl. Qed. +Hint Immediate Rge_refl: rorders. + +(** Irreflexivity of the strict order *) + +Lemma Rlt_irrefl : forall r, r < r -> False. +Proof. + intros r H; eapply Rlt_asym; eauto. +Qed. +Hint Resolve Rlt_irrefl: creal. + +Lemma Rgt_irrefl : forall r, r > r -> False. +Proof. exact Rlt_irrefl. Qed. + +Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2. +Proof. + intros. intro abs. subst r2. exact (Rlt_irrefl r1 H). +Qed. + +Lemma Rgt_not_eq : forall r1 r2, r1 > r2 -> r1 <> r2. +Proof. + intros; apply not_eq_sym; apply Rlt_not_eq; auto with creal. +Qed. + +(**********) +Lemma Rlt_dichotomy_converse : forall r1 r2, ((r1 < r2) + (r1 > r2)) -> r1 <> r2. +Proof. + intros. destruct H. + - intro abs. subst r2. exact (Rlt_irrefl r1 r). + - intro abs. subst r2. exact (Rlt_irrefl r1 r). +Qed. +Hint Resolve Rlt_dichotomy_converse: creal. + +(** Reasoning by case on equality and order *) + + +(*********************************************************) +(** ** Relating [<], [>], [<=] and [>=] *) +(*********************************************************) + +(*********************************************************) +(** ** Order *) +(*********************************************************) + +(** *** Relating strict and large orders *) + +Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2. +Proof. + intros. intro abs. apply (Rlt_asym r1 r2); assumption. +Qed. +Hint Resolve Rlt_le: creal. + +Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2. +Proof. + intros. intro abs. apply (Rlt_asym r1 r2); assumption. +Qed. + +(**********) +Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1. +Proof. + intros. intros abs. contradiction. +Qed. +Hint Immediate Rle_ge: creal. +Hint Resolve Rle_ge: rorders. + +Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1. +Proof. + intros. intro abs. contradiction. +Qed. +Hint Resolve Rge_le: creal. +Hint Immediate Rge_le: rorders. + +(**********) +Lemma Rlt_gt : forall r1 r2, r1 < r2 -> r2 > r1. +Proof. + trivial. +Qed. +Hint Resolve Rlt_gt: rorders. + +Lemma Rgt_lt : forall r1 r2, r1 > r2 -> r2 < r1. +Proof. + trivial. +Qed. +Hint Immediate Rgt_lt: rorders. + +(**********) + +Lemma Rnot_lt_le : forall r1 r2, (r1 < r2 -> False) -> r2 <= r1. +Proof. + intros. exact H. +Qed. + +Lemma Rnot_gt_le : forall r1 r2, (r1 > r2 -> False) -> r1 <= r2. +Proof. + intros. intro abs. contradiction. +Qed. + +Lemma Rnot_gt_ge : forall r1 r2, (r1 > r2 -> False) -> r2 >= r1. +Proof. + intros. intro abs. contradiction. +Qed. + +Lemma Rnot_lt_ge : forall r1 r2, (r1 < r2 -> False) -> r1 >= r2. +Proof. + intros. intro abs. contradiction. +Qed. + +(**********) +Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2. +Proof. + generalize Rlt_asym Rlt_dichotomy_converse; unfold CRealLe. + unfold not; intuition eauto 3. +Qed. +Hint Immediate Rlt_not_le: creal. + +Lemma Rgt_not_le : forall r1 r2, r1 > r2 -> ~ r1 <= r2. +Proof. exact Rlt_not_le. Qed. + +Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2. +Proof. red; intros; eapply Rlt_not_le; eauto with creal. Qed. +Hint Immediate Rlt_not_ge: creal. + +Lemma Rgt_not_ge : forall r1 r2, r2 > r1 -> ~ r1 >= r2. +Proof. exact Rlt_not_ge. Qed. + +Lemma Rle_not_lt : forall r1 r2, r2 <= r1 -> r1 < r2 -> False. +Proof. + intros r1 r2. generalize (Rlt_asym r1 r2) (Rlt_dichotomy_converse r1 r2). + unfold CRealLe; intuition. +Qed. + +Lemma Rge_not_lt : forall r1 r2, r1 >= r2 -> r1 < r2 -> False. +Proof. intros; apply (Rle_not_lt r1 r2); auto with creal. Qed. + +Lemma Rle_not_gt : forall r1 r2, r1 <= r2 -> r1 > r2 -> False. +Proof. do 2 intro; apply Rle_not_lt. Qed. + +Lemma Rge_not_gt : forall r1 r2, r2 >= r1 -> r1 > r2 -> False. +Proof. do 2 intro; apply Rge_not_lt. Qed. + +(**********) +Lemma Req_le : forall r1 r2, r1 = r2 -> r1 <= r2. +Proof. + intros. intro abs. subst r2. exact (Rlt_irrefl r1 abs). +Qed. +Hint Immediate Req_le: creal. + +Lemma Req_ge : forall r1 r2, r1 = r2 -> r1 >= r2. +Proof. + intros. intro abs. subst r2. exact (Rlt_irrefl r1 abs). +Qed. +Hint Immediate Req_ge: creal. + +Lemma Req_le_sym : forall r1 r2, r2 = r1 -> r1 <= r2. +Proof. + intros. intro abs. subst r2. exact (Rlt_irrefl r1 abs). +Qed. +Hint Immediate Req_le_sym: creal. + +Lemma Req_ge_sym : forall r1 r2, r2 = r1 -> r1 >= r2. +Proof. + intros. intro abs. subst r2. exact (Rlt_irrefl r1 abs). +Qed. +Hint Immediate Req_ge_sym: creal. + +(** *** Asymmetry *) + +(** Remark: [Rlt_asym] is an axiom *) + +Lemma Rgt_asym : forall r1 r2, r1 > r2 -> r2 > r1 -> False. +Proof. do 2 intro; apply Rlt_asym. Qed. + + +(** *** Compatibility with equality *) + +Lemma Rlt_eq_compat : + forall r1 r2 r3 r4, r1 = r2 -> r2 < r4 -> r4 = r3 -> r1 < r3. +Proof. + intros x x' y y'; intros; replace x with x'; replace y with y'; assumption. +Qed. + +Lemma Rgt_eq_compat : + forall r1 r2 r3 r4, r1 = r2 -> r2 > r4 -> r4 = r3 -> r1 > r3. +Proof. intros; red; apply Rlt_eq_compat with (r2:=r4) (r4:=r2); auto. Qed. + +(** *** Transitivity *) + +Lemma Rle_trans : forall r1 r2 r3, r1 <= r2 -> r2 <= r3 -> r1 <= r3. +Proof. + intros. intro abs. + destruct (linear_order_T r3 r2 r1 abs); contradiction. +Qed. + +Lemma Rge_trans : forall r1 r2 r3, r1 >= r2 -> r2 >= r3 -> r1 >= r3. +Proof. + intros. apply (Rle_trans _ r2); assumption. +Qed. + +Lemma Rgt_trans : forall r1 r2 r3, r1 > r2 -> r2 > r3 -> r1 > r3. +Proof. + intros. apply (Rlt_trans _ r2); assumption. +Qed. + +(**********) +Lemma Rle_lt_trans : forall r1 r2 r3, r1 <= r2 -> r2 < r3 -> r1 < r3. +Proof. + intros. + destruct (linear_order_T r2 r1 r3 H0). contradiction. apply r. +Qed. + +Lemma Rlt_le_trans : forall r1 r2 r3, r1 < r2 -> r2 <= r3 -> r1 < r3. +Proof. + intros. + destruct (linear_order_T r1 r3 r2 H). apply r. contradiction. +Qed. + +Lemma Rge_gt_trans : forall r1 r2 r3, r1 >= r2 -> r2 > r3 -> r1 > r3. +Proof. + intros. apply (Rlt_le_trans _ r2); assumption. +Qed. + +Lemma Rgt_ge_trans : forall r1 r2 r3, r1 > r2 -> r2 >= r3 -> r1 > r3. +Proof. + intros. apply (Rle_lt_trans _ r2); assumption. +Qed. + + +(*********************************************************) +(** ** Addition *) +(*********************************************************) + +(** Remark: [Rplus_0_l] is an axiom *) + +Lemma Rplus_0_r : forall r, r + 0 == r. +Proof. + intros. rewrite Rplus_comm. rewrite Rplus_0_l. reflexivity. +Qed. +Hint Resolve Rplus_0_r: creal. + +Lemma Rplus_ne : forall r, r + 0 == r /\ 0 + r == r. +Proof. + split. apply Rplus_0_r. apply Rplus_0_l. +Qed. +Hint Resolve Rplus_ne: creal. + +(**********) + +(** Remark: [Rplus_opp_r] is an axiom *) + +Lemma Rplus_opp_l : forall r, - r + r == 0. +Proof. + intros. rewrite Rplus_comm. apply Rplus_opp_r. +Qed. +Hint Resolve Rplus_opp_l: creal. + +(**********) +Lemma Rplus_opp_r_uniq : forall r1 r2, r1 + r2 == 0 -> r2 == - r1. +Proof. + intros x y H. rewrite <- (Rplus_0_l y). + rewrite <- (Rplus_opp_l x). rewrite Rplus_assoc. + rewrite H. rewrite Rplus_0_r. reflexivity. +Qed. + +Lemma Rplus_eq_compat_l : forall r r1 r2, r1 == r2 -> r + r1 == r + r2. +Proof. + intros. rewrite H. reflexivity. +Qed. + +Lemma Rplus_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 + r == r2 + r. +Proof. + intros. rewrite H. reflexivity. +Qed. + + +(**********) +Lemma Rplus_eq_reg_l : forall r r1 r2, r + r1 == r + r2 -> r1 == r2. +Proof. + intros; transitivity (- r + r + r1). + rewrite Rplus_opp_l. rewrite Rplus_0_l. reflexivity. + transitivity (- r + r + r2). + repeat rewrite Rplus_assoc; rewrite <- H; reflexivity. + rewrite Rplus_opp_l. rewrite Rplus_0_l. reflexivity. +Qed. +Hint Resolve Rplus_eq_reg_l: creal. + +Lemma Rplus_eq_reg_r : forall r r1 r2, r1 + r == r2 + r -> r1 == r2. +Proof. + intros r r1 r2 H. + apply Rplus_eq_reg_l with r. + now rewrite 2!(Rplus_comm r). +Qed. + +(**********) +Lemma Rplus_0_r_uniq : forall r r1, r + r1 == r -> r1 == 0. +Proof. + intros. apply (Rplus_eq_reg_l r). rewrite Rplus_0_r. exact H. +Qed. + + +(*********************************************************) +(** ** Multiplication *) +(*********************************************************) + +(**********) +Lemma Rinv_r : forall r (rnz : r # 0), + r # 0 -> r * ((/ r) rnz) == 1. +Proof. + intros. rewrite Rmult_comm. rewrite Rinv_l. + reflexivity. +Qed. +Hint Resolve Rinv_r: creal. + +Lemma Rinv_l_sym : forall r (rnz: r # 0), 1 == (/ r) rnz * r. +Proof. + intros. symmetry. apply Rinv_l. +Qed. +Hint Resolve Rinv_l_sym: creal. + +Lemma Rinv_r_sym : forall r (rnz : r # 0), 1 == r * (/ r) rnz. +Proof. + intros. symmetry. apply Rinv_r. apply rnz. +Qed. +Hint Resolve Rinv_r_sym: creal. + +(**********) +Lemma Rmult_0_r : forall r, r * 0 == 0. +Proof. + intro; ring. +Qed. +Hint Resolve Rmult_0_r: creal. + +(**********) +Lemma Rmult_ne : forall r, r * 1 == r /\ 1 * r == r. +Proof. + intro; split; ring. +Qed. +Hint Resolve Rmult_ne: creal. + +(**********) +Lemma Rmult_1_r : forall r, r * 1 == r. +Proof. + intro; ring. +Qed. +Hint Resolve Rmult_1_r: creal. + +(**********) +Lemma Rmult_eq_compat_l : forall r r1 r2, r1 == r2 -> r * r1 == r * r2. +Proof. + intros. rewrite H. reflexivity. +Qed. + +Lemma Rmult_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 * r == r2 * r. +Proof. + intros. rewrite H. reflexivity. +Qed. + +(**********) +Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 == r * r2 -> r # 0 -> r1 == r2. +Proof. + intros. transitivity ((/ r) H0 * r * r1). + rewrite Rinv_l. ring. + transitivity ((/ r) H0 * r * r2). + repeat rewrite Rmult_assoc; rewrite H; reflexivity. + rewrite Rinv_l. ring. +Qed. + +Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r == r2 * r -> r # 0 -> r1 == r2. +Proof. + intros. + apply Rmult_eq_reg_l with (2 := H0). + now rewrite 2!(Rmult_comm r). +Qed. + +(**********) +Lemma Rmult_eq_0_compat : forall r1 r2, r1 == 0 \/ r2 == 0 -> r1 * r2 == 0. +Proof. + intros r1 r2 [H| H]; rewrite H; auto with creal. +Qed. + +Hint Resolve Rmult_eq_0_compat: creal. + +(**********) +Lemma Rmult_eq_0_compat_r : forall r1 r2, r1 == 0 -> r1 * r2 == 0. +Proof. + auto with creal. +Qed. + +(**********) +Lemma Rmult_eq_0_compat_l : forall r1 r2, r2 == 0 -> r1 * r2 == 0. +Proof. + auto with creal. +Qed. + +(**********) +Lemma Rmult_integral_contrapositive : + forall r1 r2, (prod (r1 # 0) (r2 # 0)) -> (r1 * r2) # 0. +Proof. + assert (forall r, 0 > r -> 0 < - r). + { intros. rewrite <- (Rplus_opp_l r), <- (Rplus_0_r (-r)), Rplus_assoc. + apply Rplus_lt_compat_l. rewrite Rplus_0_l. apply H. } + intros. destruct H0, r, r0. + - right. setoid_replace (r1*r2) with (-r1 * -r2). 2: ring. + rewrite <- (Rmult_0_r (-r1)). apply Rmult_lt_compat_l; apply H; assumption. + - left. rewrite <- (Rmult_0_r r2). + rewrite Rmult_comm. apply (Rmult_lt_compat_l). apply c0. apply c. + - left. rewrite <- (Rmult_0_r r1). apply (Rmult_lt_compat_l). apply c. apply c0. + - right. rewrite <- (Rmult_0_r r1). apply Rmult_lt_compat_l; assumption. +Qed. +Hint Resolve Rmult_integral_contrapositive: creal. + +Lemma Rmult_integral_contrapositive_currified : + forall r1 r2, r1 # 0 -> r2 # 0 -> (r1 * r2) # 0. +Proof. + intros. apply Rmult_integral_contrapositive. + split; assumption. +Qed. + +(**********) +Lemma Rmult_plus_distr_r : + forall r1 r2 r3, (r1 + r2) * r3 == r1 * r3 + r2 * r3. +Proof. + intros; ring. +Qed. + +(*********************************************************) +(** ** Square function *) +(*********************************************************) + +(***********) +Definition Rsqr (r : R) := r * r. + +Notation "r ²" := (Rsqr r) (at level 1, format "r ²") : R_scope_constr. + +(***********) +Lemma Rsqr_0 : Rsqr 0 == 0. + unfold Rsqr; auto with creal. +Qed. + +(*********************************************************) +(** ** Opposite *) +(*********************************************************) + +(**********) +Lemma Ropp_eq_compat : forall r1 r2, r1 == r2 -> - r1 == - r2. +Proof. + intros. rewrite H. reflexivity. +Qed. +Hint Resolve Ropp_eq_compat: creal. + +(**********) +Lemma Ropp_0 : -0 == 0. +Proof. + ring. +Qed. +Hint Resolve Ropp_0: creal. + +(**********) +Lemma Ropp_eq_0_compat : forall r, r == 0 -> - r == 0. +Proof. + intros; rewrite H; auto with creal. +Qed. +Hint Resolve Ropp_eq_0_compat: creal. + +(**********) +Lemma Ropp_involutive : forall r, - - r == r. +Proof. + intro; ring. +Qed. +Hint Resolve Ropp_involutive: creal. + +(**********) +Lemma Ropp_plus_distr : forall r1 r2, - (r1 + r2) == - r1 + - r2. +Proof. + intros; ring. +Qed. +Hint Resolve Ropp_plus_distr: creal. + +(*********************************************************) +(** ** Opposite and multiplication *) +(*********************************************************) + +Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 == - (r1 * r2). +Proof. + intros; ring. +Qed. +Hint Resolve Ropp_mult_distr_l_reverse: creal. + +(**********) +Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 == r1 * r2. +Proof. + intros; ring. +Qed. +Hint Resolve Rmult_opp_opp: creal. + +Lemma Ropp_mult_distr_r : forall r1 r2, - (r1 * r2) == r1 * - r2. +Proof. + intros; ring. +Qed. + +Lemma Ropp_mult_distr_r_reverse : forall r1 r2, r1 * - r2 == - (r1 * r2). +Proof. + intros; ring. +Qed. + +(*********************************************************) +(** ** Subtraction *) +(*********************************************************) + +Lemma Rminus_0_r : forall r, r - 0 == r. +Proof. + intro r. unfold Rminus. ring. +Qed. +Hint Resolve Rminus_0_r: creal. + +Lemma Rminus_0_l : forall r, 0 - r == - r. +Proof. + intro r. unfold Rminus. ring. +Qed. +Hint Resolve Rminus_0_l: creal. + +(**********) +Lemma Ropp_minus_distr : forall r1 r2, - (r1 - r2) == r2 - r1. +Proof. + intros; ring. +Qed. +Hint Resolve Ropp_minus_distr: creal. + +Lemma Ropp_minus_distr' : forall r1 r2, - (r2 - r1) == r1 - r2. +Proof. + intros; ring. +Qed. + +(**********) +Lemma Rminus_diag_eq : forall r1 r2, r1 == r2 -> r1 - r2 == 0. +Proof. + intros; rewrite H; unfold Rminus; ring. +Qed. +Hint Resolve Rminus_diag_eq: creal. + +(**********) +Lemma Rminus_diag_uniq : forall r1 r2, r1 - r2 == 0 -> r1 == r2. +Proof. + intros r1 r2. unfold Rminus,CRminus; rewrite Rplus_comm; intro. + rewrite <- (Ropp_involutive r2); apply (Rplus_opp_r_uniq (- r2) r1 H). +Qed. +Hint Immediate Rminus_diag_uniq: creal. + +Lemma Rminus_diag_uniq_sym : forall r1 r2, r2 - r1 == 0 -> r1 == r2. +Proof. + intros; generalize (Rminus_diag_uniq r2 r1 H); clear H; + intro H; rewrite H; reflexivity. +Qed. +Hint Immediate Rminus_diag_uniq_sym: creal. + +Lemma Rplus_minus : forall r1 r2, r1 + (r2 - r1) == r2. +Proof. + intros; ring. +Qed. +Hint Resolve Rplus_minus: creal. + +(**********) +Lemma Rmult_minus_distr_l : + forall r1 r2 r3, r1 * (r2 - r3) == r1 * r2 - r1 * r3. +Proof. + intros; ring. +Qed. + + +(*********************************************************) +(** ** Order and addition *) +(*********************************************************) + +(** *** Compatibility *) + +(** Remark: [Rplus_lt_compat_l] is an axiom *) + +Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2. +Proof. + intros. apply Rplus_lt_compat_l. apply H. +Qed. +Hint Resolve Rplus_gt_compat_l: creal. + +(**********) +Lemma Rplus_lt_compat_r : forall r r1 r2, r1 < r2 -> r1 + r < r2 + r. +Proof. + intros. + rewrite (Rplus_comm r1 r); rewrite (Rplus_comm r2 r). + apply Rplus_lt_compat_l. exact H. +Qed. +Hint Resolve Rplus_lt_compat_r: creal. + +Lemma Rplus_gt_compat_r : forall r r1 r2, r1 > r2 -> r1 + r > r2 + r. +Proof. do 3 intro; apply Rplus_lt_compat_r. Qed. + +(**********) + +Lemma Rplus_lt_reg_r : forall r r1 r2, r1 + r < r2 + r -> r1 < r2. +Proof. + intros. + apply (Rplus_lt_reg_l r). + now rewrite 2!(Rplus_comm r). +Qed. + +Lemma Rplus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2. +Proof. + intros. intro abs. apply Rplus_lt_reg_l in abs. contradiction. +Qed. + +Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2. +Proof. + intros. apply Rplus_le_compat_l. apply H. +Qed. +Hint Resolve Rplus_ge_compat_l: creal. + +(**********) +Lemma Rplus_le_compat_r : forall r r1 r2, r1 <= r2 -> r1 + r <= r2 + r. +Proof. + intros. intro abs. apply Rplus_lt_reg_r in abs. contradiction. +Qed. + +Hint Resolve Rplus_le_compat_l Rplus_le_compat_r: creal. + +Lemma Rplus_ge_compat_r : forall r r1 r2, r1 >= r2 -> r1 + r >= r2 + r. +Proof. + intros. apply Rplus_le_compat_r. apply H. +Qed. + +(*********) +Lemma Rplus_lt_compat : + forall r1 r2 r3 r4, r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4. +Proof. + intros; apply Rlt_trans with (r2 + r3); auto with creal. +Qed. +Hint Immediate Rplus_lt_compat: creal. + +Lemma Rplus_le_compat : + forall r1 r2 r3 r4, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4. +Proof. + intros; apply Rle_trans with (r2 + r3); auto with creal. +Qed. +Hint Immediate Rplus_le_compat: creal. + +Lemma Rplus_gt_compat : + forall r1 r2 r3 r4, r1 > r2 -> r3 > r4 -> r1 + r3 > r2 + r4. +Proof. + intros. apply Rplus_lt_compat; assumption. +Qed. + +Lemma Rplus_ge_compat : + forall r1 r2 r3 r4, r1 >= r2 -> r3 >= r4 -> r1 + r3 >= r2 + r4. +Proof. + intros. apply Rplus_le_compat; assumption. +Qed. + +(*********) +Lemma Rplus_lt_le_compat : + forall r1 r2 r3 r4, r1 < r2 -> r3 <= r4 -> r1 + r3 < r2 + r4. +Proof. + intros; apply Rlt_le_trans with (r2 + r3); auto with creal. +Qed. + +Lemma Rplus_le_lt_compat : + forall r1 r2 r3 r4, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4. +Proof. + intros; apply Rle_lt_trans with (r2 + r3); auto with creal. +Qed. + +Hint Immediate Rplus_lt_le_compat Rplus_le_lt_compat: creal. + +Lemma Rplus_gt_ge_compat : + forall r1 r2 r3 r4, r1 > r2 -> r3 >= r4 -> r1 + r3 > r2 + r4. +Proof. + intros. apply Rplus_lt_le_compat; assumption. +Qed. + +Lemma Rplus_ge_gt_compat : + forall r1 r2 r3 r4, r1 >= r2 -> r3 > r4 -> r1 + r3 > r2 + r4. +Proof. + intros. apply Rplus_le_lt_compat; assumption. +Qed. + +(**********) +Lemma Rplus_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 + r2. +Proof. + intros. apply (Rlt_trans _ (r1+0)). rewrite Rplus_0_r. exact H. + apply Rplus_lt_compat_l. exact H0. +Qed. + +Lemma Rplus_le_lt_0_compat : forall r1 r2, 0 <= r1 -> 0 < r2 -> 0 < r1 + r2. +Proof. + intros. apply (Rle_lt_trans _ (r1+0)). rewrite Rplus_0_r. exact H. + apply Rplus_lt_compat_l. exact H0. +Qed. + +Lemma Rplus_lt_le_0_compat : forall r1 r2, 0 < r1 -> 0 <= r2 -> 0 < r1 + r2. +Proof. + intros x y; intros; rewrite <- Rplus_comm; apply Rplus_le_lt_0_compat; + assumption. +Qed. + +Lemma Rplus_le_le_0_compat : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 + r2. +Proof. + intros. apply (Rle_trans _ (r1+0)). rewrite Rplus_0_r. exact H. + apply Rplus_le_compat_l. exact H0. +Qed. + +(**********) +Lemma sum_inequa_Rle_lt : + forall a x b c y d, + a <= x -> x < b -> c < y -> y <= d -> a + c < x + y < b + d. +Proof. + intros; split. + apply Rlt_le_trans with (a + y); auto with creal. + apply Rlt_le_trans with (b + y); auto with creal. +Qed. + +(** *** Cancellation *) + +Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2. +Proof. + intros. intro abs. apply (Rplus_lt_compat_l r) in abs. contradiction. +Qed. + +Lemma Rplus_le_reg_r : forall r r1 r2, r1 + r <= r2 + r -> r1 <= r2. +Proof. + intros. + apply (Rplus_le_reg_l r). + now rewrite 2!(Rplus_comm r). +Qed. + +Lemma Rplus_gt_reg_l : forall r r1 r2, r + r1 > r + r2 -> r1 > r2. +Proof. + unfold CRealGt; intros; apply (Rplus_lt_reg_l r r2 r1 H). +Qed. + +Lemma Rplus_ge_reg_l : forall r r1 r2, r + r1 >= r + r2 -> r1 >= r2. +Proof. + intros; apply Rle_ge; apply Rplus_le_reg_l with r; auto with creal. +Qed. + +(**********) +Lemma Rplus_le_reg_pos_r : + forall r1 r2 r3, 0 <= r2 -> r1 + r2 <= r3 -> r1 <= r3. +Proof. + intros. apply (Rle_trans _ (r1+r2)). 2: exact H0. + rewrite <- (Rplus_0_r r1), Rplus_assoc. + apply Rplus_le_compat_l. rewrite Rplus_0_l. exact H. +Qed. + +Lemma Rplus_lt_reg_pos_r : forall r1 r2 r3, 0 <= r2 -> r1 + r2 < r3 -> r1 < r3. +Proof. + intros. apply (Rle_lt_trans _ (r1+r2)). 2: exact H0. + rewrite <- (Rplus_0_r r1), Rplus_assoc. + apply Rplus_le_compat_l. rewrite Rplus_0_l. exact H. +Qed. + +Lemma Rplus_ge_reg_neg_r : + forall r1 r2 r3, 0 >= r2 -> r1 + r2 >= r3 -> r1 >= r3. +Proof. + intros. apply (Rge_trans _ (r1+r2)). 2: exact H0. + apply Rle_ge. rewrite <- (Rplus_0_r r1), Rplus_assoc. + apply Rplus_le_compat_l. rewrite Rplus_0_l. exact H. +Qed. + +Lemma Rplus_gt_reg_neg_r : forall r1 r2 r3, 0 >= r2 -> r1 + r2 > r3 -> r1 > r3. +Proof. + intros. apply (Rlt_le_trans _ (r1+r2)). exact H0. + rewrite <- (Rplus_0_r r1), Rplus_assoc. + apply Rplus_le_compat_l. rewrite Rplus_0_l. exact H. +Qed. + +(***********) +Lemma Rplus_eq_0_l : + forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 == 0 -> r1 == 0. +Proof. + intros. split. + - intro abs. rewrite <- (Rplus_opp_r r1) in H1. + apply Rplus_eq_reg_l in H1. rewrite H1 in H0. clear H1. + apply (Rplus_le_compat_l r1) in H0. + rewrite Rplus_opp_r in H0. rewrite Rplus_0_r in H0. + contradiction. + - intro abs. clear H. rewrite <- (Rplus_opp_r r1) in H1. + apply Rplus_eq_reg_l in H1. rewrite H1 in H0. clear H1. + apply (Rplus_le_compat_l r1) in H0. + rewrite Rplus_opp_r in H0. rewrite Rplus_0_r in H0. + contradiction. +Qed. + +Lemma Rplus_eq_R0 : + forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 == 0 -> r1 == 0 /\ r2 == 0. +Proof. + intros a b; split. + apply Rplus_eq_0_l with b; auto with creal. + apply Rplus_eq_0_l with a; auto with creal. + rewrite Rplus_comm; auto with creal. +Qed. + + +(*********************************************************) +(** ** Order and opposite *) +(*********************************************************) + +(** *** Contravariant compatibility *) + +Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. +Proof. + unfold CRealGt; intros. + apply (Rplus_lt_reg_l (r2 + r1)). + setoid_replace (r2 + r1 + - r1) with r2 by ring. + setoid_replace (r2 + r1 + - r2) with r1 by ring. + exact H. +Qed. +Hint Resolve Ropp_gt_lt_contravar : creal. + +Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. +Proof. + intros. apply Ropp_gt_lt_contravar. exact H. +Qed. +Hint Resolve Ropp_lt_gt_contravar: creal. + +(**********) +Lemma Ropp_lt_contravar : forall r1 r2, r2 < r1 -> - r1 < - r2. +Proof. + auto with creal. +Qed. +Hint Resolve Ropp_lt_contravar: creal. + +Lemma Ropp_gt_contravar : forall r1 r2, r2 > r1 -> - r1 > - r2. +Proof. auto with creal. Qed. + +(**********) + +Lemma Ropp_lt_cancel : forall r1 r2, - r2 < - r1 -> r1 < r2. +Proof. + intros x y H'. + rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); + auto with creal. +Qed. +Hint Immediate Ropp_lt_cancel: creal. + +Lemma Ropp_gt_cancel : forall r1 r2, - r2 > - r1 -> r1 > r2. +Proof. + intros. apply Ropp_lt_cancel. apply H. +Qed. + +Lemma Ropp_le_ge_contravar : forall r1 r2, r1 <= r2 -> - r1 >= - r2. +Proof. + intros. intro abs. apply Ropp_lt_cancel in abs. contradiction. +Qed. +Hint Resolve Ropp_le_ge_contravar: creal. + +Lemma Ropp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2. +Proof. + intros. intro abs. apply Ropp_lt_cancel in abs. contradiction. +Qed. +Hint Resolve Ropp_ge_le_contravar: creal. + +(**********) +Lemma Ropp_le_contravar : forall r1 r2, r2 <= r1 -> - r1 <= - r2. +Proof. + intros. intro abs. apply Ropp_lt_cancel in abs. contradiction. +Qed. +Hint Resolve Ropp_le_contravar: creal. + +Lemma Ropp_ge_contravar : forall r1 r2, r2 >= r1 -> - r1 >= - r2. +Proof. + intros. apply Ropp_le_contravar. apply H. +Qed. + +(**********) +Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r. +Proof. + intros; setoid_replace 0 with (-0); auto with creal. ring. +Qed. +Hint Resolve Ropp_0_lt_gt_contravar: creal. + +Lemma Ropp_0_gt_lt_contravar : forall r, 0 > r -> 0 < - r. +Proof. + intros; setoid_replace 0 with (-0); auto with creal. ring. +Qed. +Hint Resolve Ropp_0_gt_lt_contravar: creal. + +(**********) +Lemma Ropp_lt_gt_0_contravar : forall r, r > 0 -> - r < 0. +Proof. + intros; rewrite <- Ropp_0; auto with creal. +Qed. +Hint Resolve Ropp_lt_gt_0_contravar: creal. + +Lemma Ropp_gt_lt_0_contravar : forall r, r < 0 -> - r > 0. +Proof. + intros; rewrite <- Ropp_0; auto with creal. +Qed. +Hint Resolve Ropp_gt_lt_0_contravar: creal. + +(**********) +Lemma Ropp_0_le_ge_contravar : forall r, 0 <= r -> 0 >= - r. +Proof. + intros; setoid_replace 0 with (-0); auto with creal. ring. +Qed. +Hint Resolve Ropp_0_le_ge_contravar: creal. + +Lemma Ropp_0_ge_le_contravar : forall r, 0 >= r -> 0 <= - r. +Proof. + intros; setoid_replace 0 with (-0); auto with creal. ring. +Qed. +Hint Resolve Ropp_0_ge_le_contravar: creal. + +(** *** Cancellation *) + +Lemma Ropp_le_cancel : forall r1 r2, - r2 <= - r1 -> r1 <= r2. +Proof. + intros. intro abs. apply Ropp_lt_gt_contravar in abs. contradiction. +Qed. +Hint Immediate Ropp_le_cancel: creal. + +Lemma Ropp_ge_cancel : forall r1 r2, - r2 >= - r1 -> r1 >= r2. +Proof. + intros. apply Ropp_le_cancel. apply H. +Qed. + +(*********************************************************) +(** ** Order and multiplication *) +(*********************************************************) + +(** Remark: [Rmult_lt_compat_l] is an axiom *) + +(** *** Covariant compatibility *) + +Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r. +Proof. + intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with creal. +Qed. +Hint Resolve Rmult_lt_compat_r : core. + +Lemma Rmult_gt_compat_r : forall r r1 r2, r > 0 -> r1 > r2 -> r1 * r > r2 * r. +Proof. + intros. apply Rmult_lt_compat_r; assumption. +Qed. + +Lemma Rmult_gt_compat_l : forall r r1 r2, r > 0 -> r1 > r2 -> r * r1 > r * r2. +Proof. + intros. apply Rmult_lt_compat_l; assumption. +Qed. + +Lemma Rmult_gt_0_lt_compat : + forall r1 r2 r3 r4, + r3 > 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. +Proof. + intros; apply Rlt_trans with (r2 * r3); auto with creal. +Qed. + +(*********) +Lemma Rmult_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 * r2. +Proof. + intros; setoid_replace 0 with (0 * r2); auto with creal. + rewrite Rmult_0_l. reflexivity. +Qed. + +Lemma Rmult_gt_0_compat : forall r1 r2, r1 > 0 -> r2 > 0 -> r1 * r2 > 0. +Proof. + apply Rmult_lt_0_compat. +Qed. + +(** *** Contravariant compatibility *) + +Lemma Rmult_lt_gt_compat_neg_l : + forall r r1 r2, r < 0 -> r1 < r2 -> r * r1 > r * r2. +Proof. + intros; setoid_replace r with (- - r); auto with creal. + rewrite (Ropp_mult_distr_l_reverse (- r)); + rewrite (Ropp_mult_distr_l_reverse (- r)). + apply Ropp_lt_gt_contravar; auto with creal. + rewrite Ropp_involutive. reflexivity. +Qed. + +(** *** Cancellation *) + +Lemma Rinv_0_lt_compat : forall r (rpos : 0 < r), 0 < (/ r) (inr rpos). +Proof. + intros. apply CRinv_0_lt_compat. exact rpos. +Qed. + +Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. +Proof. + intros z x y H H0. + apply (Rmult_lt_compat_l ((/z) (inr H))) in H0. + repeat rewrite <- Rmult_assoc in H0. rewrite Rinv_l in H0. + repeat rewrite Rmult_1_l in H0. apply H0. + apply Rinv_0_lt_compat. +Qed. + +Lemma Rmult_lt_reg_r : forall r r1 r2, 0 < r -> r1 * r < r2 * r -> r1 < r2. +Proof. + intros. + apply Rmult_lt_reg_l with r. + exact H. + now rewrite 2!(Rmult_comm r). +Qed. + +Lemma Rmult_gt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. +Proof. + intros. apply Rmult_lt_reg_l in H0; assumption. +Qed. + +Lemma Rmult_le_reg_l : forall r r1 r2, 0 < r -> r * r1 <= r * r2 -> r1 <= r2. +Proof. + intros. intro abs. apply (Rmult_lt_compat_l r) in abs. + contradiction. apply H. +Qed. + +Lemma Rmult_le_reg_r : forall r r1 r2, 0 < r -> r1 * r <= r2 * r -> r1 <= r2. +Proof. + intros. + apply Rmult_le_reg_l with r. + exact H. + now rewrite 2!(Rmult_comm r). +Qed. + +(*********************************************************) +(** ** Order and substraction *) +(*********************************************************) + +Lemma Rlt_minus : forall r1 r2, r1 < r2 -> r1 - r2 < 0. +Proof. + intros; apply (Rplus_lt_reg_l r2). + setoid_replace (r2 + (r1 - r2)) with r1 by ring. + now rewrite Rplus_0_r. +Qed. +Hint Resolve Rlt_minus: creal. + +Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0. +Proof. + intros; apply (Rplus_lt_reg_l r2). + setoid_replace (r2 + (r1 - r2)) with r1 by ring. + now rewrite Rplus_0_r. +Qed. + +Lemma Rlt_Rminus : forall a b, a < b -> 0 < b - a. +Proof. + intros a b; apply Rgt_minus. +Qed. + +(**********) +Lemma Rle_minus : forall r1 r2, r1 <= r2 -> r1 - r2 <= 0. +Proof. + intros. intro abs. apply (Rplus_lt_compat_l r2) in abs. + unfold Rminus in abs. + rewrite Rplus_0_r, Rplus_comm, Rplus_assoc, Rplus_opp_l, Rplus_0_r in abs. + contradiction. +Qed. + +Lemma Rge_minus : forall r1 r2, r1 >= r2 -> r1 - r2 >= 0. +Proof. + intros. intro abs. apply (Rplus_lt_compat_l r2) in abs. + unfold Rminus in abs. + rewrite Rplus_0_r, Rplus_comm, Rplus_assoc, Rplus_opp_l, Rplus_0_r in abs. + contradiction. +Qed. + +(**********) +Lemma Rminus_lt : forall r1 r2, r1 - r2 < 0 -> r1 < r2. +Proof. + intros. rewrite <- (Rplus_opp_r r2) in H. + apply Rplus_lt_reg_r in H. exact H. +Qed. + +Lemma Rminus_gt : forall r1 r2, r1 - r2 > 0 -> r1 > r2. +Proof. + intros. rewrite <- (Rplus_opp_r r2) in H. + apply Rplus_lt_reg_r in H. exact H. +Qed. + +Lemma Rminus_gt_0_lt : forall a b, 0 < b - a -> a < b. +Proof. intro; intro; apply Rminus_gt. Qed. + +(**********) +Lemma Rminus_le : forall r1 r2, r1 - r2 <= 0 -> r1 <= r2. +Proof. + intros. rewrite <- (Rplus_opp_r r2) in H. + apply Rplus_le_reg_r in H. exact H. +Qed. + +Lemma Rminus_ge : forall r1 r2, r1 - r2 >= 0 -> r1 >= r2. +Proof. + intros. rewrite <- (Rplus_opp_r r2) in H. + apply Rplus_le_reg_r in H. exact H. +Qed. + +(**********) +Lemma tech_Rplus : forall r s, 0 <= r -> 0 < s -> r + s <> 0. +Proof. + intros; apply not_eq_sym; apply Rlt_not_eq. + rewrite Rplus_comm; setoid_replace 0 with (0 + 0); auto with creal. ring. +Qed. +Hint Immediate tech_Rplus: creal. + +(*********************************************************) +(** ** Zero is less than one *) +(*********************************************************) + +Lemma Rle_0_1 : 0 <= 1. +Proof. + intro abs. apply (Rlt_asym 0 1). + apply Rlt_0_1. apply abs. +Qed. + + +(*********************************************************) +(** ** Inverse *) +(*********************************************************) + +Lemma Rinv_1 : forall nz : 1 # 0, (/ 1) nz == 1. +Proof. + intros. rewrite <- (Rmult_1_l ((/1) nz)). rewrite Rinv_r. + reflexivity. right. apply Rlt_0_1. +Qed. +Hint Resolve Rinv_1: creal. + +(*********) +Lemma Ropp_inv_permute : forall r (rnz : r # 0) (ronz : (-r) # 0), + - (/ r) rnz == (/ - r) ronz. +Proof. + intros. + apply (Rmult_eq_reg_l (-r)). rewrite Rinv_r. + rewrite <- Ropp_mult_distr_l. rewrite <- Ropp_mult_distr_r. + rewrite Ropp_involutive. rewrite Rinv_r. reflexivity. + exact rnz. exact ronz. exact ronz. +Qed. + +(*********) +Lemma Rinv_neq_0_compat : forall r (rnz : r # 0), ((/ r) rnz) # 0. +Proof. + intros. destruct rnz. left. + assert (0 < (/-r) (inr (Ropp_0_gt_lt_contravar _ c))). + { apply Rinv_0_lt_compat. } + rewrite <- (Ropp_inv_permute _ (inl c)) in H. + apply Ropp_lt_cancel. rewrite Ropp_0. exact H. + right. apply Rinv_0_lt_compat. +Qed. +Hint Resolve Rinv_neq_0_compat: creal. + +(*********) +Lemma Rinv_involutive : forall r (rnz : r # 0) (rinz : ((/ r) rnz) # 0), + (/ ((/ r) rnz)) rinz == r. +Proof. + intros. apply (Rmult_eq_reg_l ((/r) rnz)). rewrite Rinv_r. + rewrite Rinv_l. reflexivity. exact rinz. exact rinz. +Qed. +Hint Resolve Rinv_involutive: creal. + +(*********) +Lemma Rinv_mult_distr : + forall r1 r2 (r1nz : r1 # 0) (r2nz : r2 # 0) (rmnz : (r1*r2) # 0), + (/ (r1 * r2)) rmnz == (/ r1) r1nz * (/ r2) r2nz. +Proof. + intros. apply (Rmult_eq_reg_l r1). 2: exact r1nz. + rewrite <- Rmult_assoc. rewrite Rinv_r. rewrite Rmult_1_l. + apply (Rmult_eq_reg_l r2). 2: exact r2nz. + rewrite Rinv_r. rewrite <- Rmult_assoc. + rewrite (Rmult_comm r2 r1). rewrite Rinv_r. + reflexivity. exact rmnz. exact r2nz. exact r1nz. +Qed. + +Lemma Rinv_r_simpl_r : forall r1 r2 (rnz : r1 # 0), r1 * (/ r1) rnz * r2 == r2. +Proof. + intros; transitivity (1 * r2); auto with creal. + rewrite Rinv_r; auto with creal. rewrite Rmult_1_l. reflexivity. +Qed. + +Lemma Rinv_r_simpl_l : forall r1 r2 (rnz : r1 # 0), + r2 * r1 * (/ r1) rnz == r2. +Proof. + intros. rewrite Rmult_assoc. rewrite Rinv_r, Rmult_1_r. + reflexivity. exact rnz. +Qed. + +Lemma Rinv_r_simpl_m : forall r1 r2 (rnz : r1 # 0), + r1 * r2 * (/ r1) rnz == r2. +Proof. + intros. rewrite Rmult_comm, <- Rmult_assoc, Rinv_l, Rmult_1_l. + reflexivity. +Qed. +Hint Resolve Rinv_r_simpl_l Rinv_r_simpl_r Rinv_r_simpl_m: creal. + +(*********) +Lemma Rinv_mult_simpl : + forall r1 r2 r3 (r1nz : r1 # 0) (r2nz : r2 # 0), + r1 * (/ r2) r2nz * (r3 * (/ r1) r1nz) == r3 * (/ r2) r2nz. +Proof. + intros a b c; intros. + transitivity (a * (/ a) r1nz * (c * (/ b) r2nz)); auto with creal. + ring. +Qed. + +Lemma Rinv_eq_compat : forall x y (rxnz : x # 0) (rynz : y # 0), + x == y + -> (/ x) rxnz == (/ y) rynz. +Proof. + intros. apply (Rmult_eq_reg_l x). rewrite Rinv_r. + rewrite H. rewrite Rinv_r. reflexivity. + exact rynz. exact rxnz. exact rxnz. +Qed. + + +(*********************************************************) +(** ** Order and inverse *) +(*********************************************************) + +Lemma Rinv_lt_0_compat : forall r (rneg : r < 0), (/ r) (inl rneg) < 0. +Proof. + intros. assert (0 < (/-r) (inr (Ropp_0_gt_lt_contravar r rneg))). + { apply Rinv_0_lt_compat. } + rewrite <- Ropp_inv_permute in H. rewrite <- Ropp_0 in H. + apply Ropp_lt_cancel in H. apply H. +Qed. +Hint Resolve Rinv_lt_0_compat: creal. + + + +(*********************************************************) +(** ** Miscellaneous *) +(*********************************************************) + +(**********) +Lemma Rle_lt_0_plus_1 : forall r, 0 <= r -> 0 < r + 1. +Proof. + intros. apply (Rle_lt_trans _ (r+0)). rewrite Rplus_0_r. + exact H. apply Rplus_lt_compat_l. apply Rlt_0_1. +Qed. +Hint Resolve Rle_lt_0_plus_1: creal. + +(**********) +Lemma Rlt_plus_1 : forall r, r < r + 1. +Proof. + intro r. rewrite <- Rplus_0_r. rewrite Rplus_assoc. + apply Rplus_lt_compat_l. rewrite Rplus_0_l. exact Rlt_0_1. +Qed. +Hint Resolve Rlt_plus_1: creal. + +(**********) +Lemma tech_Rgt_minus : forall r1 r2, 0 < r2 -> r1 > r1 - r2. +Proof. + intros. apply (Rplus_lt_reg_r r2). + unfold Rminus, CRminus; rewrite Rplus_assoc, Rplus_opp_l. + apply Rplus_lt_compat_l. exact H. +Qed. + +(*********************************************************) +(** ** Injection from [N] to [R] *) +(*********************************************************) + +(**********) +Lemma S_INR : forall n:nat, INR (S n) == INR n + 1. +Proof. + intro; destruct n. rewrite Rplus_0_l. reflexivity. reflexivity. +Qed. + +Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. +Proof. + induction m. + - intros. exfalso. inversion H. + - intros. unfold lt in H. apply le_S_n in H. destruct m. + assert (n = 0)%nat. + { inversion H. reflexivity. } + subst n. apply Rlt_0_1. apply le_succ_r_T in H. destruct H. + rewrite S_INR. apply (Rlt_trans _ (INR (S m) + 0)). + rewrite Rplus_comm, Rplus_0_l. apply IHm. + apply le_n_S. exact l. + apply Rplus_lt_compat_l. exact Rlt_0_1. + subst n. rewrite (S_INR (S m)). rewrite <- (Rplus_0_l). + rewrite (Rplus_comm 0), Rplus_assoc. + apply Rplus_lt_compat_l. rewrite Rplus_0_l. + exact Rlt_0_1. +Qed. + +(**********) +Lemma S_O_plus_INR : forall n:nat, INR (1 + n) == INR 1 + INR n. +Proof. + intros; destruct n. + - rewrite Rplus_comm, Rplus_0_l. reflexivity. + - rewrite Rplus_comm. reflexivity. +Qed. + +(**********) +Lemma plus_INR : forall n m:nat, INR (n + m) == INR n + INR m. +Proof. + intros n m; induction n as [| n Hrecn]. + - rewrite Rplus_0_l. reflexivity. + - replace (S n + m)%nat with (S (n + m)); auto with arith. + repeat rewrite S_INR. + rewrite Hrecn; ring. +Qed. + +(**********) +Lemma minus_INR : forall n m:nat, (m <= n)%nat -> INR (n - m) == INR n - INR m. +Proof. + intros n m le; pattern m, n; apply le_elim_rel. + intros. rewrite <- minus_n_O. simpl. + unfold Rminus, CRminus. rewrite Ropp_0, Rplus_0_r. reflexivity. + intros; repeat rewrite S_INR; simpl. + rewrite H0. unfold Rminus. ring. exact le. +Qed. + +(*********) +Lemma mult_INR : forall n m:nat, INR (n * m) == INR n * INR m. +Proof. + intros n m; induction n as [| n Hrecn]. + - rewrite Rmult_0_l. reflexivity. + - intros; repeat rewrite S_INR; simpl. + rewrite plus_INR. rewrite Hrecn; ring. +Qed. + +Lemma INR_IPR : forall p, INR (Pos.to_nat p) == IPR p. +Proof. + assert (H: forall p, 2 * INR (Pos.to_nat p) == IPR_2 p). + { induction p as [p|p|]. + - unfold IPR_2; rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp. + rewrite Rplus_comm. reflexivity. + - unfold IPR_2; now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. + - apply Rmult_1_r. } + intros [p|p|] ; unfold IPR. + rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. + apply Rplus_comm. + now rewrite Pos2Nat.inj_xO, mult_INR, <- H. + easy. +Qed. + +Fixpoint pow (r:R) (n:nat) : R := + match n with + | O => 1 + | S n => r * (pow r n) + end. + +Lemma Rpow_eq_compat : forall (x y : R) (n : nat), + x == y -> pow x n == pow y n. +Proof. + intro x. induction n. + - reflexivity. + - intros. simpl. rewrite IHn, H. reflexivity. exact H. +Qed. + +Lemma pow_INR (m n: nat) : INR (m ^ n) == pow (INR m) n. +Proof. now induction n as [|n IHn];[ | simpl; rewrite mult_INR, IHn]. Qed. + +(*********) +Lemma lt_0_INR : forall n:nat, (0 < n)%nat -> 0 < INR n. +Proof. + intros. apply (lt_INR 0). exact H. +Qed. +Hint Resolve lt_0_INR: creal. + +Lemma lt_1_INR : forall n:nat, (1 < n)%nat -> 1 < INR n. +Proof. + apply lt_INR. +Qed. +Hint Resolve lt_1_INR: creal. + +(**********) +Lemma pos_INR_nat_of_P : forall p:positive, 0 < INR (Pos.to_nat p). +Proof. + intro; apply lt_0_INR. + simpl; auto with creal. + apply Pos2Nat.is_pos. +Qed. +Hint Resolve pos_INR_nat_of_P: creal. + +(**********) +Lemma pos_INR : forall n:nat, 0 <= INR n. +Proof. + intro n; case n. + simpl; auto with creal. + auto with arith creal. +Qed. +Hint Resolve pos_INR: creal. + +Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat. +Proof. + intros n m. revert n. + induction m ; intros n H. + - elim (Rlt_irrefl 0). + apply Rle_lt_trans with (2 := H). + apply pos_INR. + - destruct n as [|n]. + apply Nat.lt_0_succ. + apply lt_n_S, IHm. + rewrite 2!S_INR in H. + apply Rplus_lt_reg_r with (1 := H). +Qed. +Hint Resolve INR_lt: creal. + +(*********) +Lemma le_INR : forall n m:nat, (n <= m)%nat -> INR n <= INR m. +Proof. + simple induction 1; intros; auto with creal. + rewrite S_INR. + apply Rle_trans with (INR m0); auto with creal. +Qed. +Hint Resolve le_INR: creal. + +(**********) +Lemma INR_not_0 : forall n:nat, INR n <> 0 -> n <> 0%nat. +Proof. + red; intros n H H1. + apply H. + rewrite H1; trivial. +Qed. +Hint Immediate INR_not_0: creal. + +(**********) +Lemma not_0_INR : forall n:nat, n <> 0%nat -> 0 < INR n. +Proof. + intro n; case n. + intro; absurd (0%nat = 0%nat); trivial. + intros; rewrite S_INR. + apply (Rlt_le_trans _ (0 + 1)). rewrite Rplus_0_l. apply Rlt_0_1. + apply Rplus_le_compat_r. apply pos_INR. +Qed. +Hint Resolve not_0_INR: creal. + +Lemma not_INR : forall n m:nat, n <> m -> INR n # INR m. +Proof. + intros n m H; case (le_lt_dec n m); intros H1. + left. apply lt_INR. + case (le_lt_or_eq _ _ H1); intros H2. + exact H2. contradiction. + right. apply lt_INR. exact H1. +Qed. +Hint Resolve not_INR: creal. + +Lemma INR_eq : forall n m:nat, INR n == INR m -> n = m. +Proof. + intros n m HR. + destruct (dec_eq_nat n m) as [H|H]. + exact H. exfalso. + apply not_INR in H. destruct HR,H; contradiction. +Qed. +Hint Resolve INR_eq: creal. + +Lemma INR_le : forall n m:nat, INR n <= INR m -> (n <= m)%nat. +Proof. + intros n m. revert n. + induction m ; intros n H. + - destruct n. apply le_refl. exfalso. + rewrite S_INR in H. + assert (0 + 1 <= 0). apply (Rle_trans _ (INR n + 1)). + apply Rplus_le_compat_r. apply pos_INR. apply H. + rewrite Rplus_0_l in H0. apply H0. apply Rlt_0_1. + - destruct n as [|n]. apply le_0_n. + apply le_n_S, IHm. + rewrite 2!S_INR in H. + apply Rplus_le_reg_r in H. apply H. +Qed. +Hint Resolve INR_le: creal. + +Lemma not_1_INR : forall n:nat, n <> 1%nat -> INR n # 1. +Proof. + intros n. + apply not_INR. +Qed. +Hint Resolve not_1_INR: creal. + +(*********************************************************) +(** ** Injection from [Z] to [R] *) +(*********************************************************) + +Lemma IPR_pos : forall p:positive, 0 < IPR p. +Proof. + intro p. rewrite <- INR_IPR. apply (lt_INR 0), Pos2Nat.is_pos. +Qed. + +Lemma IPR_double : forall p:positive, IPR (2*p) == 2 * IPR p. +Proof. + intro p. destruct p; try reflexivity. + rewrite Rmult_1_r. reflexivity. +Qed. + +Lemma INR_IZR_INZ : forall n:nat, INR n == IZR (Z.of_nat n). +Proof. + intros [|n]. + easy. + simpl Z.of_nat. unfold IZR. + now rewrite <- INR_IPR, SuccNat2Pos.id_succ. +Qed. + +Lemma plus_IZR_NEG_POS : + forall p q:positive, IZR (Zpos p + Zneg q) == IZR (Zpos p) + IZR (Zneg q). +Proof. + intros p q; simpl. rewrite Z.pos_sub_spec. + case Pos.compare_spec; intros H; unfold IZR. + subst. ring. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub. + rewrite minus_INR. + 2: (now apply lt_le_weak, Pos2Nat.inj_lt). + ring. + trivial. + rewrite <- 3!INR_IPR, Pos2Nat.inj_sub. + rewrite minus_INR. + 2: (now apply lt_le_weak, Pos2Nat.inj_lt). + unfold Rminus. ring. trivial. +Qed. + +Lemma plus_IPR : forall n m:positive, IPR (n + m) == IPR n + IPR m. +Proof. + intros. repeat rewrite <- INR_IPR. + rewrite Pos2Nat.inj_add. apply plus_INR. +Qed. + +(**********) +Lemma plus_IZR : forall n m:Z, IZR (n + m) == IZR n + IZR m. +Proof. + intro z; destruct z; intro t; destruct t; intros. + - rewrite Rplus_0_l. reflexivity. + - rewrite Rplus_0_l. rewrite Z.add_0_l. reflexivity. + - rewrite Rplus_0_l. reflexivity. + - rewrite Rplus_comm,Rplus_0_l. reflexivity. + - rewrite <- Pos2Z.inj_add. unfold IZR. apply plus_IPR. + - apply plus_IZR_NEG_POS. + - rewrite Rplus_comm,Rplus_0_l, Z.add_0_r. reflexivity. + - rewrite Z.add_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS. + - simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR. + ring. +Qed. + +Lemma mult_IPR : forall n m:positive, IPR (n * m) == IPR n * IPR m. +Proof. + intros. repeat rewrite <- INR_IPR. + rewrite Pos2Nat.inj_mul. apply mult_INR. +Qed. + +(**********) +Lemma mult_IZR : forall n m:Z, IZR (n * m) == IZR n * IZR m. +Proof. + intros n m. destruct n. + - rewrite Rmult_0_l. rewrite Z.mul_0_l. reflexivity. + - destruct m. rewrite Z.mul_0_r, Rmult_0_r. reflexivity. + simpl; unfold IZR. apply mult_IPR. + simpl. unfold IZR. rewrite mult_IPR. ring. + - destruct m. rewrite Z.mul_0_r, Rmult_0_r. reflexivity. + simpl. unfold IZR. rewrite mult_IPR. ring. + simpl. unfold IZR. rewrite mult_IPR. ring. +Qed. + +Lemma pow_IZR : forall z n, pow (IZR z) n == IZR (Z.pow z (Z.of_nat n)). +Proof. + intros z [|n];simpl; trivial. reflexivity. + rewrite Zpower_pos_nat. + rewrite SuccNat2Pos.id_succ. unfold Zpower_nat;simpl. + rewrite mult_IZR. + induction n;simpl;trivial. reflexivity. + rewrite mult_IZR;ring[IHn]. +Qed. + +(**********) +Lemma succ_IZR : forall n:Z, IZR (Z.succ n) == IZR n + 1. +Proof. + intro; unfold Z.succ; apply plus_IZR. +Qed. + +(**********) +Lemma opp_IZR : forall n:Z, IZR (- n) == - IZR n. +Proof. + intros [|z|z]; unfold IZR; simpl; auto with creal. + ring. + reflexivity. rewrite Ropp_involutive. reflexivity. +Qed. + +Definition Ropp_Ropp_IZR := opp_IZR. + +Lemma minus_IZR : forall n m:Z, IZR (n - m) == IZR n - IZR m. +Proof. + intros; unfold Z.sub, Rminus,CRminus. + rewrite <- opp_IZR. + apply plus_IZR. +Qed. + +(**********) +Lemma Z_R_minus : forall n m:Z, IZR n - IZR m == IZR (n - m). +Proof. + intros z1 z2; unfold Rminus,CRminus; unfold Z.sub. + rewrite <- (Ropp_Ropp_IZR z2); symmetry; apply plus_IZR. +Qed. + +(**********) +Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. +Proof. + intro z; case z; simpl; intros. + elim (Rlt_irrefl _ H). + easy. + elim (Rlt_not_le _ _ H). + unfold IZR. + rewrite <- INR_IPR. + auto with creal. +Qed. + +(**********) +Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z. +Proof. + intros z1 z2 H; apply Z.lt_0_sub. + apply lt_0_IZR. + rewrite <- Z_R_minus. + exact (Rgt_minus (IZR z2) (IZR z1) H). +Qed. + +(**********) +Lemma eq_IZR_R0 : forall n:Z, IZR n == 0 -> n = 0%Z. +Proof. + intro z; destruct z; simpl; intros; auto with zarith. + unfold IZR in H. rewrite <- INR_IPR in H. + apply (INR_eq _ 0) in H. + exfalso. pose proof (Pos2Nat.is_pos p). + rewrite H in H0. inversion H0. + unfold IZR in H. rewrite <- INR_IPR in H. + apply (Rplus_eq_compat_r (INR (Pos.to_nat p))) in H. + rewrite Rplus_opp_l, Rplus_0_l in H. symmetry in H. + apply (INR_eq _ 0) in H. + exfalso. pose proof (Pos2Nat.is_pos p). + rewrite H in H0. inversion H0. +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); + intro; omega. +Qed. + +Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m. +Proof. + assert (forall n:Z, Z.lt 0 n -> 0 < IZR n) as posCase. + { intros. destruct (IZN n). apply Z.lt_le_incl. apply H. + subst n. rewrite <- INR_IZR_INZ. apply (lt_INR 0). + apply Nat2Z.inj_lt. apply H. } + intros. apply (Rplus_lt_reg_r (-(IZR n))). + pose proof minus_IZR. unfold Rminus,CRminus in H0. + repeat rewrite <- H0. unfold Zminus. + rewrite Z.add_opp_diag_r. apply posCase. + rewrite (Z.add_lt_mono_l _ _ n). ring_simplify. apply H. +Qed. + +(**********) +Lemma not_0_IZR : forall n:Z, n <> 0%Z -> IZR n # 0. +Proof. + intros. destruct n. exfalso. apply H. reflexivity. + right. apply (IZR_lt 0). reflexivity. + left. apply (IZR_lt _ 0). reflexivity. +Qed. + +(*********) +Lemma le_0_IZR : forall n:Z, 0 <= IZR n -> (0 <= n)%Z. +Proof. + intros. destruct n. discriminate. discriminate. + exfalso. rewrite <- Ropp_0 in H. unfold IZR in H. apply H. + apply Ropp_gt_lt_contravar. rewrite <- INR_IPR. + apply (lt_INR 0). apply Pos2Nat.is_pos. +Qed. + +(**********) +Lemma le_IZR : forall n m:Z, IZR n <= IZR m -> (n <= m)%Z. +Proof. + intros. apply (Rplus_le_compat_r (-(IZR n))) in H. + pose proof minus_IZR. unfold Rminus,CRminus in H0. + repeat rewrite <- H0 in H. unfold Zminus in H. + rewrite Z.add_opp_diag_r in H. + apply (Z.add_le_mono_l _ _ (-n)). ring_simplify. + rewrite Z.add_comm. apply le_0_IZR. apply H. +Qed. + +(**********) +Lemma le_IZR_R1 : forall n:Z, IZR n <= 1 -> (n <= 1)%Z. +Proof. + intros. apply (le_IZR n 1). apply H. +Qed. + +(**********) +Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m. +Proof. + intros m n H; apply Rnot_lt_ge. intro abs. + apply lt_IZR in abs. omega. +Qed. + +Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m. +Proof. + intros m n H; apply Rnot_lt_ge. intro abs. + apply lt_IZR in abs. omega. +Qed. + +Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 # IZR z2. +Proof. + intros. destruct (not_0_IZR (z1-z2)). + intro abs. apply H. rewrite <- (Z.add_cancel_r _ _ (-z2)). + ring_simplify. exact abs. + left. apply IZR_lt. apply (lt_IZR _ 0) in c. + rewrite (Z.add_lt_mono_r _ _ (-z2)). + ring_simplify. exact c. + right. apply IZR_lt. apply (lt_IZR 0) in c. + rewrite (Z.add_lt_mono_l _ _ (-z2)). + ring_simplify. rewrite Z.add_comm. exact c. +Qed. + +Hint Extern 0 (IZR _ <= IZR _) => apply IZR_le, Zle_bool_imp_le, eq_refl : creal. +Hint Extern 0 (IZR _ >= IZR _) => apply Rle_ge, IZR_le, Zle_bool_imp_le, eq_refl : creal. +Hint Extern 0 (IZR _ < IZR _) => apply IZR_lt, eq_refl : creal. +Hint Extern 0 (IZR _ > IZR _) => apply IZR_lt, eq_refl : creal. +Hint Extern 0 (IZR _ <> IZR _) => apply IZR_neq, Zeq_bool_neq, eq_refl : creal. + +Lemma one_IZR_lt1 : forall n:Z, -(1) < IZR n < 1 -> n = 0%Z. +Proof. + intros z [H1 H2]. + apply Z.le_antisymm. + apply Z.lt_succ_r; apply lt_IZR; trivial. + change 0%Z with (Z.succ (-1)). + apply Z.le_succ_l; apply lt_IZR; trivial. +Qed. + +Lemma one_IZR_r_R1 : + forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m. +Proof. + intros r z x [H1 H2] [H3 H4]. + cut ((z - x)%Z = 0%Z); auto with zarith. + apply one_IZR_lt1. + split; rewrite <- Z_R_minus. + setoid_replace (-(1)) with (r - (r + 1)). + unfold CReal_minus; apply Rplus_lt_le_compat; auto with creal. + ring. + setoid_replace 1 with (r + 1 - r). + unfold CReal_minus; apply Rplus_le_lt_compat; auto with creal. + ring. +Qed. + + +(**********) +Lemma single_z_r_R1 : + forall r (n m:Z), + r < IZR n -> IZR n <= r + 1 -> r < IZR m -> IZR m <= r + 1 -> n = m. +Proof. + intros; apply one_IZR_r_R1 with r; auto. +Qed. + +(**********) +Lemma tech_single_z_r_R1 : + forall r (n:Z), + r < IZR n -> + IZR n <= r + 1 -> + { s : Z & prod (s <> n) (r < IZR s <= r + 1) } -> False. +Proof. + intros r z H1 H2 [s [H3 [H4 H5]]]. + apply H3; apply single_z_r_R1 with r; trivial. +Qed. + + +Lemma Rmult_le_compat_l_half : forall r r1 r2, + 0 < r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. intro abs. apply (Rmult_lt_reg_l) in abs. + contradiction. apply H. +Qed. + +Lemma INR_gen_phiZ : forall (n : nat), + gen_phiZ 0 1 Rplus Rmult Ropp (Z.of_nat n) == INR n. +Proof. + induction n. + - apply Req_refl. + - replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z. + rewrite (gen_phiZ_add Req_rel (CRisRingExt CR) RisRing). + rewrite IHn. clear IHn. simpl. rewrite (Rplus_comm 1). + destruct n. rewrite Rplus_0_l. reflexivity. reflexivity. + replace (S n) with (1 + n)%nat. 2: reflexivity. + rewrite (Nat2Z.inj_add 1 n). reflexivity. +Qed. + +Definition Rup_nat (x : R) + : { n : nat & x < INR n }. +Proof. + intros. destruct (CRarchimedean CR x) as [p maj]. + destruct p. + - exists O. apply maj. + - exists (Pos.to_nat p). + rewrite <- positive_nat_Z, (INR_gen_phiZ (Pos.to_nat p)) in maj. exact maj. + - exists O. apply (Rlt_trans _ _ _ maj). simpl. + rewrite <- Ropp_0. apply Ropp_gt_lt_contravar. + fold (gen_phiZ 0 1 Rplus Rmult Ropp (Z.pos p)). + replace (gen_phiPOS 1 (CRplus CR) (CRmult CR) p) + with (gen_phiZ 0 1 Rplus Rmult Ropp (Z.pos p)). + 2: reflexivity. + rewrite <- positive_nat_Z, (INR_gen_phiZ (Pos.to_nat p)). + apply (lt_INR 0). apply Pos2Nat.is_pos. +Qed. + +Fixpoint Rarchimedean_ind (x:R) (n : Z) (p:nat) { struct p } + : (x < IZR n < x + 2 + (INR p)) + -> { n:Z & x < IZR n < x+2 }. +Proof. + destruct p. + - exists n. destruct H. split. exact r. rewrite Rplus_0_r in r0; exact r0. + - intros. destruct (linear_order_T (x+1+INR p) (IZR n) (x+2+INR p)). + do 2 rewrite Rplus_assoc. apply Rplus_lt_compat_l, Rplus_lt_compat_r. + rewrite <- (Rplus_0_r 1). apply Rplus_lt_compat_l. apply Rlt_0_1. + + apply (Rarchimedean_ind x (n-1)%Z p). unfold Zminus. + split; rewrite plus_IZR, opp_IZR. + setoid_replace (IZR 1) with 1. 2: reflexivity. + apply (Rplus_lt_reg_l 1). ring_simplify. + apply (Rle_lt_trans _ (x + 1 + INR p)). 2: exact r. + rewrite Rplus_assoc. apply Rplus_le_compat_l. + rewrite <- (Rplus_0_r 1), Rplus_assoc. apply Rplus_le_compat_l. + rewrite Rplus_0_l. apply (le_INR 0), le_0_n. + setoid_replace (IZR 1) with 1. 2: reflexivity. + apply (Rplus_lt_reg_l 1). ring_simplify. + setoid_replace (x + 2 + INR p + 1) with (x + 2 + INR (S p)). + apply H. rewrite S_INR. ring. + + apply (Rarchimedean_ind x n p). split. apply H. exact r. +Qed. + +Lemma Rarchimedean (x:R) : { n : Z & x < IZR n < x + 2 }. +Proof. + destruct (Rup_nat x) as [n nmaj]. + destruct (Rup_nat (INR n + - (x + 2))) as [p pmaj]. + apply (Rplus_lt_compat_r (x+2)) in pmaj. + rewrite Rplus_assoc, Rplus_opp_l, Rplus_0_r in pmaj. + apply (Rarchimedean_ind x (Z.of_nat n) p). + split; rewrite <- INR_IZR_INZ. exact nmaj. + rewrite Rplus_comm in pmaj. exact pmaj. +Qed. + +Lemma Rmult_le_0_compat : forall a b, + 0 <= a -> 0 <= b -> 0 <= a * b. +Proof. + (* Limit of (a + 1/n)*b when n -> infty. *) + intros. intro abs. + assert (0 < -(a*b)) as epsPos. + { rewrite <- Ropp_0. apply Ropp_gt_lt_contravar. apply abs. } + pose proof (Rup_nat (b * (/ (-(a*b))) (inr (Ropp_0_gt_lt_contravar _ abs)))) + as [n maj]. + destruct n as [|n]. + - simpl in maj. apply (Rmult_lt_compat_r (-(a*b))) in maj. + rewrite Rmult_0_l in maj. + rewrite Rmult_assoc in maj. rewrite Rinv_l in maj. + rewrite Rmult_1_r in maj. contradiction. + apply epsPos. + - (* n > 0 *) + assert (0 < INR (S n)) as nPos. + { apply (lt_INR 0). apply le_n_S, le_0_n. } + assert (b * (/ (INR (S n))) (inr nPos) < -(a*b)). + { apply (Rmult_lt_reg_r (INR (S n))). apply nPos. + rewrite Rmult_assoc. rewrite Rinv_l. + rewrite Rmult_1_r. apply (Rmult_lt_compat_r (-(a*b))) in maj. + rewrite Rmult_assoc in maj. rewrite Rinv_l in maj. + rewrite Rmult_1_r in maj. rewrite Rmult_comm. + apply maj. exact epsPos. } + pose proof (Rmult_le_compat_l_half (a + (/ (INR (S n))) (inr nPos)) + 0 b). + assert (a + (/ (INR (S n))) (inr nPos) > 0 + 0). + apply Rplus_le_lt_compat. apply H. apply Rinv_0_lt_compat. + rewrite Rplus_0_l in H3. specialize (H2 H3 H0). + clear H3. rewrite Rmult_0_r in H2. + apply H2. clear H2. rewrite Rmult_plus_distr_r. + apply (Rplus_lt_compat_l (a*b)) in H1. + rewrite Rplus_opp_r in H1. + rewrite (Rmult_comm ((/ (INR (S n))) (inr nPos))). + apply H1. +Qed. + +Lemma Rmult_le_compat_l : forall r r1 r2, + 0 <= r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. apply Rminus_ge. apply Rge_minus in H0. + unfold Rminus,CRminus. rewrite Ropp_mult_distr_r. + rewrite <- Rmult_plus_distr_l. + apply Rmult_le_0_compat; assumption. +Qed. +Hint Resolve Rmult_le_compat_l: creal. + +Lemma Rmult_le_compat_r : forall r r1 r2, + 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r. +Proof. + intros. rewrite <- (Rmult_comm r). rewrite <- (Rmult_comm r). + apply Rmult_le_compat_l; assumption. +Qed. +Hint Resolve Rmult_le_compat_r: creal. + +(*********) +Lemma Rmult_le_0_lt_compat : + forall r1 r2 r3 r4, + 0 <= r1 -> 0 <= r3 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. +Proof. + intros. apply (Rle_lt_trans _ (r2 * r3)). + apply Rmult_le_compat_r. apply H0. intro abs. apply (Rlt_asym r1 r2 H1). + apply abs. apply Rmult_lt_compat_l. exact (Rle_lt_trans 0 r1 r2 H H1). + exact H2. +Qed. + +Lemma Rmult_le_compat_neg_l : + forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r2 <= r * r1. +Proof. + intros. apply Ropp_le_cancel. + do 2 rewrite Ropp_mult_distr_l. apply Rmult_le_compat_l. + 2: exact H0. apply Ropp_0_ge_le_contravar. exact H. +Qed. +Hint Resolve Rmult_le_compat_neg_l: creal. + +Lemma Rmult_le_ge_compat_neg_l : + forall r r1 r2, r <= 0 -> r1 <= r2 -> r * r1 >= r * r2. +Proof. + intros; apply Rle_ge; auto with creal. +Qed. +Hint Resolve Rmult_le_ge_compat_neg_l: creal. + + +(**********) +Lemma Rmult_ge_compat_l : + forall r r1 r2, r >= 0 -> r1 >= r2 -> r * r1 >= r * r2. +Proof. + intros. apply Rmult_le_compat_l; assumption. +Qed. + +Lemma Rmult_ge_compat_r : + forall r r1 r2, r >= 0 -> r1 >= r2 -> r1 * r >= r2 * r. +Proof. + intros. apply Rmult_le_compat_r; assumption. +Qed. + + +(**********) +Lemma Rmult_le_compat : + forall r1 r2 r3 r4, + 0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4. +Proof. + intros x y z t H' H'0 H'1 H'2. + apply Rle_trans with (r2 := x * t); auto with creal. + repeat rewrite (fun x => Rmult_comm x t). + apply Rmult_le_compat_l; auto. + apply Rle_trans with z; auto. +Qed. +Hint Resolve Rmult_le_compat: creal. + +Lemma Rmult_ge_compat : + forall r1 r2 r3 r4, + r2 >= 0 -> r4 >= 0 -> r1 >= r2 -> r3 >= r4 -> r1 * r3 >= r2 * r4. +Proof. auto with creal rorders. Qed. + +Lemma mult_IPR_IZR : forall (n:positive) (m:Z), IZR (Z.pos n * m) == IPR n * IZR m. +Proof. + intros. rewrite mult_IZR. apply Rmult_eq_compat_r. reflexivity. +Qed. + +Definition IQR (q:Q) : R := + match q with + | Qmake a b => IZR a * (/ (IPR b)) (inr (IPR_pos b)) + end. +Arguments IQR q%Q : simpl never. + +Lemma plus_IQR : forall n m:Q, IQR (n + m) == IQR n + IQR m. +Proof. + intros. destruct n,m; unfold Qplus,IQR; simpl. + rewrite plus_IZR. repeat rewrite mult_IZR. + setoid_replace ((/ IPR (Qden * Qden0)) (inr (IPR_pos (Qden * Qden0)))) + with ((/ IPR Qden) (inr (IPR_pos Qden)) + * (/ IPR Qden0) (inr (IPR_pos Qden0))). + rewrite Rmult_plus_distr_r. + repeat rewrite Rmult_assoc. rewrite <- (Rmult_assoc (IZR (Z.pos Qden))). + rewrite Rinv_r. rewrite Rmult_1_l. + rewrite (Rmult_comm ((/IPR Qden) (inr (IPR_pos Qden)))). + rewrite <- (Rmult_assoc (IZR (Z.pos Qden0))). + rewrite Rinv_r. rewrite Rmult_1_l. reflexivity. unfold IZR. + right. apply IPR_pos. + right. apply IPR_pos. + rewrite <- (Rinv_mult_distr + _ _ _ _ (inr (Rmult_lt_0_compat _ _ (IPR_pos _) (IPR_pos _)))). + apply Rinv_eq_compat. apply mult_IPR. +Qed. + +Lemma IQR_pos : forall q:Q, Qlt 0 q -> 0 < IQR q. +Proof. + intros. destruct q; unfold IQR. + apply Rmult_lt_0_compat. apply (IZR_lt 0). + unfold Qlt in H; simpl in H. + rewrite Z.mul_1_r in H. apply H. + apply Rinv_0_lt_compat. +Qed. + +Lemma opp_IQR : forall q:Q, IQR (- q) == - IQR q. +Proof. + intros [a b]; unfold IQR; simpl. + rewrite Ropp_mult_distr_l. + rewrite opp_IZR. reflexivity. +Qed. + +Lemma lt_IQR : forall n m:Q, IQR n < IQR m -> (n < m)%Q. +Proof. + intros. destruct n,m; unfold IQR in H. + unfold Qlt; simpl. apply (Rmult_lt_compat_r (IPR Qden)) in H. + rewrite Rmult_assoc in H. rewrite Rinv_l in H. + rewrite Rmult_1_r in H. rewrite (Rmult_comm (IZR Qnum0)) in H. + apply (Rmult_lt_compat_l (IPR Qden0)) in H. + do 2 rewrite <- Rmult_assoc in H. rewrite Rinv_r in H. + rewrite Rmult_1_l in H. + rewrite (Rmult_comm (IZR Qnum0)) in H. + do 2 rewrite <- mult_IPR_IZR in H. apply lt_IZR in H. + rewrite Z.mul_comm. rewrite (Z.mul_comm Qnum0). + apply H. + right. rewrite <- INR_IPR. apply (lt_INR 0). apply Pos2Nat.is_pos. + rewrite <- INR_IPR. apply (lt_INR 0). apply Pos2Nat.is_pos. + apply IPR_pos. +Qed. + +Lemma IQR_lt : forall n m:Q, Qlt n m -> IQR n < IQR m. +Proof. + intros. apply (Rplus_lt_reg_r (-IQR n)). + rewrite Rplus_opp_r. rewrite <- opp_IQR. rewrite <- plus_IQR. + apply IQR_pos. apply (Qplus_lt_l _ _ n). + ring_simplify. apply H. +Qed. + +Lemma IQR_nonneg : forall q:Q, Qle 0 q -> 0 <= (IQR q). +Proof. + intros [a b] H. unfold IQR;simpl. + apply (Rle_trans _ (IZR a * 0)). rewrite Rmult_0_r. apply Rle_refl. + apply Rmult_le_compat_l. + apply (IZR_le 0 a). unfold Qle in H; simpl in H. + rewrite Z.mul_1_r in H. apply H. + unfold Rle. apply Rlt_asym. apply Rinv_0_lt_compat. +Qed. + +Lemma IQR_le : forall n m:Q, Qle n m -> IQR n <= IQR m. +Proof. + intros. apply (Rplus_le_reg_r (-IQR n)). + rewrite Rplus_opp_r. rewrite <- opp_IQR. rewrite <- plus_IQR. + apply IQR_nonneg. apply (Qplus_le_l _ _ n). + ring_simplify. apply H. +Qed. + +Add Parametric Morphism : IQR + with signature Qeq ==> Req + as IQR_morph. +Proof. + intros. destruct x,y; unfold IQR; simpl. + unfold Qeq in H; simpl in H. + apply (Rmult_eq_reg_r (IZR (Z.pos Qden))). + rewrite Rmult_assoc. rewrite Rinv_l. rewrite Rmult_1_r. + rewrite (Rmult_comm (IZR Qnum0)). + apply (Rmult_eq_reg_l (IZR (Z.pos Qden0))). + rewrite <- Rmult_assoc. rewrite <- Rmult_assoc. rewrite Rinv_r. + rewrite Rmult_1_l. + repeat rewrite <- mult_IZR. + rewrite <- H. rewrite Zmult_comm. reflexivity. + right. apply IPR_pos. + right. apply (IZR_lt 0). apply Pos2Z.is_pos. + right. apply IPR_pos. +Qed. + +Instance IQR_morph_T + : CMorphisms.Proper + (CMorphisms.respectful Qeq Req) IQR. +Proof. + intros x y H. destruct x,y; unfold IQR. + unfold Qeq in H; simpl in H. + apply (Rmult_eq_reg_r (IZR (Z.pos Qden))). + 2: right; apply IPR_pos. + rewrite Rmult_assoc, Rinv_l, Rmult_1_r. + rewrite (Rmult_comm (IZR Qnum0)). + apply (Rmult_eq_reg_l (IZR (Z.pos Qden0))). + 2: right; apply IPR_pos. + rewrite <- Rmult_assoc, <- Rmult_assoc, Rinv_r. + rewrite Rmult_1_l. + repeat rewrite <- mult_IZR. + rewrite <- H. rewrite Zmult_comm. reflexivity. + right; apply IPR_pos. +Qed. + +Fixpoint Rfloor_pos (a : R) (n : nat) { struct n } + : 0 < a + -> a < INR n + -> { p : nat & INR p < a < INR p + 2 }. +Proof. + (* Decreasing loop on n, until it is the first integer above a. *) + intros H H0. destruct n. + - exfalso. apply (Rlt_asym 0 a); assumption. + - destruct n as [|p] eqn:des. + + (* n = 1 *) exists O. split. + apply H. rewrite Rplus_0_l. apply (Rlt_trans a (1+0)). + rewrite Rplus_comm, Rplus_0_l. apply H0. + apply Rplus_le_lt_compat. + apply Rle_refl. apply Rlt_0_1. + + (* n > 1 *) + destruct (linear_order_T (INR p) a (INR (S p))). + * rewrite <- Rplus_0_l, S_INR, Rplus_comm. apply Rplus_lt_compat_l. + apply Rlt_0_1. + * exists p. split. exact r. + rewrite S_INR, S_INR, Rplus_assoc in H0. exact H0. + * apply (Rfloor_pos a n H). rewrite des. apply r. +Qed. + +Definition Rfloor (a : R) + : { p : Z & IZR p < a < IZR p + 2 }. +Proof. + destruct (linear_order_T 0 a 1 Rlt_0_1). + - destruct (Rup_nat a). destruct (Rfloor_pos a x r r0). + exists (Z.of_nat x0). split; rewrite <- INR_IZR_INZ; apply p. + - apply (Rplus_lt_compat_l (-a)) in r. + rewrite Rplus_comm, Rplus_opp_r, Rplus_comm in r. + destruct (Rup_nat (1-a)). + destruct (Rfloor_pos (1-a) x r r0). + exists (-(Z.of_nat x0 + 1))%Z. split; rewrite opp_IZR, plus_IZR. + + rewrite <- (Ropp_involutive a). apply Ropp_gt_lt_contravar. + destruct p as [_ a0]. apply (Rplus_lt_reg_r 1). + rewrite Rplus_comm, Rplus_assoc. rewrite <- INR_IZR_INZ. apply a0. + + destruct p as [a0 _]. apply (Rplus_lt_compat_l a) in a0. + unfold Rminus in a0. + rewrite <- (Rplus_comm (1+-a)), Rplus_assoc, Rplus_opp_l, Rplus_0_r in a0. + rewrite <- INR_IZR_INZ. + apply (Rplus_lt_reg_r (INR x0)). unfold IZR, IPR, IPR_2. + ring_simplify. exact a0. +Qed. + +(* A point in an archimedean field is the limit of a + sequence of rational numbers (n maps to the q between + a and a+1/n). This is how real numbers compute, + and they are measured by exact rational numbers. *) +Definition RQ_dense (a b : R) + : a < b -> { q : Q & a < IQR q < b }. +Proof. + intros H0. + assert (0 < b - a) as epsPos. + { apply (Rplus_lt_compat_r (-a)) in H0. + rewrite Rplus_opp_r in H0. apply H0. } + pose proof (Rup_nat ((/(b-a)) (inr epsPos))) + as [n maj]. + destruct n as [|k]. + - exfalso. + apply (Rmult_lt_compat_l (b-a)) in maj. 2: apply epsPos. + rewrite Rmult_0_r in maj. rewrite Rinv_r in maj. + apply (Rlt_asym 0 1). apply Rlt_0_1. apply maj. + right. apply epsPos. + - (* 0 < n *) + pose (Pos.of_nat (S k)) as n. + destruct (Rfloor (IZR (2 * Z.pos n) * b)) as [p maj2]. + exists (p # (2*n))%Q. split. + + apply (Rlt_trans a (b - IQR (1 # n))). + apply (Rplus_lt_reg_r (IQR (1#n))). + unfold Rminus,CRminus. rewrite Rplus_assoc. rewrite Rplus_opp_l. + rewrite Rplus_0_r. apply (Rplus_lt_reg_l (-a)). + rewrite <- Rplus_assoc, Rplus_opp_l, Rplus_0_l. + rewrite Rplus_comm. unfold IQR. + rewrite Rmult_1_l. apply (Rmult_lt_reg_l (IPR n)). + apply IPR_pos. rewrite Rinv_r. + apply (Rmult_lt_compat_l (b-a)) in maj. + rewrite Rinv_r, Rmult_comm in maj. + rewrite <- INR_IPR. unfold n. rewrite Nat2Pos.id. + apply maj. discriminate. right. exact epsPos. exact epsPos. + right. apply IPR_pos. + apply (Rplus_lt_reg_r (IQR (1 # n))). + unfold Rminus,CRminus. rewrite Rplus_assoc, Rplus_opp_l. + rewrite Rplus_0_r. rewrite <- plus_IQR. + destruct maj2 as [_ maj2]. + setoid_replace ((p # 2 * n) + (1 # n))%Q + with ((p + 2 # 2 * n))%Q. unfold IQR. + apply (Rmult_lt_reg_r (IZR (Z.pos (2 * n)))). + apply (IZR_lt 0). reflexivity. rewrite Rmult_assoc. + rewrite Rinv_l. rewrite Rmult_1_r. rewrite Rmult_comm. + rewrite plus_IZR. apply maj2. + setoid_replace (1#n)%Q with (2#2*n)%Q. 2: reflexivity. + apply Qinv_plus_distr. + + destruct maj2 as [maj2 _]. unfold IQR. + apply (Rmult_lt_reg_r (IZR (Z.pos (2 * n)))). + apply (IZR_lt 0). apply Pos2Z.is_pos. rewrite Rmult_assoc, Rinv_l. + rewrite Rmult_1_r, Rmult_comm. apply maj2. +Qed. + +Definition RQ_limit : forall (x : R) (n:nat), + { q:Q & x < IQR q < x + IQR (1 # Pos.of_nat n) }. +Proof. + intros x n. apply (RQ_dense x (x + IQR (1 # Pos.of_nat n))). + rewrite <- (Rplus_0_r x). rewrite Rplus_assoc. + apply Rplus_lt_compat_l. rewrite Rplus_0_l. apply IQR_pos. + reflexivity. +Qed. + +(* Rlt is decided by the LPO in Type, + which is a non-constructive oracle. *) +Lemma Rlt_lpo_dec : forall x y : R, + (forall (P : nat -> Prop), (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}) + -> (x < y) + (y <= x). +Proof. + intros x y lpo. + pose (fun n => let (l,_) := RQ_limit x n in l) as xn. + pose (fun n => let (l,_) := RQ_limit y n in l) as yn. + destruct (lpo (fun n:nat => Qle (yn n - xn n) (1 # Pos.of_nat n))). + - intro n. destruct (Qlt_le_dec (1 # Pos.of_nat n) (yn n - xn n)). + right. apply Qlt_not_le. exact q. left. exact q. + - left. destruct s as [n nmaj]. unfold xn,yn in nmaj. + destruct (RQ_limit x n), (RQ_limit y n); unfold proj1_sig in nmaj. + apply Qnot_le_lt in nmaj. + apply (Rlt_le_trans x (IQR x0)). apply p. + apply (Rle_trans _ (IQR (x1 - (1# Pos.of_nat n)))). + apply IQR_le. apply (Qplus_le_l _ _ ((1#Pos.of_nat n) - x0)). + ring_simplify. ring_simplify in nmaj. rewrite Qplus_comm. + apply Qlt_le_weak. exact nmaj. + unfold Qminus. rewrite plus_IQR,opp_IQR. + apply (Rplus_le_reg_r (IQR (1#Pos.of_nat n))). + ring_simplify. unfold Rle. apply Rlt_asym. rewrite Rplus_comm. apply p0. + - right. intro abs. + pose ((y - x) * IQR (1#2)) as eps. + assert (0 < eps) as epsPos. + { apply Rmult_lt_0_compat. apply Rgt_minus. exact abs. + apply IQR_pos. reflexivity. } + destruct (Rup_nat ((/eps) (inr epsPos))) as [n nmaj]. + specialize (q (S n)). unfold xn, yn in q. + destruct (RQ_limit x (S n)) as [a amaj], (RQ_limit y (S n)) as [b bmaj]; + unfold proj1_sig in q. + assert (IQR (1 # Pos.of_nat (S n)) < eps). + { unfold IQR. rewrite Rmult_1_l. + apply (Rmult_lt_reg_l (IPR (Pos.of_nat (S n)))). apply IPR_pos. + rewrite Rinv_r, <- INR_IPR, Nat2Pos.id. 2: discriminate. + apply (Rlt_trans _ _ (INR (S n))) in nmaj. + apply (Rmult_lt_compat_l eps) in nmaj. + rewrite Rinv_r, Rmult_comm in nmaj. exact nmaj. + right. exact epsPos. exact epsPos. apply lt_INR. apply le_n_S, le_refl. + right. apply IPR_pos. } + unfold eps in H. apply (Rlt_asym y (IQR b)). + + apply bmaj. + + apply (Rlt_le_trans _ (IQR a + (y - x) * IQR (1 # 2))). + apply IQR_le in q. + apply (Rle_lt_trans _ _ _ q) in H. + apply (Rplus_lt_reg_l (-IQR a)). + rewrite <- Rplus_assoc, Rplus_opp_l, Rplus_0_l, Rplus_comm, + <- opp_IQR, <- plus_IQR. exact H. + apply (Rplus_lt_compat_l x) in H. + destruct amaj. apply (Rlt_trans _ _ _ r0) in H. + apply (Rplus_lt_compat_r ((y - x) * IQR (1 # 2))) in H. + unfold Rle. apply Rlt_asym. + setoid_replace (x + (y - x) * IQR (1 # 2) + (y - x) * IQR (1 # 2)) with y in H. + exact H. + rewrite Rplus_assoc, <- Rmult_plus_distr_r. + setoid_replace (y - x + (y - x)) with ((y-x)*2). + unfold IQR. rewrite Rmult_1_l, Rmult_assoc, Rinv_r. ring. + right. apply (IZR_lt 0). reflexivity. + unfold IZR, IPR, IPR_2. ring. +Qed. + +Lemma Rlt_lpo_floor : forall x : R, + (forall (P : nat -> Prop), (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}) + -> { p : Z & IZR p <= x < IZR p + 1 }. +Proof. + intros x lpo. destruct (Rfloor x) as [n [H H0]]. + destruct (Rlt_lpo_dec x (IZR n + 1) lpo). + - exists n. split. unfold Rle. apply Rlt_asym. exact H. exact r. + - exists (n+1)%Z. split. rewrite plus_IZR. exact r. + rewrite plus_IZR, Rplus_assoc. exact H0. +Qed. + + +(*********) +Lemma Rmult_le_pos : forall r1 r2, 0 <= r1 -> 0 <= r2 -> 0 <= r1 * r2. +Proof. + intros x y H H0; rewrite <- (Rmult_0_l x); rewrite <- (Rmult_comm x); + apply (Rmult_le_compat_l x 0 y H H0). +Qed. + +Lemma Rinv_le_contravar : + forall x y (xpos : 0 < x) (ynz : y # 0), + x <= y -> (/ y) ynz <= (/ x) (inr xpos). +Proof. + intros. intro abs. apply (Rmult_lt_compat_l x) in abs. + 2: apply xpos. rewrite Rinv_r in abs. + apply (Rmult_lt_compat_r y) in abs. + rewrite Rmult_assoc in abs. rewrite Rinv_l in abs. + rewrite Rmult_1_r in abs. rewrite Rmult_1_l in abs. contradiction. + exact (Rlt_le_trans _ x _ xpos H). + right. exact xpos. +Qed. + +Lemma Rle_Rinv : forall x y (xpos : 0 < x) (ypos : 0 < y), + x <= y -> (/ y) (inr ypos) <= (/ x) (inr xpos). +Proof. + intros. + apply Rinv_le_contravar with (1 := H). +Qed. + +Lemma Ropp_div : forall x y (ynz : y # 0), + -x * (/y) ynz == - (x * (/ y) ynz). +Proof. + intros; ring. +Qed. + +Lemma double : forall r1, 2 * r1 == r1 + r1. +Proof. + intros. rewrite (Rmult_plus_distr_r 1 1 r1), Rmult_1_l. reflexivity. +Qed. + +Lemma Rlt_0_2 : 0 < 2. +Proof. + apply (Rlt_trans 0 (0+1)). rewrite Rplus_0_l. exact Rlt_0_1. + apply Rplus_lt_le_compat. exact Rlt_0_1. apply Rle_refl. +Qed. + +Lemma double_var : forall r1, r1 == r1 * (/ 2) (inr Rlt_0_2) + + r1 * (/ 2) (inr Rlt_0_2). +Proof. + intro; rewrite <- double; rewrite <- Rmult_assoc; + symmetry ; apply Rinv_r_simpl_m. +Qed. + +(* IZR : Z -> R is a ring morphism *) +Lemma R_rm : ring_morph + 0 1 Rplus Rmult Rminus Ropp Req + 0%Z 1%Z Zplus Zmult Zminus Z.opp Zeq_bool IZR. +Proof. +constructor ; try easy. +exact plus_IZR. +exact minus_IZR. +exact mult_IZR. +exact opp_IZR. +intros x y H. +replace y with x. reflexivity. +now apply Zeq_bool_eq. +Qed. + +Lemma Zeq_bool_IZR x y : + IZR x == IZR y -> Zeq_bool x y = true. +Proof. +intros H. +apply Zeq_is_eq_bool. +now apply eq_IZR. +Qed. + + +(*********************************************************) +(** ** Other rules about < and <= *) +(*********************************************************) + +Lemma Rmult_ge_0_gt_0_lt_compat : + forall r1 r2 r3 r4, + r3 >= 0 -> r2 > 0 -> r1 < r2 -> r3 < r4 -> r1 * r3 < r2 * r4. +Proof. + intros. apply (Rle_lt_trans _ (r2 * r3)). + apply Rmult_le_compat_r. apply H. unfold Rle. apply Rlt_asym. apply H1. + apply Rmult_lt_compat_l. apply H0. apply H2. +Qed. + +Lemma le_epsilon : + forall r1 r2, (forall eps, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2. +Proof. + intros x y H. intro abs. + assert (0 < (x - y) * (/ 2) (inr Rlt_0_2)). + { apply (Rplus_lt_compat_r (-y)) in abs. rewrite Rplus_opp_r in abs. + apply Rmult_lt_0_compat. exact abs. + apply Rinv_0_lt_compat. } + specialize (H ((x - y) * (/ 2) (inr Rlt_0_2)) H0). + apply (Rmult_le_compat_l 2) in H. + rewrite Rmult_plus_distr_l in H. + apply (Rplus_le_compat_l (-x)) in H. + rewrite (Rmult_comm (x-y)), <- Rmult_assoc, Rinv_r, Rmult_1_l, + (Rmult_plus_distr_r 1 1), (Rmult_plus_distr_r 1 1) + in H. + ring_simplify in H; contradiction. + right. apply Rlt_0_2. unfold Rle. apply Rlt_asym. apply Rlt_0_2. +Qed. + +(**********) +Lemma Rdiv_lt_0_compat : forall a b (bpos : 0 < b), + 0 < a -> 0 < a * (/b) (inr bpos). +Proof. +intros; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat]; assumption. +Qed. + +Lemma Rdiv_plus_distr : forall a b c (cnz : c # 0), + (a + b)* (/c) cnz == a* (/c) cnz + b* (/c) cnz. +Proof. + intros. apply Rmult_plus_distr_r. +Qed. + +Lemma Rdiv_minus_distr : forall a b c (cnz : c # 0), + (a - b)* (/c) cnz == a* (/c) cnz - b* (/c) cnz. +Proof. + intros; unfold Rminus,CRminus; rewrite Rmult_plus_distr_r. + apply Rplus_morph. reflexivity. + rewrite Ropp_mult_distr_l. reflexivity. +Qed. + + +(*********************************************************) +(** * Definitions of new types *) +(*********************************************************) + +Record nonnegreal : Type := mknonnegreal + {nonneg :> R; cond_nonneg : 0 <= nonneg}. + +Record posreal : Type := mkposreal {pos :> R; cond_pos : 0 < pos}. + +Record nonposreal : Type := mknonposreal + {nonpos :> R; cond_nonpos : nonpos <= 0}. + +Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}. + +Record nonzeroreal : Type := mknonzeroreal + {nonzero :> R; cond_nonzero : nonzero <> 0}. diff --git a/theories/Reals/ConstructiveRcomplete.v b/theories/Reals/ConstructiveRcomplete.v new file mode 100644 index 0000000000..ce45bcd567 --- /dev/null +++ b/theories/Reals/ConstructiveRcomplete.v @@ -0,0 +1,432 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +Require Import QArith_base. +Require Import Qabs. +Require Import ConstructiveCauchyReals. +Require Import Logic.ConstructiveEpsilon. + +Local Open Scope CReal_scope. + +Lemma CReal_absSmall : forall (x y : CReal) (n : positive), + (Qlt (2 # n) + (proj1_sig x (Pos.to_nat n) - Qabs (proj1_sig y (Pos.to_nat n)))) + -> (CRealLt (CReal_opp x) y * CRealLt y x). +Proof. + intros x y n maj. split. + - exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + simpl in maj. unfold Qminus. rewrite Qopp_involutive. + rewrite Qplus_comm. + apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). + apply maj. apply Qplus_le_r. + rewrite <- (Qopp_involutive (yn (Pos.to_nat n))). + apply Qopp_le_compat. rewrite Qabs_opp. apply Qle_Qabs. + - exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + simpl in maj. + apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). + apply maj. apply Qplus_le_r. apply Qopp_le_compat. apply Qle_Qabs. +Qed. + +Definition absSmall (a b : CReal) : Set + := -b < a < b. + +Definition Un_cv_mod (un : nat -> CReal) (l : CReal) : Set + := forall n : positive, + { p : nat & forall i:nat, le p i -> absSmall (un i - l) (IQR (1#n)) }. + +Lemma Un_cv_mod_eq : forall (v u : nat -> CReal) (s : CReal), + (forall n:nat, u n == v n) + -> Un_cv_mod u s -> Un_cv_mod v s. +Proof. + intros v u s seq H1 p. specialize (H1 p) as [N H0]. + exists N. intros. unfold absSmall. split. + rewrite <- seq. apply H0. apply H. + rewrite <- seq. apply H0. apply H. +Qed. + +Definition Un_cauchy_mod (un : nat -> CReal) : Set + := forall n : positive, + { p : nat & forall i j:nat, le p i + -> le p j + -> -IQR (1#n) < un i - un j < IQR (1#n) }. + + +(* Sharpen the archimedean property : constructive versions of + the usual floor and ceiling functions. + + n is a temporary parameter used for the recursion, + look at Ffloor below. *) +Fixpoint Rfloor_pos (a : CReal) (n : nat) { struct n } + : 0 < a + -> a < INR n + -> { p : nat & INR p < a < INR p + 2 }. +Proof. + (* Decreasing loop on n, until it is the first integer above a. *) + intros H H0. destruct n. + - exfalso. apply (CRealLt_asym 0 a); assumption. + - destruct n as [|p] eqn:des. + + (* n = 1 *) exists O. split. + apply H. rewrite CReal_plus_0_l. apply (CRealLt_trans a (1+0)). + rewrite CReal_plus_comm, CReal_plus_0_l. apply H0. + apply CReal_plus_le_lt_compat. + apply CRealLe_refl. apply CRealLt_0_1. + + (* n > 1 *) + destruct (linear_order_T (INR p) a (INR (S p))). + * rewrite <- CReal_plus_0_l, S_INR, CReal_plus_comm. apply CReal_plus_lt_compat_l. + apply CRealLt_0_1. + * exists p. split. exact c. + rewrite S_INR, S_INR, CReal_plus_assoc in H0. exact H0. + * apply (Rfloor_pos a n H). rewrite des. apply c. +Qed. + +Definition Rfloor (a : CReal) + : { p : Z & IZR p < a < IZR p + 2 }. +Proof. + assert (forall x:CReal, 0 < x -> { n : nat & x < INR n }). + { intros. pose proof (Rarchimedean x) as [n [maj _]]. + destruct n. + + exfalso. apply (CRealLt_asym 0 x); assumption. + + exists (Pos.to_nat p). rewrite INR_IPR. apply maj. + + exfalso. apply (CRealLt_asym 0 x). apply H. + apply (CRealLt_trans x (IZR (Z.neg p))). apply maj. + apply (CReal_plus_lt_reg_l (-IZR (Z.neg p))). + rewrite CReal_plus_comm, CReal_plus_opp_r. rewrite <- opp_IZR. + rewrite CReal_plus_comm, CReal_plus_0_l. + apply (IZR_lt 0). reflexivity. } + destruct (linear_order_T 0 a 1 CRealLt_0_1). + - destruct (H a c). destruct (Rfloor_pos a x c c0). + exists (Z.of_nat x0). split; rewrite <- INR_IZR_INZ; apply p. + - apply (CReal_plus_lt_compat_l (-a)) in c. + rewrite CReal_plus_comm, CReal_plus_opp_r, CReal_plus_comm in c. + destruct (H (1-a) c). + destruct (Rfloor_pos (1-a) x c c0). + exists (-(Z.of_nat x0 + 1))%Z. split; rewrite opp_IZR, plus_IZR. + + rewrite <- (CReal_opp_involutive a). apply CReal_opp_gt_lt_contravar. + destruct p as [_ a0]. apply (CReal_plus_lt_reg_r 1). + rewrite CReal_plus_comm, CReal_plus_assoc. rewrite <- INR_IZR_INZ. apply a0. + + destruct p as [a0 _]. apply (CReal_plus_lt_compat_l a) in a0. + unfold CReal_minus in a0. + rewrite <- (CReal_plus_comm (1+-a)), CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r in a0. + rewrite <- INR_IZR_INZ. + apply (CReal_plus_lt_reg_r (INR x0)). unfold IZR, IPR, IPR_2. + ring_simplify. exact a0. +Qed. + +Definition Rup_nat (x : CReal) + : { n : nat & x < INR n }. +Proof. + intros. destruct (Rarchimedean x) as [p [maj _]]. + destruct p. + - exists O. apply maj. + - exists (Pos.to_nat p). rewrite INR_IPR. apply maj. + - exists O. apply (CRealLt_trans _ (IZR (Z.neg p)) _ maj). + apply (IZR_lt _ 0). reflexivity. +Qed. + +(* A point in an archimedean field is the limit of a + sequence of rational numbers (n maps to the q between + a and a+1/n). This will yield a maximum + archimedean field, which is the field of real numbers. *) +Definition FQ_dense_pos (a b : CReal) + : 0 < b + -> a < b -> { q : Q & a < IQR q < b }. +Proof. + intros H H0. + assert (0 < b - a) as epsPos. + { apply (CReal_plus_lt_compat_l (-a)) in H0. + rewrite CReal_plus_opp_l, CReal_plus_comm in H0. + apply H0. } + pose proof (Rup_nat ((/(b-a)) (inr epsPos))) + as [n maj]. + destruct n as [|k]. + - exfalso. + apply (CReal_mult_lt_compat_l (b-a)) in maj. 2: apply epsPos. + rewrite CReal_mult_0_r in maj. rewrite CReal_inv_r in maj. + apply (CRealLt_asym 0 1). apply CRealLt_0_1. apply maj. + - (* 0 < n *) + pose (Pos.of_nat (S k)) as n. + destruct (Rfloor (IZR (2 * Z.pos n) * b)) as [p maj2]. + exists (p # (2*n))%Q. split. + + apply (CRealLt_trans a (b - IQR (1 # n))). + apply (CReal_plus_lt_reg_r (IQR (1#n))). + unfold CReal_minus. rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l. + rewrite CReal_plus_0_r. apply (CReal_plus_lt_reg_l (-a)). + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. + rewrite CReal_plus_comm. unfold IQR. + rewrite CReal_mult_1_l. apply (CReal_mult_lt_reg_l (IPR n)). + apply IPR_pos. rewrite CReal_inv_r. + apply (CReal_mult_lt_compat_l (b-a)) in maj. + rewrite CReal_inv_r, CReal_mult_comm in maj. + rewrite <- INR_IPR. unfold n. rewrite Nat2Pos.id. + apply maj. discriminate. exact epsPos. + apply (CReal_plus_lt_reg_r (IQR (1 # n))). + unfold CReal_minus. rewrite CReal_plus_assoc, CReal_plus_opp_l. + rewrite CReal_plus_0_r. rewrite <- plus_IQR. + destruct maj2 as [_ maj2]. + setoid_replace ((p # 2 * n) + (1 # n))%Q + with ((p + 2 # 2 * n))%Q. unfold IQR. + apply (CReal_mult_lt_reg_r (IZR (Z.pos (2 * n)))). + apply (IZR_lt 0). reflexivity. rewrite CReal_mult_assoc. + rewrite CReal_inv_l. rewrite CReal_mult_1_r. rewrite CReal_mult_comm. + rewrite plus_IZR. apply maj2. + setoid_replace (1#n)%Q with (2#2*n)%Q. 2: reflexivity. + apply Qinv_plus_distr. + + destruct maj2 as [maj2 _]. unfold IQR. + apply (CReal_mult_lt_reg_r (IZR (Z.pos (2 * n)))). + apply (IZR_lt 0). apply Pos2Z.is_pos. rewrite CReal_mult_assoc, CReal_inv_l. + rewrite CReal_mult_1_r, CReal_mult_comm. apply maj2. +Qed. + +Definition FQ_dense (a b : CReal) + : a < b + -> { q : Q & a < IQR q < b }. +Proof. + intros H. destruct (linear_order_T a 0 b). apply H. + - destruct (FQ_dense_pos (-b) (-a)) as [q maj]. + apply (CReal_plus_lt_compat_l (-a)) in c. rewrite CReal_plus_opp_l in c. + rewrite CReal_plus_0_r in c. apply c. + apply (CReal_plus_lt_compat_l (-a)) in H. + rewrite CReal_plus_opp_l, CReal_plus_comm in H. + apply (CReal_plus_lt_compat_l (-b)) in H. rewrite <- CReal_plus_assoc in H. + rewrite CReal_plus_opp_l in H. rewrite CReal_plus_0_l in H. + rewrite CReal_plus_0_r in H. apply H. + exists (-q)%Q. split. + + destruct maj as [_ maj]. + apply (CReal_plus_lt_compat_l (-IQR q)) in maj. + rewrite CReal_plus_opp_l, <- opp_IQR, CReal_plus_comm in maj. + apply (CReal_plus_lt_compat_l a) in maj. rewrite <- CReal_plus_assoc in maj. + rewrite CReal_plus_opp_r, CReal_plus_0_l in maj. + rewrite CReal_plus_0_r in maj. apply maj. + + destruct maj as [maj _]. + apply (CReal_plus_lt_compat_l (-IQR q)) in maj. + rewrite CReal_plus_opp_l, <- opp_IQR, CReal_plus_comm in maj. + apply (CReal_plus_lt_compat_l b) in maj. rewrite <- CReal_plus_assoc in maj. + rewrite CReal_plus_opp_r in maj. rewrite CReal_plus_0_l in maj. + rewrite CReal_plus_0_r in maj. apply maj. + - apply FQ_dense_pos. apply c. apply H. +Qed. + +Definition RQ_limit : forall (x : CReal) (n:nat), + { q:Q & x < IQR q < x + IQR (1 # Pos.of_nat n) }. +Proof. + intros x n. apply (FQ_dense x (x + IQR (1 # Pos.of_nat n))). + rewrite <- (CReal_plus_0_r x). rewrite CReal_plus_assoc. + apply CReal_plus_lt_compat_l. rewrite CReal_plus_0_l. apply IQR_pos. + reflexivity. +Qed. + +Definition Un_cauchy_Q (xn : nat -> Q) : Set + := forall n : positive, + { k : nat | forall p q : nat, le k p -> le k q + -> Qlt (-(1#n)) (xn p - xn q) + /\ Qlt (xn p - xn q) (1#n) }. + +Lemma Rdiag_cauchy_sequence : forall (xn : nat -> CReal), + Un_cauchy_mod xn + -> Un_cauchy_Q (fun n => let (l,_) := RQ_limit (xn n) n in l). +Proof. + intros xn H p. specialize (H (2 * p)%positive) as [k cv]. + exists (max k (2 * Pos.to_nat p)). intros. + specialize (cv p0 q). destruct cv. + apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). + apply Nat.le_max_l. apply H. + apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). + apply Nat.le_max_l. apply H0. + split. + - apply lt_IQR. unfold Qminus. + apply (CRealLt_trans _ (xn p0 - (xn q + IQR (1 # 2 * p)))). + + unfold CReal_minus. rewrite CReal_opp_plus_distr. unfold CReal_minus. + rewrite <- CReal_plus_assoc. + apply (CReal_plus_lt_reg_r (IQR (1 # 2 * p))). + rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l. rewrite CReal_plus_0_r. + rewrite <- plus_IQR. + setoid_replace (- (1 # p) + (1 # 2 * p))%Q with (- (1 # 2 * p))%Q. + rewrite opp_IQR. exact c. + rewrite Qplus_comm. + setoid_replace (1#p)%Q with (2 # 2 *p)%Q. rewrite Qinv_minus_distr. + reflexivity. reflexivity. + + rewrite plus_IQR. apply CReal_plus_le_lt_compat. + apply CRealLt_asym. + destruct (RQ_limit (xn p0) p0); simpl. apply p1. + destruct (RQ_limit (xn q) q); unfold proj1_sig. + rewrite opp_IQR. apply CReal_opp_gt_lt_contravar. + apply (CRealLt_Le_trans _ (xn q + IQR (1 # Pos.of_nat q))). + apply p1. apply CReal_plus_le_compat_l. apply IQR_le. + apply Z2Nat.inj_le. discriminate. discriminate. + simpl. assert ((Pos.to_nat p~0 <= q)%nat). + { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). + 2: apply H0. replace (p~0)%positive with (2*p)%positive. + 2: reflexivity. rewrite Pos2Nat.inj_mul. + apply Nat.le_max_r. } + rewrite Nat2Pos.id. apply H1. intro abs. subst q. + inversion H1. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H3 in H2. inversion H2. + - apply lt_IQR. unfold Qminus. + apply (CRealLt_trans _ (xn p0 + IQR (1 # 2 * p) - xn q)). + + rewrite plus_IQR. apply CReal_plus_le_lt_compat. + apply CRealLt_asym. + destruct (RQ_limit (xn p0) p0); unfold proj1_sig. + apply (CRealLt_Le_trans _ (xn p0 + IQR (1 # Pos.of_nat p0))). + apply p1. apply CReal_plus_le_compat_l. apply IQR_le. + apply Z2Nat.inj_le. discriminate. discriminate. + simpl. assert ((Pos.to_nat p~0 <= p0)%nat). + { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). + 2: apply H. replace (p~0)%positive with (2*p)%positive. + 2: reflexivity. rewrite Pos2Nat.inj_mul. + apply Nat.le_max_r. } + rewrite Nat2Pos.id. apply H1. intro abs. subst p0. + inversion H1. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H3 in H2. inversion H2. + rewrite opp_IQR. apply CReal_opp_gt_lt_contravar. + destruct (RQ_limit (xn q) q); simpl. apply p1. + + unfold CReal_minus. rewrite (CReal_plus_comm (xn p0)). + rewrite CReal_plus_assoc. + apply (CReal_plus_lt_reg_l (- IQR (1 # 2 * p))). + rewrite <- CReal_plus_assoc. rewrite CReal_plus_opp_l. rewrite CReal_plus_0_l. + rewrite <- opp_IQR. rewrite <- plus_IQR. + setoid_replace (- (1 # 2 * p) + (1 # p))%Q with (1 # 2 * p)%Q. + exact c0. rewrite Qplus_comm. + setoid_replace (1#p)%Q with (2 # 2*p)%Q. rewrite Qinv_minus_distr. + reflexivity. reflexivity. +Qed. + +Lemma doubleLtCovariant : forall a b c d e f : CReal, + a == b -> c == d -> e == f + -> (a < c < e) + -> (b < d < f). +Proof. + split. rewrite <- H. rewrite <- H0. apply H2. + rewrite <- H0. rewrite <- H1. apply H2. +Qed. + +(* An element of CReal is a Cauchy sequence of rational numbers, + show that it converges to itself in CReal. *) +Lemma CReal_cv_self : forall (qn : nat -> Q) (x : CReal) (cvmod : positive -> nat), + QSeqEquiv qn (fun n => proj1_sig x n) cvmod + -> Un_cv_mod (fun n => IQR (qn n)) x. +Proof. + intros qn x cvmod H p. + specialize (H (2*p)%positive). exists (cvmod (2*p)%positive). + intros p0 H0. unfold absSmall, CReal_minus. + apply (doubleLtCovariant (-inject_Q (1#p)) _ (inject_Q (qn p0) - x) _ (inject_Q (1#p))). + rewrite FinjectQ_CReal. reflexivity. + rewrite FinjectQ_CReal. reflexivity. + rewrite FinjectQ_CReal. reflexivity. + apply (CReal_absSmall _ _ (Pos.max (4 * p)%positive (Pos.of_nat (cvmod (2 * p)%positive)))). + setoid_replace (proj1_sig (inject_Q (1 # p)) (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))) + with (1 # p)%Q. + 2: reflexivity. + setoid_replace (proj1_sig (CReal_plus (inject_Q (qn p0)) (CReal_opp x)) (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))) + with (qn p0 - proj1_sig x (2 * (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive)))))%nat)%Q. + 2: destruct x; reflexivity. + apply (Qle_lt_trans _ (1 # 2 * p)). + unfold Qle; simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. + rewrite <- (Qplus_lt_r + _ _ (Qabs + (qn p0 - + proj1_sig x + (2 * Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))%nat) + -(1#2*p))). + ring_simplify. + setoid_replace (-1 * (1 # 2 * p) + (1 # p))%Q with (1 # 2 * p)%Q. + apply H. apply H0. rewrite Pos2Nat.inj_max. + apply (le_trans _ (1 * Nat.max (Pos.to_nat (4 * p)) (Pos.to_nat (Pos.of_nat (cvmod (2 * p)%positive))))). + destruct (cvmod (2*p)%positive). apply le_0_n. rewrite mult_1_l. + rewrite Nat2Pos.id. 2: discriminate. apply Nat.le_max_r. + apply Nat.mul_le_mono_nonneg_r. apply le_0_n. auto. + setoid_replace (1 # p)%Q with (2 # 2 * p)%Q. + rewrite Qplus_comm. rewrite Qinv_minus_distr. + reflexivity. reflexivity. +Qed. + +Lemma Un_cv_extens : forall (xn yn : nat -> CReal) (l : CReal), + Un_cv_mod xn l + -> (forall n : nat, xn n == yn n) + -> Un_cv_mod yn l. +Proof. + intros. intro p. destruct (H p) as [n cv]. exists n. + intros. unfold absSmall, CReal_minus. + split; rewrite <- (H0 i); apply cv; apply H1. +Qed. + +(* Q is dense in Archimedean fields, so all real numbers + are limits of rational sequences. + The biggest computable such field has all rational limits. *) +Lemma R_has_all_rational_limits : forall qn : nat -> Q, + Un_cauchy_Q qn + -> { r : CReal & Un_cv_mod (fun n => IQR (qn n)) r }. +Proof. + (* qn is an element of CReal. Show that IQR qn + converges to it in CReal. *) + intros. + destruct (standard_modulus qn (fun p => proj1_sig (H p))). + - intros p n k H0 H1. destruct (H p); simpl in H0,H1. + specialize (a n k H0 H1). apply Qabs_case. + intros _. apply a. intros _. + apply (Qplus_lt_r _ _ (qn n -qn k-(1#p))). ring_simplify. + destruct a. ring_simplify in H2. exact H2. + - exists (exist _ (fun n : nat => + qn (increasing_modulus (fun p : positive => proj1_sig (H p)) n)) H0). + apply (Un_cv_extens (fun n : nat => IQR (qn n))). + apply (CReal_cv_self qn (exist _ (fun n : nat => + qn (increasing_modulus (fun p : positive => proj1_sig (H p)) n)) H0) + (fun p : positive => Init.Nat.max (proj1_sig (H p)) (Pos.to_nat p))). + apply H1. intro n. reflexivity. +Qed. + +Lemma Rcauchy_complete : forall (xn : nat -> CReal), + Un_cauchy_mod xn + -> { l : CReal & Un_cv_mod xn l }. +Proof. + intros xn cau. + destruct (R_has_all_rational_limits (fun n => let (l,_) := RQ_limit (xn n) n in l) + (Rdiag_cauchy_sequence xn cau)) + as [l cv]. + exists l. intro p. specialize (cv (2*p)%positive) as [k cv]. + exists (max k (2 * Pos.to_nat p)). intros p0 H. specialize (cv p0). + destruct cv as [H0 H1]. apply (le_trans _ (max k (2 * Pos.to_nat p))). + apply Nat.le_max_l. apply H. + destruct (RQ_limit (xn p0) p0) as [q maj]; unfold proj1_sig in H0,H1. + split. + - apply (CRealLt_trans _ (IQR q - IQR (1 # 2 * p) - l)). + + unfold CReal_minus. rewrite (CReal_plus_comm (IQR q)). + apply (CReal_plus_lt_reg_l (IQR (1 # 2 * p))). + ring_simplify. unfold CReal_minus. rewrite <- opp_IQR. rewrite <- plus_IQR. + setoid_replace ((1 # 2 * p) + - (1 # p))%Q with (-(1#2*p))%Q. + rewrite opp_IQR. apply H0. + setoid_replace (1#p)%Q with (2 # 2*p)%Q. + rewrite Qinv_minus_distr. reflexivity. reflexivity. + + unfold CReal_minus. + do 2 rewrite <- (CReal_plus_comm (-l)). apply CReal_plus_lt_compat_l. + apply (CReal_plus_lt_reg_r (IQR (1 # 2 * p))). + ring_simplify. rewrite CReal_plus_comm. + apply (CRealLt_Le_trans _ (xn p0 + IQR (1 # Pos.of_nat p0))). + apply maj. apply CReal_plus_le_compat_l. + apply IQR_le. + apply Z2Nat.inj_le. discriminate. discriminate. + simpl. assert ((Pos.to_nat p~0 <= p0)%nat). + { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). + 2: apply H. replace (p~0)%positive with (2*p)%positive. + 2: reflexivity. rewrite Pos2Nat.inj_mul. + apply Nat.le_max_r. } + rewrite Nat2Pos.id. apply H2. intro abs. subst p0. + inversion H2. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H4 in H3. inversion H3. + - apply (CRealLt_trans _ (IQR q - l)). + + unfold CReal_minus. do 2 rewrite <- (CReal_plus_comm (-l)). + apply CReal_plus_lt_compat_l. apply maj. + + apply (CRealLt_trans _ (IQR (1 # 2 * p))). + apply H1. apply IQR_lt. + rewrite <- Qplus_0_r. + setoid_replace (1#p)%Q with ((1#2*p)+(1#2*p))%Q. + apply Qplus_lt_r. reflexivity. + rewrite Qinv_plus_distr. reflexivity. +Qed. diff --git a/theories/Reals/ConstructiveReals.v b/theories/Reals/ConstructiveReals.v new file mode 100644 index 0000000000..fc3d6afe15 --- /dev/null +++ b/theories/Reals/ConstructiveReals.v @@ -0,0 +1,149 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +(* An interface for constructive and computable real numbers. + All of its instances are isomorphic, for example it contains + the Cauchy reals implemented in file ConstructivecauchyReals + and the sumbool-based Dedekind reals defined by + +Structure R := { + (* The cuts are represented as propositional functions, rather than subsets, + as there are no subsets in type theory. *) + lower : Q -> Prop; + upper : Q -> Prop; + (* The cuts respect equality on Q. *) + lower_proper : Proper (Qeq ==> iff) lower; + upper_proper : Proper (Qeq ==> iff) upper; + (* The cuts are inhabited. *) + lower_bound : { q : Q | lower q }; + upper_bound : { r : Q | upper r }; + (* The lower cut is a lower set. *) + lower_lower : forall q r, q < r -> lower r -> lower q; + (* The lower cut is open. *) + lower_open : forall q, lower q -> exists r, q < r /\ lower r; + (* The upper cut is an upper set. *) + upper_upper : forall q r, q < r -> upper q -> upper r; + (* The upper cut is open. *) + upper_open : forall r, upper r -> exists q, q < r /\ upper q; + (* The cuts are disjoint. *) + disjoint : forall q, ~ (lower q /\ upper q); + (* There is no gap between the cuts. *) + located : forall q r, q < r -> { lower q } + { upper r } +}. + + see github.com/andrejbauer/dedekind-reals for the Prop-based + version of those Dedekind reals (although Prop fails to make + them an instance of ConstructiveReals). *) + +Require Import QArith. + +Definition isLinearOrder (X : Set) (Xlt : X -> X -> Set) : Set + := (forall x y:X, Xlt x y -> Xlt y x -> False) + * (forall x y z : X, Xlt x y -> Xlt y z -> Xlt x z) + * (forall x y z : X, Xlt x z -> Xlt x y + Xlt y z). + +Definition orderEq (X : Set) (Xlt : X -> X -> Set) (x y : X) : Prop + := (Xlt x y -> False) /\ (Xlt y x -> False). + +Definition orderAppart (X : Set) (Xlt : X -> X -> Set) (x y : X) : Set + := Xlt x y + Xlt y x. + +Definition sig_forall_dec_T : Type + := forall (P : nat -> Prop), (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}. + +Definition sig_not_dec_T : Type := forall P : Prop, { ~~P } + { ~P }. + +Record ConstructiveReals : Type := + { + CRcarrier : Set; + CRlt : CRcarrier -> CRcarrier -> Set; + CRltLinear : isLinearOrder CRcarrier CRlt; + + CRltProp : CRcarrier -> CRcarrier -> Prop; + (* This choice algorithm can be slow, keep it for the classical + quotient of the reals, where computations are blocked by + axioms like LPO. *) + CRltEpsilon : forall x y : CRcarrier, CRltProp x y -> CRlt x y; + CRltForget : forall x y : CRcarrier, CRlt x y -> CRltProp x y; + CRltDisjunctEpsilon : forall a b c d : CRcarrier, + (CRltProp a b \/ CRltProp c d) -> CRlt a b + CRlt c d; + + (* Constants *) + CRzero : CRcarrier; + CRone : CRcarrier; + + (* Addition and multiplication *) + CRplus : CRcarrier -> CRcarrier -> CRcarrier; + CRopp : CRcarrier -> CRcarrier; (* Computable opposite, + stronger than Prop-existence of opposite *) + CRmult : CRcarrier -> CRcarrier -> CRcarrier; + + CRisRing : ring_theory CRzero CRone CRplus CRmult + (fun x y => CRplus x (CRopp y)) CRopp (orderEq CRcarrier CRlt); + CRisRingExt : ring_eq_ext CRplus CRmult CRopp (orderEq CRcarrier CRlt); + + (* Compatibility with order *) + CRzero_lt_one : CRlt CRzero CRone; (* 0 # 1 would only allow 0 < 1 because + of Fmult_lt_0_compat so request 0 < 1 directly. *) + CRplus_lt_compat_l : forall r r1 r2 : CRcarrier, + CRlt r1 r2 -> CRlt (CRplus r r1) (CRplus r r2); + CRplus_lt_reg_l : forall r r1 r2 : CRcarrier, + CRlt (CRplus r r1) (CRplus r r2) -> CRlt r1 r2; + CRmult_lt_0_compat : forall x y : CRcarrier, + CRlt CRzero x -> CRlt CRzero y -> CRlt CRzero (CRmult x y); + + (* A constructive total inverse function on F would need to be continuous, + which is impossible because we cannot connect plus and minus infinities. + Therefore it has to be a partial function, defined on non zero elements. + For this reason we cannot use Coq's field_theory and field tactic. + + To implement Finv by Cauchy sequences we need orderAppart, + ~orderEq is not enough. *) + CRinv : forall x : CRcarrier, orderAppart _ CRlt x CRzero -> CRcarrier; + CRinv_l : forall (r:CRcarrier) (rnz : orderAppart _ CRlt r CRzero), + orderEq _ CRlt (CRmult (CRinv r rnz) r) CRone; + CRinv_0_lt_compat : forall (r : CRcarrier) (rnz : orderAppart _ CRlt r CRzero), + CRlt CRzero r -> CRlt CRzero (CRinv r rnz); + + CRarchimedean : forall x : CRcarrier, + { k : Z & CRlt x (gen_phiZ CRzero CRone CRplus CRmult CRopp k) }; + + CRminus (x y : CRcarrier) : CRcarrier + := CRplus x (CRopp y); + CR_cv (un : nat -> CRcarrier) (l : CRcarrier) : Set + := forall eps:CRcarrier, + CRlt CRzero eps + -> { p : nat & forall i:nat, le p i -> CRlt (CRopp eps) (CRminus (un i) l) + * CRlt (CRminus (un i) l) eps }; + CR_cauchy (un : nat -> CRcarrier) : Set + := forall eps:CRcarrier, + CRlt CRzero eps + -> { p : nat & forall i j:nat, le p i -> le p j -> + CRlt (CRopp eps) (CRminus (un i) (un j)) + * CRlt (CRminus (un i) (un j)) eps }; + + CR_complete : + forall xn : nat -> CRcarrier, CR_cauchy xn -> { l : CRcarrier & CR_cv xn l }; + + (* Those are redundant, they could be proved from the previous hypotheses *) + CRis_upper_bound (E:CRcarrier -> Prop) (m:CRcarrier) + := forall x:CRcarrier, E x -> CRlt m x -> False; + + CR_sig_lub : + forall (E:CRcarrier -> Prop), + sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CRcarrier, E x) + -> (exists x : CRcarrier, CRis_upper_bound E x) + -> { u : CRcarrier | CRis_upper_bound E u /\ + forall y:CRcarrier, CRis_upper_bound E y -> CRlt y u -> False }; + }. diff --git a/theories/Reals/ConstructiveRealsLUB.v b/theories/Reals/ConstructiveRealsLUB.v new file mode 100644 index 0000000000..f5c447f7db --- /dev/null +++ b/theories/Reals/ConstructiveRealsLUB.v @@ -0,0 +1,276 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +(* Proof that LPO and the excluded middle for negations imply + the existence of least upper bounds for all non-empty and bounded + subsets of the real numbers. *) + +Require Import QArith_base. +Require Import Qabs. +Require Import ConstructiveCauchyReals. +Require Import ConstructiveRcomplete. +Require Import Logic.ConstructiveEpsilon. + +Local Open Scope CReal_scope. + +Definition sig_forall_dec_T : Type + := forall (P : nat -> Prop), (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}. + +Definition sig_not_dec_T : Type := forall P : Prop, { ~~P } + { ~P }. + +Definition is_upper_bound (E:CReal -> Prop) (m:CReal) + := forall x:CReal, E x -> x <= m. + +Definition is_lub (E:CReal -> Prop) (m:CReal) := + is_upper_bound E m /\ (forall b:CReal, is_upper_bound E b -> m <= b). + +Lemma is_upper_bound_dec : + forall (E:CReal -> Prop) (x:CReal), + sig_forall_dec_T + -> sig_not_dec_T + -> { is_upper_bound E x } + { ~is_upper_bound E x }. +Proof. + intros E x lpo sig_not_dec. + destruct (sig_not_dec (~exists y:CReal, E y /\ CRealLtProp x y)). + - left. intros y H. + destruct (CRealLt_lpo_dec x y lpo). 2: exact f. + exfalso. apply n. intro abs. apply abs. + exists y. split. exact H. destruct c. exists x0. exact q. + - right. intro abs. apply n. intros [y [H H0]]. + specialize (abs y H). apply CRealLtEpsilon in H0. contradiction. +Qed. + +Lemma is_upper_bound_epsilon : + forall (E:CReal -> Prop), + sig_forall_dec_T + -> sig_not_dec_T + -> (exists x:CReal, is_upper_bound E x) + -> { n:nat | is_upper_bound E (INR n) }. +Proof. + intros E lpo sig_not_dec Ebound. + apply constructive_indefinite_ground_description_nat. + - intro n. apply is_upper_bound_dec. exact lpo. exact sig_not_dec. + - destruct Ebound as [x H]. destruct (Rup_nat x). exists x0. + intros y ey. specialize (H y ey). + apply CRealLt_asym. apply (CRealLe_Lt_trans _ x); assumption. +Qed. + +Lemma is_upper_bound_not_epsilon : + forall E:CReal -> Prop, + sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CReal, E x) + -> { m:nat | ~is_upper_bound E (-INR m) }. +Proof. + intros E lpo sig_not_dec H. + apply constructive_indefinite_ground_description_nat. + - intro n. destruct (is_upper_bound_dec E (-INR n) lpo sig_not_dec). + right. intro abs. contradiction. left. exact n0. + - destruct H as [x H]. destruct (Rup_nat (-x)) as [n H0]. + exists n. intro abs. specialize (abs x H). + apply abs. apply (CReal_plus_lt_reg_l (INR n-x)). + ring_simplify. exact H0. +Qed. + +(* Decidable Dedekind cuts are Cauchy reals. *) +Record DedekindDecCut : Type := + { + DDupcut : Q -> Prop; + DDproper : forall q r : Q, (q == r -> DDupcut q -> DDupcut r)%Q; + DDlow : Q; + DDhigh : Q; + DDdec : forall q:Q, { DDupcut q } + { ~DDupcut q }; + DDinterval : forall q r : Q, Qle q r -> DDupcut q -> DDupcut r; + DDhighProp : DDupcut DDhigh; + DDlowProp : ~DDupcut DDlow; + }. + +Lemma DDlow_below_up : forall (upcut : DedekindDecCut) (a b : Q), + DDupcut upcut a -> ~DDupcut upcut b -> Qlt b a. +Proof. + intros. destruct (Qlt_le_dec b a). exact q. + exfalso. apply H0. apply (DDinterval upcut a). + exact q. exact H. +Qed. + +Fixpoint DDcut_limit_fix (upcut : DedekindDecCut) (r : Q) (n : nat) : + Qlt 0 r + -> (DDupcut upcut (DDlow upcut + (Z.of_nat n#1) * r)) + -> { q : Q | DDupcut upcut q /\ ~DDupcut upcut (q - r) }. +Proof. + destruct n. + - intros. exfalso. simpl in H0. + apply (DDproper upcut _ (DDlow upcut)) in H0. 2: ring. + exact (DDlowProp upcut H0). + - intros. destruct (DDdec upcut (DDlow upcut + (Z.of_nat n # 1) * r)). + + exact (DDcut_limit_fix upcut r n H d). + + exists (DDlow upcut + (Z.of_nat (S n) # 1) * r)%Q. split. + exact H0. intro abs. + apply (DDproper upcut _ (DDlow upcut + (Z.of_nat n # 1) * r)) in abs. + contradiction. + rewrite Nat2Z.inj_succ. unfold Z.succ. rewrite <- Qinv_plus_distr. + ring. +Qed. + +Lemma DDcut_limit : forall (upcut : DedekindDecCut) (r : Q), + Qlt 0 r + -> { q : Q | DDupcut upcut q /\ ~DDupcut upcut (q - r) }. +Proof. + intros. + destruct (Qarchimedean ((DDhigh upcut - DDlow upcut)/r)) as [n nmaj]. + apply (DDcut_limit_fix upcut r (Pos.to_nat n) H). + apply (Qmult_lt_r _ _ r) in nmaj. 2: exact H. + unfold Qdiv in nmaj. + rewrite <- Qmult_assoc, (Qmult_comm (/r)), Qmult_inv_r, Qmult_1_r in nmaj. + apply (DDinterval upcut (DDhigh upcut)). 2: exact (DDhighProp upcut). + apply Qlt_le_weak. apply (Qplus_lt_r _ _ (-DDlow upcut)). + rewrite Qplus_assoc, <- (Qplus_comm (DDlow upcut)), Qplus_opp_r, + Qplus_0_l, Qplus_comm. + rewrite positive_nat_Z. exact nmaj. + intros abs. rewrite abs in H. exact (Qlt_irrefl 0 H). +Qed. + +Lemma glb_dec_Q : forall upcut : DedekindDecCut, + { x : CReal | forall r:Q, (x < IQR r -> DDupcut upcut r) + /\ (IQR r < x -> ~DDupcut upcut r) }. +Proof. + intros. + assert (forall a b : Q, Qle a b -> Qle (-b) (-a)). + { intros. apply (Qplus_le_l _ _ (a+b)). ring_simplify. exact H. } + assert (QCauchySeq (fun n:nat => proj1_sig (DDcut_limit + upcut (1#Pos.of_nat n) (eq_refl _))) + Pos.to_nat). + { intros p i j pi pj. + destruct (DDcut_limit upcut (1 # Pos.of_nat i) eq_refl), + (DDcut_limit upcut (1 # Pos.of_nat j) eq_refl); unfold proj1_sig. + apply Qabs_case. intros. + apply (Qplus_lt_l _ _ (x0- (1#p))). ring_simplify. + setoid_replace (x + -1 * (1 # p))%Q with (x - (1 # p))%Q. + 2: ring. apply (Qle_lt_trans _ (x- (1#Pos.of_nat i))). + apply Qplus_le_r. apply H. + apply Z2Nat.inj_le. discriminate. discriminate. simpl. + rewrite Nat2Pos.id. exact pi. intro abs. + subst i. inversion pi. pose proof (Pos2Nat.is_pos p). + rewrite H2 in H1. inversion H1. + apply (DDlow_below_up upcut). apply a0. apply a. + intros. + apply (Qplus_lt_l _ _ (x- (1#p))). ring_simplify. + setoid_replace (x0 + -1 * (1 # p))%Q with (x0 - (1 # p))%Q. + 2: ring. apply (Qle_lt_trans _ (x0- (1#Pos.of_nat j))). + apply Qplus_le_r. apply H. + apply Z2Nat.inj_le. discriminate. discriminate. simpl. + rewrite Nat2Pos.id. exact pj. intro abs. + subst j. inversion pj. pose proof (Pos2Nat.is_pos p). + rewrite H2 in H1. inversion H1. + apply (DDlow_below_up upcut). apply a. apply a0. } + pose (exist (fun qn => QSeqEquiv qn qn Pos.to_nat) _ H0) as l. + exists l. split. + - intros. (* find an upper point between the limit and r *) + rewrite FinjectQ_CReal in H1. destruct H1 as [p pmaj]. + unfold l,proj1_sig in pmaj. + destruct (DDcut_limit upcut (1 # Pos.of_nat (Pos.to_nat p)) eq_refl) as [q qmaj] + ; simpl in pmaj. + apply (DDinterval upcut q). 2: apply qmaj. + apply (Qplus_lt_l _ _ q) in pmaj. ring_simplify in pmaj. + apply (Qle_trans _ ((2#p) + q)). + apply (Qplus_le_l _ _ (-q)). ring_simplify. discriminate. + apply Qlt_le_weak. exact pmaj. + - intros H1 abs. + rewrite FinjectQ_CReal in H1. destruct H1 as [p pmaj]. + unfold l,proj1_sig in pmaj. + destruct (DDcut_limit upcut (1 # Pos.of_nat (Pos.to_nat p)) eq_refl) as [q qmaj] + ; simpl in pmaj. + rewrite Pos2Nat.id in qmaj. + apply (Qplus_lt_r _ _ (r - (2#p))) in pmaj. ring_simplify in pmaj. + destruct qmaj. apply H2. + apply (DDinterval upcut r). 2: exact abs. + apply Qlt_le_weak, (Qlt_trans _ (-1*(2#p) + q) _ pmaj). + apply (Qplus_lt_l _ _ ((2#p) -q)). ring_simplify. + setoid_replace (-1 * (1 # p))%Q with (-(1#p))%Q. + 2: ring. rewrite Qinv_minus_distr. reflexivity. +Qed. + +Lemma is_upper_bound_glb : + forall (E:CReal -> Prop), + sig_not_dec_T + -> sig_forall_dec_T + -> (exists x : CReal, E x) + -> (exists x : CReal, is_upper_bound E x) + -> { x : CReal | forall r:Q, (x < IQR r -> is_upper_bound E (IQR r)) + /\ (IQR r < x -> ~is_upper_bound E (IQR r)) }. +Proof. + intros E sig_not_dec lpo Einhab Ebound. + destruct (is_upper_bound_epsilon E lpo sig_not_dec Ebound) as [a luba]. + destruct (is_upper_bound_not_epsilon E lpo sig_not_dec Einhab) as [b glbb]. + pose (fun q => is_upper_bound E (IQR q)) as upcut. + assert (forall q:Q, { upcut q } + { ~upcut q } ). + { intro q. apply is_upper_bound_dec. exact lpo. exact sig_not_dec. } + assert (forall q r : Q, (q <= r)%Q -> upcut q -> upcut r). + { intros. intros x Ex. specialize (H1 x Ex). intro abs. + apply H1. apply (CRealLe_Lt_trans _ (IQR r)). 2: exact abs. + apply IQR_le. exact H0. } + assert (upcut (Z.of_nat a # 1)%Q). + { intros x Ex. unfold IQR. rewrite CReal_inv_1, CReal_mult_1_r. + specialize (luba x Ex). rewrite <- INR_IZR_INZ. exact luba. } + assert (~upcut (- Z.of_nat b # 1)%Q). + { intros abs. apply glbb. intros x Ex. + specialize (abs x Ex). unfold IQR in abs. + rewrite CReal_inv_1, CReal_mult_1_r, opp_IZR, <- INR_IZR_INZ in abs. + exact abs. } + assert (forall q r : Q, (q == r)%Q -> upcut q -> upcut r). + { intros. intros x Ex. specialize (H4 x Ex). rewrite <- H3. exact H4. } + destruct (glb_dec_Q (Build_DedekindDecCut + upcut H3 (-Z.of_nat b # 1)%Q (Z.of_nat a # 1) + H H0 H1 H2)). + simpl in a0. exists x. intro r. split. + - intros. apply a0. exact H4. + - intros H6 abs. specialize (a0 r) as [_ a0]. apply a0. + exact H6. exact abs. +Qed. + +Lemma is_upper_bound_closed : + forall (E:CReal -> Prop) (sig_forall_dec : sig_forall_dec_T) + (sig_not_dec : sig_not_dec_T) + (Einhab : exists x : CReal, E x) + (Ebound : exists x : CReal, is_upper_bound E x), + is_lub + E (proj1_sig (is_upper_bound_glb + E sig_not_dec sig_forall_dec Einhab Ebound)). +Proof. + intros. split. + - intros x Ex. + destruct (is_upper_bound_glb E sig_not_dec sig_forall_dec Einhab Ebound); simpl. + intro abs. destruct (FQ_dense x0 x abs) as [q [qmaj H]]. + specialize (a q) as [a _]. specialize (a qmaj x Ex). + contradiction. + - intros. + destruct (is_upper_bound_glb E sig_not_dec sig_forall_dec Einhab Ebound); simpl. + intro abs. destruct (FQ_dense b x abs) as [q [qmaj H0]]. + specialize (a q) as [_ a]. apply a. exact H0. + intros y Ey. specialize (H y Ey). intro abs2. + apply H. exact (CRealLt_trans _ (IQR q) _ qmaj abs2). +Qed. + +Lemma sig_lub : + forall (E:CReal -> Prop), + sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CReal, E x) + -> (exists x : CReal, is_upper_bound E x) + -> { u : CReal | is_lub E u }. +Proof. + intros E sig_forall_dec sig_not_dec Einhab Ebound. + pose proof (is_upper_bound_closed E sig_forall_dec sig_not_dec Einhab Ebound). + destruct (is_upper_bound_glb + E sig_not_dec sig_forall_dec Einhab Ebound); simpl in H. + exists x. exact H. +Qed. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 51ae0baf1b..75298855b2 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -13,6 +13,7 @@ (** * Basic lemmas for the classical real numbers *) (*********************************************************) +Require Import ConstructiveRIneq. Require Export Raxioms. Require Import Rpow_def. Require Import Zpower. @@ -456,13 +457,11 @@ Qed. Lemma Rplus_eq_0_l : forall r1 r2, 0 <= r1 -> 0 <= r2 -> r1 + r2 = 0 -> r1 = 0. Proof. - intros a b H [H0| H0] H1; auto with real. - absurd (0 < a + b). - rewrite H1; auto with real. - apply Rle_lt_trans with (a + 0). - rewrite Rplus_0_r; assumption. - auto using Rplus_lt_compat_l with real. - rewrite <- H0, Rplus_0_r in H1; assumption. + intros. apply Rquot1. rewrite Rrepr_0. + apply (Rplus_eq_0_l (Rrepr r1) (Rrepr r2)). + rewrite Rrepr_le, Rrepr_0 in H. exact H. + rewrite Rrepr_le, Rrepr_0 in H0. exact H0. + rewrite <- Rrepr_plus, H1, Rrepr_0. reflexivity. Qed. Lemma Rplus_eq_R0 : @@ -542,11 +541,9 @@ Qed. (**********) Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> 0 -> r1 = r2. Proof. - intros; transitivity (/ r * r * r1). - field; trivial. - transitivity (/ r * r * r2). - repeat rewrite Rmult_assoc; rewrite H; trivial. - field; trivial. + intros. apply Rquot1. apply (Rmult_eq_reg_l (Rrepr r)). + rewrite <- Rrepr_mult, <- Rrepr_mult, H. reflexivity. + apply Rrepr_appart in H0. rewrite Rrepr_0 in H0. exact H0. Qed. Lemma Rmult_eq_reg_r : forall r r1 r2, r1 * r = r2 * r -> r <> 0 -> r1 = r2. @@ -999,19 +996,16 @@ Qed. Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. Proof. - intros; cut (- r + r + r1 < - r + r + r2). - rewrite Rplus_opp_l. - elim (Rplus_ne r1); elim (Rplus_ne r2); intros; rewrite <- H3; rewrite <- H1; - auto with zarith real. - rewrite Rplus_assoc; rewrite Rplus_assoc; - apply (Rplus_lt_compat_l (- r) (r + r1) (r + r2) H). + intros. rewrite Rlt_def. apply Rlt_forget. apply (Rplus_lt_reg_l (Rrepr r)). + rewrite <- Rrepr_plus, <- Rrepr_plus. + rewrite Rlt_def in H. apply Rlt_epsilon. exact H. Qed. Lemma Rplus_lt_reg_r : forall r r1 r2, r1 + r < r2 + r -> r1 < r2. Proof. - intros. - apply (Rplus_lt_reg_l r). - now rewrite 2!(Rplus_comm r). + intros. rewrite Rlt_def. apply Rlt_forget. apply (Rplus_lt_reg_r (Rrepr r)). + rewrite <- Rrepr_plus, <- Rrepr_plus. rewrite Rlt_def in H. + apply Rlt_epsilon. exact H. Qed. Lemma Rplus_le_reg_l : forall r r1 r2, r + r1 <= r + r2 -> r1 <= r2. @@ -1081,17 +1075,19 @@ Qed. Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. Proof. - unfold Rgt; intros. - apply (Rplus_lt_reg_l (r2 + r1)). - replace (r2 + r1 + - r1) with r2 by ring. - replace (r2 + r1 + - r2) with r1 by ring. - exact H. + intros. rewrite Rlt_def. rewrite Rrepr_opp, Rrepr_opp. + apply Rlt_forget. + apply Ropp_gt_lt_contravar. unfold Rgt in H. + rewrite Rlt_def in H. apply Rlt_epsilon. exact H. Qed. Hint Resolve Ropp_gt_lt_contravar : core. Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. Proof. - unfold Rgt; auto with real. + intros. unfold Rgt. rewrite Rlt_def. rewrite Rrepr_opp, Rrepr_opp. + apply Rlt_forget. + apply Ropp_lt_gt_contravar. rewrite Rlt_def in H. + apply Rlt_epsilon. exact H. Qed. Hint Resolve Ropp_lt_gt_contravar: real. @@ -1243,11 +1239,10 @@ Lemma Rmult_le_compat : forall r1 r2 r3 r4, 0 <= r1 -> 0 <= r3 -> r1 <= r2 -> r3 <= r4 -> r1 * r3 <= r2 * r4. Proof. - intros x y z t H' H'0 H'1 H'2. - apply Rle_trans with (r2 := x * t); auto with real. - repeat rewrite (fun x => Rmult_comm x t). - apply Rmult_le_compat_l; auto. - apply Rle_trans with z; auto. + intros. rewrite Rrepr_le, Rrepr_mult, Rrepr_mult. + apply Rmult_le_compat. rewrite <- Rrepr_0, <- Rrepr_le. exact H. + rewrite <- Rrepr_0, <- Rrepr_le. exact H0. + rewrite <- Rrepr_le. exact H1. rewrite <- Rrepr_le. exact H2. Qed. Hint Resolve Rmult_le_compat: real. @@ -1312,20 +1307,18 @@ Qed. Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. Proof. - intros z x y H H0. - case (Rtotal_order x y); intros Eq0; auto; elim Eq0; clear Eq0; intros Eq0. - rewrite Eq0 in H0; exfalso; apply (Rlt_irrefl (z * y)); auto. - generalize (Rmult_lt_compat_l z y x H Eq0); intro; exfalso; - generalize (Rlt_trans (z * x) (z * y) (z * x) H0 H1); - intro; apply (Rlt_irrefl (z * x)); auto. + intros. rewrite Rlt_def in H,H0. rewrite Rlt_def. apply Rlt_forget. + apply (Rmult_lt_reg_l (Rrepr r)). + rewrite <- Rrepr_0. apply Rlt_epsilon. exact H. + rewrite <- Rrepr_mult, <- Rrepr_mult. apply Rlt_epsilon. exact H0. Qed. Lemma Rmult_lt_reg_r : forall r r1 r2 : R, 0 < r -> r1 * r < r2 * r -> r1 < r2. Proof. - intros. - apply Rmult_lt_reg_l with r. - exact H. - now rewrite 2!(Rmult_comm r). + intros. rewrite Rlt_def. rewrite Rlt_def in H, H0. + apply Rlt_forget. apply (Rmult_lt_reg_r (Rrepr r)). + rewrite <- Rrepr_0. apply Rlt_epsilon. exact H. + rewrite <- Rrepr_mult, <- Rrepr_mult. apply Rlt_epsilon. exact H0. Qed. Lemma Rmult_gt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. @@ -1333,14 +1326,10 @@ Proof. eauto using Rmult_lt_reg_l with rorders. Qed. Lemma Rmult_le_reg_l : forall r r1 r2, 0 < r -> r * r1 <= r * r2 -> r1 <= r2. Proof. - intros z x y H H0; case H0; auto with real. - intros H1; apply Rlt_le. - apply Rmult_lt_reg_l with (r := z); auto. - intros H1; replace x with (/ z * (z * x)); auto with real. - replace y with (/ z * (z * y)). - rewrite H1; auto with real. - rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. - rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real. + intros. rewrite Rrepr_le. rewrite Rlt_def in H. apply (Rmult_le_reg_l (Rrepr r)). + rewrite <- Rrepr_0. apply Rlt_epsilon. exact H. + rewrite <- Rrepr_mult, <- Rrepr_mult. + rewrite <- Rrepr_le. exact H0. Qed. Lemma Rmult_le_reg_r : forall r r1 r2, 0 < r -> r1 * r <= r2 * r -> r1 <= r2. @@ -1522,7 +1511,7 @@ Qed. Lemma Rinv_1_lt_contravar : forall r1 r2, 1 <= r1 -> r1 < r2 -> / r2 < / r1. Proof. - intros x y H' H'0. + intros x y H' H'0. cut (0 < x); [ intros Lt0 | apply Rlt_le_trans with (r2 := 1) ]; auto with real. apply Rmult_lt_reg_l with (r := x); auto with real. @@ -1585,11 +1574,9 @@ Qed. (**********) Lemma plus_INR : forall n m:nat, INR (n + m) = INR n + INR m. Proof. - intros n m; induction n as [| n Hrecn]. - simpl; auto with real. - replace (S n + m)%nat with (S (n + m)); auto with arith. - repeat rewrite S_INR. - rewrite Hrecn; ring. + intros. apply Rquot1. + rewrite Rrepr_INR, Rrepr_plus, plus_INR, + <- Rrepr_INR, <- Rrepr_INR. reflexivity. Qed. Hint Resolve plus_INR: real. @@ -1658,16 +1645,8 @@ Hint Resolve pos_INR: real. Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat. Proof. - intros n m. revert n. - induction m ; intros n H. - - elim (Rlt_irrefl 0). - apply Rle_lt_trans with (2 := H). - apply pos_INR. - - destruct n as [|n]. - apply Nat.lt_0_succ. - apply lt_n_S, IHm. - rewrite 2!S_INR in H. - apply Rplus_lt_reg_r with (1 := H). + intros. apply INR_lt. rewrite Rlt_def in H. + rewrite Rrepr_INR, Rrepr_INR in H. apply Rlt_epsilon. exact H. Qed. Hint Resolve INR_lt: real. @@ -1701,11 +1680,8 @@ Hint Resolve not_0_INR: real. Lemma not_INR : forall n m:nat, n <> m -> INR n <> INR m. Proof. - intros n m H; case (le_or_lt n m); intros H1. - case (le_lt_or_eq _ _ H1); intros H2. - apply Rlt_dichotomy_converse; auto with real. - exfalso; auto. - apply not_eq_sym; apply Rlt_dichotomy_converse; auto with real. + intros. apply Rappart_repr. rewrite Rrepr_INR, Rrepr_INR. + apply not_INR. exact H. Qed. Hint Resolve not_INR: real. @@ -1746,17 +1722,8 @@ Qed. Lemma INR_IPR : forall p, INR (Pos.to_nat p) = IPR p. Proof. - assert (H: forall p, 2 * INR (Pos.to_nat p) = IPR_2 p). - induction p as [p|p|] ; simpl IPR_2. - rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp. - now rewrite (Rplus_comm (2 * _)). - now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. - apply Rmult_1_r. - intros [p|p|] ; unfold IPR. - rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. - apply Rplus_comm. - now rewrite Pos2Nat.inj_xO, mult_INR, <- H. - easy. + intros. apply Rquot1. rewrite Rrepr_INR, Rrepr_IPR. + apply INR_IPR. Qed. (**********) @@ -1771,26 +1738,15 @@ Qed. Lemma plus_IZR_NEG_POS : forall p q:positive, IZR (Zpos p + Zneg q) = IZR (Zpos p) + IZR (Zneg q). Proof. - intros p q; simpl. rewrite Z.pos_sub_spec. - case Pos.compare_spec; intros H; unfold IZR. - subst. ring. - rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial. - rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt). - ring. - rewrite <- 3!INR_IPR, Pos2Nat.inj_sub by trivial. - rewrite minus_INR by (now apply lt_le_weak, Pos2Nat.inj_lt). - ring. + intros. apply Rquot1. rewrite Rrepr_plus. + do 3 rewrite Rrepr_IZR. apply plus_IZR_NEG_POS. Qed. (**********) Lemma plus_IZR : forall n m:Z, IZR (n + m) = IZR n + IZR m. Proof. - intro z; destruct z; intro t; destruct t; intros; auto with real. - simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add. apply plus_INR. - apply plus_IZR_NEG_POS. - rewrite Z.add_comm; rewrite Rplus_comm; apply plus_IZR_NEG_POS. - simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR. - apply Ropp_plus_distr. + intros. apply Rquot1. + rewrite Rrepr_plus. do 3 rewrite Rrepr_IZR. apply plus_IZR. Qed. (**********) @@ -1800,14 +1756,21 @@ Proof. unfold IZR; intros m n; rewrite <- 3!INR_IPR, Pos2Nat.inj_mul, mult_INR; ring. Qed. +Lemma Rrepr_pow : forall (x : R) (n : nat), + (ConstructiveRIneq.Req (Rrepr (pow x n)) + (ConstructiveRIneq.pow (Rrepr x) n)). +Proof. + intro x. induction n. + - apply Rrepr_1. + - simpl. rewrite Rrepr_mult, <- IHn. reflexivity. +Qed. + Lemma pow_IZR : forall z n, pow (IZR z) n = IZR (Z.pow z (Z.of_nat n)). Proof. - intros z [|n];simpl;trivial. - rewrite Zpower_pos_nat. - rewrite SuccNat2Pos.id_succ. unfold Zpower_nat;simpl. - rewrite mult_IZR. - induction n;simpl;trivial. - rewrite mult_IZR;ring[IHn]. + intros. apply Rquot1. + rewrite Rrepr_IZR, Rrepr_pow. + rewrite (Rpow_eq_compat _ _ n (Rrepr_IZR z)). + apply pow_IZR. Qed. (**********) @@ -1841,34 +1804,23 @@ Qed. (**********) Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. Proof. - intro z; case z; simpl; intros. - elim (Rlt_irrefl _ H). - easy. - elim (Rlt_not_le _ _ H). - unfold IZR. - rewrite <- INR_IPR. - auto with real. + intros. apply lt_0_IZR. rewrite <- Rrepr_0, <- Rrepr_IZR. + rewrite Rlt_def in H. apply Rlt_epsilon. exact H. Qed. (**********) Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z. Proof. - intros z1 z2 H; apply Z.lt_0_sub. - apply lt_0_IZR. - rewrite <- Z_R_minus. - exact (Rgt_minus (IZR z2) (IZR z1) H). + intros. apply lt_IZR. + rewrite <- Rrepr_IZR, <- Rrepr_IZR. rewrite Rlt_def in H. + apply Rlt_epsilon. exact H. Qed. (**********) Lemma eq_IZR_R0 : forall n:Z, IZR n = 0 -> n = 0%Z. Proof. - intro z; destruct z; simpl; intros; auto with zarith. - elim Rgt_not_eq with (2 := H). - unfold IZR. rewrite <- INR_IPR. - apply lt_0_INR, Pos2Nat.is_pos. - elim Rlt_not_eq with (2 := H). - unfold IZR. rewrite <- INR_IPR. - apply Ropp_lt_gt_0_contravar, lt_0_INR, Pos2Nat.is_pos. + intros. apply eq_IZR_R0. + rewrite <- Rrepr_0, <- Rrepr_IZR, H. reflexivity. Qed. (**********) @@ -1944,26 +1896,21 @@ Hint Extern 0 (IZR _ <> IZR _) => apply IZR_neq, Zeq_bool_neq, eq_refl : real. Lemma one_IZR_lt1 : forall n:Z, -1 < IZR n < 1 -> n = 0%Z. Proof. - intros z [H1 H2]. - apply Z.le_antisymm. - apply Z.lt_succ_r; apply lt_IZR; trivial. - change 0%Z with (Z.succ (-1)). - apply Z.le_succ_l; apply lt_IZR; trivial. + intros. apply one_IZR_lt1. do 2 rewrite Rlt_def in H. split. + rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_opp. + apply Rlt_epsilon. apply H. + rewrite <- Rrepr_IZR, <- Rrepr_1. apply Rlt_epsilon. apply H. Qed. Lemma one_IZR_r_R1 : forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m. Proof. - intros r z x [H1 H2] [H3 H4]. - cut ((z - x)%Z = 0%Z); auto with zarith. - apply one_IZR_lt1. - rewrite <- Z_R_minus; split. - replace (-1) with (r - (r + 1)). - unfold Rminus; apply Rplus_lt_le_compat; auto with real. - ring. - replace 1 with (r + 1 - r). - unfold Rminus; apply Rplus_le_lt_compat; auto with real. - ring. + intros. rewrite Rlt_def in H, H0. apply (one_IZR_r_R1 (Rrepr r)); split. + rewrite <- Rrepr_IZR. apply Rlt_epsilon. apply H. + rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_plus, <- Rrepr_le. + apply H. rewrite <- Rrepr_IZR. apply Rlt_epsilon. apply H0. + rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_plus, <- Rrepr_le. + apply H0. Qed. @@ -1996,13 +1943,13 @@ Qed. Lemma Rinv_le_contravar : forall x y, 0 < x -> x <= y -> / y <= / x. Proof. - intros x y H1 [H2|H2]. - apply Rlt_le. - apply Rinv_lt_contravar with (2 := H2). - apply Rmult_lt_0_compat with (1 := H1). - now apply Rlt_trans with x. - rewrite H2. - apply Rle_refl. + intros. apply Rrepr_le. assert (y <> 0). + intro abs. subst y. apply (Rlt_irrefl 0). exact (Rlt_le_trans 0 x 0 H H0). + apply Rrepr_appart in H1. + rewrite Rrepr_0 in H1. rewrite Rlt_def in H. rewrite Rrepr_0 in H. + apply Rlt_epsilon in H. + rewrite (Rrepr_inv y H1), (Rrepr_inv x (inr H)). + apply Rinv_le_contravar. rewrite <- Rrepr_le. exact H0. Qed. Lemma Rle_Rinv : forall x y:R, 0 < x -> 0 < y -> x <= y -> / y <= / x. @@ -2066,18 +2013,10 @@ Qed. Lemma le_epsilon : forall r1 r2, (forall eps:R, 0 < eps -> r1 <= r2 + eps) -> r1 <= r2. Proof. - intros x y H. - destruct (Rle_or_lt x y) as [H1|H1]. - exact H1. - apply Rplus_le_reg_r with x. - replace (y + x) with (2 * (y + (x - y) * / 2)) by field. - replace (x + x) with (2 * x) by ring. - apply Rmult_le_compat_l. - now apply (IZR_le 0 2). - apply H. - apply Rmult_lt_0_compat. - now apply Rgt_minus. - apply Rinv_0_lt_compat, Rlt_0_2. + intros. rewrite Rrepr_le. apply le_epsilon. + intros. rewrite <- (Rquot2 eps), <- Rrepr_plus. + rewrite <- Rrepr_le. apply H. rewrite Rlt_def. + rewrite Rquot2, Rrepr_0. apply Rlt_forget. exact H0. Qed. (**********) @@ -2089,7 +2028,7 @@ Proof. Qed. Lemma Rdiv_lt_0_compat : forall a b, 0 < a -> 0 < b -> 0 < a/b. -Proof. +Proof. intros; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat]; assumption. Qed. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 0d29e821c6..f03b0ccea3 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -8,37 +8,138 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* This file continues Rdefinitions, with more properties of the + classical reals, including the existence of least upper bounds + for non-empty and bounded subsets. + The name "Raxioms" and its contents are kept for backward compatibility, + when the classical reals were axiomatized. Otherwise we would + have merged this file into RIneq. *) + (*********************************************************) -(** Axiomatisation of the classical reals *) +(** Lifts of basic operations for classical reals *) (*********************************************************) Require Export ZArith_base. +Require Import ConstructiveRIneq. Require Export Rdefinitions. Declare Scope R_scope. Local Open Scope R_scope. (*********************************************************) -(** * Field axioms *) +(** * Field operations *) (*********************************************************) (*********************************************************) (** ** Addition *) (*********************************************************) +Open Scope R_scope_constr. + +Lemma Rrepr_0 : Rrepr 0 == 0. +Proof. + intros. unfold IZR. rewrite RbaseSymbolsImpl.R0_def, (Rquot2 0). reflexivity. +Qed. + +Lemma Rrepr_1 : Rrepr 1 == 1. +Proof. + intros. unfold IZR, IPR. rewrite RbaseSymbolsImpl.R1_def, (Rquot2 1). reflexivity. +Qed. + +Lemma Rrepr_plus : forall x y:R, Rrepr (x + y) == Rrepr x + Rrepr y. +Proof. + intros. rewrite RbaseSymbolsImpl.Rplus_def, Rquot2. reflexivity. +Qed. + +Lemma Rrepr_opp : forall x:R, Rrepr (- x) == - Rrepr x. +Proof. + intros. rewrite RbaseSymbolsImpl.Ropp_def, Rquot2. reflexivity. +Qed. + +Lemma Rrepr_minus : forall x y:R, Rrepr (x - y) == Rrepr x - Rrepr y. +Proof. + intros. unfold Rminus, CRminus. + rewrite Rrepr_plus, Rrepr_opp. reflexivity. +Qed. + +Lemma Rrepr_mult : forall x y:R, Rrepr (x * y) == Rrepr x * Rrepr y. +Proof. + intros. rewrite RbaseSymbolsImpl.Rmult_def. rewrite Rquot2. reflexivity. +Qed. + +Lemma Rrepr_inv : forall (x:R) (xnz : Rrepr x # 0), + Rrepr (/ x) == (/ Rrepr x) xnz. +Proof. + intros. rewrite RinvImpl.Rinv_def. destruct (Req_appart_dec x R0). + - exfalso. subst x. destruct xnz. + rewrite Rrepr_0 in c. exact (Rlt_irrefl 0 c). + rewrite Rrepr_0 in c. exact (Rlt_irrefl 0 c). + - rewrite Rquot2. apply (Rmult_eq_reg_l (Rrepr x)). 2: exact xnz. + rewrite Rmult_comm, (Rmult_comm (Rrepr x)), Rinv_l, Rinv_l. + reflexivity. +Qed. + +Lemma Rrepr_le : forall x y:R, (x <= y)%R <-> Rrepr x <= Rrepr y. +Proof. + split. + - intros [H|H] abs. rewrite RbaseSymbolsImpl.Rlt_def in H. + apply Rlt_epsilon in H. + exact (Rlt_asym (Rrepr x) (Rrepr y) H abs). + destruct H. exact (Rlt_asym (Rrepr x) (Rrepr x) abs abs). + - intros. destruct (total_order_T x y). destruct s. + left. exact r. right. exact e. + rewrite RbaseSymbolsImpl.Rlt_def in r. apply Rlt_epsilon in r. contradiction. +Qed. + +Lemma Rrepr_appart : forall x y:R, + (x <> y)%R -> Rrepr x # Rrepr y. +Proof. + intros. destruct (total_order_T x y). destruct s. + left. rewrite RbaseSymbolsImpl.Rlt_def in r. + apply Rlt_epsilon. exact r. contradiction. + right. rewrite RbaseSymbolsImpl.Rlt_def in r. + apply Rlt_epsilon. exact r. +Qed. + +Lemma Rappart_repr : forall x y:R, + Rrepr x # Rrepr y -> (x <> y)%R. +Proof. + intros x y [H|H] abs. + destruct abs. exact (Rlt_asym (Rrepr x) (Rrepr x) H H). + destruct abs. exact (Rlt_asym (Rrepr x) (Rrepr x) H H). +Qed. + +Close Scope R_scope_constr. + + (**********) -Axiom Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1. +Lemma Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1. +Proof. + intros. apply Rquot1. do 2 rewrite Rrepr_plus. apply Rplus_comm. +Qed. Hint Resolve Rplus_comm: real. (**********) -Axiom Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 = r1 + (r2 + r3). +Lemma Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 = r1 + (r2 + r3). +Proof. + intros. apply Rquot1. repeat rewrite Rrepr_plus. + apply Rplus_assoc. +Qed. Hint Resolve Rplus_assoc: real. (**********) -Axiom Rplus_opp_r : forall r:R, r + - r = 0. +Lemma Rplus_opp_r : forall r:R, r + - r = 0. +Proof. + intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_opp, Rrepr_0. + apply Rplus_opp_r. +Qed. Hint Resolve Rplus_opp_r: real. (**********) -Axiom Rplus_0_l : forall r:R, 0 + r = r. +Lemma Rplus_0_l : forall r:R, 0 + r = r. +Proof. + intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_0. + apply Rplus_0_l. +Qed. Hint Resolve Rplus_0_l: real. (***********************************************************) @@ -46,23 +147,53 @@ Hint Resolve Rplus_0_l: real. (***********************************************************) (**********) -Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. +Lemma Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. +Proof. + intros. apply Rquot1. do 2 rewrite Rrepr_mult. apply Rmult_comm. +Qed. Hint Resolve Rmult_comm: real. (**********) -Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3). +Lemma Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3). +Proof. + intros. apply Rquot1. repeat rewrite Rrepr_mult. + apply Rmult_assoc. +Qed. Hint Resolve Rmult_assoc: real. (**********) -Axiom Rinv_l : forall r:R, r <> 0 -> / r * r = 1. +Lemma Rinv_l : forall r:R, r <> 0 -> / r * r = 1. +Proof. + intros. rewrite RinvImpl.Rinv_def; destruct (Req_appart_dec r R0). + - contradiction. + - apply Rquot1. rewrite Rrepr_mult, Rquot2, Rrepr_1. apply Rinv_l. +Qed. Hint Resolve Rinv_l: real. (**********) -Axiom Rmult_1_l : forall r:R, 1 * r = r. +Lemma Rmult_1_l : forall r:R, 1 * r = r. +Proof. + intros. apply Rquot1. rewrite Rrepr_mult, Rrepr_1. + apply Rmult_1_l. +Qed. Hint Resolve Rmult_1_l: real. (**********) -Axiom R1_neq_R0 : 1 <> 0. +Lemma R1_neq_R0 : 1 <> 0. +Proof. + intro abs. + assert (Req (CRone CR) (CRzero CR)). + { transitivity (Rrepr 1). symmetry. + replace 1%R with (Rabst (CRone CR)). + 2: unfold IZR,IPR; rewrite RbaseSymbolsImpl.R1_def; reflexivity. + rewrite Rquot2. reflexivity. transitivity (Rrepr 0). + rewrite abs. reflexivity. + replace 0%R with (Rabst (CRzero CR)). + 2: unfold IZR; rewrite RbaseSymbolsImpl.R0_def; reflexivity. + rewrite Rquot2. reflexivity. } + pose proof (Rlt_morph (CRzero CR) (CRzero CR) (Req_refl _) (CRone CR) (CRzero CR) H). + apply (Rlt_irrefl (CRzero CR)). apply H0. apply Rlt_0_1. +Qed. Hint Resolve R1_neq_R0: real. (*********************************************************) @@ -70,36 +201,57 @@ Hint Resolve R1_neq_R0: real. (*********************************************************) (**********) -Axiom +Lemma Rmult_plus_distr_l : forall r1 r2 r3:R, r1 * (r2 + r3) = r1 * r2 + r1 * r3. +Proof. + intros. apply Rquot1. + rewrite Rrepr_mult, Rrepr_plus, Rrepr_plus, Rrepr_mult, Rrepr_mult. + apply Rmult_plus_distr_l. +Qed. Hint Resolve Rmult_plus_distr_l: real. (*********************************************************) -(** * Order axioms *) -(*********************************************************) -(*********************************************************) -(** ** Total Order *) +(** * Order *) (*********************************************************) -(**********) -Axiom total_order_T : forall r1 r2:R, {r1 < r2} + {r1 = r2} + {r1 > r2}. - (*********************************************************) (** ** Lower *) (*********************************************************) (**********) -Axiom Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1. +Lemma Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1. +Proof. + intros. intro abs. rewrite RbaseSymbolsImpl.Rlt_def in H, abs. + apply Rlt_epsilon in H. apply Rlt_epsilon in abs. + apply (Rlt_asym (Rrepr r1) (Rrepr r2)); assumption. +Qed. (**********) -Axiom Rlt_trans : forall r1 r2 r3:R, r1 < r2 -> r2 < r3 -> r1 < r3. +Lemma Rlt_trans : forall r1 r2 r3:R, r1 < r2 -> r2 < r3 -> r1 < r3. +Proof. + intros. rewrite RbaseSymbolsImpl.Rlt_def. rewrite RbaseSymbolsImpl.Rlt_def in H, H0. + apply Rlt_epsilon in H. apply Rlt_epsilon in H0. + apply Rlt_forget. + apply (Rlt_trans (Rrepr r1) (Rrepr r2) (Rrepr r3)); assumption. +Qed. (**********) -Axiom Rplus_lt_compat_l : forall r r1 r2:R, r1 < r2 -> r + r1 < r + r2. +Lemma Rplus_lt_compat_l : forall r r1 r2:R, r1 < r2 -> r + r1 < r + r2. +Proof. + intros. rewrite RbaseSymbolsImpl.Rlt_def. rewrite RbaseSymbolsImpl.Rlt_def in H. + do 2 rewrite Rrepr_plus. apply Rlt_forget. + apply Rplus_lt_compat_l. apply Rlt_epsilon. exact H. +Qed. (**********) -Axiom - Rmult_lt_compat_l : forall r r1 r2:R, 0 < r -> r1 < r2 -> r * r1 < r * r2. +Lemma Rmult_lt_compat_l : forall r r1 r2:R, 0 < r -> r1 < r2 -> r * r1 < r * r2. +Proof. + intros. rewrite RbaseSymbolsImpl.Rlt_def. rewrite RbaseSymbolsImpl.Rlt_def in H. + do 2 rewrite Rrepr_mult. apply Rlt_forget. apply Rmult_lt_compat_l. + rewrite <- (Rquot2 (CRzero CR)). unfold IZR in H. + rewrite RbaseSymbolsImpl.R0_def in H. apply Rlt_epsilon. exact H. + rewrite RbaseSymbolsImpl.Rlt_def in H0. apply Rlt_epsilon. exact H0. +Qed. Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. @@ -116,13 +268,125 @@ Fixpoint INR (n:nat) : R := end. Arguments INR n%nat. - (**********************************************************) (** * [R] Archimedean *) (**********************************************************) +Lemma Rrepr_INR : forall n : nat, + Req (Rrepr (INR n)) (ConstructiveRIneq.INR n). +Proof. + induction n. + - apply Rrepr_0. + - simpl. destruct n. apply Rrepr_1. + rewrite Rrepr_plus, <- IHn, Rrepr_1. reflexivity. +Qed. + +Lemma Rrepr_IPR2 : forall n : positive, + Req (Rrepr (IPR_2 n)) (ConstructiveRIneq.IPR_2 n). +Proof. + induction n. + - unfold IPR_2, ConstructiveRIneq.IPR_2. + rewrite RbaseSymbolsImpl.R1_def, Rrepr_mult, Rrepr_plus, Rrepr_plus, <- IHn. + unfold IPR_2. + rewrite Rquot2. rewrite RbaseSymbolsImpl.R1_def. reflexivity. + - unfold IPR_2, ConstructiveRIneq.IPR_2. + rewrite Rrepr_mult, Rrepr_plus, <- IHn. + rewrite RbaseSymbolsImpl.R1_def. rewrite Rquot2. + unfold IPR_2. rewrite RbaseSymbolsImpl.R1_def. reflexivity. + - unfold IPR_2, ConstructiveRIneq.IPR_2. + rewrite RbaseSymbolsImpl.R1_def. + rewrite Rrepr_plus, Rquot2. reflexivity. +Qed. + +Lemma Rrepr_IPR : forall n : positive, + Req (Rrepr (IPR n)) (ConstructiveRIneq.IPR n). +Proof. + intro n. destruct n. + - unfold IPR, ConstructiveRIneq.IPR. + rewrite Rrepr_plus, <- Rrepr_IPR2. + rewrite RbaseSymbolsImpl.R1_def. rewrite Rquot2. reflexivity. + - unfold IPR, ConstructiveRIneq.IPR. + apply Rrepr_IPR2. + - unfold IPR. rewrite RbaseSymbolsImpl.R1_def. apply Rquot2. +Qed. + +Lemma Rrepr_IZR : forall n : Z, + Req (Rrepr (IZR n)) (ConstructiveRIneq.IZR n). +Proof. + intros [|p|n]. + - unfold IZR. rewrite RbaseSymbolsImpl.R0_def. apply Rquot2. + - apply Rrepr_IPR. + - unfold IZR, ConstructiveRIneq.IZR. + rewrite <- Rrepr_IPR, Rrepr_opp. reflexivity. +Qed. + (**********) -Axiom archimed : forall r:R, IZR (up r) > r /\ IZR (up r) - r <= 1. +Lemma archimed : forall r:R, IZR (up r) > r /\ IZR (up r) - r <= 1. +Proof. + intro r. unfold up. + destruct (Rarchimedean (Rrepr r)) as [n nmaj], (total_order_T (IZR n - r) R1). + destruct s. + - split. unfold Rgt. rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_IZR. + apply Rlt_forget. apply nmaj. + unfold Rle. left. exact r0. + - split. unfold Rgt. rewrite RbaseSymbolsImpl.Rlt_def. + rewrite Rrepr_IZR. apply Rlt_forget. apply nmaj. right. exact e. + - split. + + unfold Rgt, Z.pred. rewrite RbaseSymbolsImpl.Rlt_def. + rewrite Rrepr_IZR, plus_IZR. + rewrite RbaseSymbolsImpl.Rlt_def in r0. rewrite Rrepr_minus in r0. + rewrite <- (Rrepr_IZR n). + unfold ConstructiveRIneq.IZR, ConstructiveRIneq.IPR. + apply Rlt_forget. apply Rlt_epsilon in r0. + unfold ConstructiveRIneq.Rminus in r0. + apply (ConstructiveRIneq.Rplus_lt_compat_l + (ConstructiveRIneq.Rplus (Rrepr r) (ConstructiveRIneq.Ropp (Rrepr R1)))) + in r0. + rewrite ConstructiveRIneq.Rplus_assoc, + ConstructiveRIneq.Rplus_opp_l, + ConstructiveRIneq.Rplus_0_r, + RbaseSymbolsImpl.R1_def, Rquot2, + ConstructiveRIneq.Rplus_comm, + ConstructiveRIneq.Rplus_assoc, + <- (ConstructiveRIneq.Rplus_assoc (ConstructiveRIneq.Ropp (Rrepr r))), + ConstructiveRIneq.Rplus_opp_l, + ConstructiveRIneq.Rplus_0_l + in r0. + exact r0. + + destruct (total_order_T (IZR (Z.pred n) - r) 1). destruct s. + left. exact r1. right. exact e. + exfalso. destruct nmaj as [_ nmaj]. rewrite <- Rrepr_IZR in nmaj. + apply (Rlt_asym (IZR n) (r + 2)). + rewrite RbaseSymbolsImpl.Rlt_def. rewrite Rrepr_plus. rewrite (Rrepr_plus 1 1). + apply Rlt_forget. + apply (ConstructiveRIneq.Rlt_le_trans + _ (ConstructiveRIneq.Rplus (Rrepr r) (ConstructiveRIneq.IZR 2))). + apply nmaj. + unfold IZR, IPR. rewrite RbaseSymbolsImpl.R1_def, Rquot2. apply Rle_refl. + clear nmaj. + unfold Z.pred in r1. rewrite RbaseSymbolsImpl.Rlt_def in r1. + rewrite Rrepr_minus, (Rrepr_IZR (n + -1)), plus_IZR, + <- (Rrepr_IZR n) + in r1. + unfold ConstructiveRIneq.IZR, ConstructiveRIneq.IPR in r1. + rewrite RbaseSymbolsImpl.Rlt_def, Rrepr_plus. + apply Rlt_epsilon in r1. + apply (ConstructiveRIneq.Rplus_lt_compat_l + (ConstructiveRIneq.Rplus (Rrepr r) (CRone CR))) in r1. + apply Rlt_forget. + apply (ConstructiveRIneq.Rle_lt_trans + _ (ConstructiveRIneq.Rplus (ConstructiveRIneq.Rplus (Rrepr r) (Rrepr 1)) (CRone CR))). + rewrite (Rrepr_plus 1 1). unfold IZR, IPR. + rewrite RbaseSymbolsImpl.R1_def, (Rquot2 (CRone CR)), <- ConstructiveRIneq.Rplus_assoc. + apply Rle_refl. + rewrite <- (ConstructiveRIneq.Rplus_comm (Rrepr 1)), + <- ConstructiveRIneq.Rplus_assoc, + (ConstructiveRIneq.Rplus_comm (Rrepr 1)) + in r1. + apply (ConstructiveRIneq.Rlt_le_trans _ _ _ r1). + unfold ConstructiveRIneq.Rminus. + ring_simplify. apply ConstructiveRIneq.Rle_refl. +Qed. (**********************************************************) (** * [R] Complete *) @@ -139,7 +403,30 @@ Definition is_lub (E:R -> Prop) (m:R) := is_upper_bound E m /\ (forall b:R, is_upper_bound E b -> m <= b). (**********) -Axiom - completeness : +Lemma completeness : forall E:R -> Prop, bound E -> (exists x : R, E x) -> { m:R | is_lub E m }. +Proof. + intros. pose (fun x:ConstructiveRIneq.R => E (Rabst x)) as Er. + assert (exists x : ConstructiveRIneq.R, Er x) as Einhab. + { destruct H0. exists (Rrepr x). unfold Er. + replace (Rabst (Rrepr x)) with x. exact H0. + apply Rquot1. rewrite Rquot2. reflexivity. } + assert (exists x : ConstructiveRIneq.R, + (forall y:ConstructiveRIneq.R, Er y -> ConstructiveRIneq.Rle y x)) + as Ebound. + { destruct H. exists (Rrepr x). intros y Ey. rewrite <- (Rquot2 y). + apply Rrepr_le. apply H. exact Ey. } + destruct (CR_sig_lub CR + Er sig_forall_dec sig_not_dec Einhab Ebound). + exists (Rabst x). split. + intros y Ey. apply Rrepr_le. rewrite Rquot2. + unfold ConstructiveRIneq.Rle. apply a. + unfold Er. replace (Rabst (Rrepr y)) with y. exact Ey. + apply Rquot1. rewrite Rquot2. reflexivity. + intros. destruct a. apply Rrepr_le. rewrite Rquot2. + unfold ConstructiveRIneq.Rle. apply H3. intros y Ey. + intros. rewrite <- (Rquot2 y) in H4. + apply Rrepr_le in H4. exact H4. + apply H1, Ey. +Qed. diff --git a/theories/Reals/Rdefinitions.v b/theories/Reals/Rdefinitions.v index bb32000841..b1ce8109ca 100644 --- a/theories/Reals/Rdefinitions.v +++ b/theories/Reals/Rdefinitions.v @@ -8,11 +8,15 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(*********************************************************) -(** Definitions for the axiomatization *) -(*********************************************************) +(* Classical quotient of the constructive Cauchy real numbers. + This file contains the definition of the classical real numbers + type R, its algebraic operations, its order and the proof that + it is total, and the proof that R is archimedean (up). + It also defines IZR, the ring morphism from Z to R. *) Require Export ZArith_base. +Require Import QArith_base. +Require Import ConstructiveRIneq. Parameter R : Set. @@ -28,19 +32,72 @@ Bind Scope R_scope with R. Local Open Scope R_scope. -Parameter R0 : R. -Parameter R1 : R. -Parameter Rplus : R -> R -> R. -Parameter Rmult : R -> R -> R. -Parameter Ropp : R -> R. -Parameter Rinv : R -> R. -Parameter Rlt : R -> R -> Prop. -Parameter up : R -> Z. +(* The limited principle of omniscience *) +Axiom sig_forall_dec + : forall (P : nat -> Prop), + (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}. + +Axiom sig_not_dec : forall P : Prop, { ~~P } + { ~P }. + +Axiom Rabst : ConstructiveRIneq.R -> R. +Axiom Rrepr : R -> ConstructiveRIneq.R. +Axiom Rquot1 : forall x y:R, Req (Rrepr x) (Rrepr y) -> x = y. +Axiom Rquot2 : forall x:ConstructiveRIneq.R, Req (Rrepr (Rabst x)) x. + +(* Those symbols must be kept opaque, for backward compatibility. *) +Module Type RbaseSymbolsSig. + Parameter R0 : R. + Parameter R1 : R. + Parameter Rplus : R -> R -> R. + Parameter Rmult : R -> R -> R. + Parameter Ropp : R -> R. + Parameter Rlt : R -> R -> Prop. + + Parameter R0_def : R0 = Rabst (CRzero CR). + Parameter R1_def : R1 = Rabst (CRone CR). + Parameter Rplus_def : forall x y : R, + Rplus x y = Rabst (ConstructiveRIneq.Rplus (Rrepr x) (Rrepr y)). + Parameter Rmult_def : forall x y : R, + Rmult x y = Rabst (ConstructiveRIneq.Rmult (Rrepr x) (Rrepr y)). + Parameter Ropp_def : forall x : R, + Ropp x = Rabst (ConstructiveRIneq.Ropp (Rrepr x)). + Parameter Rlt_def : forall x y : R, + Rlt x y = ConstructiveRIneq.RltProp (Rrepr x) (Rrepr y). +End RbaseSymbolsSig. + +Module RbaseSymbolsImpl : RbaseSymbolsSig. + Definition R0 : R := Rabst (CRzero CR). + Definition R1 : R := Rabst (CRone CR). + Definition Rplus : R -> R -> R + := fun x y : R => Rabst (ConstructiveRIneq.Rplus (Rrepr x) (Rrepr y)). + Definition Rmult : R -> R -> R + := fun x y : R => Rabst (ConstructiveRIneq.Rmult (Rrepr x) (Rrepr y)). + Definition Ropp : R -> R + := fun x : R => Rabst (ConstructiveRIneq.Ropp (Rrepr x)). + Definition Rlt : R -> R -> Prop + := fun x y : R => ConstructiveRIneq.RltProp (Rrepr x) (Rrepr y). + + Definition R0_def := eq_refl R0. + Definition R1_def := eq_refl R1. + Definition Rplus_def := fun x y => eq_refl (Rplus x y). + Definition Rmult_def := fun x y => eq_refl (Rmult x y). + Definition Ropp_def := fun x => eq_refl (Ropp x). + Definition Rlt_def := fun x y => eq_refl (Rlt x y). +End RbaseSymbolsImpl. +Export RbaseSymbolsImpl. + +(* Keep the same names as before *) +Notation R0 := RbaseSymbolsImpl.R0 (only parsing). +Notation R1 := RbaseSymbolsImpl.R1 (only parsing). +Notation Rplus := RbaseSymbolsImpl.Rplus (only parsing). +Notation Rmult := RbaseSymbolsImpl.Rmult (only parsing). +Notation Ropp := RbaseSymbolsImpl.Ropp (only parsing). +Notation Rlt := RbaseSymbolsImpl.Rlt (only parsing). Infix "+" := Rplus : R_scope. Infix "*" := Rmult : R_scope. Notation "- x" := (Ropp x) : R_scope. -Notation "/ x" := (Rinv x) : R_scope. Infix "<" := Rlt : R_scope. @@ -58,13 +115,10 @@ Definition Rge (r1 r2:R) : Prop := Rgt r1 r2 \/ r1 = r2. (**********) Definition Rminus (r1 r2:R) : R := r1 + - r2. -(**********) -Definition Rdiv (r1 r2:R) : R := r1 * / r2. (**********) Infix "-" := Rminus : R_scope. -Infix "/" := Rdiv : R_scope. Infix "<=" := Rle : R_scope. Infix ">=" := Rge : R_scope. @@ -103,3 +157,67 @@ Definition IZR (z:Z) : R := | Zneg n => - IPR n end. Arguments IZR z%Z : simpl never. + +Lemma total_order_T : forall r1 r2:R, {Rlt r1 r2} + {r1 = r2} + {Rlt r2 r1}. +Proof. + intros. destruct (Rlt_lpo_dec (Rrepr r1) (Rrepr r2) sig_forall_dec). + - left. left. rewrite RbaseSymbolsImpl.Rlt_def. + apply Rlt_forget. exact r. + - destruct (Rlt_lpo_dec (Rrepr r2) (Rrepr r1) sig_forall_dec). + + right. rewrite RbaseSymbolsImpl.Rlt_def. apply Rlt_forget. exact r0. + + left. right. apply Rquot1. split; assumption. +Qed. + +Lemma Req_appart_dec : forall x y : R, + { x = y } + { x < y \/ y < x }. +Proof. + intros. destruct (total_order_T x y). destruct s. + - right. left. exact r. + - left. exact e. + - right. right. exact r. +Qed. + +Lemma Rrepr_appart_0 : forall x:R, + (x < R0 \/ R0 < x) -> Rappart (Rrepr x) (CRzero CR). +Proof. + intros. apply CRltDisjunctEpsilon. destruct H. + left. rewrite RbaseSymbolsImpl.Rlt_def, RbaseSymbolsImpl.R0_def, Rquot2 in H. + exact H. + right. rewrite RbaseSymbolsImpl.Rlt_def, RbaseSymbolsImpl.R0_def, Rquot2 in H. + exact H. +Qed. + +Module Type RinvSig. + Parameter Rinv : R -> R. + Parameter Rinv_def : forall x : R, + Rinv x = match Req_appart_dec x R0 with + | left _ => R0 (* / 0 is undefined, we take 0 arbitrarily *) + | right r => Rabst ((ConstructiveRIneq.Rinv (Rrepr x) (Rrepr_appart_0 x r))) + end. +End RinvSig. + +Module RinvImpl : RinvSig. + Definition Rinv : R -> R + := fun x => match Req_appart_dec x R0 with + | left _ => R0 (* / 0 is undefined, we take 0 arbitrarily *) + | right r => Rabst ((ConstructiveRIneq.Rinv (Rrepr x) (Rrepr_appart_0 x r))) + end. + Definition Rinv_def := fun x => eq_refl (Rinv x). +End RinvImpl. +Notation Rinv := RinvImpl.Rinv (only parsing). + +Notation "/ x" := (Rinv x) : R_scope. + +(**********) +Definition Rdiv (r1 r2:R) : R := r1 * / r2. +Infix "/" := Rdiv : R_scope. + +(* First integer strictly above x *) +Definition up (x : R) : Z. +Proof. + destruct (Rarchimedean (Rrepr x)) as [n nmaj], (total_order_T (IZR n - x) R1). + destruct s. + - exact n. + - (* x = n-1 *) exact n. + - exact (Z.pred n). +Defined. diff --git a/theories/Reals/RiemannInt_SF.v b/theories/Reals/RiemannInt_SF.v index 128ee286b8..6da0fe3966 100644 --- a/theories/Reals/RiemannInt_SF.v +++ b/theories/Reals/RiemannInt_SF.v @@ -137,7 +137,6 @@ Definition IsStepFun (f:R -> R) (a b:R) : Type := { l:Rlist & is_subdivision f a b l }. (** ** Class of step functions *) -#[universes(template)] Record StepFun (a b:R) : Type := mkStepFun {fe :> R -> R; pre : IsStepFun fe a b}. diff --git a/theories/Reals/Rlimit.v b/theories/Reals/Rlimit.v index 5443ff68ed..c94a373ca0 100644 --- a/theories/Reals/Rlimit.v +++ b/theories/Reals/Rlimit.v @@ -116,7 +116,6 @@ Qed. (*******************************) (*********) -#[universes(template)] Record Metric_Space : Type := {Base : Type; dist : Base -> Base -> R; diff --git a/theories/Reals/Rtopology.v b/theories/Reals/Rtopology.v index cfcc82d765..d21042884e 100644 --- a/theories/Reals/Rtopology.v +++ b/theories/Reals/Rtopology.v @@ -380,7 +380,6 @@ Proof. apply Rinv_0_lt_compat; prove_sup0. Qed. -#[universes(template)] Record family : Type := mkfamily {ind : R -> Prop; f :> R -> R -> Prop; diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index e1d7d37e42..745db25a54 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -100,11 +100,9 @@ Hint Resolve Totally_ordered_definition Upper_Bound_definition Section Specific_orders. Variable U : Type. - #[universes(template)] Record Cpo : Type := Definition_of_cpo {PO_of_cpo : PO U; Cpo_cond : Complete U PO_of_cpo}. - #[universes(template)] Record Chain : Type := Definition_of_chain {PO_of_chain : PO U; Chain_cond : Totally_ordered U PO_of_chain (@Carrier_of _ PO_of_chain)}. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index e9233a34e7..6aefcf32c0 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -22,7 +22,6 @@ Section multiset_defs. Hypothesis eqA_equiv : Equivalence eqA. Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}. - #[universes(template)] Inductive multiset : Type := Bag : (A -> nat) -> multiset. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index d2fae6db28..e23d9c2f55 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -36,7 +36,6 @@ Section Partial_orders. Definition Rel := Relation U. - #[universes(template)] Record PO : Type := Definition_of_PO { Carrier_of : Ensemble U; Rel_of : Relation U; diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 76e555ed5a..48a852052e 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -42,7 +42,6 @@ Section defs. Let emptyBag := EmptyBag A. Let singletonBag := SingletonBag _ eqA_dec. - #[universes(template)] Inductive Tree := | Tree_Leaf : Tree | Tree_Node : A -> Tree -> Tree -> Tree. @@ -129,8 +128,7 @@ Section defs. (** ** Merging two sorted lists *) - #[universes(template)] - Inductive merge_lem (l1 l2:list A) : Type := + Inductive merge_lem (l1 l2:list A) : Type := merge_exist : forall l:list A, Sorted leA l -> @@ -203,7 +201,6 @@ Section defs. (** ** Specification of heap insertion *) - #[universes(template)] Inductive insert_spec (a:A) (T:Tree) : Type := insert_exist : forall T1:Tree, @@ -237,7 +234,6 @@ Section defs. (** ** Building a heap from a list *) - #[universes(template)] Inductive build_heap (l:list A) : Type := heap_exist : forall T:Tree, @@ -262,7 +258,6 @@ Section defs. (** ** Building the sorted list *) - #[universes(template)] Inductive flat_spec (T:Tree) : Type := flat_exist : forall l:list A, diff --git a/theories/Wellfounded/Well_Ordering.v b/theories/Wellfounded/Well_Ordering.v index d747258f56..6ddbc8e214 100644 --- a/theories/Wellfounded/Well_Ordering.v +++ b/theories/Wellfounded/Well_Ordering.v @@ -14,17 +14,18 @@ Require Import Eqdep. +#[universes(template)] +Inductive WO (A : Type) (B : A -> Type) : Type := + sup : forall (a:A) (f:B a -> WO A B), WO A B. + Section WellOrdering. Variable A : Type. Variable B : A -> Type. - #[universes(template)] - Inductive WO : Type := - sup : forall (a:A) (f:B a -> WO), WO. - + Notation WO := (WO A B). 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). + 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. diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v index 577544f971..fee928430c 100644 --- a/theories/ZArith/Int.v +++ b/theories/ZArith/Int.v @@ -212,7 +212,6 @@ Module MoreInt (Import I:Int). | EZofI : ExprI -> ExprZ | EZraw : Z -> ExprZ. - #[universes(template)] Inductive ExprP : Type := | EPeq : ExprZ -> ExprZ -> ExprP | EPlt : ExprZ -> ExprZ -> ExprP diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index c2c97fca4f..b0744caa7b 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -21,6 +21,5 @@ Require Export Zpow_def. Require Export Zcomplements. Require Export Zpower. Require Export Zdiv. -Require Export Zlogarithm. Export ZArithRing. diff --git a/theories/ZArith/Zlogarithm.v b/theories/ZArith/Zlogarithm.v deleted file mode 100644 index edbd3a18fe..0000000000 --- a/theories/ZArith/Zlogarithm.v +++ /dev/null @@ -1,273 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(**********************************************************************) - -(** The integer logarithms with base 2. *) - -(** THIS FILE IS DEPRECATED. - Please rather use [Z.log2] (or [Z.log2_up]), which - are defined in [BinIntDef], and whose properties can - be found in [BinInt.Z]. *) - -(* There are three logarithms defined here, - depending on the rounding of the real 2-based logarithm: - - [Log_inf]: [y = (Log_inf x) iff 2^y <= x < 2^(y+1)] - i.e. [Log_inf x] is the biggest integer that is smaller than [Log x] - - [Log_sup]: [y = (Log_sup x) iff 2^(y-1) < x <= 2^y] - i.e. [Log_inf x] is the smallest integer that is bigger than [Log x] - - [Log_nearest]: [y= (Log_nearest x) iff 2^(y-1/2) < x <= 2^(y+1/2)] - i.e. [Log_nearest x] is the integer nearest from [Log x] *) - -Require Import ZArith_base Omega Zcomplements Zpower. -Local Open Scope Z_scope. - -Section Log_pos. (* Log of positive integers *) - - (** First we build [log_inf] and [log_sup] *) - - Fixpoint log_inf (p:positive) : Z := - match p with - | xH => 0 (* 1 *) - | xO q => Z.succ (log_inf q) (* 2n *) - | xI q => Z.succ (log_inf q) (* 2n+1 *) - end. - - Fixpoint log_sup (p:positive) : Z := - match p with - | xH => 0 (* 1 *) - | xO n => Z.succ (log_sup n) (* 2n *) - | xI n => Z.succ (Z.succ (log_inf n)) (* 2n+1 *) - end. - - Hint Unfold log_inf log_sup : core. - - Lemma Psize_log_inf : forall p, Zpos (Pos.size p) = Z.succ (log_inf p). - Proof. - induction p; simpl; now rewrite ?Pos2Z.inj_succ, ?IHp. - Qed. - - Lemma Zlog2_log_inf : forall p, Z.log2 (Zpos p) = log_inf p. - Proof. - unfold Z.log2. destruct p; simpl; trivial; apply Psize_log_inf. - Qed. - - Lemma Zlog2_up_log_sup : forall p, Z.log2_up (Zpos p) = log_sup p. - Proof. - induction p; simpl log_sup. - - change (Zpos p~1) with (2*(Zpos p)+1). - rewrite Z.log2_up_succ_double, Zlog2_log_inf; try easy. - unfold Z.succ. now rewrite !(Z.add_comm _ 1), Z.add_assoc. - - change (Zpos p~0) with (2*Zpos p). - now rewrite Z.log2_up_double, IHp. - - reflexivity. - Qed. - - (** Then we give the specifications of [log_inf] and [log_sup] - and prove their validity *) - - Hint Resolve Z.le_trans: zarith. - - Theorem log_inf_correct : - forall x:positive, - 0 <= log_inf x /\ two_p (log_inf x) <= Zpos x < two_p (Z.succ (log_inf x)). - Proof. - simple induction x; intros; simpl; - [ elim H; intros Hp HR; clear H; split; - [ auto with zarith - | rewrite two_p_S with (x := Z.succ (log_inf p)) by (apply Z.le_le_succ_r; trivial); - rewrite two_p_S by trivial; - rewrite two_p_S in HR by trivial; rewrite (BinInt.Pos2Z.inj_xI p); - omega ] - | elim H; intros Hp HR; clear H; split; - [ auto with zarith - | rewrite two_p_S with (x := Z.succ (log_inf p)) by (apply Z.le_le_succ_r; trivial); - rewrite two_p_S by trivial; - rewrite two_p_S in HR by trivial; rewrite (BinInt.Pos2Z.inj_xO p); - omega ] - | unfold two_power_pos; unfold shift_pos; simpl; - omega ]. - Qed. - - Definition log_inf_correct1 (p:positive) := proj1 (log_inf_correct p). - Definition log_inf_correct2 (p:positive) := proj2 (log_inf_correct p). - - Opaque log_inf_correct1 log_inf_correct2. - - Hint Resolve log_inf_correct1 log_inf_correct2: zarith. - - Lemma log_sup_correct1 : forall p:positive, 0 <= log_sup p. - Proof. - simple induction p; intros; simpl; auto with zarith. - Qed. - - (** For every [p], either [p] is a power of two and [(log_inf p)=(log_sup p)] - either [(log_sup p)=(log_inf p)+1] *) - - Theorem log_sup_log_inf : - forall p:positive, - IF Zpos p = two_p (log_inf p) then Zpos p = two_p (log_sup p) - else log_sup p = Z.succ (log_inf p). - Proof. - simple induction p; intros; - [ elim H; right; simpl; - rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); - rewrite BinInt.Pos2Z.inj_xI; unfold Z.succ; omega - | elim H; clear H; intro Hif; - [ left; simpl; - rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); - rewrite (two_p_S (log_sup p0) (log_sup_correct1 p0)); - rewrite <- (proj1 Hif); rewrite <- (proj2 Hif); - auto - | right; simpl; - rewrite (two_p_S (log_inf p0) (log_inf_correct1 p0)); - rewrite BinInt.Pos2Z.inj_xO; unfold Z.succ; - omega ] - | left; auto ]. - Qed. - - Theorem log_sup_correct2 : - forall x:positive, two_p (Z.pred (log_sup x)) < Zpos x <= two_p (log_sup x). - Proof. - intro. - elim (log_sup_log_inf x). - (* x is a power of two and [log_sup = log_inf] *) - intros [E1 E2]; rewrite E2. - split; [ apply two_p_pred; apply log_sup_correct1 | apply Z.le_refl ]. - intros [E1 E2]; rewrite E2. - rewrite (Z.pred_succ (log_inf x)). - generalize (log_inf_correct2 x); omega. - Qed. - - Lemma log_inf_le_log_sup : forall p:positive, log_inf p <= log_sup p. - Proof. - simple induction p; simpl; intros; omega. - Qed. - - Lemma log_sup_le_Slog_inf : forall p:positive, log_sup p <= Z.succ (log_inf p). - Proof. - simple induction p; simpl; intros; omega. - Qed. - - (** Now it's possible to specify and build the [Log] rounded to the nearest *) - - Fixpoint log_near (x:positive) : Z := - match x with - | xH => 0 - | xO xH => 1 - | xI xH => 2 - | xO y => Z.succ (log_near y) - | xI y => Z.succ (log_near y) - end. - - Theorem log_near_correct1 : forall p:positive, 0 <= log_near p. - Proof. - simple induction p; simpl; intros; - [ elim p0; auto with zarith - | elim p0; auto with zarith - | trivial with zarith ]. - intros; apply Z.le_le_succ_r. - generalize H0; now elim p1. - intros; apply Z.le_le_succ_r. - generalize H0; now elim p1. - Qed. - - Theorem log_near_correct2 : - forall p:positive, log_near p = log_inf p \/ log_near p = log_sup p. - Proof. - simple induction p. - intros p0 [Einf| Esup]. - simpl. rewrite Einf. - case p0; [ left | left | right ]; reflexivity. - simpl; rewrite Esup. - elim (log_sup_log_inf p0). - generalize (log_inf_le_log_sup p0). - generalize (log_sup_le_Slog_inf p0). - case p0; auto with zarith. - intros; omega. - case p0; intros; auto with zarith. - intros p0 [Einf| Esup]. - simpl. - repeat rewrite Einf. - case p0; intros; auto with zarith. - simpl. - repeat rewrite Esup. - case p0; intros; auto with zarith. - auto. - Qed. - -End Log_pos. - -Section divers. - - (** Number of significative digits. *) - - Definition N_digits (x:Z) := - match x with - | Zpos p => log_inf p - | Zneg p => log_inf p - | Z0 => 0 - end. - - Lemma ZERO_le_N_digits : forall x:Z, 0 <= N_digits x. - Proof. - simple induction x; simpl; - [ apply Z.le_refl | exact log_inf_correct1 | exact log_inf_correct1 ]. - Qed. - - Lemma log_inf_shift_nat : forall n:nat, log_inf (shift_nat n 1) = Z.of_nat n. - Proof. - simple induction n; intros; - [ try trivial | rewrite Nat2Z.inj_succ; rewrite <- H; reflexivity ]. - Qed. - - Lemma log_sup_shift_nat : forall n:nat, log_sup (shift_nat n 1) = Z.of_nat n. - Proof. - simple induction n; intros; - [ try trivial | rewrite Nat2Z.inj_succ; rewrite <- H; reflexivity ]. - Qed. - - (** [Is_power p] means that p is a power of two *) - Fixpoint Is_power (p:positive) : Prop := - match p with - | xH => True - | xO q => Is_power q - | xI q => False - end. - - Lemma Is_power_correct : - forall p:positive, Is_power p <-> (exists y : nat, p = shift_nat y 1). - Proof. - split; - [ elim p; - [ simpl; tauto - | simpl; intros; generalize (H H0); intro H1; elim H1; - intros y0 Hy0; exists (S y0); rewrite Hy0; reflexivity - | intro; exists 0%nat; reflexivity ] - | intros; elim H; intros; rewrite H0; elim x; intros; simpl; trivial ]. - Qed. - - Lemma Is_power_or : forall p:positive, Is_power p \/ ~ Is_power p. - Proof. - simple induction p; - [ intros; right; simpl; tauto - | intros; elim H; - [ intros; left; simpl; exact H0 - | intros; right; simpl; exact H0 ] - | left; simpl; trivial ]. - Qed. - -End divers. - - - - - - diff --git a/theories/ZArith/Zsqrt_compat.v b/theories/ZArith/Zsqrt_compat.v deleted file mode 100644 index 6873c737a7..0000000000 --- a/theories/ZArith/Zsqrt_compat.v +++ /dev/null @@ -1,234 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) -(* <O___,, * (see CREDITS file for the list of authors) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -Require Import ZArithRing. -Require Import Omega. -Require Export ZArith_base. -Local Open Scope Z_scope. - -(** THIS FILE IS DEPRECATED - - Instead of the various [Zsqrt] defined here, please use rather - [Z.sqrt] (or [Z.sqrtrem]). The latter are pure functions without - proof parts, and more results are available about them. - Some equivalence proofs between the old and the new versions - can be found below. Importing ZArith will provides by default - the new versions. - -*) - -(**********************************************************************) -(** Definition and properties of square root on Z *) - -(** The following tactic replaces all instances of (POS (xI ...)) by - `2*(POS ...)+1`, but only when ... is not made only with xO, XI, or xH. *) -Ltac compute_POS := - match goal with - | |- context [(Zpos (xI ?X1))] => - match constr:(X1) with - | context [1%positive] => fail 1 - | _ => rewrite (Pos2Z.inj_xI X1) - end - | |- context [(Zpos (xO ?X1))] => - match constr:(X1) with - | context [1%positive] => fail 1 - | _ => rewrite (Pos2Z.inj_xO X1) - end - end. - -Inductive sqrt_data (n:Z) : Set := - c_sqrt : forall s r:Z, n = s * s + r -> 0 <= r <= 2 * s -> sqrt_data n. - -Definition sqrtrempos : forall p:positive, sqrt_data (Zpos p). - refine - (fix sqrtrempos (p:positive) : sqrt_data (Zpos p) := - match p return sqrt_data (Zpos p) with - | xH => c_sqrt 1 1 0 _ _ - | xO xH => c_sqrt 2 1 1 _ _ - | xI xH => c_sqrt 3 1 2 _ _ - | xO (xO p') => - match sqrtrempos p' with - | c_sqrt _ s' r' Heq Hint => - match Z_le_gt_dec (4 * s' + 1) (4 * r') with - | left Hle => - c_sqrt (Zpos (xO (xO p'))) (2 * s' + 1) - (4 * r' - (4 * s' + 1)) _ _ - | right Hgt => c_sqrt (Zpos (xO (xO p'))) (2 * s') (4 * r') _ _ - end - end - | xO (xI p') => - match sqrtrempos p' with - | c_sqrt _ s' r' Heq Hint => - match Z_le_gt_dec (4 * s' + 1) (4 * r' + 2) with - | left Hle => - c_sqrt (Zpos (xO (xI p'))) (2 * s' + 1) - (4 * r' + 2 - (4 * s' + 1)) _ _ - | right Hgt => - c_sqrt (Zpos (xO (xI p'))) (2 * s') (4 * r' + 2) _ _ - end - end - | xI (xO p') => - match sqrtrempos p' with - | c_sqrt _ s' r' Heq Hint => - match Z_le_gt_dec (4 * s' + 1) (4 * r' + 1) with - | left Hle => - c_sqrt (Zpos (xI (xO p'))) (2 * s' + 1) - (4 * r' + 1 - (4 * s' + 1)) _ _ - | right Hgt => - c_sqrt (Zpos (xI (xO p'))) (2 * s') (4 * r' + 1) _ _ - end - end - | xI (xI p') => - match sqrtrempos p' with - | c_sqrt _ s' r' Heq Hint => - match Z_le_gt_dec (4 * s' + 1) (4 * r' + 3) with - | left Hle => - c_sqrt (Zpos (xI (xI p'))) (2 * s' + 1) - (4 * r' + 3 - (4 * s' + 1)) _ _ - | right Hgt => - c_sqrt (Zpos (xI (xI p'))) (2 * s') (4 * r' + 3) _ _ - end - end - end); clear sqrtrempos; repeat compute_POS; - try (try rewrite Heq; ring); try omega. -Defined. - -(** Define with integer input, but with a strong (readable) specification. *) -Definition Zsqrt : - forall x:Z, - 0 <= x -> - {s : Z & {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}}. - refine - (fun x => - match - x - return - 0 <= x -> - {s : Z & {r : Z | x = s * s + r /\ s * s <= x < (s + 1) * (s + 1)}} - with - | Zpos p => - fun h => - match sqrtrempos p with - | c_sqrt _ s r Heq Hint => - existT - (fun s:Z => - {r : Z | - Zpos p = s * s + r /\ s * s <= Zpos p < (s + 1) * (s + 1)}) - s - (exist - (fun r:Z => - Zpos p = s * s + r /\ - s * s <= Zpos p < (s + 1) * (s + 1)) r _) - end - | Zneg p => - fun h => - False_rec - {s : Z & - {r : Z | - Zneg p = s * s + r /\ s * s <= Zneg p < (s + 1) * (s + 1)}} - (h (eq_refl Datatypes.Gt)) - | Z0 => - fun h => - existT - (fun s:Z => - {r : Z | 0 = s * s + r /\ s * s <= 0 < (s + 1) * (s + 1)}) 0 - (exist - (fun r:Z => 0 = 0 * 0 + r /\ 0 * 0 <= 0 < (0 + 1) * (0 + 1)) 0 - _) - end); try omega. - split; [ omega | rewrite Heq; ring_simplify (s*s) ((s + 1) * (s + 1)); omega ]. -Defined. - -(** Define a function of type Z->Z that computes the integer square root, - but only for positive numbers, and 0 for others. *) -Definition Zsqrt_plain (x:Z) : Z := - match x with - | Zpos p => - match Zsqrt (Zpos p) (Pos2Z.is_nonneg p) with - | existT _ s _ => s - end - | Zneg p => 0 - | Z0 => 0 - end. - -(** A basic theorem about Zsqrt_plain *) - -Theorem Zsqrt_interval : - forall n:Z, - 0 <= n -> - Zsqrt_plain n * Zsqrt_plain n <= n < - (Zsqrt_plain n + 1) * (Zsqrt_plain n + 1). -Proof. - intros [|p|p] Hp. - - now compute. - - unfold Zsqrt_plain. - now destruct Zsqrt as (s & r & Heq & Hint). - - now elim Hp. -Qed. - -(** Positivity *) - -Theorem Zsqrt_plain_is_pos: forall n, 0 <= n -> 0 <= Zsqrt_plain n. -Proof. - intros n m; case (Zsqrt_interval n); auto with zarith. - intros H1 H2; case (Z.le_gt_cases 0 (Zsqrt_plain n)); auto. - intros H3; contradict H2; auto; apply Z.le_ngt. - apply Z.le_trans with ( 2 := H1 ). - replace ((Zsqrt_plain n + 1) * (Zsqrt_plain n + 1)) - with (Zsqrt_plain n * Zsqrt_plain n + (2 * Zsqrt_plain n + 1)); - auto with zarith. - ring. -Qed. - -(** Direct correctness on squares. *) - -Theorem Zsqrt_square_id: forall a, 0 <= a -> Zsqrt_plain (a * a) = a. -Proof. - intros a H. - generalize (Zsqrt_plain_is_pos (a * a)); auto with zarith; intros Haa. - case (Zsqrt_interval (a * a)); auto with zarith. - intros H1 H2. - case (Z.le_gt_cases a (Zsqrt_plain (a * a))); intros H3. - - Z.le_elim H3; auto. - contradict H1; auto; apply Z.lt_nge; auto with zarith. - apply Z.le_lt_trans with (a * Zsqrt_plain (a * a)); auto with zarith. - apply Z.mul_lt_mono_pos_r; auto with zarith. - - contradict H2; auto; apply Z.le_ngt; auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. -Qed. - -(** [Zsqrt_plain] is increasing *) - -Theorem Zsqrt_le: - forall p q, 0 <= p <= q -> Zsqrt_plain p <= Zsqrt_plain q. -Proof. - intros p q [H1 H2]. - Z.le_elim H2; [ | subst q; auto with zarith]. - case (Z.le_gt_cases (Zsqrt_plain p) (Zsqrt_plain q)); auto; intros H3. - assert (Hp: (0 <= Zsqrt_plain q)). - { apply Zsqrt_plain_is_pos; auto with zarith. } - absurd (q <= p); auto with zarith. - apply Z.le_trans with ((Zsqrt_plain q + 1) * (Zsqrt_plain q + 1)). - case (Zsqrt_interval q); auto with zarith. - apply Z.le_trans with (Zsqrt_plain p * Zsqrt_plain p); auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - case (Zsqrt_interval p); auto with zarith. -Qed. - - -(** Equivalence between Zsqrt_plain and [Z.sqrt] *) - -Lemma Zsqrt_equiv : forall n, Zsqrt_plain n = Z.sqrt n. -Proof. - intros. destruct (Z_le_gt_dec 0 n). - symmetry. apply Z.sqrt_unique; trivial. - now apply Zsqrt_interval. - now destruct n. -Qed. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index 1920d493de..adb416e3ce 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -193,9 +193,7 @@ let pp_vo_dep dir fmt vo = pp_rule fmt all_targets deps action let pp_mlg_dep _dir fmt ml = - let target = Filename.(remove_extension ml) ^ ".ml" in - let mlg_rule = "(run coqpp %{pp-file})" in - pp_rule fmt [target] [ml] mlg_rule + fprintf fmt "@[(coq.pp (modules %s))@]@\n" (Filename.remove_extension ml) let pp_dep dir fmt oo = match oo with | VO vo -> pp_vo_dep dir fmt vo diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 0685f979c8..a44ddf7467 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -940,7 +940,7 @@ and escaped_coq = parse { (* likely to be a syntax error: we escape *) backtrack lexbuf } | eof { Tokens.flush_sublexer () } - | (identifier '.')* identifier + | identifier { Tokens.flush_sublexer(); Output.ident (lexeme lexbuf) None; escaped_coq lexbuf } diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index f4a0e594fc..3600658e23 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -108,8 +108,6 @@ let compile opts copts ~echo ~f_in ~f_out = in match copts.compilation_mode with | BuildVo -> - Flags.record_aux_file := true; - let long_f_dot_v, long_f_dot_vo = ensure_exists_with_prefix f_in f_out ".v" ".vo" in @@ -124,8 +122,11 @@ let compile opts copts ~echo ~f_in ~f_out = Aux_file.(start_aux_file ~aux_file:(aux_file_name_for long_f_dot_vo) ~v_file:long_f_dot_v); + + Dumpglob.set_glob_output copts.glob_out; Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo; Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); + let wall_clock1 = Unix.gettimeofday () in let check = Stm.AsyncOpts.(stm_options.async_proofs_mode = APoff) in let state = Vernac.load_vernac ~echo ~check ~interactive:false ~state long_f_dot_v in @@ -139,9 +140,6 @@ let compile opts copts ~echo ~f_in ~f_out = Dumpglob.end_dump_glob () | BuildVio -> - Flags.record_aux_file := false; - Dumpglob.noglob (); - let long_f_dot_v, long_f_dot_vio = ensure_exists_with_prefix f_in f_out ".v" ".vio" in @@ -174,9 +172,6 @@ let compile opts copts ~echo ~f_in ~f_out = Stm.reset_task_queue () | Vio2Vo -> - - Flags.record_aux_file := false; - Dumpglob.noglob (); let long_f_dot_vio, long_f_dot_vo = ensure_exists_with_prefix f_in f_out ".vio" ".vo" in let sum, lib, univs, tasks, proofs = diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index c99ca9f5b5..113b1fb5d7 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -32,6 +32,10 @@ let set_type_in_type () = let typing_flags = Environ.typing_flags (Global.env ()) in Global.set_typing_flags { typing_flags with Declarations.check_universes = false } +let set_no_template_check () = + let typing_flags = Environ.typing_flags (Global.env ()) in + Global.set_typing_flags { typing_flags with Declarations.check_template = false } + (******************************************************************************) type color = [`ON | `AUTO | `EMACS | `OFF] @@ -59,7 +63,6 @@ type coqargs_config = { debug : bool; diffs_set : bool; time : bool; - glob_opt : bool; print_emacs : bool; set_options : (Goptions.option_name * option_command) list; } @@ -125,7 +128,6 @@ let default_config = { debug = false; diffs_set = false; time = false; - glob_opt = false; print_emacs = false; set_options = []; @@ -184,7 +186,7 @@ let add_load_vernacular opts verb s = (** Options for proof general *) let set_emacs opts = Printer.enable_goal_tags_printing := true; - { opts with config = { opts.config with color = `OFF; print_emacs = true }} + { opts with config = { opts.config with color = `EMACS; print_emacs = true }} let set_logic f oval = { oval with config = { oval.config with logic = f oval.config.logic }} @@ -380,13 +382,6 @@ let parse_args ~help ~init arglist : t * string list = Flags.compat_version := v; add_compat_require oval v - |"-dump-glob" -> - Dumpglob.dump_into_file (next ()); - { oval with config = { oval.config with glob_opt = true }} - - |"-feedback-glob" -> - Dumpglob.feedback_glob (); oval - |"-exclude-dir" -> System.exclude_directory (next ()); oval @@ -524,7 +519,6 @@ let parse_args ~help ~init arglist : t * string list = |"-indices-matter" -> set_logic (fun o -> { o with indices_matter = true }) oval |"-m"|"--memory" -> { oval with post = { oval.post with memory_stat = true }} |"-noinit"|"-nois" -> { oval with pre = { oval.pre with load_init = false }} - |"-no-glob"|"-noglob" -> Dumpglob.noglob (); { oval with config = { oval.config with glob_opt = true }} |"-output-context" -> { oval with post = { oval.post with output_context = true }} |"-profile-ltac" -> Flags.profile_ltac := true; oval |"-q" -> { oval with pre = { oval.pre with load_rcfile = false; }} @@ -535,6 +529,7 @@ let parse_args ~help ~init arglist : t * string list = |"-list-tags" -> set_query oval PrintTags |"-time" -> { oval with config = { oval.config with time = true }} |"-type-in-type" -> set_type_in_type (); oval + |"-no-template-check" -> set_no_template_check (); oval |"-unicode" -> add_vo_require oval "Utf8_core" None (Some false) |"-where" -> set_query oval PrintWhere |"-h"|"-H"|"-?"|"-help"|"--help" -> set_query oval (PrintHelp help) diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index e414888861..26f22386a0 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -35,7 +35,6 @@ type coqargs_config = { debug : bool; diffs_set : bool; time : bool; - glob_opt : bool; print_emacs : bool; set_options : (Goptions.option_name * option_command) list; } diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index 5678acb2b1..7658ad68a5 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -11,13 +11,12 @@ let outputstate opts = Option.iter (fun ostate_file -> let fname = CUnix.make_suffix ostate_file ".coq" in - States.extern_state fname) opts.Coqcargs.outputstate + Library.extern_state fname) opts.Coqcargs.outputstate let coqc_init _copts ~opts = Flags.quiet := true; System.trust_file_cache := true; - Coqtop.init_color opts.Coqargs.config; - if not opts.Coqargs.config.Coqargs.glob_opt then Dumpglob.dump_to_dotglob () + Coqtop.init_color opts.Coqargs.config let coqc_specific_usage = Usage.{ executable_name = "coqc"; @@ -54,7 +53,8 @@ let coqc_main copts ~opts = if opts.Coqargs.post.Coqargs.output_context then begin let sigma, env = let e = Global.env () in Evd.from_env e, e in - Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) + let library_accessor = Library.indirect_accessor in + Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context ~library_accessor env) sigma) ++ fnl ()) end; CProfile.print_profile () diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index 3dc11c0209..c4e3571281 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -23,7 +23,8 @@ type t = ; echo : bool - ; outputstate : string option; + ; outputstate : string option + ; glob_out : Dumpglob.glob_output } let default = @@ -40,6 +41,7 @@ let default = ; echo = false ; outputstate = None + ; glob_out = Dumpglob.MultFiles } let depr opt = @@ -187,6 +189,15 @@ let parse arglist : t = | "-outputstate" -> set_outputstate oval (next ()) + (* Glob options *) + |"-no-glob" | "-noglob" -> + { oval with glob_out = Dumpglob.NoGlob } + + |"-dump-glob" -> + let file = next () in + { oval with glob_out = Dumpglob.File file } + + (* Rest *) | s -> extras := s :: !extras; oval diff --git a/toplevel/coqcargs.mli b/toplevel/coqcargs.mli index b02eeeb9ee..13bea3bf3e 100644 --- a/toplevel/coqcargs.mli +++ b/toplevel/coqcargs.mli @@ -24,6 +24,7 @@ type t = ; echo : bool ; outputstate : string option + ; glob_out : Dumpglob.glob_output } val default : t diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 2673995a86..07466d641e 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -242,10 +242,10 @@ let set_prompt prompt = (* Read the input stream until a dot is encountered *) let parse_to_dot = - let rec dot st = match Stream.next st with + let rec dot tok st = match Stream.next st with | Tok.KEYWORD ("."|"...") -> () | Tok.EOI -> () - | _ -> dot st + | _ -> dot tok st in Pcoq.Entry.of_parser "Coqtoplevel.dot" dot @@ -340,8 +340,8 @@ let print_anyway_opts = [ let print_anyway c = let open Vernacexpr in - match c with - | VernacExpr (_, VernacSetOption (_, opt, _)) -> List.mem opt print_anyway_opts + match c.expr with + | VernacSetOption (_, opt, _) -> List.mem opt print_anyway_opts | _ -> false (* We try to behave better when goal printing raises an exception @@ -438,19 +438,15 @@ let rec loop ~state = loop ~state (* Default toplevel loop *) -let warning s = Flags.(with_option warn Feedback.msg_warning (strbrk s)) let drop_args = ref None + let loop ~opts ~state = drop_args := Some opts; let open Coqargs in print_emacs := opts.config.print_emacs; (* We initialize the console only if we run the toploop_run *) let tl_feed = Feedback.add_feeder coqloop_feed in - if Dumpglob.dump () then begin - Flags.if_verbose warning "Dumpglob cannot be used in interactive mode."; - Dumpglob.noglob () - end; let _ = loop ~state in (* Initialise and launch the Ocaml toplevel *) Coqinit.init_ocaml_path(); diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index f09d202edf..eded9f4bcd 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -30,7 +30,7 @@ let get_version_date () = let print_header () = let (ver,rev) = get_version_date () in - Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); + Feedback.msg_info (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); flush_all () let print_memory_stat () = @@ -87,7 +87,7 @@ let set_options = List.iter set_option let inputstate opts = Option.iter (fun istate_file -> let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in - States.intern_state fname) opts.inputstate + Library.intern_state fname) opts.inputstate (******************************************************************************) (* Fatal Errors *) diff --git a/toplevel/dune b/toplevel/dune index f51e50aaa3..2d64ae303c 100644 --- a/toplevel/dune +++ b/toplevel/dune @@ -7,7 +7,4 @@ ; Coqlevel provides the `Num` library to plugins, we could also use ; -linkall in the plugins file, to be discussed. -(rule - (targets g_toplevel.ml) - (deps (:mlg-file g_toplevel.mlg)) - (action (run coqpp %{mlg-file}))) +(coq.pp (modules g_toplevel)) diff --git a/toplevel/g_toplevel.mlg b/toplevel/g_toplevel.mlg index 1a1537113e..e180d9e750 100644 --- a/toplevel/g_toplevel.mlg +++ b/toplevel/g_toplevel.mlg @@ -36,7 +36,7 @@ let err () = raise Stream.Failure let test_show_goal = Pcoq.Entry.of_parser "test_show_goal" - (fun strm -> + (fun _ strm -> match stream_nth 0 strm with | IDENT "Show" -> (match stream_nth 1 strm with diff --git a/toplevel/usage.ml b/toplevel/usage.ml index cdb2e36fbd..8555d78156 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -82,6 +82,7 @@ let print_usage_common co command = \n -sprop-cumulative make sort SProp cumulative with the rest of the hierarchy\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ +\n -no-template-check disable checking of universes constraints on universes parameterizing template polymorphic inductive types\ \n -mangle-names x mangle auto-generated names using prefix x\ \n -set \"Foo Bar\" enable Foo Bar (as Set Foo Bar. in a file)\ \n -set \"Foo Bar=value\" set Foo Bar to value (value is interpreted according to Foo Bar's type)\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index ef8d98c219..bca6b48499 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -20,14 +20,10 @@ open Vernacprop Use the module Coqtoplevel, which catches these exceptions (the exceptions are explained only at the toplevel). *) -let checknav_simple ({ CAst.loc; _ } as cmd) = - if is_navigation_vernac cmd && not (is_reset cmd) then +let checknav { CAst.loc; v = { expr } } = + if is_navigation_vernac expr && not (is_reset expr) then CErrors.user_err ?loc (str "Navigation commands forbidden in files.") -let checknav_deep ({ CAst.loc; _ } as cmd) = - if is_deep_navigation_vernac cmd then - CErrors.user_err ?loc (str "Navigation commands forbidden in nested commands.") - (* Echo from a buffer based on position. XXX: Should move to utility file. *) let vernac_echo ?loc in_chan = let open Loc in @@ -60,7 +56,7 @@ let interp_vernac ~check ~interactive ~state ({CAst.loc;_} as com) = due to the way it prints. *) let com = if state.time then begin - CAst.make ?loc @@ VernacTime(state.time,com) + CAst.map (fun cmd -> { cmd with control = ControlTime state.time :: cmd.control }) com end else com in let doc, nsid, ntip = Stm.add ~doc:state.doc ~ontop:state.sid (not !Flags.quiet) com in @@ -108,7 +104,7 @@ let load_vernac_core ~echo ~check ~interactive ~state file = (* Printing of AST for -compile-verbose *) Option.iter (vernac_echo ?loc:ast.CAst.loc) in_echo; - checknav_simple ast; + checknav ast; let state = Flags.silently (interp_vernac ~check ~interactive ~state) ast in @@ -122,7 +118,6 @@ let load_vernac_core ~echo ~check ~interactive ~state file = iraise (e, info) let process_expr ~state loc_ast = - checknav_deep loc_ast; interp_vernac ~interactive:true ~check:true ~state loc_ast (******************************************************************************) diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 23b5f4daef..adc1606016 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -23,31 +23,31 @@ open Ltac_plugin let err () = raise Stream.Failure -type lookahead = int -> Tok.t Stream.t -> int option +type lookahead = Gramlib.Plexing.location_function -> int -> Tok.t Stream.t -> int option let entry_of_lookahead s (lk : lookahead) = - let run strm = match lk 0 strm with None -> err () | Some _ -> () in + let run tok strm = match lk tok 0 strm with None -> err () | Some _ -> () in Pcoq.Entry.of_parser s run -let (>>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with +let (>>) (lk1 : lookahead) lk2 tok n strm = match lk1 tok n strm with | None -> None -| Some n -> lk2 n strm +| Some n -> lk2 tok n strm -let (<+>) (lk1 : lookahead) lk2 n strm = match lk1 n strm with -| None -> lk2 n strm +let (<+>) (lk1 : lookahead) lk2 tok n strm = match lk1 tok n strm with +| None -> lk2 tok n strm | Some n -> Some n -let lk_empty n strm = Some n +let lk_empty tok n strm = Some n -let lk_kw kw n strm = match stream_nth n strm with +let lk_kw kw tok n strm = match stream_nth n strm with | KEYWORD kw' | IDENT kw' -> if String.equal kw kw' then Some (n + 1) else None | _ -> None -let lk_ident n strm = match stream_nth n strm with +let lk_ident tok n strm = match stream_nth n strm with | IDENT _ -> Some (n + 1) | _ -> None -let lk_int n strm = match stream_nth n strm with +let lk_int tok n strm = match stream_nth n strm with | NUMERAL { NumTok.int = _; frac = ""; exp = "" } -> Some (n + 1) | _ -> None @@ -80,9 +80,13 @@ let test_lpar_id_rpar = lk_kw "(" >> lk_ident >> lk_kw ")" end +let check_no_space tok m strm = + let n = Stream.count strm in + if G_prim.contiguous tok n (n+m-1) then Some m else None + let test_ampersand_ident = entry_of_lookahead "test_ampersand_ident" begin - lk_kw "&" >> lk_ident + lk_kw "&" >> lk_ident >> check_no_space end let test_dollar_ident = diff --git a/vernac/assumptions.ml b/vernac/assumptions.ml index ab341e4ab8..cb034bdff6 100644 --- a/vernac/assumptions.ml +++ b/vernac/assumptions.ml @@ -313,9 +313,15 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = if cb.const_typing_flags.check_guarded then accu else let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in - ContextObjectMap.add (Axiom (Guarded kn, l)) Constr.mkProp accu + ContextObjectMap.add (Axiom (Guarded obj, l)) Constr.mkProp accu in - if not (Declareops.constant_has_body cb) || not cb.const_typing_flags.check_universes then + let accu = + if cb.const_typing_flags.check_universes then accu + else + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (TypeInType obj, l)) Constr.mkProp accu + in + if not (Declareops.constant_has_body cb) then let t = type_of_constant cb in let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in ContextObjectMap.add (Axiom (Constant kn,l)) t accu @@ -329,10 +335,26 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = accu | IndRef (m,_) | ConstructRef ((m,_),_) -> let mind = lookup_mind m in - if mind.mind_typing_flags.check_guarded then - accu - else + let accu = + if mind.mind_typing_flags.check_positive then accu + else + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (Positive m, l)) Constr.mkProp accu + in + let accu = + if mind.mind_typing_flags.check_guarded then accu + else + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (Guarded obj, l)) Constr.mkProp accu + in + let accu = + if mind.mind_typing_flags.check_universes then accu + else + let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (TypeInType obj, l)) Constr.mkProp accu + in + if not mind.mind_typing_flags.check_template then let l = try GlobRef.Map_env.find obj ax2ty with Not_found -> [] in - ContextObjectMap.add (Axiom (Positive m, l)) Constr.mkProp accu - in - GlobRef.Map_env.fold fold graph ContextObjectMap.empty + ContextObjectMap.add (Axiom (TemplatePolymorphic m, l)) Constr.mkProp accu + else accu + in GlobRef.Map_env.fold fold graph ContextObjectMap.empty diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index d414d57c0d..98fe436a22 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -345,7 +345,7 @@ let build_beq_scheme mode kn = Vars.substl subst cores.(i) in create_input fix), - UState.make (Global.universes ())), + UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ())), !eff let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme @@ -690,7 +690,7 @@ let make_bl_scheme mode mind = let lnonparrec,lnamesparrec = (* TODO subst *) context_chop (nparams-nparrec) mib.mind_params_ctxt in let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in - let ctx = UState.make (Global.universes ()) in + let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let bl_goal = EConstr.of_constr bl_goal in let (ans, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ctx bl_goal @@ -820,7 +820,7 @@ let make_lb_scheme mode mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in - let ctx = UState.make (Global.universes ()) in + let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let lb_goal = EConstr.of_constr lb_goal in let (ans, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ctx lb_goal @@ -996,7 +996,7 @@ let make_eq_decidability mode mind = let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let u = Univ.Instance.empty in - let ctx = UState.make (Global.universes ()) in + let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let side_eff = side_effect_of_mode mode in diff --git a/vernac/classes.ml b/vernac/classes.ml index efe452d5f1..d5f5656e1d 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -28,9 +28,7 @@ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration (*i*) -open Decl_kinds - -let set_typeclass_transparency c local b = +let set_typeclass_transparency c local b = Hints.add_hints ~local [typeclasses_db] (Hints.HintsTransparencyEntry (Hints.HintsReferences [c], b)) @@ -179,7 +177,7 @@ let discharge_class (_,cl) = let open CVars in let repl = Lib.replacement_context () in let rel_of_variable_context ctx = List.fold_right - ( fun (decl,_) (ctx', subst) -> + ( fun decl (ctx', subst) -> let decl' = decl |> NamedDecl.map_constr (substn_vars 1 subst) |> NamedDecl.to_rel_decl in (decl' :: ctx', NamedDecl.get_id decl :: subst) ) ctx ([], []) in @@ -527,7 +525,7 @@ let do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri let interp_instance_context ~program_mode env ctx ~generalize pl tclass = let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in let tclass = - if generalize then CAst.make @@ CGeneralization (Implicit, Some AbsPi, tclass) + if generalize then CAst.make @@ CGeneralization (Glob_term.Implicit, Some AbsPi, tclass) else tclass in let sigma, (impls, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma ctx in diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index d59d471d5f..e3f90ab98c 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -59,7 +59,7 @@ match scope with let sigma = Evd.from_env env in let () = Classes.declare_instance env sigma None true r in let () = if is_coe then Class.try_add_new_coercion r ~local:true ~poly:false in - (r,Univ.Instance.empty,true) + (r,Univ.Instance.empty) | Global local -> let do_instance = should_axiom_into_instance kind in @@ -84,7 +84,7 @@ match scope with | Polymorphic_entry (_, univs) -> Univ.UContext.instance univs | Monomorphic_entry _ -> Univ.Instance.empty in - (gr,inst,Lib.is_modtype_strict ()) + (gr,inst) let interp_assumption ~program_mode sigma env impls c = let sigma, (ty, impls) = interp_type_evars_impls ~program_mode env sigma ~impls c in @@ -98,14 +98,13 @@ let next_uctx = | Monomorphic_entry _ -> empty_uctx let declare_assumptions idl is_coe ~scope ~poly ~kind typ uctx pl imps nl = - let refs, status, _ = - List.fold_left (fun (refs,status,uctx) id -> - let ref',u',status' = - declare_assumption is_coe ~scope ~poly ~kind typ uctx pl imps false nl id in - (ref',u')::refs, status' && status, next_uctx uctx) - ([],true,uctx) idl + let refs, _ = + List.fold_left (fun (refs,uctx) id -> + let ref = declare_assumption is_coe ~scope ~poly ~kind typ uctx pl imps Glob_term.Explicit nl id in + ref::refs, next_uctx uctx) + ([],uctx) idl in - List.rev refs, status + List.rev refs let maybe_error_many_udecls = function @@ -178,15 +177,17 @@ let do_assumptions ~program_mode ~poly ~scope ~kind nl l = let sigma = Evd.restrict_universe_context sigma uvars in let uctx = Evd.check_univ_decl ~poly sigma udecl in let ubinders = Evd.universe_binders sigma in - pi2 (List.fold_left (fun (subst,status,uctx) ((is_coe,idl),typ,imps) -> + let _, _ = List.fold_left (fun (subst,uctx) ((is_coe,idl),typ,imps) -> let typ = replace_vars subst typ in - let refs, status' = declare_assumptions idl is_coe ~poly ~scope ~kind typ uctx ubinders imps nl in + let refs = declare_assumptions idl is_coe ~poly ~scope ~kind typ uctx ubinders imps nl in let subst' = List.map2 (fun {CAst.v=id} (c,u) -> (id, Constr.mkRef (c,u))) idl refs in - subst'@subst, status' && status, next_uctx uctx) - ([], true, uctx) l) + subst'@subst, next_uctx uctx) + ([], uctx) l + in + () let do_primitive id prim typopt = if Lib.sections_are_opened () then @@ -270,41 +271,43 @@ let context ~poly l = Monomorphic_entry Univ.ContextSet.empty end in - let fn status (name, b, t) = + let fn (name, b, t) = let b, t = Option.map (EConstr.to_constr sigma) b, EConstr.to_constr sigma t in if Lib.is_modtype () && not (Lib.sections_are_opened ()) then (* Declare the universe context once *) let kind = Decls.(IsAssumption Logical) in let decl = match b with - | None -> - Declare.ParameterEntry (None,(t,univs),None) - | Some b -> - let entry = Declare.definition_entry ~univs ~types:t b in - Declare.DefinitionEntry entry + | None -> + Declare.ParameterEntry (None,(t,univs),None) + | Some b -> + let entry = Declare.definition_entry ~univs ~types:t b in + Declare.DefinitionEntry entry in let cst = Declare.declare_constant ~name ~kind decl in let env = Global.env () in Classes.declare_instance env sigma (Some Hints.empty_hint_info) true (GlobRef.ConstRef cst); - status + () else let test x = match x.CAst.v with - | Some (Name id',_) -> Id.equal name id' - | _ -> false + | Some (Name id',_) -> Id.equal name id' + | _ -> false in - let impl = List.exists test impls in + let impl = if List.exists test impls then Glob_term.Implicit else Glob_term.Explicit in let scope = if Lib.sections_are_opened () then DeclareDef.Discharge else DeclareDef.Global ImportDefaultBehavior in - let nstatus = match b with + match b with | None -> - pi3 (declare_assumption false ~scope ~poly ~kind:Decls.Context t univs UnivNames.empty_binders [] impl - Declaremods.NoInline (CAst.make name)) + let _, _ = + declare_assumption false ~scope ~poly ~kind:Decls.Context t + univs UnivNames.empty_binders [] impl + Declaremods.NoInline (CAst.make name) + in + () | Some b -> let entry = Declare.definition_entry ~univs ~types:t b in let _gr = DeclareDef.declare_definition ~name ~scope:DeclareDef.Discharge ~kind:Decls.Definition UnivNames.empty_binders entry [] in - Lib.sections_are_opened () || Lib.is_modtype_strict () - in - status && nstatus + () in - List.fold_left fn true (List.rev ctx) + List.iter fn (List.rev ctx) diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 028ed39656..2715bd8305 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -21,7 +21,7 @@ val do_assumptions -> kind:Decls.assumption_object_kind -> Declaremods.inline -> (ident_decl list * constr_expr) with_coercion list - -> bool + -> unit (** returns [false] if the assumption is neither local to a section, nor in a module type and meant to be instantiated. *) @@ -34,10 +34,10 @@ val declare_assumption -> Entries.universes_entry -> UnivNames.universe_binders -> Impargs.manual_implicits - -> bool (** implicit *) + -> Glob_term.binding_kind -> Declaremods.inline -> variable CAst.t - -> GlobRef.t * Univ.Instance.t * bool + -> GlobRef.t * Univ.Instance.t (** Context command *) @@ -46,6 +46,6 @@ val declare_assumption val context : poly:bool -> local_binder_expr list - -> bool + -> unit val do_primitive : lident -> CPrimitives.op_or_type -> constr_expr option -> unit diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 57de719cb4..9745358ba2 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -85,12 +85,12 @@ let do_definition ~program_mode ?hook ~name ~scope ~poly ~kind univdecl bl red_o in if program_mode then let env = Global.env () in - let (c,ctx), sideff = Future.force ce.Proof_global.proof_entry_body in + let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); assert(Univ.ContextSet.is_empty ctx); Obligations.check_evars env evd; let c = EConstr.of_constr c in - let typ = match ce.Proof_global.proof_entry_type with + let typ = match ce.Declare.proof_entry_type with | Some t -> EConstr.of_constr t | None -> Retyping.get_type_of env evd c in diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index db0c102e14..01505d0733 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -41,5 +41,5 @@ val interp_definition -> red_expr option -> constr_expr -> constr_expr option - -> Evd.side_effects Proof_global.proof_entry * + -> Evd.side_effects Declare.proof_entry * Evd.evar_map * UState.universe_decl * Impargs.manual_implicits diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 74c9bc2886..b6843eab33 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -323,11 +323,6 @@ let adjust_rec_order ~structonly binders rec_order = in Option.map (extract_decreasing_argument ~structonly) rec_order -let check_safe () = - let open Declarations in - let flags = Environ.typing_flags (Global.env ()) in - flags.check_universes && flags.check_guarded - let do_fixpoint_common (fixl : Vernacexpr.fixpoint_expr list) = let fixl = List.map (fun fix -> Vernacexpr.{ fix @@ -339,13 +334,11 @@ let do_fixpoint_common (fixl : Vernacexpr.fixpoint_expr list) = let do_fixpoint_interactive ~scope ~poly l : Lemmas.t = let fixl, ntns, fix, possible_indexes = do_fixpoint_common l in let lemma = declare_fixpoint_interactive_generic ~indexes:possible_indexes ~scope ~poly fix ntns in - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); lemma let do_fixpoint ~scope ~poly l = let fixl, ntns, fix, possible_indexes = do_fixpoint_common l in - declare_fixpoint_generic ~indexes:possible_indexes ~scope ~poly fix ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + declare_fixpoint_generic ~indexes:possible_indexes ~scope ~poly fix ntns let do_cofixpoint_common (fixl : Vernacexpr.cofixpoint_expr list) = let fixl = List.map (fun fix -> {fix with Vernacexpr.rec_order = None}) fixl in @@ -355,10 +348,8 @@ let do_cofixpoint_common (fixl : Vernacexpr.cofixpoint_expr list) = let do_cofixpoint_interactive ~scope ~poly l = let cofix, ntns = do_cofixpoint_common l in let lemma = declare_fixpoint_interactive_generic ~scope ~poly cofix ntns in - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else (); lemma let do_cofixpoint ~scope ~poly l = let cofix, ntns = do_cofixpoint_common l in - declare_fixpoint_generic ~scope ~poly cofix ntns; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + declare_fixpoint_generic ~scope ~poly cofix ntns diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 664010c917..98b869d72e 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -114,20 +114,22 @@ let mk_mltype_data sigma env assums arity indname = inductives which are recognized when a "Type" appears at the end of the conlusion in the source syntax. *) -let rec check_anonymous_type ind = +let rec check_type_conclusion ind = let open Glob_term in match DAst.get ind with - | GSort (UAnonymous {rigid=true}) -> true + | GSort (UAnonymous {rigid=true}) -> (Some true) + | GSort (UNamed _) -> (Some false) | GProd ( _, _, _, e) | GLetIn (_, _, _, e) | GLambda (_, _, _, e) | GApp (e, _) - | GCast (e, _) -> check_anonymous_type e - | _ -> false + | GCast (e, _) -> check_type_conclusion e + | _ -> None -let make_conclusion_flexible sigma = function +let make_anonymous_conclusion_flexible sigma = function | None -> sigma - | Some s -> + | Some (false, _) -> sigma + | Some (true, s) -> (match EConstr.ESorts.kind sigma s with | Type u -> (match Univ.universe_level u with @@ -136,17 +138,23 @@ let make_conclusion_flexible sigma = function | None -> sigma) | _ -> sigma) -let interp_ind_arity env sigma ind = +let intern_ind_arity env sigma ind = let c = intern_gen IsType env sigma ind.ind_arity in let impls = Implicit_quantifiers.implicits_of_glob_constr ~with_products:true c in + let pseudo_poly = check_type_conclusion c in + (constr_loc ind.ind_arity, c, impls, pseudo_poly) + +let pretype_ind_arity env sigma (loc, c, impls, pseudo_poly) = let sigma,t = understand_tcc env sigma ~expected_type:IsType c in - let pseudo_poly = check_anonymous_type c in match Reductionops.sort_of_arity env sigma t with | exception Invalid_argument _ -> - user_err ?loc:(constr_loc ind.ind_arity) (str "Not an arity") + user_err ?loc (str "Not an arity") | s -> - let concl = if pseudo_poly then Some s else None in - sigma, (t, Retyping.relevance_of_sort s, concl, impls) + let concl = match pseudo_poly with + | Some b -> Some (b, s) + | None -> None + in + sigma, (t, Retyping.relevance_of_sort s, concl, impls) let interp_cstrs env sigma impls mldata arity ind = let cnames,ctyps = List.split ind.ind_lc in @@ -251,7 +259,7 @@ let solve_constraints_system levels level_bounds = done; v -let inductive_levels env evd poly arities inds = +let inductive_levels env evd arities inds = let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in let levels = List.map (fun (x,(ctx,a)) -> if Sorts.is_prop a || Sorts.is_sprop a then None @@ -286,7 +294,7 @@ let inductive_levels env evd poly arities inds = CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> if is_impredicative_sort env du then (* Any product is allowed here. *) - evd, arity :: arities + evd, (false, arity) :: arities else (* If in a predicative sort, or asked to infer the type, we take the max of: - indices (if in indices-matter mode) @@ -300,7 +308,6 @@ let inductive_levels env evd poly arities inds = raise (InductiveError LargeNonPropInductiveNotInType) else evd else evd - (* Evd.set_leq_sort env evd (Type cu) du *) in let evd = if len >= 2 && Univ.is_type0m_univ cu then @@ -311,14 +318,14 @@ let inductive_levels env evd poly arities inds = else evd in let duu = Sorts.univ_of_sort du in - let evd = + let template_prop, evd = if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then - Evd.set_eq_sort env evd Sorts.prop du - else evd - else Evd.set_eq_sort env evd (sort_of_univ cu) du + true, Evd.set_eq_sort env evd Sorts.prop du + else false, evd + else false, Evd.set_eq_sort env evd (sort_of_univ cu) du in - (evd, arity :: arities)) + (evd, (template_prop, arity) :: arities)) (evd,[]) (Array.to_list levels') destarities sizes in evd, List.rev arities @@ -328,6 +335,17 @@ let check_named {CAst.loc;v=na} = match na with let msg = str "Parameters must be named." in user_err ?loc msg +let template_polymorphism_candidate env uctx params concl = + match uctx with + | Entries.Monomorphic_entry uctx -> + let concltemplate = Option.cata (fun s -> not (Sorts.is_small s)) false concl in + if not concltemplate then false + else + let template_check = Environ.check_template env in + let conclu = Option.cata Sorts.univ_of_sort Univ.type0m_univ concl in + let params, conclunivs = IndTyping.template_polymorphic_univs ~template_check uctx params conclu in + not (template_check && Univ.LSet.is_empty conclunivs) + | Entries.Polymorphic_entry _ -> false let check_param = function | CLocalDef (na, _, _) -> check_named na @@ -345,25 +363,46 @@ let restrict_inductive_universes sigma ctx_params arities constructors = let uvars = List.fold_right (fun (_,ctypes,_) -> List.fold_right merge_universes_of_constr ctypes) constructors uvars in Evd.restrict_universe_context sigma uvars -let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) notations ~cumulative ~poly ~private_ind finite = - check_all_names_different indl; - List.iter check_param paramsl; - if not (List.is_empty uparamsl) && not (List.is_empty notations) - then user_err (str "Inductives with uniform parameters may not have attached notations."); - let sigma, udecl = interp_univ_decl_opt env0 udecl in +let interp_params env udecl uparamsl paramsl = + let sigma, udecl = interp_univ_decl_opt env udecl in let sigma, (uimpls, ((env_uparams, ctx_uparams), useruimpls)) = - interp_context_evars ~program_mode:false env0 sigma uparamsl in + interp_context_evars ~program_mode:false env sigma uparamsl in let sigma, (impls, ((env_params, ctx_params), userimpls)) = interp_context_evars ~program_mode:false ~impl_env:uimpls env_uparams sigma paramsl in - let indnames = List.map (fun ind -> ind.ind_name) indl in - (* Names of parameters as arguments of the inductive type (defs removed) *) let assums = List.filter is_local_assum ctx_params in - let params = List.map (RelDecl.get_name %> Name.get_id) assums in + sigma, env_params, (ctx_params, env_uparams, ctx_uparams, + List.map (RelDecl.get_name %> Name.get_id) assums, userimpls, useruimpls, impls, udecl) + +let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) notations ~cumulative ~poly ~private_ind finite = + check_all_names_different indl; + List.iter check_param paramsl; + if not (List.is_empty uparamsl) && not (List.is_empty notations) + then user_err (str "Inductives with uniform parameters may not have attached notations."); + + let indnames = List.map (fun ind -> ind.ind_name) indl in + let sigma, env_params, infos = + interp_params env0 udecl uparamsl paramsl + in (* Interpret the arities *) - let sigma, arities = List.fold_left_map (fun sigma -> interp_ind_arity env_params sigma) sigma indl in + let arities = List.map (intern_ind_arity env_params sigma) indl in + + let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, params, userimpls, useruimpls, impls, udecl), arities, is_template = + let is_template = List.exists (fun (_,_,_,pseudo_poly) -> not (Option.is_empty pseudo_poly)) arities in + if not poly && is_template then + (* In case of template polymorphism, we need to compute more constraints *) + let env0 = Environ.set_universes_lbound env0 Univ.Level.prop in + let sigma, env_params, infos = + interp_params env0 udecl uparamsl paramsl + in + let arities = List.map (intern_ind_arity env_params sigma) indl in + sigma, env_params, infos, arities, is_template + else sigma, env_params, infos, arities, is_template + in + + let sigma, arities = List.fold_left_map (pretype_ind_arity env_params) sigma arities in let arities, relevances, arityconcl, indimpls = List.split4 arities in let fullarities = List.map (fun c -> EConstr.it_mkProd_or_LetIn c ctx_params) arities in @@ -410,31 +449,36 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let nf = Evarutil.nf_evars_universes sigma in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in let arities = List.map EConstr.(to_constr sigma) arities in - let sigma = List.fold_left make_conclusion_flexible sigma arityconcl in - let sigma, arities = inductive_levels env_ar_params sigma poly arities constructors in + let sigma = List.fold_left make_anonymous_conclusion_flexible sigma arityconcl in + let sigma, arities = inductive_levels env_ar_params sigma arities constructors in let sigma = Evd.minimize_universes sigma in let nf = Evarutil.nf_evars_universes sigma in - let arities = List.map nf arities in + let arities = List.map (fun (template, arity) -> template, nf arity) arities in let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in let ctx_params = List.map Termops.(map_rel_decl (EConstr.to_constr sigma)) ctx_params in - let arityconcl = List.map (Option.map (EConstr.ESorts.kind sigma)) arityconcl in - let sigma = restrict_inductive_universes sigma ctx_params arities constructors in + let arityconcl = List.map (Option.map (fun (anon, s) -> EConstr.ESorts.kind sigma s)) arityconcl in + let sigma = restrict_inductive_universes sigma ctx_params (List.map snd arities) constructors in let uctx = Evd.check_univ_decl ~poly sigma udecl in - List.iter (fun c -> check_evars env_params (Evd.from_env env_params) sigma (EConstr.of_constr c)) arities; + List.iter (fun c -> check_evars env_params (Evd.from_env env_params) sigma (EConstr.of_constr (snd c))) arities; Context.Rel.iter (fun c -> check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr c)) ctx_params; List.iter (fun (_,ctyps,_) -> List.iter (fun c -> check_evars env_ar_params (Evd.from_env env_ar_params) sigma (EConstr.of_constr c)) ctyps) constructors; (* Build the inductive entries *) - let entries = List.map4 (fun ind arity concl (cnames,ctypes,cimpls) -> + let entries = List.map4 (fun ind (templatearity, arity) concl (cnames,ctypes,cimpls) -> + let template_candidate () = + templatearity || template_polymorphism_candidate env0 uctx ctx_params concl in let template = match template with | Some template -> - if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); + if poly && template then user_err + Pp.(strbrk "Template-polymorphism and universe polymorphism are not compatible."); + if template && not (template_candidate ()) then + user_err Pp.(strbrk "Inductive " ++ Id.print ind.ind_name ++ + str" cannot be made template polymorphic."); template | None -> - should_auto_template ind.ind_name (not poly && - Option.cata (fun s -> not (Sorts.is_small s)) false concl) + should_auto_template ind.ind_name (template_candidate ()) in { mind_entry_typename = ind.ind_name; mind_entry_arity = arity; @@ -567,9 +611,7 @@ let do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uni (* Declare the possible notations of inductive types *) List.iter (Metasyntax.add_notation_interpretation (Global.env ())) ntns; (* Declare the coercions *) - List.iter (fun qid -> Class.try_add_new_coercion (Nametab.locate qid) ~local:false ~poly) coes; - (* If positivity is assumed declares itself as unsafe. *) - if Environ.deactivated_guard (Global.env ()) then Feedback.feedback Feedback.AddedAxiom else () + List.iter (fun qid -> Class.try_add_new_coercion (Nametab.locate qid) ~local:false ~poly) coes (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 285be8cd51..7587bd165f 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -62,3 +62,17 @@ val should_auto_template : Id.t -> bool -> bool (** [should_auto_template x b] is [true] when [b] is [true] and we automatically use template polymorphism. [x] is the name of the inductive under consideration. *) + +val template_polymorphism_candidate : + Environ.env -> Entries.universes_entry -> Constr.rel_context -> Sorts.t option -> bool +(** [template_polymorphism_candidate env uctx params conclsort] is + [true] iff an inductive with params [params] and conclusion + [conclsort] would be definable as template polymorphic. It should + have at least one universe in its monomorphic universe context that + can be made parametric in its conclusion sort, if one is given. + If the [Template Check] flag is false we just check that the conclusion sort + is not small. *) + +val sign_level : Environ.env -> Evd.evar_map -> Constr.rel_declaration list -> Univ.Universe.t +(** [sign_level env sigma ctx] computes the universe level of the context [ctx] + as the [sup] of its individual assumptions, which should be well-typed in [env] and [sigma] *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index c6e68effd7..3497e6369f 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -292,7 +292,7 @@ let do_program_recursive ~scope ~poly fixkind fixl = let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in Obligations.add_mutual_definitions defs ~poly ~scope ~kind ~univdecl:pl ctx ntns fixkind -let do_program_fixpoint ~scope ~poly l = +let do_fixpoint ~scope ~poly l = let g = List.map (fun { Vernacexpr.rec_order } -> rec_order) l in match g, l with | [Some { CAst.v = CWfRec (n,r) }], @@ -322,19 +322,9 @@ let do_program_fixpoint ~scope ~poly l = do_program_recursive ~scope ~poly fixkind l | _, _ -> - user_err ~hdr:"do_program_fixpoint" + user_err ~hdr:"do_fixpoint" (str "Well-founded fixpoints not allowed in mutually recursive blocks") -let check_safe () = - let open Declarations in - let flags = Environ.typing_flags (Global.env ()) in - flags.check_universes && flags.check_guarded - -let do_fixpoint ~scope ~poly l = - do_program_fixpoint ~scope ~poly l; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () - let do_cofixpoint ~scope ~poly fixl = let fixl = List.map (fun fix -> { fix with Vernacexpr.rec_order = None }) fixl in - do_program_recursive ~scope ~poly DeclareObl.IsCoFixpoint fixl; - if not (check_safe ()) then Feedback.feedback Feedback.AddedAxiom else () + do_program_recursive ~scope ~poly DeclareObl.IsCoFixpoint fixl diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 5e4f2dcd34..1926faaf0e 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -44,7 +44,7 @@ end (* Locality stuff *) let declare_definition ~name ~scope ~kind ?hook_data udecl ce imps = - let fix_exn = Future.fix_exn_of ce.Proof_global.proof_entry_body in + let fix_exn = Future.fix_exn_of ce.proof_entry_body in let gr = match scope with | Discharge -> let () = diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 606cfade46..54a0c9a7e8 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -45,7 +45,7 @@ val declare_definition -> kind:Decls.definition_object_kind -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) -> UnivNames.universe_binders - -> Evd.side_effects Proof_global.proof_entry + -> Evd.side_effects Declare.proof_entry -> Impargs.manual_implicits -> GlobRef.t @@ -66,7 +66,7 @@ val prepare_definition : allow_evars:bool -> ?opaque:bool -> ?inline:bool -> poly:bool -> Evd.evar_map -> UState.universe_decl -> types:EConstr.t option -> body:EConstr.t -> - Evd.evar_map * Evd.side_effects Proof_global.proof_entry + Evd.evar_map * Evd.side_effects Declare.proof_entry val prepare_parameter : allow_evars:bool -> poly:bool -> Evd.evar_map -> UState.universe_decl -> EConstr.types -> diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index c5cbb095ca..8fd6bc7eab 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -149,18 +149,8 @@ let declare_obligation prg obl body ty uctx = if get_shrink_obligations () && not poly then shrink_body body ty else ([], body, ty, [||]) in - let body = - ((body, Univ.ContextSet.empty), Evd.empty_side_effects) - in - let ce = - Proof_global.{ proof_entry_body = Future.from_val ~fix_exn:(fun x -> x) body - ; proof_entry_secctx = None - ; proof_entry_type = ty - ; proof_entry_universes = uctx - ; proof_entry_opaque = opaque - ; proof_entry_inline_code = false - ; proof_entry_feedback = None } - in + let ce = Declare.definition_entry ?types:ty ~opaque ~univs:uctx body in + (* ppedrot: seems legit to have obligations as local *) let constant = Declare.declare_constant ~name:obl.obl_name @@ -495,12 +485,11 @@ type obligation_qed_info = } let obligation_terminator entries uctx { name; num; auto } = - let open Proof_global in match entries with | [entry] -> let env = Global.env () in - let ty = entry.proof_entry_type in - let body, eff = Future.force entry.proof_entry_body in + let ty = entry.Declare.proof_entry_type in + let body, eff = Future.force entry.Declare.proof_entry_body in let (body, cstr) = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in let sigma = Evd.from_ctx uctx in let sigma = Evd.merge_context_set ~sideff:true Evd.univ_rigid sigma cstr in @@ -514,7 +503,7 @@ let obligation_terminator entries uctx { name; num; auto } = let obls, rem = prg.prg_obligations in let obl = obls.(num) in let status = - match obl.obl_status, entry.proof_entry_opaque with + match obl.obl_status, entry.Declare.proof_entry_opaque with | (_, Evar_kinds.Expand), true -> err_not_transp () | (true, _), true -> err_not_transp () | (false, _), true -> Evar_kinds.Define true @@ -541,7 +530,7 @@ let obligation_terminator entries uctx { name; num; auto } = declares the univs of the constant, each subsequent obligation declares its own additional universes and constraints if any *) - if defined then UState.make (Global.universes ()) + if defined then UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) else ctx in let prg = {prg with prg_ctx} in diff --git a/vernac/declareObl.mli b/vernac/declareObl.mli index 2a8fa734b3..7d8a112cc6 100644 --- a/vernac/declareObl.mli +++ b/vernac/declareObl.mli @@ -76,7 +76,7 @@ type obligation_qed_info = } val obligation_terminator - : Evd.side_effects Proof_global.proof_entry list + : Evd.side_effects Declare.proof_entry list -> UState.t -> obligation_qed_info -> unit (** [obligation_terminator] part 2 of saving an obligation *) diff --git a/vernac/dune b/vernac/dune index 45b567d631..ba361b1377 100644 --- a/vernac/dune +++ b/vernac/dune @@ -5,12 +5,4 @@ (wrapped false) (libraries tactics parsing)) -(rule - (targets g_proofs.ml) - (deps (:mlg-file g_proofs.mlg)) - (action (run coqpp %{mlg-file}))) - -(rule - (targets g_vernac.ml) - (deps (:mlg-file g_vernac.mlg)) - (action (run coqpp %{mlg-file}))) +(coq.pp (modules g_proofs g_vernac)) diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index ad5d98669d..8a94a010a0 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -72,16 +72,29 @@ let parse_compat_version = let open Flags in function CErrors.user_err ~hdr:"get_compat_version" Pp.(str "Unknown compatibility version \"" ++ str s ++ str "\".") +(* For now we just keep the top-level location of the whole + vernacular, that is to say, including attributes and control flags; + this is not very convenient for advanced clients tho, so in the + future it'd be cool to actually locate the attributes and control + flags individually too. *) +let add_control_flag ~loc ~flag { CAst.v = cmd } = + CAst.make ~loc { cmd with control = flag :: cmd.control } + } GRAMMAR EXTEND Gram GLOBAL: vernac_control quoted_attributes gallina_ext noedit_mode subprf; vernac_control: FIRST - [ [ IDENT "Time"; c = vernac_control -> { CAst.make ~loc @@ VernacTime (false,c) } - | IDENT "Redirect"; s = ne_string; c = vernac_control -> { CAst.make ~loc @@ VernacRedirect (s, c) } - | IDENT "Timeout"; n = natural; v = vernac_control -> { CAst.make ~loc @@ VernacTimeout(n,v) } - | IDENT "Fail"; v = vernac_control -> { CAst.make ~loc @@ VernacFail v } - | v = decorated_vernac -> { let (f, v) = v in CAst.make ~loc @@ VernacExpr(f, v) } ] + [ [ IDENT "Time"; c = vernac_control -> + { add_control_flag ~loc ~flag:(ControlTime false) c } + | IDENT "Redirect"; s = ne_string; c = vernac_control -> + { add_control_flag ~loc ~flag:(ControlRedirect s) c } + | IDENT "Timeout"; n = natural; c = vernac_control -> + { add_control_flag ~loc ~flag:(ControlTimeout n) c } + | IDENT "Fail"; c = vernac_control -> + { add_control_flag ~loc ~flag:ControlFail c } + | v = decorated_vernac -> + { let (attrs, expr) = v in CAst.make ~loc { control = []; attrs; expr = expr } } ] ] ; decorated_vernac: @@ -519,7 +532,7 @@ END let only_starredidentrefs = Pcoq.Entry.of_parser "test_only_starredidentrefs" - (fun strm -> + (fun _ strm -> let rec aux n = match Util.stream_nth n strm with | KEYWORD "." -> () @@ -1035,6 +1048,7 @@ GRAMMAR EXTEND Gram | IDENT "Coercion"; IDENT "Paths"; s = class_rawexpr; t = class_rawexpr -> { PrintCoercionPaths (s,t) } | IDENT "Canonical"; IDENT "Projections" -> { PrintCanonicalConversions } + | IDENT "Typing"; IDENT "Flags" -> { PrintTypingFlags } | IDENT "Tables" -> { PrintTables } | IDENT "Options" -> { PrintTables (* A Synonymous to Tables *) } | IDENT "Hint" -> { PrintHintGoal } diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 23a8bf20a3..a6c577a878 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -98,20 +98,11 @@ let () = (* Util *) -let define ~poly name sigma c t = +let define ~poly name sigma c types = let f = declare_constant ~kind:Decls.(IsDefinition Scheme) in let univs = Evd.univ_entry ~poly sigma in - let open Proof_global in - let kn = f ~name - (DefinitionEntry - { proof_entry_body = c; - proof_entry_secctx = None; - proof_entry_type = t; - proof_entry_universes = univs; - proof_entry_opaque = false; - proof_entry_inline_code = false; - proof_entry_feedback = None; - }) in + let entry = Declare.definition_entry ~univs ?types c in + let kn = f ~name (DefinitionEntry entry) in definition_message name; kn @@ -412,8 +403,7 @@ let do_mutual_induction_scheme ?(force_mutual=false) lnamedepindsort = let declare decl fi lrecref = let decltype = Retyping.get_type_of env0 sigma (EConstr.of_constr decl) in let decltype = EConstr.to_constr sigma decltype in - let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Evd.empty_side_effects) in - let cst = define ~poly fi sigma proof_output (Some decltype) in + let cst = define ~poly fi sigma decl (Some decltype) in GlobRef.ConstRef cst :: lrecref in let _ = List.fold_right2 declare listdecl lrecnames [] in @@ -534,7 +524,6 @@ let do_combined_scheme name schemes = schemes in let sigma,body,typ = build_combined_scheme (Global.env ()) csts in - let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Evd.empty_side_effects) in (* It is possible for the constants to have different universe polymorphism from each other, however that is only when the user manually defined at least one of them (as Scheme would pick the @@ -542,7 +531,7 @@ let do_combined_scheme name schemes = some other polymorphism they can also manually define the combined scheme. *) let poly = Global.is_polymorphic (GlobRef.ConstRef (List.hd csts)) in - ignore (define ~poly name.v sigma proof_output (Some typ)); + ignore (define ~poly name.v sigma body (Some typ)); fixpoint_message None [name.v] (**********************************************************************) @@ -553,7 +542,7 @@ let declare_default_schemes kn = let mib = Global.lookup_mind kn in let n = Array.length mib.mind_packets in if !elim_flag && (mib.mind_finite <> Declarations.BiFinite || !bifinite_elim_flag) - && mib.mind_typing_flags.check_guarded then + && mib.mind_typing_flags.check_positive then declare_induction_schemes kn; if !case_flag then map_inductive_block declare_one_case_analysis_scheme kn n; if is_eq_flag() then try_declare_beq_scheme kn; diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 6a754a0cde..42d1a1f3fc 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -258,7 +258,7 @@ let save_remaining_recthms env sigma ~poly ~scope ~udecl uctx body opaq i { Rect let open DeclareDef in (match scope with | Discharge -> - let impl = false in (* copy values from Vernacentries *) + let impl = Glob_term.Explicit in let univs = match univs with | Polymorphic_entry (_, univs) -> (* What is going on here? *) @@ -336,8 +336,7 @@ let finish_admitted env sigma ~name ~poly ~scope pe ctx hook ~udecl impargs othe let () = Declare.assumption_message name in Declare.declare_univ_binders (GlobRef.ConstRef kn) (UState.universe_binders ctx); (* This takes care of the implicits and hook for the current constant*) - process_recthms ?fix_exn:None ?hook env sigma ctx ~udecl ~poly ~scope:(Global local) (GlobRef.ConstRef kn) impargs other_thms; - Feedback.feedback Feedback.AddedAxiom + process_recthms ?fix_exn:None ?hook env sigma ctx ~udecl ~poly ~scope:(Global local) (GlobRef.ConstRef kn) impargs other_thms let save_lemma_admitted ~(lemma : t) : unit = (* Used for printing in recthms *) @@ -384,10 +383,9 @@ let adjust_guardness_conditions const = function | possible_indexes -> (* Try all combinations... not optimal *) let env = Global.env() in - let open Proof_global in { const with - proof_entry_body = - Future.chain const.proof_entry_body + Declare.proof_entry_body = + Future.chain const.Declare.proof_entry_body (fun ((body, ctx), eff) -> match Constr.kind body with | Fix ((nv,0),(_,_,fixdefs as fixdecls)) -> @@ -405,10 +403,11 @@ let finish_proved env sigma idopt po info = let name = match idopt with | None -> name | Some { CAst.v = save_id } -> check_anonymity name save_id; save_id in - let fix_exn = Future.fix_exn_of const.proof_entry_body in + let fix_exn = Future.fix_exn_of const.Declare.proof_entry_body in let () = try let const = adjust_guardness_conditions const compute_guard in - let should_suggest = const.proof_entry_opaque && Option.is_empty const.proof_entry_secctx in + let should_suggest = const.Declare.proof_entry_opaque && + Option.is_empty const.Declare.proof_entry_secctx in let open DeclareDef in let r = match scope with | Discharge -> @@ -452,7 +451,7 @@ let finish_derived ~f ~name ~idopt ~entries = in (* The opacity of [f_def] is adjusted to be [false], as it must. Then [f] is declared in the global environment. *) - let f_def = { f_def with Proof_global.proof_entry_opaque = false } in + let f_def = { f_def with Declare.proof_entry_opaque = false } in let f_kind = Decls.(IsDefinition Definition) in let f_def = Declare.DefinitionEntry f_def in let f_kn = Declare.declare_constant ~name:f ~kind:f_kind f_def in @@ -464,17 +463,17 @@ let finish_derived ~f ~name ~idopt ~entries = let substf c = Vars.replace_vars [f,f_kn_term] c in (* Extracts the type of the proof of [suchthat]. *) let lemma_pretype = - match Proof_global.(lemma_def.proof_entry_type) with + match lemma_def.Declare.proof_entry_type with | Some t -> t | None -> assert false (* Proof_global always sets type here. *) in (* The references of [f] are subsituted appropriately. *) let lemma_type = substf lemma_pretype in (* The same is done in the body of the proof. *) - let lemma_body = Future.chain Proof_global.(lemma_def.proof_entry_body) (fun ((b,ctx),fx) -> (substf b, ctx), fx) in - let lemma_def = let open Proof_global in + let lemma_body = Future.chain lemma_def.Declare.proof_entry_body (fun ((b,ctx),fx) -> (substf b, ctx), fx) in + let lemma_def = { lemma_def with - proof_entry_body = lemma_body; + Declare.proof_entry_body = lemma_body; proof_entry_type = Some lemma_type } in let lemma_def = Declare.DefinitionEntry lemma_def in @@ -531,7 +530,7 @@ let save_lemma_admitted_delayed ~proof ~info = let { Info.hook; scope; impargs; other_thms } = info in if List.length entries <> 1 then user_err Pp.(str "Admitted does not support multiple statements"); - let { proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in + let { Declare.proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in let poly = match proof_entry_universes with | Entries.Monomorphic_entry _ -> false | Entries.Polymorphic_entry (_, _) -> true in diff --git a/library/library.ml b/vernac/library.ml index 0faef7bf84..e91cb965f5 100644 --- a/library/library.ml +++ b/vernac/library.ml @@ -474,10 +474,10 @@ let require_library_from_dirpath ~lib_resolver modrefl export = if Lib.is_module_or_modtype () then begin warn_require_in_module (); - add_anonymous_leaf (in_require (needed,modrefl,None)); - Option.iter (fun exp -> - add_anonymous_leaf (in_import_library (modrefl,exp))) - export + add_anonymous_leaf (in_require (needed,modrefl,None)); + Option.iter (fun exp -> + add_anonymous_leaf (in_import_library (modrefl,exp))) + export end else add_anonymous_leaf (in_require (needed,modrefl,export)); @@ -547,7 +547,7 @@ let current_deps () = let current_reexports () = !libraries_exports_list let error_recursively_dependent_library dir = - user_err + user_err (strbrk "Unable to use logical name " ++ DirPath.print dir ++ strbrk " to save current library because" ++ strbrk " it already depends on a library of this name.") @@ -640,3 +640,12 @@ let get_used_load_paths () = StringSet.empty !libraries_loaded_list) let _ = Nativelib.get_load_paths := get_used_load_paths + +(* These commands may not be very safe due to ML-side plugin loading + etc... use at your own risk *) +let extern_state s = + System.extern_state Coq_config.state_magic_number s (States.freeze ~marshallable:true) + +let intern_state s = + States.unfreeze (System.with_magic_number_check (System.intern_state Coq_config.state_magic_number) s); + overwrite_library_filenames s diff --git a/library/library.mli b/vernac/library.mli index bb6c42e393..973b369226 100644 --- a/library/library.mli +++ b/vernac/library.mli @@ -75,3 +75,7 @@ val native_name_from_filename : string -> string (** {6 Opaque accessors} *) val indirect_accessor : Opaqueproof.indirect_accessor + +(** Low-level state overwriting, not very safe *) +val intern_state : string -> unit +val extern_state : string -> unit diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 37fe0df0ee..da14b6e979 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -423,11 +423,11 @@ let solve_by_tac ?loc name evi t poly ctx = Pfedit.build_constant_by_tactic ~name ~poly ctx evi.evar_hyps evi.evar_concl t in let env = Global.env () in - let (body, eff) = Future.force entry.Proof_global.proof_entry_body in + let (body, eff) = Future.force entry.Declare.proof_entry_body in let body = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in Inductiveops.control_only_guard env ctx' (EConstr.of_constr (fst body)); - Some (fst body, entry.Proof_global.proof_entry_type, Evd.evar_universe_context ctx') + Some (fst body, entry.Declare.proof_entry_type, Evd.evar_universe_context ctx') with | Refiner.FailError (_, s) as exn -> let _ = CErrors.push exn in @@ -454,7 +454,7 @@ let obligation_hook prg obl num auto { DeclareDef.Hook.S.uctx = ctx'; dref; _ } if not prg.prg_poly (* Not polymorphic *) then (* The universe context was declared globally, we continue from the new global environment. *) - let ctx = UState.make (Global.universes ()) in + let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let ctx' = UState.merge_subst ctx (UState.subst ctx') in Univ.Instance.empty, ctx' else diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 0eb0b1b6f6..f91983d31c 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -514,6 +514,8 @@ let string_of_theorem_kind = let open Decls in function ++ pr_class_rawexpr t | PrintCanonicalConversions -> keyword "Print Canonical Structures" + | PrintTypingFlags -> + keyword "Print Typing Flags" | PrintTables -> keyword "Print Tables" | PrintHintGoal -> @@ -1266,6 +1268,16 @@ let string_of_definition_object_kind = let open Decls in function | VernacEndSubproof -> return (str "}") +let pr_control_flag (p : control_flag) = + let w = match p with + | ControlTime _ -> keyword "Time" + | ControlRedirect s -> keyword "Redirect" ++ spc() ++ qs s + | ControlTimeout n -> keyword "Timeout " ++ int n + | ControlFail -> keyword "Fail" in + w ++ spc () + +let pr_vernac_control flags = Pp.prlist pr_control_flag flags + let rec pr_vernac_flag (k, v) = let k = keyword k in let open Attributes in @@ -1281,19 +1293,11 @@ let pr_vernac_attributes = | [] -> mt () | flags -> str "#[" ++ pr_vernac_flags flags ++ str "]" ++ cut () - let rec pr_vernac_control v = - let return = tag_vernac v in - match v.v with - | VernacExpr (f, v') -> pr_vernac_attributes f ++ pr_vernac_expr v' ++ sep_end v' - | VernacTime (_,v) -> - return (keyword "Time" ++ spc() ++ pr_vernac_control v) - | VernacRedirect (s, v) -> - return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_control v) - | VernacTimeout(n,v) -> - return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac_control v) - | VernacFail v-> - return (keyword "Fail" ++ spc() ++ pr_vernac_control v) - - let pr_vernac v = - try pr_vernac_control v - with e -> CErrors.print e +let pr_vernac ({v = {control; attrs; expr}} as v) = + try + tag_vernac v + (pr_vernac_control control ++ + pr_vernac_attributes attrs ++ + pr_vernac_expr expr ++ + sep_end expr) + with e -> CErrors.print e diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index 094e2c1184..cfb3248c7b 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -130,7 +130,7 @@ let suggest_common env ppid used ids_typ skip = str "should start with one of the following commands:"++spc()++ v 0 ( prlist_with_sep cut (fun x->str"Proof using " ++x++ str". ") !valid_exprs)); - if !Flags.record_aux_file + if Aux_file.recording () then let s = string_of_ppcmds (prlist_with_sep (fun _ -> str";") (fun x->x) !valid_exprs) in record_proof_using s diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index da28e260b3..826e88cabf 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -67,7 +67,7 @@ module Vernac_ = let command_entry = Pcoq.Entry.of_parser "command_entry" - (fun strm -> Pcoq.Entry.parse_token_stream (select_tactic_entry !command_entry_ref) strm) + (fun _ strm -> Pcoq.Entry.parse_token_stream (select_tactic_entry !command_entry_ref) strm) end diff --git a/vernac/record.ml b/vernac/record.ml index 86745212e7..831fb53549 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -85,10 +85,10 @@ let interp_fields_evars env sigma impls_env nots l = let compute_constructor_level evars env l = List.fold_right (fun d (env, univ) -> - let univ = + let univ = if is_local_assum d then let s = Retyping.get_sort_of env evars (RelDecl.get_type d) in - Univ.sup (univ_of_sort s) univ + Univ.sup (univ_of_sort s) univ else univ in (EConstr.push_rel d env, univ)) l (env, Univ.Universe.sprop) @@ -101,8 +101,19 @@ let binder_of_decl = function let binders_of_decls = List.map binder_of_decl +let check_anonymous_type ind = + match ind with + | { CAst.v = CSort (Glob_term.UAnonymous {rigid=true}) } -> true + | _ -> false + let typecheck_params_and_fields finite def poly pl ps records = let env0 = Global.env () in + (* Special case elaboration for template-polymorphic inductives, + lower bound on introduced universes is Prop so that we do not miss + any Set <= i constraint for universes that might actually be instantiated with Prop. *) + let is_template = + List.exists (fun (_, arity, _, _) -> Option.cata check_anonymous_type true arity) records in + let env0 = if not poly && is_template then Environ.set_universes_lbound env0 Univ.Level.prop else env0 in let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env0 pl in let () = let error bk {CAst.loc; v=name} = @@ -111,15 +122,15 @@ let typecheck_params_and_fields finite def poly pl ps records = user_err ?loc ~hdr:"record" (str "Record parameters must be named") | _ -> () in - List.iter + List.iter (function CLocalDef (b, _, _) -> error default_binder_kind b | CLocalAssum (ls, bk, ce) -> List.iter (error bk) ls | CLocalPattern {CAst.loc} -> Loc.raise ?loc (Stream.Error "pattern with quote not allowed in record parameters")) ps - in + in let sigma, (impls_env, ((env1,newps), imps)) = interp_context_evars ~program_mode:false env0 sigma ps in let fold (sigma, template) (_, t, _, _) = match t with - | Some t -> + | Some t -> let env = EConstr.push_rel_context newps env0 in let poly = match t with @@ -138,7 +149,7 @@ let typecheck_params_and_fields finite def poly pl ps records = (sigma, false), (s, s') else (sigma, false), (s, s')) | _ -> user_err ?loc:(constr_loc t) (str"Sort expected.")) - | None -> + | None -> let uvarkind = Evd.univ_flexible_alg in let sigma, s = Evd.new_sort_variable uvarkind sigma in (sigma, template), (EConstr.mkSort s, s) @@ -168,23 +179,23 @@ let typecheck_params_and_fields finite def poly pl ps records = let _, univ = compute_constructor_level sigma env_ar newfs in let univ = if Sorts.is_sprop sort then univ else Univ.Universe.sup univ Univ.type0m_univ in if not def && is_impredicative_sort env0 sort then - sigma, typ + sigma, (univ, typ) else let sigma = Evd.set_leq_sort env_ar sigma (Sorts.sort_of_univ univ) sort in if Univ.is_small_univ univ && Option.cata (Evd.is_flexible_level sigma) false (Evd.is_sort_variable sigma sort) then (* We can assume that the level in aritysort is not constrained and clear it, if it is flexible *) - Evd.set_eq_sort env_ar sigma Sorts.set sort, EConstr.mkSort (Sorts.sort_of_univ univ) - else sigma, typ + Evd.set_eq_sort env_ar sigma Sorts.set sort, (univ, EConstr.mkSort (Sorts.sort_of_univ univ)) + else sigma, (univ, typ) in let (sigma, typs) = List.fold_left2_map fold sigma typs data in let sigma, (newps, ans) = Evarutil.finalize sigma (fun nf -> let newps = List.map (RelDecl.map_constr_het nf) newps in - let map (impls, newfs) typ = + let map (impls, newfs) (univ, typ) = let newfs = List.map (RelDecl.map_constr_het nf) newfs in let typ = nf typ in - (typ, impls, newfs) + (univ, typ, impls, newfs) in let ans = List.map2 map data typs in newps, ans) @@ -295,7 +306,7 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let x = make_annot (Name binder_name) mip.mind_relevance in let fields = instantiate_possibly_recursive_type (fst indsp) u mib.mind_ntypes paramdecls fields in let lifted_fields = Termops.lift_rel_context 1 fields in - let primitive = + let primitive = match mib.mind_record with | PrimRecord _ -> true | FakeRecord | NotRecord -> false @@ -310,7 +321,7 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f | Anonymous -> (None::sp_projs,i,NoProjection fi::subst) | Name fid -> try - let kn, term = + let kn, term = if is_local_assum decl && primitive then let p = Projection.Repr.make indsp ~proj_npars:mib.mind_nparams @@ -340,26 +351,17 @@ let declare_projections indsp ctx ?(kind=Decls.StructureComponent) binder_name f let projtyp = it_mkProd_or_LetIn (mkProd (x,rp,ccl)) paramdecls in try - let open Proof_global in - let entry = { - proof_entry_body = - Future.from_val ((proj, Univ.ContextSet.empty), Evd.empty_side_effects); - proof_entry_secctx = None; - proof_entry_type = Some projtyp; - proof_entry_universes = ctx; - proof_entry_opaque = false; - proof_entry_inline_code = false; - proof_entry_feedback = None } in + let entry = Declare.definition_entry ~univs:ctx ~types:projtyp proj in let kind = Decls.IsDefinition kind in let kn = declare_constant ~name:fid ~kind (Declare.DefinitionEntry entry) in let constr_fip = let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in - applist (mkConstU (kn,u),proj_args) + applist (mkConstU (kn,u),proj_args) in Declare.definition_message fid; kn, constr_fip with Type_errors.TypeError (ctx,te) -> - raise (NotDefinable (BadTypedProj (fid,ctx,te))) + raise (NotDefinable (BadTypedProj (fid,ctx,te))) in let refi = GlobRef.ConstRef kn in Impargs.maybe_declare_manual_implicits false refi impls; @@ -413,29 +415,33 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let binder_name = match name with | None -> - let map (id, _, _, _, _, _, _) = + let map (id, _, _, _, _, _, _, _) = Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) in Array.map_of_list map record_data | Some n -> n in let ntypes = List.length record_data in - let mk_block i (id, idbuild, arity, _, fields, _, _) = + let mk_block i (id, idbuild, min_univ, arity, _, fields, _, _) = let nfields = List.length fields in let args = Context.Rel.to_extended_list mkRel nfields params in let ind = applist (mkRel (ntypes - i + nparams + nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in let template = + let template_candidate () = + ComInductive.template_polymorphism_candidate (Global.env ()) univs params + (Some (Sorts.sort_of_univ min_univ)) + in match template with | Some template, _ -> (* templateness explicitly requested *) if poly && template then user_err Pp.(strbrk "template and polymorphism not compatible"); + if template && not (template_candidate ()) then + user_err Pp.(strbrk "record cannot be made template polymorphic on any universe"); template | None, template -> (* auto detect template *) - ComInductive.should_auto_template id (template && not poly && - let _, s = Reduction.dest_arity (Global.env()) arity in - not (Sorts.is_small s)) + ComInductive.should_auto_template id (template && template_candidate ()) in { mind_entry_typename = id; mind_entry_arity = arity; @@ -446,7 +452,7 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let blocks = List.mapi mk_block record_data in let primitive = !primitive_flag && - List.for_all (fun (_,_,_,_,fields,_,_) -> List.exists is_local_assum fields) record_data + List.for_all (fun (_,_,_,_,_,fields,_,_) -> List.exists is_local_assum fields) record_data in let mie = { mind_entry_params = params; @@ -463,7 +469,7 @@ let declare_structure ~cumulative finite ubinders univs paramimpls params templa let kn = ComInductive.declare_mutual_inductive_with_eliminations mie ubinders impls ~primitive_expected:!primitive_flag in - let map i (_, _, _, fieldimpls, fields, is_coe, coers) = + let map i (_, _, _, _, fieldimpls, fields, is_coe, coers) = let rsp = (kn, i) in (* This is ind path of idstruc *) let cstr = (rsp, 1) in let kinds,sp_projs = declare_projections rsp ctx ~kind binder_name.(i) coers fieldimpls fields in @@ -478,7 +484,7 @@ let implicits_of_context ctx = List.map (fun name -> CAst.make (Some (name,true))) (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) -let declare_class def cumulative ubinders univs id idbuild paramimpls params arity +let declare_class def cumulative ubinders univs id idbuild paramimpls params univ arity template fieldimpls fields ?(kind=Decls.StructureComponent) coers priorities = let fieldimpls = (* Make the class implicit in the projections, and the params if applicable. *) @@ -493,7 +499,7 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params ari let binder = {binder with binder_name=Name binder_name} in let class_body = it_mkLambda_or_LetIn field params in let class_type = it_mkProd_or_LetIn arity params in - let class_entry = + let class_entry = Declare.definition_entry ~types:class_type ~univs class_body in let cst = Declare.declare_constant ~name:id (DefinitionEntry class_entry) ~kind:Decls.(IsDefinition Definition) @@ -518,18 +524,18 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params ari Impargs.declare_manual_implicits false (GlobRef.ConstRef proj_cst) (List.hd fieldimpls); Classes.set_typeclass_transparency (EvalConstRef cst) false false; let sub = match List.hd coers with - | Some b -> Some ((if b then Backward else Forward), List.hd priorities) - | None -> None + | Some b -> Some ((if b then Backward else Forward), List.hd priorities) + | None -> None in [cref, [Name proj_name, sub, Some proj_cst]] | _ -> - let record_data = [id, idbuild, arity, fieldimpls, fields, false, + let record_data = [id, idbuild, univ, arity, fieldimpls, fields, false, List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields] in let inds = declare_structure ~cumulative Declarations.BiFinite ubinders univs paramimpls params template ~kind:Decls.Method ~name:[|binder_name|] record_data in - let coers = List.map2 (fun coe pri -> - Option.map (fun b -> + let coers = List.map2 (fun coe pri -> + Option.map (fun b -> if b then Backward, pri else Forward, pri) coe) coers priorities in @@ -584,7 +590,7 @@ let add_constant_class env sigma cst = let ctx, _ = decompose_prod_assum ty in let args = Context.Rel.to_extended_vect Constr.mkRel 0 ctx in let t = mkApp (mkConstU (cst, Univ.make_abstract_instance univs), args) in - let tc = + let tc = { cl_univs = univs; cl_impl = GlobRef.ConstRef cst; cl_context = (List.map (const None) ctx, ctx); @@ -688,24 +694,24 @@ let definition_structure udecl kind ~template ~cumulative ~poly finite records = let template = template, auto_template in match kind with | Class def -> - let (_, id, _, cfs, idbuild, _), (arity, implfs, fields) = match records, data with + let (_, id, _, cfs, idbuild, _), (univ, arity, implfs, fields) = match records, data with | [r], [d] -> r, d | _, _ -> CErrors.user_err (str "Mutual definitional classes are not handled") in let priorities = List.map (fun (_, { rf_priority }) -> {hint_priority = rf_priority ; hint_pattern = None}) cfs in let coers = List.map (fun (_, { rf_subclass }) -> rf_subclass) cfs in declare_class def cumulative ubinders univs id.CAst.v idbuild - implpars params arity template implfs fields coers priorities + implpars params univ arity template implfs fields coers priorities | _ -> let map impls = implpars @ [CAst.make None] @ impls in - let data = List.map (fun (arity, implfs, fields) -> (arity, List.map map implfs, fields)) data in - let map (arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = + let data = List.map (fun (univ, arity, implfs, fields) -> (univ, arity, List.map map implfs, fields)) data in + let map (univ, arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = let coe = List.map (fun (_, { rf_subclass ; rf_canonical }) -> { pf_subclass = not (Option.is_empty rf_subclass); pf_canonical = rf_canonical }) cfs in - id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe + id.CAst.v, idbuild, univ, arity, implfs, fields, is_coe, coe in let data = List.map2 map data records in let inds = declare_structure ~cumulative finite ubinders univs implpars params template data in diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 20de6b4ff2..cd13f83e96 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -16,6 +16,7 @@ DeclareDef DeclareObl Canonical RecLemmas +Library Lemmas Class Auto_ind_decl diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 9af8d8b67c..3d14e8d510 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -604,8 +604,25 @@ let vernac_assumption ~atts discharge kind l nl = match scope with | DeclareDef.Global _ -> Dumpglob.dump_definition lid false "ax" | DeclareDef.Discharge -> Dumpglob.dump_definition lid true "var") idl) l; - let status = ComAssumption.do_assumptions ~poly:atts.polymorphic ~program_mode:atts.program ~scope ~kind nl l in - if not status then Feedback.feedback Feedback.AddedAxiom + ComAssumption.do_assumptions ~poly:atts.polymorphic ~program_mode:atts.program ~scope ~kind nl l + +let set_template_check b = + let typing_flags = Environ.typing_flags (Global.env ()) in + Global.set_typing_flags { typing_flags with Declarations.check_template = b } + +let is_template_check () = + let typing_flags = Environ.typing_flags (Global.env ()) in + typing_flags.Declarations.check_template + +let () = + let tccheck = + { optdepr = true; + optname = "Template universe check"; + optkey = ["Template"; "Check"]; + optread = (fun () -> is_template_check ()); + optwrite = (fun b -> set_template_check b)} + in + declare_bool_option tccheck let is_polymorphic_inductive_cumulativity = declare_bool_option_and_ref ~depr:false ~value:false @@ -1074,9 +1091,6 @@ let vernac_declare_instance ~atts id bl inst pri = let global = not (make_section_locality locality) in Classes.declare_new_instance ~program_mode:program ~global ~poly id bl inst pri -let vernac_context ~poly l = - if not (ComAssumption.context ~poly l) then Feedback.feedback Feedback.AddedAxiom - let vernac_existing_instance ~section_local insts = let glob = not section_local in List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts @@ -1165,11 +1179,11 @@ let vernac_chdir = function let vernac_write_state file = let file = CUnix.make_suffix file ".coq" in - States.extern_state file + Library.extern_state file let vernac_restore_state file = let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in - States.intern_state file + Library.intern_state file (************) (* Commands *) @@ -1728,6 +1742,30 @@ let () = optread = Nativenorm.get_profiling_enabled; optwrite = Nativenorm.set_profiling_enabled } +let _ = + declare_bool_option + { optdepr = false; + optname = "guard checking"; + optkey = ["Guard"; "Checking"]; + optread = (fun () -> (Global.typing_flags ()).Declarations.check_guarded); + optwrite = (fun b -> Global.set_check_guarded b) } + +let _ = + declare_bool_option + { optdepr = false; + optname = "positivity/productivity checking"; + optkey = ["Positivity"; "Checking"]; + optread = (fun () -> (Global.typing_flags ()).Declarations.check_positive); + optwrite = (fun b -> Global.set_check_positive b) } + +let _ = + declare_bool_option + { optdepr = false; + optname = "universes checking"; + optkey = ["Universe"; "Checking"]; + optread = (fun () -> (Global.typing_flags ()).Declarations.check_universes); + optwrite = (fun b -> Global.set_check_universes b) } + let vernac_set_strategy ~local l = let local = Option.default false local in let glob_ref r = @@ -1932,10 +1970,11 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let vernac_print ~pstate ~atts = let sigma, env = get_current_or_global_context ~pstate in function + | PrintTypingFlags -> pr_typing_flags (Environ.typing_flags (Global.env ())) | PrintTables -> print_tables () - | PrintFullContext-> print_full_context_typ env sigma - | PrintSectionContext qid -> print_sec_context_typ env sigma qid - | PrintInspect n -> inspect env sigma n + | PrintFullContext-> print_full_context_typ Library.indirect_accessor env sigma + | PrintSectionContext qid -> print_sec_context_typ Library.indirect_accessor env sigma qid + | PrintInspect n -> inspect Library.indirect_accessor env sigma n | PrintGrammar ent -> Metasyntax.pr_grammar ent | PrintCustomGrammar ent -> Metasyntax.pr_custom_grammar ent | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir @@ -1948,7 +1987,7 @@ let vernac_print ~pstate ~atts = | PrintDebugGC -> Mltop.print_gc () | PrintName (qid,udecl) -> dump_global qid; - print_name env sigma qid udecl + print_name Library.indirect_accessor env sigma qid udecl | PrintGraph -> Prettyp.print_graph () | PrintClasses -> Prettyp.print_classes() | PrintTypeClasses -> Prettyp.print_typeclasses() @@ -2246,14 +2285,40 @@ let with_fail ~st f = user_err ~hdr:"Fail" (str "The command has not failed!") | Ok msg -> if not !Flags.quiet || !test_mode - then Feedback.msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) + then Feedback.msg_notice (str "The command has indeed failed with message:" ++ fnl () ++ msg) let locate_if_not_already ?loc (e, info) = match Loc.get_loc info with | None -> (e, Option.cata (Loc.add_loc info) info loc) | Some l -> (e, info) -exception End_of_input +let mk_time_header = + (* Drop the time header to print the command, we should indeed use a + different mechanism to `-time` commands than the current hack of + adding a time control to the AST. *) + let pr_time_header vernac = + let vernac = match vernac with + | { v = { control = ControlTime _ :: control; attrs; expr }; loc } -> + CAst.make ?loc { control; attrs; expr } + | _ -> vernac + in + Topfmt.pr_cmd_header vernac + in + fun vernac -> Lazy.from_fun (fun () -> pr_time_header vernac) + +let interp_control_flag ~time_header (f : control_flag) ~st + (fn : st:Vernacstate.t -> Vernacstate.LemmaStack.t option) = + match f with + | ControlFail -> + with_fail ~st (fun () -> fn ~st); + st.Vernacstate.lemmas + | ControlTimeout timeout -> + vernac_timeout ~timeout (fun () -> fn ~st) () + | ControlTime batch -> + let header = if batch then Lazy.force time_header else Pp.mt () in + System.with_time ~batch ~header (fun () -> fn ~st) () + | ControlRedirect s -> + Topfmt.with_output_to_file s (fun () -> fn ~st) () (* EJGA: We may remove this, only used twice below *) let vernac_require_open_lemma ~stack f = @@ -2439,7 +2504,7 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with | VernacDeclareInstance (id, bl, inst, info) -> VtDefault(fun () -> vernac_declare_instance ~atts id bl inst info) | VernacContext sup -> - VtDefault(fun () -> vernac_context ~poly:(only_polymorphism atts) sup) + VtDefault(fun () -> ComAssumption.context ~poly:(only_polymorphism atts) sup) | VernacExistingInstance insts -> VtDefault(fun () -> with_section_locality ~atts vernac_existing_instance insts) | VernacExistingClass id -> @@ -2491,7 +2556,7 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with VtDefault(fun () -> vernac_hints ~atts dbnames hints) | VernacSyntacticDefinition (id,c,b) -> - VtDefault(fun () -> vernac_syntactic_definition ~atts id c b) + VtDefault(fun () -> vernac_syntactic_definition ~atts id c b) | VernacArguments (qid, args, more_implicits, nargs, bidi, flags) -> VtDefault(fun () -> with_section_locality ~atts (vernac_arguments qid args more_implicits nargs bidi flags)) @@ -2614,7 +2679,7 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -and interp_expr ?proof ~atts ~st c = +and interp_expr ~atts ~st c = let stack = st.Vernacstate.lemmas in vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); match c with @@ -2644,6 +2709,8 @@ and interp_expr ?proof ~atts ~st c = without a considerable amount of refactoring. *) and vernac_load ~verbosely fname = + let exception End_of_input in + (* Note that no proof should be open here, so the state here is just token for now *) let st = Vernacstate.freeze_interp_state ~marshallable:false in let fname = @@ -2664,7 +2731,7 @@ and vernac_load ~verbosely fname = try let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) stack in let stack = - v_mod (interp_control ?proof:None ~st:{ st with Vernacstate.lemmas = stack }) + v_mod (interp_control ~st:{ st with Vernacstate.lemmas = stack }) (parse_sentence proof_mode input) in load_loop ~stack with @@ -2677,23 +2744,36 @@ and vernac_load ~verbosely fname = CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); () -and interp_control ?proof ~st v = match v with - | { v=VernacExpr (atts, cmd) } -> - let before_univs = Global.universes () in - let pstack = interp_expr ?proof ~atts ~st cmd in - if before_univs == Global.universes () then pstack - else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Proof_global.update_global_env) pstack - | { v=VernacFail v } -> - with_fail ~st (fun () -> interp_control ?proof ~st v); - st.Vernacstate.lemmas - | { v=VernacTimeout (timeout,v) } -> - vernac_timeout ~timeout (interp_control ?proof ~st) v - | { v=VernacRedirect (s, v) } -> - Topfmt.with_output_to_file s (interp_control ?proof ~st) v - | { v=VernacTime (batch, cmd) }-> - let header = if batch then Topfmt.pr_cmd_header cmd else Pp.mt () in - System.with_time ~batch ~header (interp_control ?proof ~st) cmd - +and interp_control ~st ({ v = cmd } as vernac) = + let time_header = mk_time_header vernac in + List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) + cmd.control + (fun ~st -> + let before_univs = Global.universes () in + let pstack = interp_expr ~atts:cmd.attrs ~st cmd.expr in + if before_univs == Global.universes () then pstack + else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Proof_global.update_global_env) pstack) + ~st + +(* Interpreting a possibly delayed proof *) +let interp_qed_delayed ~proof ~info ~st pe : Vernacstate.LemmaStack.t option = + let stack = st.Vernacstate.lemmas in + let stack = Option.cata (fun stack -> snd @@ Vernacstate.LemmaStack.pop stack) None stack in + let () = match pe with + | Admitted -> + save_lemma_admitted_delayed ~proof ~info + | Proved (_,idopt) -> + save_lemma_proved_delayed ~proof ~info ~idopt in + stack + +let interp_qed_delayed_control ~proof ~info ~st ~control { loc; v=pe } = + let time_header = mk_time_header (CAst.make ?loc { control; attrs = []; expr = VernacEndProof pe }) in + List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) + control + (fun ~st -> interp_qed_delayed ~proof ~info ~st pe) + ~st + +(* General interp with management of state *) let () = declare_int_option { optdepr = false; @@ -2703,11 +2783,11 @@ let () = optwrite = ((:=) default_timeout) } (* Be careful with the cache here in case of an exception. *) -let interp ?(verbosely=true) ~st cmd = +let interp_gen ~verbosely ~st ~interp_fn cmd = Vernacstate.unfreeze_interp_state st; try vernac_timeout (fun st -> let v_mod = if verbosely then Flags.verbosely else Flags.silently in - let ontop = v_mod (interp_control ~st) cmd in + let ontop = v_mod (interp_fn ~st) cmd in Vernacstate.Proof_global.set ontop [@ocaml.warning "-3"]; Vernacstate.freeze_interp_state ~marshallable:false ) st @@ -2717,18 +2797,10 @@ let interp ?(verbosely=true) ~st cmd = Vernacstate.invalidate_cache (); iraise exn -let interp_qed_delayed_proof ~proof ~info ~st ?loc pe : Vernacstate.t = - let stack = st.Vernacstate.lemmas in - let stack = Option.cata (fun stack -> snd @@ Vernacstate.LemmaStack.pop stack) None stack in - try - let () = match pe with - | Admitted -> - save_lemma_admitted_delayed ~proof ~info - | Proved (_,idopt) -> - save_lemma_proved_delayed ~proof ~info ~idopt in - { st with Vernacstate.lemmas = stack } - with exn -> - let exn = CErrors.push exn in - let exn = locate_if_not_already ?loc exn in - Vernacstate.invalidate_cache (); - iraise exn +(* Regular interp *) +let interp ?(verbosely=true) ~st cmd = + interp_gen ~verbosely ~st ~interp_fn:interp_control cmd + +let interp_qed_delayed_proof ~proof ~info ~st ~control pe : Vernacstate.t = + interp_gen ~verbosely:false ~st + ~interp_fn:(interp_qed_delayed_control ~proof ~info ~control) pe diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index e618cdcefe..e65f9d3cfe 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -17,8 +17,8 @@ val interp_qed_delayed_proof : proof:Proof_global.proof_object -> info:Lemmas.Info.t -> st:Vernacstate.t - -> ?loc:Loc.t - -> Vernacexpr.proof_end + -> control:Vernacexpr.control_flag list + -> Vernacexpr.proof_end CAst.t -> Vernacstate.t (** [with_fail ~st f] runs [f ()] and expects it to fail, otherwise it fails. *) diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 0968632c2d..b712d7e264 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -24,6 +24,7 @@ type goal_reference = | GoalId of Id.t type printable = + | PrintTypingFlags | PrintTables | PrintFullContext | PrintSectionContext of qualid @@ -169,7 +170,7 @@ type inductive_expr = type one_inductive_expr = lident * local_binder_expr list * constr_expr option * constructor_expr list -type typeclass_constraint = name_decl * Decl_kinds.binding_kind * constr_expr +type typeclass_constraint = name_decl * Glob_term.binding_kind * constr_expr and typeclass_context = typeclass_constraint list type proof_expr = @@ -414,12 +415,17 @@ type nonrec vernac_expr = (* For extension *) | VernacExtend of extend_name * Genarg.raw_generic_argument list -type vernac_control_r = - | VernacExpr of Attributes.vernac_flags * vernac_expr +type control_flag = + | ControlTime of bool (* boolean is true when the `-time` batch-mode command line flag was set. the flag is used to print differently in `-time` vs `Time foo` *) - | VernacTime of bool * vernac_control - | VernacRedirect of string * vernac_control - | VernacTimeout of int * vernac_control - | VernacFail of vernac_control + | ControlRedirect of string + | ControlTimeout of int + | ControlFail + +type vernac_control_r = + { control : control_flag list + ; attrs : Attributes.vernac_flags + ; expr : vernac_expr + } and vernac_control = vernac_control_r CAst.t diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml index 747998c6cc..903a28e953 100644 --- a/vernac/vernacprop.ml +++ b/vernac/vernacprop.ml @@ -13,47 +13,26 @@ open Vernacexpr -let rec under_control v = v |> CAst.with_val (function - | VernacExpr (_, c) -> c - | VernacRedirect (_,c) - | VernacTime (_,c) - | VernacFail c - | VernacTimeout (_,c) -> under_control c - ) - -let rec has_Fail v = v |> CAst.with_val (function - | VernacExpr _ -> false - | VernacRedirect (_,c) - | VernacTime (_,c) - | VernacTimeout (_,c) -> has_Fail c - | VernacFail _ -> true) +(* Does this vernacular involve Fail? *) +let has_Fail { CAst.v } = List.mem ControlFail v.control (* Navigation commands are allowed in a coqtop session but not in a .v file *) -let is_navigation_vernac_expr = function +let is_navigation_vernac = function | VernacResetInitial | VernacResetName _ | VernacBack _ -> true | _ -> false -let is_navigation_vernac c = - is_navigation_vernac_expr (under_control c) - -let rec is_deep_navigation_vernac v = v |> CAst.with_val (function - | VernacTime (_,c) -> is_deep_navigation_vernac c - | VernacRedirect (_, c) - | VernacTimeout (_, c) | VernacFail c -> is_navigation_vernac c - | VernacExpr _ -> false) - (* NB: Reset is now allowed again as asked by A. Chlipala *) -let is_reset = CAst.with_val (function - | VernacExpr ( _, VernacResetInitial) - | VernacExpr (_, VernacResetName _) -> true - | _ -> false) +let is_reset = function + | VernacResetInitial + | VernacResetName _ -> true + | _ -> false -let is_debug cmd = match under_control cmd with +let is_debug = function | VernacSetOption (_, ["Ltac";"Debug"], _) -> true | _ -> false -let is_undo cmd = match under_control cmd with +let is_undo = function | VernacUndo _ | VernacUndoTo _ -> true | _ -> false diff --git a/vernac/vernacprop.mli b/vernac/vernacprop.mli index 8875b86d94..320878e401 100644 --- a/vernac/vernacprop.mli +++ b/vernac/vernacprop.mli @@ -13,16 +13,9 @@ open Vernacexpr -(* Return the vernacular command below control (Time, Timeout, Redirect, Fail). - Beware that Fail can change many properties of the underlying command, since - a success of Fail means the command was backtracked over. *) -val under_control : vernac_control -> vernac_expr - val has_Fail : vernac_control -> bool - -val is_navigation_vernac : vernac_control -> bool -val is_deep_navigation_vernac : vernac_control -> bool -val is_reset : vernac_control -> bool -val is_debug : vernac_control -> bool -val is_undo : vernac_control -> bool +val is_navigation_vernac : vernac_expr -> bool +val is_reset : vernac_expr -> bool +val is_debug : vernac_expr -> bool +val is_undo : vernac_expr -> bool |