diff options
138 files changed, 3640 insertions, 1679 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 7c9a5c9a31..ce0c1d9af7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -2,10 +2,15 @@ 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 @@ -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 bf07e37ef4..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 ### 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/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..ac9bc26344 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|] let v_univs = v_sum "universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] @@ -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/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/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/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/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/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/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/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/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/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 774732825a..c391cc949d 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1204,6 +1204,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 dcfe4a08f3..cc91776a4d 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -514,9 +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 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/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..3f216b0d63 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) -> 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/impargs.ml b/interp/impargs.ml index 3f2a1b075c..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,17 @@ 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 = let id = NamedDecl.get_id decl in - match Lib.variable_section_kind id with - | Implicit -> Some (id, Manual, (true, true)) - | _ -> None + 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 (NamedDecl.is_local_assum) ctx) @@ -579,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_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/kernel/declarations.ml b/kernel/declarations.ml index dff19dee5e..8d32684b09 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 *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 7a553700e8..391b139496 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -19,6 +19,7 @@ module RelDecl = Context.Rel.Declaration let safe_flags oracle = { check_guarded = true; + check_positive = true; check_universes = true; conv_oracle = oracle; share_reduction = true; diff --git a/kernel/environ.ml b/kernel/environ.ml index 9a75f0b682..655094e88b 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -216,6 +216,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 = @@ -418,6 +421,7 @@ 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; @@ -426,6 +430,7 @@ let same_flags { enable_native_compiler; } 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 && diff --git a/kernel/environ.mli b/kernel/environ.mli index 6cd4f96645..e6d814ac7d 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -176,6 +176,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 } *) 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/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/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/library/decl_kinds.ml b/library/decl_kinds.ml deleted file mode 100644 index 17746645ee..0000000000 --- a/library/decl_kinds.ml +++ /dev/null @@ -1,11 +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) *) -(************************************************************************) - -type binding_kind = Explicit | Implicit diff --git a/library/global.ml b/library/global.ml index ca774dbd74..0fc9e11364 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) diff --git a/library/global.mli b/library/global.mli index d034bc4208..b089b7dd80 100644 --- a/library/global.mli +++ b/library/global.mli @@ -31,6 +31,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 diff --git a/library/lib.ml b/library/lib.ml index 6b01eb07e9..3f51826315 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -441,9 +441,6 @@ let empty_section_data ~poly = { let sectab = Summary.ref ([] : section_data list) ~name:"section-context" -let sec_implicits = - Summary.ref Id.Map.empty ~name:"section-implicits" - let check_same_poly p sec = if p != sec.sec_poly then user_err Pp.(str "Cannot mix universe polymorphic and monomorphic declarations in sections.") @@ -452,14 +449,13 @@ 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 = +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} :: s.sec_entry } in - sectab := s :: sl; - sec_implicits := Id.Map.add name kind !sec_implicits + sectab := s :: sl let add_section_context ctx = match !sectab with @@ -576,8 +572,6 @@ let section_segment_of_reference = let open GlobRef in function let variable_section_segment_of_reference gr = (section_segment_of_reference gr).abstr_ctx -let variable_section_kind id = Id.Map.get id !sec_implicits - let section_instance = let open GlobRef in function | VarRef id -> let eq = function diff --git a/library/lib.mli b/library/lib.mli index 7dc8b52282..9ffa69ef93 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -177,12 +177,11 @@ 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 -> Constr.named_context -val variable_section_kind : Id.t -> Decl_kinds.binding_kind 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 -> 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..3b75438ccd 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -1,4 +1,3 @@ -Decl_kinds Libnames Globnames Libobject @@ -11,5 +10,4 @@ Library States Kindops Goptions -Keys Coqlib 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/g_constr.mlg b/parsing/g_constr.mlg index 78a12a2e7d..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 diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 5a939b4adf..ca33e4e757 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -941,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 @@ -953,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 *) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index d220058120..2b990400e3 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -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 diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 730ae48393..60717c6eec 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -495,14 +495,17 @@ let find_induction_principle evd f = | Constr.Const c' -> c' | _ -> CErrors.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 + 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. @@ -1016,12 +1019,12 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti *) 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 -> CErrors.user_err Pp.(str "No graph found") + 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 + 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 @@ -1174,9 +1177,9 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef 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 + 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 @@ -1231,12 +1234,15 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef in incr i; let opacity = - let finfos = find_Function_infos (fst first_fun) in - try - let equation = Option.get finfos.equation_lemma in + let finfos = + match find_Function_infos (fst first_fun) with + | None -> raise Not_found + | Some finfos -> finfos + in + match finfos.equation_lemma with + | None -> false (* non recursive definition *) + | Some equation -> 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 *) @@ -1381,7 +1387,11 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = 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 = find_Function_infos (fst f_as_constant) 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 @@ -1443,7 +1453,11 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = (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 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 @@ -1600,7 +1614,7 @@ let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt w let b = Names.Id.of_string "___b" in Constrexpr_ops.mkLambdaC( [CAst.make @@ Name a; CAst.make @@ Name b], - Constrexpr.Default Decl_kinds.Explicit, + Constrexpr.Default Glob_term.Explicit, wf_arg_type, Constrexpr_ops.mkAppC(wf_rel_expr, [ @@ -2028,7 +2042,11 @@ let build_case_scheme fa = 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 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 diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 798c62d549..ddd6ecfb5c 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -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 diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index d36d86a65b..fbf63c69dd 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -4,7 +4,6 @@ open Glob_term open CErrors open Util open Names -open Decl_kinds (* Some basic functions to rebuild glob_constr diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index eeb2f246c2..2937ae5d14 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -8,15 +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 EConstr -open Pp + +open Tacmach.New +open Tacticals.New +open Tactics + open Indfun_common -open Tactypes module RelDecl = Context.Rel.Declaration @@ -37,111 +41,106 @@ 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 + 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)) + | _ -> raise (UserError(None,str "functional induction must be used with a function" )) + end + | 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 - 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 + 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 - Tacticals.tclTHEN - (Proofview.V82.of_tactic (choose_dest_or_ind - princ_infos - (args_as_induction_constr,princ'))) - subst_and_reduce - g' - in res + 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 + 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 (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 + 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 97a840e950..476d74b3f8 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -8,9 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -val functional_induction : - bool -> - EConstr.constr -> - (EConstr.constr * EConstr.constr Tactypes.bindings) option -> - Ltac_plugin.Tacexpr.or_and_intro_pattern option -> - Goal.goal Evd.sigma -> Goal.goal list Evd.sigma +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 52a29fb559..7719705138 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -92,13 +92,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 @@ @@ -301,20 +294,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) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index fff4711044..16beaaa3c7 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -38,7 +38,6 @@ 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 make_eq : unit -> EConstr.constr @@ -75,8 +74,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 diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 38fdd789a3..d72319d078 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -34,9 +34,10 @@ let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> 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 !*) + 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 @@ -108,18 +109,20 @@ let invfun qhyp 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 - Tactics.try_intros_until (fun hid -> functional_inversion kn hid (mkConst f) f_correct) qhyp - with - | Not_found -> CErrors.user_err (Pp.str "No graph found") - | Option.IsNone -> CErrors.user_err (Pp.str "Cannot use equivalence with graph!") - -exception NoFunction + match find_Function_infos f with + | None -> + CErrors.user_err (Pp.str "No graph found") + | Some finfos -> + match finfos.correctness_lemma with + | None -> + 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 -> @@ -132,31 +135,33 @@ let invfun qhyp f = 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 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 | 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 with - | NoFunction -> - CErrors.user_err Pp.(str "Hypothesis " ++ Ppconstr.pr_id hid ++ str " must contain at least one Function") - | Option.IsNone -> - 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) - | Not_found -> - 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) + | 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 diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 7cd43cb5cd..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 @@ -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/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/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 33e9f871fd..473612fda7 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) diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index aa1316f15e..4c6b7cdcb6 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -128,10 +128,9 @@ 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 () -> @@ -336,17 +335,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 +494,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/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 175a863ad8..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 @@ -1337,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) ")" ] -> @@ -1362,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 @@ -1391,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 | _ -> [] @@ -1521,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") diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 0adabb0673..f3f1d713e9 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 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/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/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/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/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/printer.ml b/printing/printer.ml index ec1b9b8e49..e3225fadd5 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -853,7 +853,8 @@ 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 *) + | 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 *) @@ -873,7 +874,7 @@ struct | Positive m1 , Positive m2 -> MutInd.CanOrd.compare m1 m2 | Guarded k1 , Guarded k2 -> - Constant.CanOrd.compare k1 k2 + GlobRef.Ordered.compare k1 k2 | _ , Constant _ -> 1 | _ , Positive _ -> 1 | _ -> -1 @@ -903,14 +904,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 +934,11 @@ 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.") + | 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 +1012,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..788f303aee 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -191,7 +191,8 @@ 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 *) + | 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 +208,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/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 69dbebbc57..7f0632bd7c 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" @@ -2873,7 +2876,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); @@ -2939,7 +2942,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/tactics/auto.ml b/tactics/auto.ml index 499e7a63d7..67f49f0074 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; 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 61f9c3b1c5..c280760e84 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -243,11 +243,16 @@ 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 @@ -257,19 +262,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,7 +300,7 @@ 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 } + | 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) *) @@ -311,7 +317,6 @@ let declare_variable ~name ~kind d = | 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 | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a @@ -336,14 +341,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, + 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; + 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 *) @@ -489,6 +494,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..4ae9f6c7ae 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -23,7 +23,7 @@ open Entries type variable_declaration = | SectionLocalDef of Evd.side_effects Proof_global.proof_entry - | SectionLocalAssum of { typ:types; univs:Univ.ContextSet.t; poly:bool; impl:bool } + | 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 diff --git a/tactics/equality.ml b/tactics/equality.ml index 7c90c59f61..220b9bc475 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; @@ -334,6 +332,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 +358,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/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/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/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/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 21bea6c315..b60feb9256 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -726,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. @@ -980,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 index 3ca9248600..004854e751 100644 --- a/theories/Reals/ConstructiveCauchyReals.v +++ b/theories/Reals/ConstructiveCauchyReals.v @@ -13,6 +13,7 @@ Require Import QArith. Require Import Qabs. Require Import Qround. Require Import Logic.ConstructiveEpsilon. +Require CMorphisms. Open Scope Q. @@ -24,95 +25,9 @@ Open Scope Q. 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. *) + under more abstract names, like Rlt_asym instead of CRealLt_asym. -(* First some limit results about Q *) -Lemma Qarchimedean : forall q : Q, { p : positive | Qlt q (Z.pos p # 1) }. -Proof. - intros. destruct q. unfold Qlt. simpl. - rewrite Zmult_1_r. destruct Qnum. - - exists xH. reflexivity. - - exists (p+1)%positive. apply (Z.lt_le_trans _ (Z.pos (p+1))). - apply Z.lt_succ_diag_r. 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. -Qed. - -Lemma Qinv_lt_contravar : forall a b : Q, - Qlt 0 a -> Qlt 0 b -> (Qlt a b <-> Qlt (/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. - -Lemma Qabs_separation : forall q : Q, - (forall k:positive, Qlt (Qabs q) (1 # k)) - -> q == 0. -Proof. - intros. destruct (Qle_lt_or_eq 0 (Qabs q)). apply Qabs_nonneg. - - exfalso. destruct (Qarchimedean (Qinv (Qabs q))) as [p maj]. - specialize (H p). apply (Qlt_not_le (/ Qabs q) (Z.pos p # 1)). - apply maj. apply Qlt_le_weak. - setoid_replace (Z.pos p # 1) with (/(1#p)). 2: reflexivity. - rewrite <- Qinv_lt_contravar. apply H. apply H0. - reflexivity. - - destruct q. unfold Qeq in H0. simpl in H0. - rewrite Zmult_1_r in H0. replace Qnum with 0%Z. reflexivity. - destruct (Zabs_dec Qnum). rewrite e. rewrite H0. reflexivity. - rewrite e. rewrite <- H0. ring. -Qed. - -Lemma Qle_limit : forall (a b : Q), - (forall eps:Q, Qlt 0 eps -> Qlt a (b + eps)) - -> Qle a b. -Proof. - intros. destruct (Q_dec a b). destruct s. - apply Qlt_le_weak. assumption. exfalso. - assert (0 < a - b). unfold Qminus. apply (Qlt_minus_iff b a). - assumption. specialize (H (a-b) H0). - apply (Qlt_irrefl a). ring_simplify in H. assumption. - rewrite q. apply Qle_refl. -Qed. - -Lemma Qopp_lt_compat : forall p q, p<q -> -q < -p. -Proof. - intros (a1,a2) (b1,b2); unfold Qlt; simpl. - rewrite !Z.mul_opp_l. omega. -Qed. - -Lemma Qmult_minus_one : forall q : Q, inject_Z (-1) * q == - q. -Proof. - intros. field. -Qed. - -Lemma Qsub_comm : forall a b : Q, - a + b == b - a. -Proof. - intros. unfold Qeq. simpl. rewrite Pos.mul_comm. ring. -Qed. - -Lemma PosLt_le_total : forall p q, Pos.lt p q \/ Pos.le q p. -Proof. - intros. destruct (Pos.lt_total p q). left. assumption. - right. destruct H. subst q. apply Pos.le_refl. unfold Pos.lt in H. - unfold Pos.le. rewrite H. discriminate. -Qed. - - - - -(* Cauchy reals are Cauchy sequences of rational numbers, equipped with explicit moduli of convergence and an equivalence relation (the difference converges to zero). @@ -290,105 +205,36 @@ Qed. Definition CReal : Set := { x : (nat -> Q) | QCauchySeq x Pos.to_nat }. -Declare Scope R_scope_constr. +Declare Scope CReal_scope. (* Declare Scope R_scope with Key R *) -Delimit Scope R_scope_constr with CReal. +Delimit Scope CReal_scope with CReal. (* Automatically open scope R_scope for arguments of type R *) -Bind Scope R_scope_constr with CReal. +Bind Scope CReal_scope with CReal. -Open Scope R_scope_constr. - - - - -(* 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. - intros [xn limx] [yn limy]. unfold proj1_sig. split. - - intros [cvmod H] n. unfold proj1_sig in H. - apply Qle_limit. intros. - 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 H1 H1). - setoid_replace (xn (Pos.to_nat n) - yn (Pos.to_nat n)) - with (xn (Pos.to_nat n) - xn p + (xn p - yn p + (yn p - yn (Pos.to_nat n)))). - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat n) - xn p) - + Qabs (xn p - yn p + (yn p - yn (Pos.to_nat n))))). - apply Qabs_triangle. - setoid_replace (2 # n) with ((1 # n) + (1#n)). rewrite <- Qplus_assoc. - apply Qplus_lt_le_compat. - apply limx. apply le_refl. assumption. - apply (Qle_trans _ (Qabs (xn p - yn p) + Qabs (yn p - yn (Pos.to_nat n)))). - apply Qabs_triangle. rewrite (Qplus_comm (1#n)). apply Qplus_le_compat. - apply Qle_lteq. left. apply (Qlt_trans _ (1 # k)). - assumption. - setoid_replace (Z.pos k #1) with (/ (1#k)) in maj. 2: reflexivity. - apply Qinv_lt_contravar. reflexivity. apply H0. apply maj. - apply Qle_lteq. left. - apply limy. assumption. apply le_refl. - ring_simplify. reflexivity. field. - - intros. 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) 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) with (2 # 2 * (3 * k)). 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. +Open Scope CReal_scope. (* So QSeqEquiv is the equivalence relation of this constructive pre-order *) -Definition CRealLt (x y : CReal) : Prop +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) := CRealLt x y \/ CRealLt y x. +Definition CReal_appart (x y : CReal) := sum (CRealLt x y) (CRealLt y x). -Infix "<" := CRealLt : R_scope_constr. -Infix ">" := CRealGt : R_scope_constr. -Infix "#" := CReal_appart : R_scope_constr. +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, - x < y - -> { n : positive | Qlt (2 # n) - (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)) }. + CRealLtProp x y -> x < y. Proof. intros. assert (exists n : nat, n <> O @@ -409,25 +255,55 @@ Proof. (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 /\ ~CRealLt y x. + := (CRealLt x y -> False) /\ (CRealLt y x -> False). -Infix "==" := CRealEq : R_scope_constr. +Infix "==" := CRealEq : CReal_scope. (* Alias the large order *) Definition CRealLe (x y : CReal) : Prop - := ~CRealLt y x. + := CRealLt y x -> False. Definition CRealGe (x y : CReal) := CRealLe y x. -Infix "<=" := CRealLe : R_scope_constr. -Infix ">=" := CRealGe : R_scope_constr. +Infix "<=" := CRealLe : CReal_scope. +Infix ">=" := CRealGe : CReal_scope. -Notation "x <= y <= z" := (x <= y /\ y <= z) : R_scope_constr. -Notation "x <= y < z" := (x <= y /\ y < z) : R_scope_constr. -Notation "x < y < z" := (x < y /\ y < z) : R_scope_constr. -Notation "x < y <= z" := (x < y /\ y <= z) : R_scope_constr. +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)) @@ -465,6 +341,79 @@ Proof. 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) @@ -520,8 +469,8 @@ Qed. Lemma CRealLt_above : forall (x y : CReal), CRealLt x y - -> exists 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)). + -> { 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). @@ -565,20 +514,15 @@ 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). - destruct (PosLt_le_total n p). - - apply (Qlt_not_le (proj1_sig y (Pos.to_nat p)) (proj1_sig x (Pos.to_nat p))). - apply H0. unfold Pos.le. unfold Pos.lt in H1. rewrite H1. discriminate. - apply Qlt_le_weak. apply (Qplus_lt_l _ _ (-proj1_sig x (Pos.to_nat p))). - rewrite Qplus_opp_r. apply (Qlt_trans _ (2#p)). - unfold Qlt. simpl. unfold Z.lt. auto. apply H. apply Pos.le_refl. - - apply (Qlt_not_le (proj1_sig y (Pos.to_nat n)) (proj1_sig x (Pos.to_nat n))). - apply H0. apply Pos.le_refl. apply Qlt_le_weak. - apply (Qplus_lt_l _ _ (-proj1_sig x (Pos.to_nat n))). - rewrite Qplus_opp_r. apply (Qlt_trans _ (2#p)). - unfold Qlt. simpl. unfold Z.lt. auto. apply H. assumption. + 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). +Lemma CRealLt_irrefl : forall x:CReal, x < x -> False. Proof. intros x abs. exact (CRealLt_asym x x abs abs). Qed. @@ -600,10 +544,10 @@ Proof. Qed. Lemma CRealLt_dec : forall x y z : CReal, - CRealLt x y -> { CRealLt x z } + { CRealLt z y }. + CRealLt x y -> CRealLt x z + CRealLt z y. Proof. intros [xn limx] [yn limy] [zn limz] clt. - destruct (CRealLtEpsilon _ _ clt) as [n inf]. + 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. @@ -656,9 +600,10 @@ Proof. 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_l _ _ (1#n)). rewrite Qplus_opp_r. - apply (Qplus_lt_r _ _ (yn (Pos.to_nat n) - yn (Pos.to_nat (Pos.max n (4 * k))))). - ring_simplify. rewrite Qmult_minus_one. + + 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. @@ -680,7 +625,7 @@ Proof. apply Qinv_lt_contravar. reflexivity. apply epsPos. apply kmaj. unfold Qeq. simpl. rewrite Pos.mul_1_r. reflexivity. field. assumption. -Qed. +Defined. Definition linear_order_T x y z := CRealLt_dec x z y. @@ -692,13 +637,19 @@ Proof. Qed. Lemma CRealLt_Le_trans : forall x y z : CReal, - CRealLt x y - -> CRealLe y z -> CRealLt x z. + 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. @@ -720,11 +671,16 @@ Add Parametric Relation : CReal CRealEq transitivity proved by CRealEq_trans as CRealEq_rel. -Add Parametric Morphism : CRealLt - with signature CRealEq ==> CRealEq ==> iff - as CRealLt_morph. +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. destruct H, H0. split. + 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. @@ -733,22 +689,22 @@ Proof. assumption. assumption. contradiction. Qed. -Add Parametric Morphism : CRealGt - with signature CRealEq ==> CRealEq ==> iff - as CRealGt_morph. +Instance CRealGt_morph + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRelationClasses.iffT)) CRealGt. Proof. - intros. unfold CRealGt. apply CRealLt_morph; assumption. + intros x y H x0 y0 H0. apply CRealLt_morph; assumption. Qed. -Add Parametric Morphism : CReal_appart - with signature CRealEq ==> CRealEq ==> iff - as CReal_appart_morph. +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 H1. - right. rewrite <- H0, <- H. exact H1. - - intros. destruct H1. left. rewrite H0, H. exact H1. - right. rewrite H0, H. exact H1. + - 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 @@ -818,8 +774,8 @@ Proof. intro q. exists (fun n => q). apply ConstCauchy. Defined. -Notation "0" := (inject_Q 0) : R_scope_constr. -Notation "1" := (inject_Q 1) : R_scope_constr. +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. @@ -948,7 +904,13 @@ Proof. apply le_0_n. apply H1. apply le_refl. Defined. -Infix "+" := CReal_plus : R_scope_constr. +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)) @@ -981,15 +943,15 @@ Proof. destruct x as [xn limx]. exists (fun n : nat => - xn n). intros k p q H H0. unfold Qminus. rewrite Qopp_involutive. - rewrite Qsub_comm. apply limx; assumption. + rewrite Qplus_comm. apply limx; assumption. Defined. -Notation "- x" := (CReal_opp x) : R_scope_constr. +Notation "- x" := (CReal_opp x) : CReal_scope. Definition CReal_minus (x y : CReal) : CReal := CReal_plus x (CReal_opp y). -Infix "-" := CReal_minus : R_scope_constr. +Infix "-" := CReal_minus : CReal_scope. Lemma belowMultiple : forall n p : nat, lt 0 p -> le n (p * n). Proof. @@ -1060,6 +1022,12 @@ Proof. 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 @@ -1080,9 +1048,7 @@ Proof. Qed. Lemma CReal_plus_lt_reg_l : - forall x y z : CReal, - CRealLt (CReal_plus x y) (CReal_plus x z) - -> CRealLt y z. + 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 @@ -1095,6 +1061,27 @@ Proof. 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. @@ -1105,6 +1092,12 @@ Proof. 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. @@ -1135,6 +1128,17 @@ Proof. - 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. @@ -1144,7 +1148,7 @@ Proof. - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. Qed. -Fixpoint BoundFromZero (qn : nat -> Q) (k : nat) (A : positive) {struct k} +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. @@ -1291,7 +1295,7 @@ Proof. apply H; apply linear_max; assumption. Defined. -Infix "*" := CReal_mult : R_scope_constr. +Infix "*" := CReal_mult : CReal_scope. Lemma CReal_mult_unfold : forall x y : CReal, QSeqEquivEx (proj1_sig (CReal_mult x y)) @@ -1451,7 +1455,7 @@ Lemma CReal_mult_lt_0_compat : forall x y : CReal, -> CRealLt (inject_Q 0) y -> CRealLt (inject_Q 0) (CReal_mult x y). Proof. - intros. destruct H, H0. + 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]. @@ -1492,8 +1496,7 @@ Proof. Qed. Lemma CReal_mult_plus_distr_l : forall r1 r2 r3 : CReal, - CRealEq (CReal_mult r1 (CReal_plus r2 r3)) - (CReal_plus (CReal_mult r1 r2) (CReal_mult r1 r3)). + 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 @@ -1613,6 +1616,15 @@ Proof. + 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. @@ -1692,6 +1704,13 @@ 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. @@ -1699,6 +1718,13 @@ 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. @@ -1706,14 +1732,50 @@ 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. @@ -1728,9 +1790,7 @@ Proof. Qed. Lemma CReal_mult_lt_compat_l : forall x y z : CReal, - CRealLt (inject_Q 0) x - -> CRealLt y z - -> CRealLt (CReal_mult x y) (CReal_mult x z). + 0 < x -> y < z -> x*y < x*z. Proof. intros. apply (CReal_plus_lt_reg_l (CReal_opp (CReal_mult x y))). @@ -1744,6 +1804,13 @@ Proof. 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) @@ -1753,15 +1820,15 @@ Proof. - 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 H. + 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 H. + 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 H. + 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 H. + exact (CRealLt_irrefl _ abs). exact c. Qed. @@ -1783,8 +1850,8 @@ Arguments INR n%nat. Fixpoint IPR_2 (p:positive) : CReal := match p with | xH => 1 + 1 - | xO p => (1 + 1) * IPR_2 p - | xI p => (1 + 1) * (1 + IPR_2 p) + | xO p => IPR_2 p + IPR_2 p + | xI p => (1 + IPR_2 p) + (1 + IPR_2 p) end. Definition IPR (p:positive) : CReal := @@ -1804,7 +1871,7 @@ Definition IZR (z:Z) : CReal := end. Arguments IZR z%Z : simpl never. -Notation "2" := (IZR 2) : R_scope_constr. +Notation "2" := (IZR 2) : CReal_scope. (**********) Lemma S_INR : forall n:nat, INR (S n) == INR n + 1. @@ -1812,15 +1879,24 @@ 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. inversion H. + - intros. exfalso. inversion H. - intros. unfold lt in H. apply le_S_n in H. destruct m. - inversion H. apply CRealLt_0_1. apply Nat.le_succ_r in H. destruct H. + 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 H. + 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. @@ -1866,29 +1942,73 @@ Proof. Qed. (**********) -Lemma IZN : forall n:Z, (0 <= n)%Z -> exists m : nat, n = Z.of_nat m. +Lemma IZN : forall n:Z, (0 <= n)%Z -> { m : nat | n = Z.of_nat m }. Proof. - intros z; idtac; apply Z_of_nat_complete; assumption. + 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, 2 * INR (Pos.to_nat p) == IPR_2 p). + 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. - rewrite CReal_plus_comm. reflexivity. - - unfold IPR_2; now rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. - - apply CReal_mult_1_r. } + 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. - apply CReal_plus_comm. - now rewrite Pos2Nat.inj_xO, 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. rewrite <- INR_IPR. apply (lt_INR 0), Pos2Nat.is_pos. + 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. (**********) @@ -1939,6 +2059,77 @@ Proof. 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). @@ -1975,7 +2166,7 @@ Qed. (* Axiom Rarchimed_constr *) Lemma Rarchimedean : forall x:CReal, - { n:Z | x < IZR n /\ IZR n < x+2 }. + { n:Z & x < IZR n < x+2 }. Proof. (* Locate x within 1/4 and pick the first integer above this interval. *) intros [xn limx]. @@ -2018,7 +2209,7 @@ Proof. Qed. Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal, - (CRealLt a b \/ CRealLt c d) -> { CRealLt a b } + { CRealLt c d }. + (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b + CRealLt c d. Proof. intros. assert (exists n : nat, n <> O /\ @@ -2100,7 +2291,7 @@ Definition CRealNegShift (x : CReal) -> { y : prod positive CReal | CRealEq x (snd y) /\ forall n:nat, Qlt (proj1_sig (snd y) n) (-1 # fst y) }. Proof. - intro xNeg. apply CRealLtEpsilon in xNeg. + intro xNeg. pose proof (CRealLt_aboveSig x (inject_Q 0)). pose proof (CRealShiftReal x). pose proof (CRealShiftEqual x). @@ -2137,7 +2328,7 @@ Definition CRealPosShift (x : CReal) -> { y : prod positive CReal | CRealEq x (snd y) /\ forall n:nat, Qlt (1 # fst y) (proj1_sig (snd y) n) }. Proof. - intro xPos. apply CRealLtEpsilon in xPos. + intro xPos. pose proof (CRealLt_aboveSig (inject_Q 0) x). pose proof (CRealShiftReal x). pose proof (CRealShiftEqual x). @@ -2318,7 +2509,7 @@ Qed. Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal. Proof. - apply CRealLtDisjunctEpsilon in xnz. destruct xnz as [xNeg | xPos]. + 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))). @@ -2329,17 +2520,17 @@ Proof. apply (CReal_inv_pos yn). apply cau. apply maj. Defined. -Notation "/ x" := (CReal_inv x) (at level 35, right associativity) : R_scope_constr. +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 (CRealLtDisjunctEpsilon r (inject_Q 0) (inject_Q 0) r rnz). + destruct rnz. - exfalso. apply CRealLt_asym in H. contradiction. - destruct (CRealPosShift r c) as [[k rpos] [req maj]]. - clear req. clear rnz. destruct rpos as [rn cau]; simpl in 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. @@ -2393,7 +2584,7 @@ Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), ((/ r) rnz) * r == 1. Proof. intros. unfold CReal_inv; simpl. - destruct (CRealLtDisjunctEpsilon r (inject_Q 0) (inject_Q 0) r rnz). + 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 _ @@ -2478,6 +2669,72 @@ Proof. 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 @@ -2488,12 +2745,136 @@ Fixpoint pow (r:CReal) (n:nat) : CReal := (**********) Definition IQR (q:Q) : CReal := match q with - | Qmake a b => IZR a * (CReal_inv (IPR b)) (or_intror (IPR_pos b)) + | 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)) (or_intror (CReal_injectQPos (Z.pos b # 1) pos))) + CRealEq (CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos))) (inject_Q (1 # b)). Proof. intros. @@ -2511,12 +2892,12 @@ Qed. Lemma FinjectQ_CReal : forall q : Q, IQR q == inject_Q q. Proof. - intros [a b]. unfold IQR; simpl. + 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)) (or_intror (CReal_injectQPos (Z.pos b # 1) pos))))). + (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. @@ -2530,6 +2911,41 @@ Proof. discriminate. Qed. -Close Scope R_scope_constr. +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 index adffa9b719..b53436be55 100644 --- a/theories/Reals/ConstructiveRIneq.v +++ b/theories/Reals/ConstructiveRIneq.v @@ -10,68 +10,423 @@ (************************************************************************) (*********************************************************) -(** * Basic lemmas for the classical real numbers *) +(** * 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. -(* Export all axioms *) - -Notation Rplus_comm := CReal_plus_comm (only parsing). -Notation Rplus_assoc := CReal_plus_assoc (only parsing). -Notation Rplus_opp_r := CReal_plus_opp_r (only parsing). -Notation Rplus_0_l := CReal_plus_0_l (only parsing). -Notation Rmult_comm := CReal_mult_comm (only parsing). -Notation Rmult_assoc := CReal_mult_assoc (only parsing). -Notation Rinv_l := CReal_inv_l (only parsing). -Notation Rmult_1_l := CReal_mult_1_l (only parsing). -Notation Rmult_plus_distr_l := CReal_mult_plus_distr_l (only parsing). -Notation Rlt_0_1 := CRealLt_0_1 (only parsing). -Notation Rlt_asym := CRealLt_asym (only parsing). -Notation Rlt_trans := CRealLt_trans (only parsing). -Notation Rplus_lt_compat_l := CReal_plus_lt_compat_l (only parsing). -Notation Rmult_lt_compat_l := CReal_mult_lt_compat_l (only parsing). -Notation Rmult_0_l := CReal_mult_0_l (only parsing). +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 *) (*********************************************************) -(** Reflexivity of the large order *) - -Lemma Rle_refl : forall r, r <= r. -Proof. - intros r abs. apply (CRealLt_asym r r); exact abs. -Qed. -Hint Immediate Rle_refl: rorders. - 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. +Lemma Rlt_irrefl : forall r, r < r -> False. Proof. - intros r H; eapply CRealLt_asym; eauto. + intros r H; eapply Rlt_asym; eauto. Qed. Hint Resolve Rlt_irrefl: creal. -Lemma Rgt_irrefl : forall r, ~ r > r. +Lemma Rgt_irrefl : forall r, r > r -> False. Proof. exact Rlt_irrefl. Qed. Lemma Rlt_not_eq : forall r1 r2, r1 < r2 -> r1 <> r2. @@ -85,11 +440,11 @@ Proof. Qed. (**********) -Lemma Rlt_dichotomy_converse : forall r1 r2, r1 < r2 \/ r1 > r2 -> r1 <> r2. +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 H). - - intro abs. subst r2. exact (Rlt_irrefl r1 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. @@ -108,13 +463,13 @@ Hint Resolve Rlt_dichotomy_converse: creal. Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2. Proof. - intros. intro abs. apply (CRealLt_asym r1 r2); assumption. + 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 (CRealLt_asym r1 r2); assumption. + intros. intro abs. apply (Rlt_asym r1 r2); assumption. Qed. (**********) @@ -147,22 +502,22 @@ Hint Immediate Rgt_lt: rorders. (**********) -Lemma Rnot_lt_le : forall r1 r2, ~ r1 < r2 -> r2 <= r1. +Lemma Rnot_lt_le : forall r1 r2, (r1 < r2 -> False) -> r2 <= r1. Proof. - intros. intro abs. contradiction. + intros. exact H. Qed. -Lemma Rnot_gt_le : forall r1 r2, ~ r1 > r2 -> r1 <= r2. +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 -> r2 >= r1. +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 -> r1 >= r2. +Lemma Rnot_lt_ge : forall r1 r2, (r1 < r2 -> False) -> r1 >= r2. Proof. intros. intro abs. contradiction. Qed. @@ -170,7 +525,7 @@ Qed. (**********) Lemma Rlt_not_le : forall r1 r2, r2 < r1 -> ~ r1 <= r2. Proof. - generalize CRealLt_asym Rlt_dichotomy_converse; unfold CRealLe. + generalize Rlt_asym Rlt_dichotomy_converse; unfold CRealLe. unfold not; intuition eauto 3. Qed. Hint Immediate Rlt_not_le: creal. @@ -185,19 +540,19 @@ 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. +Lemma Rle_not_lt : forall r1 r2, r2 <= r1 -> r1 < r2 -> False. Proof. - intros r1 r2. generalize (CRealLt_asym r1 r2) (Rlt_dichotomy_converse r1 r2). + 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. -Proof. intros; apply Rle_not_lt; auto with creal. 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. +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. +Lemma Rge_not_gt : forall r1 r2, r2 >= r1 -> r1 > r2 -> False. Proof. do 2 intro; apply Rge_not_lt. Qed. (**********) @@ -227,10 +582,10 @@ Hint Immediate Req_ge_sym: creal. (** *** Asymmetry *) -(** Remark: [CRealLt_asym] is an axiom *) +(** Remark: [Rlt_asym] is an axiom *) -Lemma Rgt_asym : forall r1 r2, r1 > r2 -> ~ r2 > r1. -Proof. do 2 intro; apply CRealLt_asym. Qed. +Lemma Rgt_asym : forall r1 r2, r1 > r2 -> r2 > r1 -> False. +Proof. do 2 intro; apply Rlt_asym. Qed. (** *** Compatibility with equality *) @@ -260,20 +615,20 @@ Qed. Lemma Rgt_trans : forall r1 r2 r3, r1 > r2 -> r2 > r3 -> r1 > r3. Proof. - intros. apply (CRealLt_trans _ r2); assumption. + 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 c. + 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 c. contradiction. + 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. @@ -367,7 +722,7 @@ Qed. Lemma Rinv_r : forall r (rnz : r # 0), r # 0 -> r * ((/ r) rnz) == 1. Proof. - intros. rewrite Rmult_comm. rewrite CReal_inv_l. + intros. rewrite Rmult_comm. rewrite Rinv_l. reflexivity. Qed. Hint Resolve Rinv_r: creal. @@ -455,17 +810,17 @@ Qed. (**********) Lemma Rmult_integral_contrapositive : - forall r1 r2, r1 # 0 /\ r2 # 0 -> (r1 * r2) # 0. + 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, H0, H1. + 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 H1. apply H0. - - left. rewrite <- (Rmult_0_r r1). apply (Rmult_lt_compat_l). apply H0. apply H1. + 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. @@ -489,7 +844,7 @@ Qed. (*********************************************************) (***********) -Definition Rsqr (r : CReal) := r * r. +Definition Rsqr (r : R) := r * r. Notation "r ²" := (Rsqr r) (at level 1, format "r ²") : R_scope_constr. @@ -541,11 +896,6 @@ Hint Resolve Ropp_plus_distr: creal. (** ** Opposite and multiplication *) (*********************************************************) -Lemma Ropp_mult_distr_l : forall r1 r2, - (r1 * r2) == - r1 * r2. -Proof. - intros; ring. -Qed. - Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 == - (r1 * r2). Proof. intros; ring. @@ -575,13 +925,13 @@ Qed. Lemma Rminus_0_r : forall r, r - 0 == r. Proof. - intro; ring. + intro r. unfold Rminus. ring. Qed. Hint Resolve Rminus_0_r: creal. Lemma Rminus_0_l : forall r, 0 - r == - r. Proof. - intro; ring. + intro r. unfold Rminus. ring. Qed. Hint Resolve Rminus_0_l: creal. @@ -600,22 +950,22 @@ Qed. (**********) Lemma Rminus_diag_eq : forall r1 r2, r1 == r2 -> r1 - r2 == 0. Proof. - intros; rewrite H; ring. + 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 CReal_minus; rewrite Rplus_comm; intro. + 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; - ring. + intros; generalize (Rminus_diag_uniq r2 r1 H); clear H; + intro H; rewrite H; reflexivity. Qed. Hint Immediate Rminus_diag_uniq_sym: creal. @@ -661,11 +1011,6 @@ Proof. do 3 intro; apply Rplus_lt_compat_r. Qed. (**********) -Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. -Proof. - intros. apply CReal_plus_lt_reg_l in H. exact H. -Qed. - Lemma Rplus_lt_reg_r : forall r r1 r2, r1 + r < r2 + r -> r1 < r2. Proof. intros. @@ -701,7 +1046,7 @@ Qed. Lemma Rplus_lt_compat : forall r1 r2 r3 r4, r1 < r2 -> r3 < r4 -> r1 + r3 < r2 + r4. Proof. - intros; apply CRealLt_trans with (r2 + r3); auto with creal. + intros; apply Rlt_trans with (r2 + r3); auto with creal. Qed. Hint Immediate Rplus_lt_compat: creal. @@ -754,7 +1099,7 @@ Qed. (**********) Lemma Rplus_lt_0_compat : forall r1 r2, 0 < r1 -> 0 < r2 -> 0 < r1 + r2. Proof. - intros. apply (CRealLt_trans _ (r1+0)). rewrite Rplus_0_r. exact H. + intros. apply (Rlt_trans _ (r1+0)). rewrite Rplus_0_r. exact H. apply Rplus_lt_compat_l. exact H0. Qed. @@ -882,11 +1227,11 @@ Proof. setoid_replace (r2 + r1 + - r2) with r1 by ring. exact H. Qed. -Hint Resolve Ropp_gt_lt_contravar : core. +Hint Resolve Ropp_gt_lt_contravar : creal. Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. Proof. - unfold CRealGt; auto with creal. + intros. apply Ropp_gt_lt_contravar. exact H. Qed. Hint Resolve Ropp_lt_gt_contravar: creal. @@ -942,13 +1287,13 @@ Qed. (**********) Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r. Proof. - intros; setoid_replace 0 with (-0); auto with creal. + 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. + intros; setoid_replace 0 with (-0); auto with creal. ring. Qed. Hint Resolve Ropp_0_gt_lt_contravar: creal. @@ -968,13 +1313,13 @@ 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. + 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. + intros; setoid_replace 0 with (-0); auto with creal. ring. Qed. Hint Resolve Ropp_0_ge_le_contravar: creal. @@ -1019,7 +1364,7 @@ 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 CRealLt_trans with (r2 * r3); auto with creal. + intros; apply Rlt_trans with (r2 * r3); auto with creal. Qed. (*********) @@ -1048,15 +1393,15 @@ Qed. (** *** Cancellation *) -Lemma Rinv_0_lt_compat : forall r (rpos : 0 < r), 0 < (/ r) (or_intror rpos). +Lemma Rinv_0_lt_compat : forall r (rpos : 0 < r), 0 < (/ r) (inr rpos). Proof. - intros. apply CReal_inv_0_lt_compat. exact rpos. + 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) (or_intror H))) in 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. @@ -1117,13 +1462,17 @@ Qed. Lemma Rle_minus : forall r1 r2, r1 <= r2 -> r1 - r2 <= 0. Proof. intros. intro abs. apply (Rplus_lt_compat_l r2) in abs. - ring_simplify in abs. contradiction. + 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. - ring_simplify in abs. contradiction. + unfold Rminus in abs. + rewrite Rplus_0_r, Rplus_comm, Rplus_assoc, Rplus_opp_l, Rplus_0_r in abs. + contradiction. Qed. (**********) @@ -1159,7 +1508,7 @@ 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. + rewrite Rplus_comm; setoid_replace 0 with (0 + 0); auto with creal. ring. Qed. Hint Immediate tech_Rplus: creal. @@ -1169,7 +1518,7 @@ Hint Immediate tech_Rplus: creal. Lemma Rle_0_1 : 0 <= 1. Proof. - intro abs. apply (CRealLt_asym 0 1). + intro abs. apply (Rlt_asym 0 1). apply Rlt_0_1. apply abs. Qed. @@ -1200,9 +1549,9 @@ Qed. Lemma Rinv_neq_0_compat : forall r (rnz : r # 0), ((/ r) rnz) # 0. Proof. intros. destruct rnz. left. - assert (0 < (/-r) (or_intror (Ropp_0_gt_lt_contravar _ c))). + assert (0 < (/-r) (inr (Ropp_0_gt_lt_contravar _ c))). { apply Rinv_0_lt_compat. } - rewrite <- (Ropp_inv_permute _ (or_introl c)) in H. + rewrite <- (Ropp_inv_permute _ (inl c)) in H. apply Ropp_lt_cancel. rewrite Ropp_0. exact H. right. apply Rinv_0_lt_compat. Qed. @@ -1275,9 +1624,9 @@ Qed. (** ** Order and inverse *) (*********************************************************) -Lemma Rinv_lt_0_compat : forall r (rneg : r < 0), (/ r) (or_introl rneg) < 0. +Lemma Rinv_lt_0_compat : forall r (rneg : r < 0), (/ r) (inl rneg) < 0. Proof. - intros. assert (0 < (/-r) (or_intror (Ropp_0_gt_lt_contravar r rneg))). + 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. @@ -1310,7 +1659,7 @@ 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 CReal_minus; rewrite Rplus_assoc, Rplus_opp_l. + unfold Rminus, CRminus; rewrite Rplus_assoc, Rplus_opp_l. apply Rplus_lt_compat_l. exact H. Qed. @@ -1318,7 +1667,89 @@ Qed. (** ** Injection from [N] to [R] *) (*********************************************************) -Lemma Rpow_eq_compat : forall (x y : CReal) (n : nat), +(**********) +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. @@ -1332,17 +1763,10 @@ 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. - simple induction 1; intros. apply Rlt_0_1. - rewrite S_INR. apply (CRealLt_trans _ (INR m)). apply H1. apply Rlt_plus_1. + intros. apply (lt_INR 0). exact H. Qed. Hint Resolve lt_0_INR: creal. -Notation lt_INR := lt_INR (only parsing). -Notation plus_INR := plus_INR (only parsing). -Notation INR_IPR := INR_IPR (only parsing). -Notation plus_IZR_NEG_POS := plus_IZR_NEG_POS (only parsing). -Notation plus_IZR := plus_IZR (only parsing). - Lemma lt_1_INR : forall n:nat, (1 < n)%nat -> 1 < INR n. Proof. apply lt_INR. @@ -1413,9 +1837,10 @@ 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_or_lt n m); intros H1. + intros n m H; case (le_lt_dec n m); intros H1. + left. apply lt_INR. case (le_lt_or_eq _ _ H1); intros H2. - left. apply lt_INR. exact H2. contradiction. + exact H2. contradiction. right. apply lt_INR. exact H1. Qed. Hint Resolve not_INR: creal. @@ -1456,6 +1881,64 @@ 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. @@ -1495,6 +1978,7 @@ 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. @@ -1502,7 +1986,7 @@ 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, CReal_minus. + intros; unfold Z.sub, Rminus,CRminus. rewrite <- opp_IZR. apply plus_IZR. Qed. @@ -1510,8 +1994,8 @@ 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 <- (Ropp_Ropp_IZR z2); symmetry ; apply plus_IZR. + intros z1 z2; unfold Rminus,CRminus; unfold Z.sub. + rewrite <- (Ropp_Ropp_IZR z2); symmetry; apply plus_IZR. Qed. (**********) @@ -1566,7 +2050,7 @@ Proof. 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 CReal_minus in H0. + 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. @@ -1575,10 +2059,9 @@ Qed. (**********) Lemma not_0_IZR : forall n:Z, n <> 0%Z -> IZR n # 0. Proof. - intros. destruct (Z.lt_trichotomy n 0). - left. apply (IZR_lt n 0). exact H0. - destruct H0. contradiction. - right. apply (IZR_lt 0 n). exact H0. + intros. destruct n. exfalso. apply H. reflexivity. + right. apply (IZR_lt 0). reflexivity. + left. apply (IZR_lt _ 0). reflexivity. Qed. (*********) @@ -1594,7 +2077,7 @@ 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 CReal_minus in H0. + 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. @@ -1610,22 +2093,27 @@ Qed. (**********) Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m. Proof. - intros m n H; apply Rnot_lt_ge; red; intro. - generalize (lt_IZR m n H0); intro; omega. + 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_gt_le; red; intro. - unfold CRealGt in H0; generalize (lt_IZR n m H0); intro; omega. + 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 (Z.lt_trichotomy z1 z2). - left. apply IZR_lt. exact H0. - destruct H0. contradiction. - right. apply IZR_lt. exact H0. + 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. @@ -1649,7 +2137,7 @@ 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. + split; rewrite <- Z_R_minus. setoid_replace (-(1)) with (r - (r + 1)). unfold CReal_minus; apply Rplus_lt_le_compat; auto with creal. ring. @@ -1672,18 +2160,13 @@ Lemma tech_single_z_r_R1 : forall r (n:Z), r < IZR n -> IZR n <= r + 1 -> - (exists s : Z, s <> n /\ r < IZR s /\ IZR s <= r + 1) -> False. + { 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. - -(*********************************************************) -(** ** Computable Reals *) -(*********************************************************) - Lemma Rmult_le_compat_l_half : forall r r1 r2, 0 < r -> r1 <= r2 -> r * r1 <= r * r2. Proof. @@ -1691,6 +2174,72 @@ Proof. 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. @@ -1698,51 +2247,42 @@ Proof. intros. intro abs. assert (0 < -(a*b)) as epsPos. { rewrite <- Ropp_0. apply Ropp_gt_lt_contravar. apply abs. } - pose proof (Rarchimedean (b * (/ (-(a*b))) (or_intror (Ropp_0_gt_lt_contravar _ abs)))) - as [n [maj _]]. - destruct n as [|n|n]. + 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 < IZR (Z.pos n)) as nPos. - apply (IZR_lt 0). reflexivity. - assert (b * (/ (IZR (Z.pos n))) (or_intror nPos) < -(a*b)). - { apply (Rmult_lt_reg_r (IZR (Z.pos n))). apply nPos. + 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 + (/ (IZR (Z.pos n))) (or_intror nPos)) + pose proof (Rmult_le_compat_l_half (a + (/ (INR (S n))) (inr nPos)) 0 b). - assert (a + (/ (IZR (Z.pos n))) (or_intror nPos) > 0 + 0). + 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 ((/ (IZR (Z.pos n))) (or_intror nPos))). + rewrite (Rmult_comm ((/ (INR (S n))) (inr nPos))). apply H1. - - (* n < 0 *) - assert (b * (/ (- (a * b))) (or_intror (Ropp_0_gt_lt_contravar _ abs)) < 0). - apply (CRealLt_trans _ (IZR (Z.neg n)) _ maj). - apply Ropp_lt_cancel. rewrite Ropp_0. - rewrite <- opp_IZR. apply (IZR_lt 0). reflexivity. - apply (Rmult_lt_compat_r (-(a*b))) in H1. - rewrite Rmult_0_l in H1. rewrite Rmult_assoc in H1. - rewrite Rinv_l in H1. rewrite Rmult_1_r in H1. contradiction. - apply epsPos. 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 CReal_minus. rewrite Ropp_mult_distr_r. + unfold Rminus,CRminus. rewrite Ropp_mult_distr_r. rewrite <- Rmult_plus_distr_l. apply Rmult_le_0_compat; assumption. Qed. @@ -1762,8 +2302,8 @@ Lemma Rmult_le_0_lt_compat : 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. apply CRealLt_asym. - apply H1. apply Rmult_lt_compat_l. exact (Rle_lt_trans 0 r1 r2 H H1). + 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. @@ -1816,36 +2356,34 @@ Lemma Rmult_ge_compat : r2 >= 0 -> r4 >= 0 -> r1 >= r2 -> r3 >= r4 -> r1 * r3 >= r2 * r4. Proof. auto with creal rorders. Qed. -Lemma IPR_double : forall p:positive, IPR (2*p) == 2 * IPR p. -Proof. - intro p. destruct p. - - reflexivity. - - reflexivity. - - rewrite Rmult_1_r. reflexivity. -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)) (or_intror (IPR_pos (Qden * Qden0)))) - with ((/ IPR Qden) (or_intror (IPR_pos Qden)) - * (/ IPR Qden0) (or_intror (IPR_pos Qden0))). + 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) (or_intror (IPR_pos Qden)))). + 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 - _ _ _ _ (or_intror (Rmult_lt_0_compat _ _ (IPR_pos _) (IPR_pos _)))). + _ _ _ _ (inr (Rmult_lt_0_compat _ _ (IPR_pos _) (IPR_pos _)))). apply Rinv_eq_compat. apply mult_IPR. Qed. @@ -1898,7 +2436,7 @@ Proof. 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. - apply CRealLt_asym. apply Rinv_0_lt_compat. + 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. @@ -1910,7 +2448,7 @@ Proof. Qed. Add Parametric Morphism : IQR - with signature Qeq ==> CRealEq + with signature Qeq ==> Req as IQR_morph. Proof. intros. destruct x,y; unfold IQR; simpl. @@ -1928,115 +2466,108 @@ Proof. right. apply IPR_pos. Qed. -Definition Rup_nat (x : CReal) - : { n : nat | x < INR n }. +Instance IQR_morph_T + : CMorphisms.Proper + (CMorphisms.respectful Qeq Req) IQR. 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. + 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. -(* 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 } +Fixpoint Rfloor_pos (a : R) (n : nat) { struct n } : 0 < a -> a < INR n - -> { p : nat | INR p < a < INR p + 2 }. + -> { 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. + - 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 (CRealLt_trans a (1+0)). - rewrite Rplus_0_r. apply H0. apply Rplus_le_lt_compat. + 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_r, S_INR. apply Rplus_lt_compat_l. + * rewrite <- Rplus_0_l, S_INR, Rplus_comm. apply Rplus_lt_compat_l. apply Rlt_0_1. - * exists p. split. exact c. + * 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 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 (Rplus_lt_reg_r (-IZR (Z.neg p))). - rewrite Rplus_opp_r. rewrite <- opp_IZR. - rewrite Rplus_0_l. apply (IZR_lt 0). reflexivity. } + * 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 (H a c). destruct (Rfloor_pos a x c c0). - exists (Z.of_nat x0). rewrite <- INR_IZR_INZ. apply a0. - - apply (Rplus_lt_compat_r (-a)) in c. - rewrite Rplus_opp_r in c. destruct (H (1-a) c). - destruct (Rfloor_pos (1-a) x c c0). - exists (-(Z.of_nat x0 + 1))%Z. rewrite opp_IZR. - rewrite plus_IZR. simpl. split. + - 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 a0 as [_ a0]. apply (Rplus_lt_reg_r 1). + destruct p as [_ a0]. apply (Rplus_lt_reg_r 1). rewrite Rplus_comm, Rplus_assoc. rewrite <- INR_IZR_INZ. apply a0. - + destruct a0 as [a0 _]. apply (Rplus_lt_compat_l a) in a0. - ring_simplify in a0. rewrite <- INR_IZR_INZ. + + 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. -Lemma Qplus_same_denom : forall a b c, ((a # c) + (b # c) == (a+b) # c)%Q. -Proof. - intros. unfold Qeq. simpl. rewrite Pos2Z.inj_mul. ring. -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 }. + 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 H H0. + 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 (Rarchimedean ((/(b-a)) (or_intror epsPos))) - as [n [maj _]]. - destruct n as [|n|n]. + 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 (CRealLt_asym 0 1). apply Rlt_0_1. apply maj. - right. exact epsPos. + 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 (CRealLt_trans a (b - IQR (1 # n))). + + apply (Rlt_trans a (b - IQR (1 # n))). apply (Rplus_lt_reg_r (IQR (1#n))). - unfold CReal_minus. rewrite Rplus_assoc. rewrite Rplus_opp_l. + unfold Rminus,CRminus. rewrite Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_r. apply (Rplus_lt_reg_l (-a)). - rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l. + rewrite <- Rplus_assoc, Rplus_opp_l, Rplus_0_l. rewrite Rplus_comm. unfold IQR. - rewrite Rmult_1_l. apply (Rmult_lt_reg_l (IZR (Z.pos n))). - apply (IZR_lt 0). reflexivity. rewrite Rinv_r. - apply (Rmult_lt_compat_r (b-a)) in maj. rewrite Rinv_l in maj. - apply maj. exact epsPos. + 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 CReal_minus. rewrite Rplus_assoc. rewrite Rplus_opp_l. + 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 @@ -2046,47 +2577,95 @@ Proof. 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 Qplus_same_denom. + 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. rewrite Rinv_l. - rewrite Rmult_1_r. rewrite Rmult_comm. apply maj2. - - exfalso. - apply (Rmult_lt_compat_l (b-a)) in maj. 2: apply epsPos. - rewrite Rinv_r in maj. apply (CRealLt_asym 0 1). apply Rlt_0_1. - apply (CRealLt_trans 1 ((b - a) * IZR (Z.neg n)) _ maj). - rewrite <- (Rmult_0_r (b-a)). - apply Rmult_lt_compat_l. apply epsPos. apply (IZR_lt _ 0). reflexivity. - right. apply epsPos. + 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. -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 (Rplus_lt_compat_l (-a)) in c. rewrite Rplus_opp_l in c. - rewrite Rplus_0_r in c. apply c. - apply (Rplus_lt_compat_r (-a)) in H. - rewrite Rplus_opp_r in H. - apply (Rplus_lt_compat_l (-b)) in H. rewrite <- Rplus_assoc in H. - rewrite Rplus_opp_l in H. rewrite Rplus_0_l in H. - rewrite Rplus_0_r in H. apply H. - exists (-q)%Q. split. - + destruct maj as [_ maj]. - apply (Rplus_lt_compat_r (-IQR q)) in maj. - rewrite Rplus_opp_r in maj. rewrite <- opp_IQR in maj. - apply (Rplus_lt_compat_l a) in maj. rewrite <- Rplus_assoc in maj. - rewrite Rplus_opp_r in maj. rewrite Rplus_0_l in maj. - rewrite Rplus_0_r in maj. apply maj. - + destruct maj as [maj _]. - apply (Rplus_lt_compat_r (-IQR q)) in maj. - rewrite Rplus_opp_r in maj. rewrite <- opp_IQR in maj. - apply (Rplus_lt_compat_l b) in maj. rewrite <- Rplus_assoc in maj. - rewrite Rplus_opp_r in maj. rewrite Rplus_0_l in maj. - rewrite Rplus_0_r in maj. apply maj. - - apply FQ_dense_pos. apply c. apply H. +(* 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. @@ -2099,7 +2678,7 @@ Qed. Lemma Rinv_le_contravar : forall x y (xpos : 0 < x) (ynz : y # 0), - x <= y -> (/ y) ynz <= (/ x) (or_intror xpos). + 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. @@ -2111,7 +2690,7 @@ Proof. Qed. Lemma Rle_Rinv : forall x y (xpos : 0 < x) (ypos : 0 < y), - x <= y -> (/ y) (or_intror ypos) <= (/ x) (or_intror xpos). + x <= y -> (/ y) (inr ypos) <= (/ x) (inr xpos). Proof. intros. apply Rinv_le_contravar with (1 := H). @@ -2130,12 +2709,12 @@ Qed. Lemma Rlt_0_2 : 0 < 2. Proof. - apply (CRealLt_trans 0 (0+1)). rewrite Rplus_0_l. exact Rlt_0_1. + 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) (or_intror Rlt_0_2) - + r1 * (/ 2) (or_intror Rlt_0_2). +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. @@ -2143,7 +2722,7 @@ Qed. (* IZR : Z -> R is a ring morphism *) Lemma R_rm : ring_morph - 0 1 CReal_plus CReal_mult CReal_minus CReal_opp CRealEq + 0 1 Rplus Rmult Rminus Ropp Req 0%Z 1%Z Zplus Zmult Zminus Z.opp Zeq_bool IZR. Proof. constructor ; try easy. @@ -2174,7 +2753,7 @@ Lemma Rmult_ge_0_gt_0_lt_compat : 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. apply CRealLt_asym. apply H1. + apply Rmult_le_compat_r. apply H. unfold Rle. apply Rlt_asym. apply H1. apply Rmult_lt_compat_l. apply H0. apply H2. Qed. @@ -2182,11 +2761,11 @@ 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) (or_intror Rlt_0_2)). + 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) (or_intror Rlt_0_2)) H0). + 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. @@ -2194,12 +2773,12 @@ Proof. (Rmult_plus_distr_r 1 1), (Rmult_plus_distr_r 1 1) in H. ring_simplify in H; contradiction. - right. apply Rlt_0_2. apply CRealLt_asym. apply Rlt_0_2. + 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) (or_intror bpos). + 0 < a -> 0 < a * (/b) (inr bpos). Proof. intros; apply Rmult_lt_0_compat;[|apply Rinv_0_lt_compat]; assumption. Qed. @@ -2213,7 +2792,9 @@ 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 CReal_minus; rewrite Rmult_plus_distr_r; ring. + intros; unfold Rminus,CRminus; rewrite Rmult_plus_distr_r. + apply Rplus_morph. reflexivity. + rewrite Ropp_mult_distr_l. reflexivity. Qed. @@ -2222,14 +2803,14 @@ Qed. (*********************************************************) Record nonnegreal : Type := mknonnegreal - {nonneg :> CReal; cond_nonneg : 0 <= nonneg}. + {nonneg :> R; cond_nonneg : 0 <= nonneg}. -Record posreal : Type := mkposreal {pos :> CReal; cond_pos : 0 < pos}. +Record posreal : Type := mkposreal {pos :> R; cond_pos : 0 < pos}. Record nonposreal : Type := mknonposreal - {nonpos :> CReal; cond_nonpos : nonpos <= 0}. + {nonpos :> R; cond_nonpos : nonpos <= 0}. -Record negreal : Type := mknegreal {neg :> CReal; cond_neg : neg < 0}. +Record negreal : Type := mknegreal {neg :> R; cond_neg : neg < 0}. Record nonzeroreal : Type := mknonzeroreal - {nonzero :> CReal; cond_nonzero : nonzero <> 0}. + {nonzero :> R; cond_nonzero : nonzero <> 0}. diff --git a/theories/Reals/ConstructiveRcomplete.v b/theories/Reals/ConstructiveRcomplete.v index 9fb98a528b..ce45bcd567 100644 --- a/theories/Reals/ConstructiveRcomplete.v +++ b/theories/Reals/ConstructiveRcomplete.v @@ -12,16 +12,16 @@ Require Import QArith_base. Require Import Qabs. Require Import ConstructiveCauchyReals. -Require Import ConstructiveRIneq. +Require Import Logic.ConstructiveEpsilon. -Local Open Scope R_scope_constr. +Local Open Scope CReal_scope. -Lemma CReal_absSmall : forall x y : CReal, - (exists 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). +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. destruct H as [n maj]. split. + 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. @@ -35,120 +35,191 @@ Proof. 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 - -> -IQR (1#n) < un i - l < IQR (1#n) }. + { 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. rewrite <- seq. apply H0. apply H. + exists N. intros. unfold absSmall. split. + rewrite <- seq. apply H0. apply H. + rewrite <- seq. apply H0. apply H. Qed. -Lemma IQR_double_inv : forall n : positive, - IQR (1 # 2*n) + IQR (1 # 2*n) == IQR (1 # n). +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. - intros. apply (Rmult_eq_reg_l (IPR (2*n))). - unfold IQR. do 2 rewrite Rmult_1_l. - rewrite Rmult_plus_distr_l, Rinv_r, IPR_double, Rmult_assoc, Rinv_r. - rewrite (Rmult_plus_distr_r 1 1). ring. - right. apply IPR_pos. - right. apply IPR_pos. - right. apply IPR_pos. + (* 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. -Lemma CV_mod_plus : - forall (An Bn:nat -> CReal) (l1 l2:CReal), - Un_cv_mod An l1 -> Un_cv_mod Bn l2 - -> Un_cv_mod (fun i:nat => An i + Bn i) (l1 + l2). +Definition Rfloor (a : CReal) + : { p : Z & IZR p < a < IZR p + 2 }. Proof. - assert (forall x:CReal, x + x == 2*x) as double. - { intro. rewrite (Rmult_plus_distr_r 1 1), Rmult_1_l. reflexivity. } - intros. intros n. - destruct (H (2*n)%positive). - destruct (H0 (2*n)%positive). - exists (Nat.max x x0). intros. - setoid_replace (An i + Bn i - (l1 + l2)) - with (An i - l1 + (Bn i - l2)). 2: ring. - rewrite <- IQR_double_inv. split. - - rewrite Ropp_plus_distr. - apply Rplus_lt_compat. apply a. apply (le_trans _ (max x x0)). - apply Nat.le_max_l. apply H1. - apply a0. apply (le_trans _ (max x x0)). - apply Nat.le_max_r. apply H1. - - apply Rplus_lt_compat. apply a. apply (le_trans _ (max x x0)). - apply Nat.le_max_l. apply H1. - apply a0. apply (le_trans _ (max x x0)). - apply Nat.le_max_r. apply H1. + 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. -Lemma Un_cv_mod_const : forall x : CReal, - Un_cv_mod (fun _ => x) x. +Definition Rup_nat (x : CReal) + : { n : nat & x < INR n }. Proof. - intros. intro p. exists O. intros. - unfold CReal_minus. rewrite Rplus_opp_r. - split. rewrite <- Ropp_0. - apply Ropp_gt_lt_contravar. unfold IQR. rewrite Rmult_1_l. - apply Rinv_0_lt_compat. unfold IQR. rewrite Rmult_1_l. - apply Rinv_0_lt_compat. + 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. -(** Unicity of limit for convergent sequences *) -Lemma UL_sequence_mod : - forall (Un:nat -> CReal) (l1 l2:CReal), - Un_cv_mod Un l1 -> Un_cv_mod Un l2 -> l1 == l2. +(* 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. - assert (forall (Un:nat -> CReal) (l1 l2:CReal), - Un_cv_mod Un l1 -> Un_cv_mod Un l2 - -> l1 <= l2). - - intros Un l1 l2; unfold Un_cv_mod; intros. intro abs. - assert (0 < l1 - l2) as epsPos. - { apply Rgt_minus. apply abs. } - destruct (Rup_nat ((/(l1-l2)) (or_intror epsPos))) as [n nmaj]. - assert (lt 0 n) as nPos. - { apply (INR_lt 0). apply (Rlt_trans _ ((/ (l1 - l2)) (or_intror epsPos))). - 2: apply nmaj. apply Rinv_0_lt_compat. } - specialize (H (2*Pos.of_nat n)%positive) as [i imaj]. - specialize (H0 (2*Pos.of_nat n))%positive as [j jmaj]. - specialize (imaj (max i j) (Nat.le_max_l _ _)) as [imaj _]. - specialize (jmaj (max i j) (Nat.le_max_r _ _)) as [_ jmaj]. - apply Ropp_gt_lt_contravar in imaj. rewrite Ropp_involutive in imaj. - unfold CReal_minus in imaj. rewrite Ropp_plus_distr in imaj. - rewrite Ropp_involutive in imaj. rewrite Rplus_comm in imaj. - apply (Rplus_lt_compat _ _ _ _ imaj) in jmaj. - clear imaj. - rewrite Rplus_assoc in jmaj. unfold CReal_minus in jmaj. - rewrite <- (Rplus_assoc (- Un (Init.Nat.max i j))) in jmaj. - rewrite Rplus_opp_l in jmaj. - rewrite <- double in jmaj. rewrite Rplus_0_l in jmaj. - rewrite (Rmult_plus_distr_r 1 1), Rmult_1_l, IQR_double_inv in jmaj. - unfold IQR in jmaj. rewrite Rmult_1_l in jmaj. - apply (Rmult_lt_compat_l (IPR (Pos.of_nat n))) in jmaj. - rewrite Rinv_r, <- INR_IPR, Nat2Pos.id in jmaj. - apply (Rmult_lt_compat_l (l1-l2)) in nmaj. - rewrite Rinv_r in nmaj. rewrite Rmult_comm in jmaj. - apply (CRealLt_asym 1 ((l1-l2)*INR n)); assumption. - right. apply epsPos. apply epsPos. - intro abss. subst n. inversion nPos. - right. apply IPR_pos. apply IPR_pos. - - intros. split; apply (H Un); assumption. + 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 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) }. +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) }. + { 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 <- (Rplus_0_r x). rewrite Rplus_assoc. - apply Rplus_lt_compat_l. rewrite Rplus_0_l. apply IQR_pos. + 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. @@ -160,7 +231,7 @@ Definition Un_cauchy_Q (xn : nat -> Q) : Set Lemma Rdiag_cauchy_sequence : forall (xn : nat -> CReal), Un_cauchy_mod xn - -> Un_cauchy_Q (fun n => proj1_sig (RQ_limit (xn n) n)). + -> 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. @@ -171,60 +242,71 @@ Proof. apply Nat.le_max_l. apply H0. split. - apply lt_IQR. unfold Qminus. - apply (Rlt_trans _ (xn p0 - (xn q + IQR (1 # 2 * p)))). - + unfold CReal_minus. rewrite Ropp_plus_distr. unfold CReal_minus. - rewrite <- Rplus_assoc. - apply (Rplus_lt_reg_r (IQR (1 # 2 * p))). - rewrite Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_r. + 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 H1. + 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 Rplus_lt_compat. - destruct (RQ_limit (xn p0) p0); simpl. apply a. + + 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 Ropp_gt_lt_contravar. - apply (Rlt_le_trans _ (xn q + IQR (1 # Pos.of_nat q))). - apply a. apply Rplus_le_compat_l. apply IQR_le. + 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 H3. intro abs. subst q. - inversion H3. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H5 in H4. inversion H4. + 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 (Rlt_trans _ (xn p0 + IQR (1 # 2 * p) - xn q)). - + rewrite plus_IQR. apply Rplus_lt_compat. + 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 (Rlt_le_trans _ (xn p0 + IQR (1 # Pos.of_nat p0))). - apply a. apply Rplus_le_compat_l. apply IQR_le. + 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 H3. intro abs. subst p0. - inversion H3. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H5 in H4. inversion H4. - rewrite opp_IQR. apply Ropp_gt_lt_contravar. - destruct (RQ_limit (xn q) q); simpl. apply a. - + unfold CReal_minus. rewrite (Rplus_comm (xn p0)). - rewrite Rplus_assoc. - apply (Rplus_lt_reg_l (- IQR (1 # 2 * p))). - rewrite <- Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_l. + 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 H2. rewrite Qplus_comm. + 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), @@ -233,11 +315,12 @@ Lemma CReal_cv_self : forall (qn : nat -> Q) (x : CReal) (cvmod : positive -> na Proof. intros qn x cvmod H p. specialize (H (2*p)%positive). exists (cvmod (2*p)%positive). - intros p0 H0. unfold CReal_minus. rewrite FinjectQ_CReal. - setoid_replace (IQR (qn p0)) with (inject_Q (qn p0)). - 2: apply FinjectQ_CReal. - apply CReal_absSmall. - exists (Pos.max (4 * p)%positive (Pos.of_nat (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. @@ -246,12 +329,15 @@ Proof. 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 _ _ (-(1#p))). unfold Qminus. rewrite Qplus_assoc. - rewrite (Qplus_comm _ (1#p)). rewrite Qplus_opp_r. rewrite Qplus_0_l. - setoid_replace (- (1 # p) + (1 # 2 * p))%Q with (-(1 # 2 * p))%Q. - apply Qopp_lt_compat. apply H. apply H0. - - rewrite Pos2Nat.inj_max. + 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. @@ -267,7 +353,8 @@ Lemma Un_cv_extens : forall (xn yn : nat -> CReal) (l : CReal), -> Un_cv_mod yn l. Proof. intros. intro p. destruct (H p) as [n cv]. exists n. - intros. unfold CReal_minus. rewrite <- (H0 i). apply cv. apply H1. + intros. unfold absSmall, CReal_minus. + split; rewrite <- (H0 i); apply cv; apply H1. Qed. (* Q is dense in Archimedean fields, so all real numbers @@ -284,8 +371,8 @@ Proof. - 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 _. - rewrite <- (Qopp_involutive (1#p)). apply Qopp_lt_compat. - apply a. + 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))). @@ -300,28 +387,29 @@ Lemma Rcauchy_complete : forall (xn : nat -> CReal), -> { l : CReal & Un_cv_mod xn l }. Proof. intros xn cau. - destruct (R_has_all_rational_limits (fun n => proj1_sig (RQ_limit (xn n) n)) + 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. apply (le_trans _ (max k (2 * Pos.to_nat p))). + 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 (Rlt_trans _ (IQR q - IQR (1 # 2 * p) - l)). - + unfold CReal_minus. rewrite (Rplus_comm (IQR q)). - apply (Rplus_lt_reg_l (IQR (1 # 2 * p))). + - 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. apply Rplus_lt_compat_r. - apply (Rplus_lt_reg_r (IQR (1 # 2 * p))). - ring_simplify. rewrite Rplus_comm. - apply (Rlt_le_trans _ (xn p0 + IQR (1 # Pos.of_nat p0))). - apply maj. apply Rplus_le_compat_l. + + 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). @@ -332,12 +420,13 @@ Proof. 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 (Rlt_trans _ (IQR q - l)). - + apply Rplus_lt_compat_r. apply maj. - + apply (Rlt_trans _ (IQR (1 # 2 * p))). + - 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 Qplus_same_denom. 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 72475b79d7..75298855b2 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -543,7 +543,7 @@ Lemma Rmult_eq_reg_l : forall r r1 r2, r * r1 = r * r2 -> r <> 0 -> r1 = r2. Proof. intros. apply Rquot1. apply (Rmult_eq_reg_l (Rrepr r)). rewrite <- Rrepr_mult, <- Rrepr_mult, H. reflexivity. - rewrite Rrepr_appart, Rrepr_0 in H0. exact H0. + 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. @@ -996,15 +996,16 @@ Qed. Lemma Rplus_lt_reg_l : forall r r1 r2, r + r1 < r + r2 -> r1 < r2. Proof. - intros. rewrite Rlt_def. apply (Rplus_lt_reg_l (Rrepr r)). + intros. rewrite Rlt_def. apply Rlt_forget. apply (Rplus_lt_reg_l (Rrepr r)). rewrite <- Rrepr_plus, <- Rrepr_plus. - rewrite Rlt_def in H. exact H. + 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. rewrite Rlt_def. apply (Rplus_lt_reg_r (Rrepr r)). - rewrite <- Rrepr_plus, <- Rrepr_plus. rewrite Rlt_def in H. exact H. + 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. @@ -1075,15 +1076,18 @@ Qed. Lemma Ropp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. Proof. 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. exact 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. intros. unfold Rgt. rewrite Rlt_def. rewrite Rrepr_opp, Rrepr_opp. - apply Ropp_lt_gt_contravar. rewrite Rlt_def in H. exact H. + 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. @@ -1303,18 +1307,18 @@ Qed. Lemma Rmult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. Proof. - intros. rewrite Rlt_def in H,H0. rewrite Rlt_def. + intros. rewrite Rlt_def in H,H0. rewrite Rlt_def. apply Rlt_forget. apply (Rmult_lt_reg_l (Rrepr r)). - rewrite <- Rrepr_0. exact H. - rewrite <- Rrepr_mult, <- Rrepr_mult. exact H0. + 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. rewrite Rlt_def. rewrite Rlt_def in H, H0. - apply (Rmult_lt_reg_r (Rrepr r)). - rewrite <- Rrepr_0. exact H. - rewrite <- Rrepr_mult, <- Rrepr_mult. exact 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. @@ -1323,7 +1327,7 @@ 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. rewrite Rrepr_le. rewrite Rlt_def in H. apply (Rmult_le_reg_l (Rrepr r)). - rewrite <- Rrepr_0. exact H. + rewrite <- Rrepr_0. apply Rlt_epsilon. exact H. rewrite <- Rrepr_mult, <- Rrepr_mult. rewrite <- Rrepr_le. exact H0. Qed. @@ -1642,7 +1646,7 @@ Hint Resolve pos_INR: real. Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat. Proof. intros. apply INR_lt. rewrite Rlt_def in H. - rewrite Rrepr_INR, Rrepr_INR in H. exact H. + rewrite Rrepr_INR, Rrepr_INR in H. apply Rlt_epsilon. exact H. Qed. Hint Resolve INR_lt: real. @@ -1676,7 +1680,7 @@ Hint Resolve not_0_INR: real. Lemma not_INR : forall n m:nat, n <> m -> INR n <> INR m. Proof. - intros. rewrite Rrepr_appart, Rrepr_INR, Rrepr_INR. + intros. apply Rappart_repr. rewrite Rrepr_INR, Rrepr_INR. apply not_INR. exact H. Qed. Hint Resolve not_INR: real. @@ -1753,8 +1757,8 @@ Proof. Qed. Lemma Rrepr_pow : forall (x : R) (n : nat), - (ConstructiveCauchyReals.CRealEq (Rrepr (pow x n)) - (ConstructiveCauchyReals.pow (Rrepr x) n)). + (ConstructiveRIneq.Req (Rrepr (pow x n)) + (ConstructiveRIneq.pow (Rrepr x) n)). Proof. intro x. induction n. - apply Rrepr_1. @@ -1801,14 +1805,15 @@ Qed. Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. Proof. intros. apply lt_0_IZR. rewrite <- Rrepr_0, <- Rrepr_IZR. - rewrite Rlt_def in H. exact H. + 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. apply lt_IZR. - rewrite <- Rrepr_IZR, <- Rrepr_IZR. rewrite Rlt_def in H. exact H. + rewrite <- Rrepr_IZR, <- Rrepr_IZR. rewrite Rlt_def in H. + apply Rlt_epsilon. exact H. Qed. (**********) @@ -1892,17 +1897,18 @@ 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. apply one_IZR_lt1. do 2 rewrite Rlt_def in H. split. - rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_opp. apply H. - rewrite <- Rrepr_IZR, <- Rrepr_1. apply H. + 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. rewrite Rlt_def in H, H0. apply (one_IZR_r_R1 (Rrepr r)); split. - rewrite <- Rrepr_IZR. apply H. + rewrite <- Rrepr_IZR. apply Rlt_epsilon. apply H. rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_plus, <- Rrepr_le. - apply H. rewrite <- Rrepr_IZR. apply H0. + apply H. rewrite <- Rrepr_IZR. apply Rlt_epsilon. apply H0. rewrite <- Rrepr_IZR, <- Rrepr_1, <- Rrepr_plus, <- Rrepr_le. apply H0. Qed. @@ -1939,8 +1945,10 @@ Lemma Rinv_le_contravar : Proof. intros. apply Rrepr_le. assert (y <> 0). intro abs. subst y. apply (Rlt_irrefl 0). exact (Rlt_le_trans 0 x 0 H H0). - rewrite Rrepr_appart, Rrepr_0 in H1. rewrite Rlt_def in H. rewrite Rrepr_0 in H. - rewrite (Rrepr_inv y H1), (Rrepr_inv x (or_intror H)). + 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. @@ -2008,7 +2016,7 @@ Proof. 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. exact H0. + rewrite Rquot2, Rrepr_0. apply Rlt_forget. exact H0. Qed. (**********) diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 8379829037..f03b0ccea3 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -8,12 +8,19 @@ (* * (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. *) + (*********************************************************) (** Lifts of basic operations for classical reals *) (*********************************************************) Require Export ZArith_base. -Require Import ConstructiveCauchyReals. +Require Import ConstructiveRIneq. Require Export Rdefinitions. Declare Scope R_scope. Local Open Scope R_scope. @@ -26,75 +33,88 @@ Local Open Scope R_scope. (** ** Addition *) (*********************************************************) -Lemma Rrepr_0 : (Rrepr 0 == 0)%CReal. +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)%CReal. +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)%CReal. +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)%CReal. +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)%CReal. +Lemma Rrepr_minus : forall x y:R, Rrepr (x - y) == Rrepr x - Rrepr y. Proof. - intros. unfold Rminus, CReal_minus. + 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)%CReal. +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)%CReal), - (Rrepr (/ x) == (/ Rrepr x) xnz)%CReal. +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 H. exact (CRealLt_irrefl 0 H). - rewrite Rrepr_0 in H. exact (CRealLt_irrefl 0 H). - - rewrite Rquot2. apply (CReal_mult_eq_reg_l (Rrepr x) _ _ xnz). - rewrite CReal_mult_comm, (CReal_mult_comm (Rrepr x)), CReal_inv_l, CReal_inv_l. + 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 <-> (Rrepr x <= Rrepr y)%CReal. +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. - exact (CRealLt_asym (Rrepr x) (Rrepr y) H abs). - destruct H. exact (CRealLt_asym (Rrepr x) (Rrepr x) abs abs). + 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. contradiction. + 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 <-> (Rrepr x # Rrepr y)%CReal. +Lemma Rrepr_appart : forall x y:R, + (x <> y)%R -> Rrepr x # Rrepr y. Proof. - split. - - intros. destruct (total_order_T x y). destruct s. - left. rewrite RbaseSymbolsImpl.Rlt_def in r. exact r. contradiction. - right. rewrite RbaseSymbolsImpl.Rlt_def in r. exact r. - - intros [H|H] abs. - destruct abs. exact (CRealLt_asym (Rrepr x) (Rrepr x) H H). - destruct abs. exact (CRealLt_asym (Rrepr x) (Rrepr x) H H). + 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. + (**********) Lemma Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1. Proof. - intros. apply Rquot1. do 2 rewrite Rrepr_plus. apply CReal_plus_comm. + intros. apply Rquot1. do 2 rewrite Rrepr_plus. apply Rplus_comm. Qed. Hint Resolve Rplus_comm: real. @@ -102,7 +122,7 @@ Hint Resolve Rplus_comm: real. Lemma Rplus_assoc : forall r1 r2 r3:R, r1 + r2 + r3 = r1 + (r2 + r3). Proof. intros. apply Rquot1. repeat rewrite Rrepr_plus. - apply CReal_plus_assoc. + apply Rplus_assoc. Qed. Hint Resolve Rplus_assoc: real. @@ -110,7 +130,7 @@ Hint Resolve Rplus_assoc: real. Lemma Rplus_opp_r : forall r:R, r + - r = 0. Proof. intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_opp, Rrepr_0. - apply CReal_plus_opp_r. + apply Rplus_opp_r. Qed. Hint Resolve Rplus_opp_r: real. @@ -118,7 +138,7 @@ Hint Resolve Rplus_opp_r: real. Lemma Rplus_0_l : forall r:R, 0 + r = r. Proof. intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_0. - apply CReal_plus_0_l. + apply Rplus_0_l. Qed. Hint Resolve Rplus_0_l: real. @@ -129,7 +149,7 @@ Hint Resolve Rplus_0_l: real. (**********) Lemma Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. Proof. - intros. apply Rquot1. do 2 rewrite Rrepr_mult. apply CReal_mult_comm. + intros. apply Rquot1. do 2 rewrite Rrepr_mult. apply Rmult_comm. Qed. Hint Resolve Rmult_comm: real. @@ -137,7 +157,7 @@ Hint Resolve Rmult_comm: real. Lemma Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3). Proof. intros. apply Rquot1. repeat rewrite Rrepr_mult. - apply CReal_mult_assoc. + apply Rmult_assoc. Qed. Hint Resolve Rmult_assoc: real. @@ -146,7 +166,7 @@ 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 CReal_inv_l. + - apply Rquot1. rewrite Rrepr_mult, Rquot2, Rrepr_1. apply Rinv_l. Qed. Hint Resolve Rinv_l: real. @@ -154,7 +174,7 @@ Hint Resolve Rinv_l: real. Lemma Rmult_1_l : forall r:R, 1 * r = r. Proof. intros. apply Rquot1. rewrite Rrepr_mult, Rrepr_1. - apply CReal_mult_1_l. + apply Rmult_1_l. Qed. Hint Resolve Rmult_1_l: real. @@ -162,16 +182,17 @@ Hint Resolve Rmult_1_l: real. Lemma R1_neq_R0 : 1 <> 0. Proof. intro abs. - assert (1 == 0)%CReal. + assert (Req (CRone CR) (CRzero CR)). { transitivity (Rrepr 1). symmetry. - replace 1 with (Rabst 1). 2: unfold IZR,IPR; rewrite RbaseSymbolsImpl.R1_def; reflexivity. + 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 with (Rabst 0). + replace 0%R with (Rabst (CRzero CR)). 2: unfold IZR; rewrite RbaseSymbolsImpl.R0_def; reflexivity. rewrite Rquot2. reflexivity. } - pose proof (CRealLt_morph 0 0 (CRealEq_refl _) 1 0 H). - apply (CRealLt_irrefl 0). apply H0. apply CRealLt_0_1. + 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. @@ -185,7 +206,7 @@ Lemma Proof. intros. apply Rquot1. rewrite Rrepr_mult, Rrepr_plus, Rrepr_plus, Rrepr_mult, Rrepr_mult. - apply CReal_mult_plus_distr_l. + apply Rmult_plus_distr_l. Qed. Hint Resolve Rmult_plus_distr_l: real. @@ -201,30 +222,35 @@ Hint Resolve Rmult_plus_distr_l: real. Lemma Rlt_asym : forall r1 r2:R, r1 < r2 -> ~ r2 < r1. Proof. intros. intro abs. rewrite RbaseSymbolsImpl.Rlt_def in H, abs. - apply (CRealLt_asym (Rrepr r1) (Rrepr r2)); assumption. + apply Rlt_epsilon in H. apply Rlt_epsilon in abs. + apply (Rlt_asym (Rrepr r1) (Rrepr r2)); assumption. Qed. (**********) 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 (CRealLt_trans (Rrepr r1) (Rrepr r2) (Rrepr r3)); assumption. + apply Rlt_epsilon in H. apply Rlt_epsilon in H0. + apply Rlt_forget. + apply (Rlt_trans (Rrepr r1) (Rrepr r2) (Rrepr r3)); assumption. Qed. (**********) 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 CReal_plus_lt_compat_l. exact H. + do 2 rewrite Rrepr_plus. apply Rlt_forget. + apply Rplus_lt_compat_l. apply Rlt_epsilon. exact H. Qed. (**********) 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 CReal_mult_lt_compat_l. - rewrite <- (Rquot2 0). unfold IZR in H. rewrite RbaseSymbolsImpl.R0_def in H. exact H. - rewrite RbaseSymbolsImpl.Rlt_def in H0. exact H0. + 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. @@ -247,7 +273,7 @@ Arguments INR n%nat. (**********************************************************) Lemma Rrepr_INR : forall n : nat, - (Rrepr (INR n) == ConstructiveCauchyReals.INR n)%CReal. + Req (Rrepr (INR n)) (ConstructiveRIneq.INR n). Proof. induction n. - apply Rrepr_0. @@ -256,41 +282,41 @@ Proof. Qed. Lemma Rrepr_IPR2 : forall n : positive, - (Rrepr (IPR_2 n) == ConstructiveCauchyReals.IPR_2 n)%CReal. + Req (Rrepr (IPR_2 n)) (ConstructiveRIneq.IPR_2 n). Proof. induction n. - - unfold IPR_2, ConstructiveCauchyReals.IPR_2. + - 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, ConstructiveCauchyReals.IPR_2. + - 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, ConstructiveCauchyReals.IPR_2. + - unfold IPR_2, ConstructiveRIneq.IPR_2. rewrite RbaseSymbolsImpl.R1_def. rewrite Rrepr_plus, Rquot2. reflexivity. Qed. Lemma Rrepr_IPR : forall n : positive, - (Rrepr (IPR n) == ConstructiveCauchyReals.IPR n)%CReal. + Req (Rrepr (IPR n)) (ConstructiveRIneq.IPR n). Proof. intro n. destruct n. - - unfold IPR, ConstructiveCauchyReals.IPR. + - unfold IPR, ConstructiveRIneq.IPR. rewrite Rrepr_plus, <- Rrepr_IPR2. rewrite RbaseSymbolsImpl.R1_def. rewrite Rquot2. reflexivity. - - unfold IPR, ConstructiveCauchyReals.IPR. + - unfold IPR, ConstructiveRIneq.IPR. apply Rrepr_IPR2. - unfold IPR. rewrite RbaseSymbolsImpl.R1_def. apply Rquot2. Qed. Lemma Rrepr_IZR : forall n : Z, - (Rrepr (IZR n) == ConstructiveCauchyReals.IZR n)%CReal. + Req (Rrepr (IZR n)) (ConstructiveRIneq.IZR n). Proof. intros [|p|n]. - unfold IZR. rewrite RbaseSymbolsImpl.R0_def. apply Rquot2. - apply Rrepr_IPR. - - unfold IZR, ConstructiveCauchyReals.IZR. + - unfold IZR, ConstructiveRIneq.IZR. rewrite <- Rrepr_IPR, Rrepr_opp. reflexivity. Qed. @@ -300,38 +326,66 @@ 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 nmaj. + - 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 nmaj. - right. exact e. + - 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. + + 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 ConstructiveCauchyReals.IZR, ConstructiveCauchyReals.IPR. - apply (CReal_plus_lt_compat_l (Rrepr r - Rrepr R1)) in r0. - ring_simplify in r0. rewrite RbaseSymbolsImpl.R1_def in r0. rewrite Rquot2 in r0. - rewrite CReal_plus_comm. exact r0. + 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. rewrite <- Rrepr_IZR in nmaj. + 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 (CRealLt_Le_trans _ (Rrepr r + 2)). apply nmaj. - unfold IZR, IPR. rewrite RbaseSymbolsImpl.R1_def, Rquot2. apply CRealLe_refl. + 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 ConstructiveCauchyReals.IZR, ConstructiveCauchyReals.IPR in r1. + unfold ConstructiveRIneq.IZR, ConstructiveRIneq.IPR in r1. rewrite RbaseSymbolsImpl.Rlt_def, Rrepr_plus. - apply (CReal_plus_lt_compat_l (Rrepr r + 1)) in r1. - ring_simplify in r1. - apply (CRealLe_Lt_trans _ (Rrepr r + Rrepr 1 + 1)). 2: apply r1. + 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 1), <- CReal_plus_assoc. - apply CRealLe_refl. + 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. (**********************************************************) @@ -349,12 +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). (**********) -(* This axiom can be proved by excluded middle in sort Set. - For this, define a sequence by dichotomy, using excluded middle - to know whether the current point majorates E or not. - Then conclude by the Cauchy-completeness of R, which is proved - constructively. *) -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 03eb6c8b44..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) *) (************************************************************************) -(* Classical quotient of the constructive Cauchy real numbers. *) +(* 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 ConstructiveCauchyReals. +Require Import ConstructiveRIneq. Parameter R : Set. @@ -30,13 +34,16 @@ Local Open Scope R_scope. (* 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}. + : forall (P : nat -> Prop), + (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}. -Axiom Rabst : CReal -> R. -Axiom Rrepr : R -> CReal. -Axiom Rquot1 : forall x y:R, CRealEq (Rrepr x) (Rrepr y) -> x = y. -Axiom Rquot2 : forall x:CReal, CRealEq (Rrepr (Rabst x)) x. +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. @@ -47,29 +54,29 @@ Module Type RbaseSymbolsSig. Parameter Ropp : R -> R. Parameter Rlt : R -> R -> Prop. - Parameter R0_def : R0 = Rabst 0%CReal. - Parameter R1_def : R1 = Rabst 1%CReal. + 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 (CReal_plus (Rrepr x) (Rrepr y)). + Rplus x y = Rabst (ConstructiveRIneq.Rplus (Rrepr x) (Rrepr y)). Parameter Rmult_def : forall x y : R, - Rmult x y = Rabst (CReal_mult (Rrepr x) (Rrepr y)). + Rmult x y = Rabst (ConstructiveRIneq.Rmult (Rrepr x) (Rrepr y)). Parameter Ropp_def : forall x : R, - Ropp x = Rabst (CReal_opp (Rrepr x)). + Ropp x = Rabst (ConstructiveRIneq.Ropp (Rrepr x)). Parameter Rlt_def : forall x y : R, - Rlt x y = CRealLt (Rrepr x) (Rrepr y). + Rlt x y = ConstructiveRIneq.RltProp (Rrepr x) (Rrepr y). End RbaseSymbolsSig. Module RbaseSymbolsImpl : RbaseSymbolsSig. - Definition R0 : R := Rabst 0%CReal. - Definition R1 : R := Rabst 1%CReal. + Definition R0 : R := Rabst (CRzero CR). + Definition R1 : R := Rabst (CRone CR). Definition Rplus : R -> R -> R - := fun x y : R => Rabst (CReal_plus (Rrepr x) (Rrepr y)). + := fun x y : R => Rabst (ConstructiveRIneq.Rplus (Rrepr x) (Rrepr y)). Definition Rmult : R -> R -> R - := fun x y : R => Rabst (CReal_mult (Rrepr x) (Rrepr y)). + := fun x y : R => Rabst (ConstructiveRIneq.Rmult (Rrepr x) (Rrepr y)). Definition Ropp : R -> R - := fun x : R => Rabst (CReal_opp (Rrepr x)). + := fun x : R => Rabst (ConstructiveRIneq.Ropp (Rrepr x)). Definition Rlt : R -> R -> Prop - := fun x y : R => CRealLt (Rrepr x) (Rrepr y). + := fun x y : R => ConstructiveRIneq.RltProp (Rrepr x) (Rrepr y). Definition R0_def := eq_refl R0. Definition R1_def := eq_refl R1. @@ -151,31 +158,13 @@ Definition IZR (z:Z) : R := end. Arguments IZR z%Z : simpl never. -Lemma CRealLt_dec : forall x y : CReal, { CRealLt x y } + { ~CRealLt x y }. -Proof. - intros. - destruct (sig_forall_dec - (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. - Lemma total_order_T : forall r1 r2:R, {Rlt r1 r2} + {r1 = r2} + {Rlt r2 r1}. Proof. - intros. destruct (CRealLt_dec (Rrepr r1) (Rrepr r2)). - - left. left. rewrite RbaseSymbolsImpl.Rlt_def. exact c. - - destruct (CRealLt_dec (Rrepr r2) (Rrepr r1)). - + right. rewrite RbaseSymbolsImpl.Rlt_def. exact c. + 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. @@ -189,10 +178,13 @@ Proof. Qed. Lemma Rrepr_appart_0 : forall x:R, - (x < R0 \/ R0 < x) -> (Rrepr x # 0)%CReal. + (x < R0 \/ R0 < x) -> Rappart (Rrepr x) (CRzero CR). Proof. - intros. 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. + 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. @@ -200,7 +192,7 @@ Module Type RinvSig. 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 ((CReal_inv (Rrepr x) (Rrepr_appart_0 x r))) + | right r => Rabst ((ConstructiveRIneq.Rinv (Rrepr x) (Rrepr_appart_0 x r))) end. End RinvSig. @@ -208,7 +200,7 @@ 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 ((CReal_inv (Rrepr x) (Rrepr_appart_0 x r))) + | right r => Rabst ((ConstructiveRIneq.Rinv (Rrepr x) (Rrepr_appart_0 x r))) end. Definition Rinv_def := fun x => eq_refl (Rinv x). End RinvImpl. 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/toplevel/coqloop.ml b/toplevel/coqloop.ml index f37feb24de..78640334e2 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -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 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/vernac.ml b/toplevel/vernac.ml index 7a59a4dd12..e9d8263b85 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/vernac/assumptions.ml b/vernac/assumptions.ml index ab341e4ab8..a72e43de01 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,24 @@ 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 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 + 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 + accu + + in GlobRef.Map_env.fold fold graph ContextObjectMap.empty diff --git a/vernac/classes.ml b/vernac/classes.ml index 075d89d0df..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)) @@ -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/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..adbe196699 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -567,9 +567,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/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/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 dcd1979a85..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: @@ -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..cf87646905 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -553,7 +553,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..7809425a10 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 *) 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/vernacentries.ml b/vernac/vernacentries.ml index 9af8d8b67c..4ae9d6d54f 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -604,8 +604,7 @@ 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 is_polymorphic_inductive_cumulativity = declare_bool_option_and_ref ~depr:false ~value:false @@ -1074,9 +1073,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 @@ -1728,6 +1724,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,6 +1952,7 @@ 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 @@ -2253,7 +2274,33 @@ let locate_if_not_already ?loc (e, info) = | 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 +2486,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 -> @@ -2614,7 +2661,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 +2691,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 +2713,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 +2726,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 +2765,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 +2779,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 |