diff options
172 files changed, 9167 insertions, 5111 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 39c801197b..caed21f5c3 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,7 +18,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2020-03-19-V29" + CACHEKEY: "bionic_coq-V2020-03-27-V12" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -103,6 +103,9 @@ before_script: interruptible: true dependencies: [] script: + # flambda can be pretty stack hungry, specially with -O3 + # See also https://github.com/ocaml/ocaml/issues/7842#issuecomment-596863244 + - ulimit -s 16384 - set -e - make -f Makefile.dune world - set +e @@ -534,6 +537,30 @@ test-suite:edge:dune:dev: # Gitlab doesn't support yet "expire_in: never" so we use the instance default # expire_in: never +test-suite:edge+4.11+trunk+dune: + stage: stage-1 + dependencies: [] + script: + - opam switch create 4.11.0 --empty + - eval $(opam env) + - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git + - opam update + - opam install ocaml-variants=4.11.0+trunk + - opam install dune num + - eval $(opam env) + - export COQ_UNIT_TEST=noop + - make -f Makefile.dune test-suite + variables: + OPAM_SWITCH: base + artifacts: + name: "$CI_JOB_NAME.logs" + when: always + paths: + - _build/log + - _build/default/test-suite/logs + expire_in: 2 week + allow_failure: true + test-suite:base+async: extends: .test-suite-template dependencies: diff --git a/.ocamlformat b/.ocamlformat index 6d73a5297f..4480935e3b 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,5 +1,10 @@ version=0.13.0 profile=ocamlformat + +# to enable a whole directory, put "disable=false" in dir/.ocamlformat +# to enable specific files put them in .ocamlformat-enable +disable=true + module-item-spacing=compact sequence-style=terminator cases-exp-indent=2 diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore deleted file mode 100644 index b1f6597140..0000000000 --- a/.ocamlformat-ignore +++ /dev/null @@ -1,53 +0,0 @@ -configure.ml -dev/* -coqpp/* -lib/* -clib/* -config/* -checker/* -kernel/* -library/* -engine/* -gramlib/* -parsing/* -interp/* -pretyping/* -printing/* -proofs/* -stm/* -tactics/* -theories/* -user-contrib/*/* -vernac/* -toplevel/* -topbin/* -ide/* -ide/*/* -doc/plugin_tutorial/*/*/* -doc/tools/docgram/* -test-suite/* -test-suite/*/*/* -test-suite/*/*/*/* -test-suite/*/*/*/*/* -tools/* -tools/*/* -plugins/btauto/* -plugins/cc/* -plugins/derive/* -plugins/extraction/* -plugins/firstorder/* -plugins/fourier/* -plugins/funind/* -plugins/ltac/* -plugins/nsatz/* -plugins/omega/* -plugins/rtauto/* -plugins/setoid/* -plugins/ing/* -plugins/setoid_ring/* -plugins/ssr/* -plugins/ssrmatching/* -plugins/syntax/* -# Enabled: micromega -# plugins/micromega/* -plugins/micromega/micromega.ml diff --git a/INSTALL.md b/INSTALL.md index 0c98a611a5..2397f2c5c2 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -7,7 +7,7 @@ Build Requirements To compile Coq yourself, you need: - [OCaml](https://ocaml.org/) (version >= 4.05.0) - (This version of Coq has been tested up to OCaml 4.09.1) + (This version of Coq has been tested up to OCaml 4.10.0) - The [num](https://github.com/ocaml/num) library; note that it is included in the OCaml distribution for OCaml versions < 4.06.0 @@ -45,7 +45,7 @@ CoqIDE with: Opam (https://opam.ocaml.org/) is recommended to install OCaml and the corresponding packages. - $ opam switch create coq 4.09.1+flambda + $ opam switch create coq 4.10.0+flambda $ eval $(opam env) $ opam install num ocamlfind lablgtk3-sourceview3 diff --git a/Makefile.doc b/Makefile.doc index a8703b0acf..9da175f0e5 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -246,16 +246,16 @@ $(DOC_GRAM): $(DOC_GRAMCMO) coqpp/coqpp_parser.mli coqpp/coqpp_parser.ml doc/too # user-contrib/*/*.mlg omitted for now (e.g. ltac2) PLUGIN_MLGS := $(wildcard plugins/*/*.mlg) OMITTED_PLUGIN_MLGS := plugins/ssr/ssrparser.mlg plugins/ssr/ssrvernac.mlg plugins/ssrmatching/g_ssrmatching.mlg -DOC_MLGS := */*.mlg $(sort $(filter-out $(OMITTED_PLUGIN_MLGS), $(PLUGIN_MLGS))) -DOC_EDIT_MLGS := doc/tools/docgram/*.edit_mlg -DOC_RSTS := doc/sphinx/*/*.rst +DOC_MLGS := $(wildcard */*.mlg) $(sort $(filter-out $(OMITTED_PLUGIN_MLGS), $(PLUGIN_MLGS))) +DOC_EDIT_MLGS := $(wildcard doc/tools/docgram/*.edit_mlg) +DOC_RSTS := $(wildcard doc/sphinx/*/*.rst) doc/tools/docgram/fullGrammar: $(DOC_GRAM) $(DOC_MLGS) $(SHOW)'DOC_GRAM' $(HIDE)$(DOC_GRAM) -short -no-warn $(DOC_MLGS) #todo: add a dependency of sphinx on updated_rsts when we're ready -doc/tools/docgram/orderedGrammar doc/tools/docgram/updated_rsts: $(DOC_GRAM) $(DOC_EDIT_MLGS) +doc/tools/docgram/orderedGrammar doc/tools/docgram/updated_rsts: doc/tools/docgram/fullGrammar $(DOC_GRAM) $(DOC_EDIT_MLGS) $(SHOW)'DOC_GRAM_RSTS' $(HIDE)$(DOC_GRAM) -check-cmds $(DOC_MLGS) $(DOC_RSTS) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index aae2c3cb42..0bc30f0196 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -72,7 +72,7 @@ jobs: opam list displayName: 'Install OCaml dependencies' env: - COMPILER: "4.09.1" + COMPILER: "4.10.0" FINDLIB_VER: ".1.8.1" OPAMYES: "true" diff --git a/configure.ml b/configure.ml index 55d71f6c2e..eaa0e321b0 100644 --- a/configure.ml +++ b/configure.ml @@ -616,8 +616,9 @@ let camltag = match caml_version_list with 45: "open" shadowing a label or constructor: see 44 48: implicit elimination of optional arguments: too common 58: "no cmx file was found in path": See https://github.com/ocaml/num/issues/9 + 67: "unused functor parameter" seems totally bogus *) -let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-58" +let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-58-67" let coq_warn_error = if !prefs.warn_error then "-warn-error +a" @@ -923,7 +924,11 @@ let datadir,datadirsuffix = let (_,_,d,s) = select "DATADIR" in d,s (** * CC runtime flags *) -let cflags_dflt = "-Wall -Wno-unused -g -O2 -std=c99 -fasm" +(* Note that Coq's VM requires at least C99-compliant floating-point + arithmetic; this should be ensured by OCaml's own C flags, which + set a minimum of [--std=gnu99] ; modern compilers by default assume + C11 or later, so no explicit [--std=] flags are added by OCaml *) +let cflags_dflt = "-Wall -Wno-unused -g -O2" let cflags_sse2 = "-msse2 -mfpmath=sse" diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index bdffabf0b2..43cd6f1784 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -115,7 +115,7 @@ let print_local fmt ext = match locals with | [] -> () | e :: locals -> - let mk_e fmt e = fprintf fmt "Pcoq.Entry.create \"%s\"" e in + let mk_e fmt e = fprintf fmt "Pcoq.Entry.make \"%s\"" e in let () = fprintf fmt "@[<hv 2>let %s =@ @[%a@]@]@ " e mk_e e in let iter e = fprintf fmt "@[<hv 2>and %s =@ @[%a@]@]@ " e mk_e e in let () = List.iter iter locals in @@ -217,43 +217,43 @@ let rec print_prod fmt p = and print_extrule fmt (tkn, vars, body) = let tkn = List.rev tkn in - fprintf fmt "@[Extend.Rule@ (@[%a@],@ @[(%a)@])@]" (print_symbols ~norec:false) tkn print_fun (vars, body) + fprintf fmt "@[Pcoq.Production.make@ @[(%a)@]@ @[(%a)@]@]" (print_symbols ~norec:false) tkn print_fun (vars, body) and print_symbols ~norec fmt = function -| [] -> fprintf fmt "Extend.Stop" +| [] -> fprintf fmt "Pcoq.Rule.stop" | tkn :: tkns -> - let c = if norec then "Extend.NextNoRec" else "Extend.Next" in - fprintf fmt "%s @[(%a,@ %a)@]" c (print_symbols ~norec) tkns print_symbol tkn + let c = if norec then "Pcoq.Rule.next_norec" else "Pcoq.Rule.next" in + fprintf fmt "%s @[(%a)@ (%a)@]" c (print_symbols ~norec) tkns print_symbol tkn and print_symbol fmt tkn = match tkn with | SymbToken (t, s) -> - fprintf fmt "(Extend.Atoken (%a))" print_tok (t, s) + fprintf fmt "(Pcoq.Symbol.token (%a))" print_tok (t, s) | SymbEntry (e, None) -> - fprintf fmt "(Extend.Aentry %s)" e + fprintf fmt "(Pcoq.Symbol.nterm %s)" e | SymbEntry (e, Some l) -> - fprintf fmt "(Extend.Aentryl (%s, %a))" e print_string l + fprintf fmt "(Pcoq.Symbol.nterml %s (%a))" e print_string l | SymbSelf -> - fprintf fmt "Extend.Aself" + fprintf fmt "Pcoq.Symbol.self" | SymbNext -> - fprintf fmt "Extend.Anext" + fprintf fmt "Pcoq.Symbol.next" | SymbList0 (s, None) -> - fprintf fmt "(Extend.Alist0 %a)" print_symbol s + fprintf fmt "(Pcoq.Symbol.list0 %a)" print_symbol s | SymbList0 (s, Some sep) -> - fprintf fmt "(Extend.Alist0sep (%a, %a))" print_symbol s print_symbol sep + fprintf fmt "(Pcoq.Symbol.list0sep (%a) (%a) false)" print_symbol s print_symbol sep | SymbList1 (s, None) -> - fprintf fmt "(Extend.Alist1 %a)" print_symbol s + fprintf fmt "(Pcoq.Symbol.list1 (%a))" print_symbol s | SymbList1 (s, Some sep) -> - fprintf fmt "(Extend.Alist1sep (%a, %a))" print_symbol s print_symbol sep + fprintf fmt "(Pcoq.Symbol.list1sep (%a) (%a) false)" print_symbol s print_symbol sep | SymbOpt s -> - fprintf fmt "(Extend.Aopt %a)" print_symbol s + fprintf fmt "(Pcoq.Symbol.opt %a)" print_symbol s | SymbRules rules -> let pr fmt (r, body) = let (vars, tkn) = List.split r in let tkn = List.rev tkn in - fprintf fmt "Extend.Rules @[(%a,@ (%a))@]" (print_symbols ~norec:true) tkn print_fun (vars, body) + fprintf fmt "Pcoq.Rules.make @[(%a)@ (%a)@]" (print_symbols ~norec:true) tkn print_fun (vars, body) in let pr fmt rules = print_list fmt pr rules in - fprintf fmt "(Extend.Arules %a)" pr (List.rev rules) + fprintf fmt "(Pcoq.Symbol.rules %a)" pr (List.rev rules) | SymbQuote c -> fprintf fmt "(%s)" c @@ -266,7 +266,7 @@ let print_rule fmt r = let print_entry fmt e = let print_position_opt fmt pos = print_opt fmt print_position pos in let print_rules fmt rules = print_list fmt print_rule rules in - fprintf fmt "let () =@ @[Pcoq.grammar_extend@ %s@ @[(%a, %a)@]@]@ in@ " + fprintf fmt "let () =@ @[Pcoq.grammar_extend@ %s@ @[{ Pcoq.pos=%a; data=%a}@]@]@ in@ " e.gentry_name print_position_opt e.gentry_pos print_rules e.gentry_rules let print_ast fmt ext = @@ -452,7 +452,7 @@ let terminal s = let p = if s <> "" && s.[0] >= '0' && s.[0] <= '9' then "CLexer.terminal_numeral" else "CLexer.terminal" in - let c = Printf.sprintf "Extend.Atoken (%s \"%s\")" p s in + let c = Printf.sprintf "Pcoq.Symbol.token (%s \"%s\")" p s in SymbQuote c let rec parse_symb self = function diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh index 7b3e2703b8..64936cd236 100755 --- a/dev/ci/azure-opam.sh +++ b/dev/ci/azure-opam.sh @@ -2,7 +2,7 @@ set -e -x -OPAM_VARIANT=ocaml-variants.4.09.1+mingw64c +OPAM_VARIANT=ocaml-variants.4.10.0+mingw64c wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz tar -xf opam64.tar.xz diff --git a/dev/ci/ci-bignums.sh b/dev/ci/ci-bignums.sh index 756f54dfbd..a21310cbd5 100755 --- a/dev/ci/ci-bignums.sh +++ b/dev/ci/ci-bignums.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download bignums -( cd "${CI_BUILD_DIR}/bignums" && make && make install) +( cd "${CI_BUILD_DIR}/bignums" && make && make install && cd tests && make) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index e56e4d38ea..0c8733c75a 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2020-03-19-V29" +# CACHEKEY: "bionic_coq-V2020-03-27-V12" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -56,7 +56,7 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ opam install $BASE_OPAM # EDGE switch -ENV COMPILER_EDGE="4.09.1" \ +ENV COMPILER_EDGE="4.10.0" \ BASE_OPAM_EDGE="dune-release.1.3.3 ocamlformat.0.13.0" # EDGE+flambda switch, we install CI_OPAM as to be able to use diff --git a/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh b/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh new file mode 100644 index 0000000000..e3a8eb07f3 --- /dev/null +++ b/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "11818" ] || [ "$CI_BRANCH" = "proof+remove_special_case_first_declaration_in_mutual" ]; then + + metacoq_CI_REF=proof+remove_special_case_first_declaration_in_mutual + metacoq_CI_GITURL=https://github.com/ejgallego/metacoq + + elpi_CI_REF=proof+remove_special_case_first_declaration_in_mutual + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + paramcoq_CI_REF=proof+remove_special_case_first_declaration_in_mutual + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + + equations_CI_REF=proof+remove_special_case_first_declaration_in_mutual + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + +fi diff --git a/dev/dune-workspace.all b/dev/dune-workspace.all index 556493ffad..d6348a3624 100644 --- a/dev/dune-workspace.all +++ b/dev/dune-workspace.all @@ -3,5 +3,5 @@ ; Add custom flags here. Default developer profile is `dev` (context (opam (switch 4.05.0))) (context (opam (switch 4.05.0+32bit))) -(context (opam (switch 4.09.1))) -(context (opam (switch 4.09.1+flambda))) +(context (opam (switch 4.10.0))) +(context (opam (switch 4.10.0+flambda))) diff --git a/dev/tools/pre-commit b/dev/tools/pre-commit index ad2f2f93e7..633913aac6 100755 --- a/dev/tools/pre-commit +++ b/dev/tools/pre-commit @@ -7,69 +7,75 @@ set -e dev/tools/check-overlays.sh -if ! git diff --cached --name-only -z | xargs -0 dev/tools/check-eof-newline.sh || - ! git diff-index --check --cached HEAD >/dev/null 2>&1 ; +# Can we check and fix formatting? +# NB: we will ignore errors from ocamlformat as it fails when +# encountering OCaml syntax errors +ocamlformat=$(command -v ocamlformat || echo true) +if [ "$ocamlformat" = true ] then - 1>&2 echo "Auto fixing whitespace issues..." + 1>&2 echo "Warning: ocamlformat is not in path. Cannot check formatting." +fi - # We fix whitespace in the index and in the working tree - # separately to preserve non-added changes. - index=$(mktemp "git-fix-ws-index.XXXXXX") - fixed_index=$(mktemp "git-fix-ws-index-fixed.XXXXXX") - tree=$(mktemp "git-fix-ws-tree.XXXXXX") - 1>&2 echo "Patches are saved in '$index', '$fixed_index' and '$tree'." - 1>&2 echo "If an error destroys your changes you can recover using them." - 1>&2 echo "(The files are cleaned up on success.)" - 1>&2 echo #newline +1>&2 echo "Auto fixing whitespace and formatting issues..." - git diff-index -p --cached HEAD > "$index" - git diff-index -p HEAD > "$tree" +# We fix whitespace in the index and in the working tree +# separately to preserve non-added changes. +index=$(mktemp "git-fix-ws-index.XXXXXX") +fixed_index=$(mktemp "git-fix-ws-index-fixed.XXXXXX") +tree=$(mktemp "git-fix-ws-tree.XXXXXX") +1>&2 echo "Patches are saved in '$index', '$fixed_index' and '$tree'." +1>&2 echo "If an error destroys your changes you can recover using them." +1>&2 echo "(The files are cleaned up on success.)" +1>&2 echo #newline - # reset work tree and index - # NB: untracked files which were not added are untouched - git apply --whitespace=nowarn --cached -R "$index" - git apply --whitespace=nowarn -R "$tree" +git diff-index -p --cached HEAD > "$index" +git diff-index -p HEAD > "$tree" - # Fix index - # For end of file newlines we must go through the worktree +# reset work tree and index +# NB: untracked files which were not added are untouched +if [ -s "$index" ]; then git apply --whitespace=nowarn --cached -R "$index"; fi +if [ -s "$tree" ]; then git apply --whitespace=nowarn -R "$tree"; fi + +# Fix index +# For end of file newlines we must go through the worktree +if [ -s "$index" ]; then 1>&2 echo "Fixing staged changes..." git apply --cached --whitespace=fix "$index" git apply --whitespace=fix "$index" 2>/dev/null # no need to repeat yourself git diff --cached --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix + git diff --cached --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true git add -u 1>&2 echo #newline +fi - # reset work tree - git diff-index -p --cached HEAD > "$fixed_index" - # If all changes were bad whitespace changes the patch is empty - # making git fail. Don't fail now: we fix the worktree first. - if [ -s "$fixed_index" ] - then - git apply --whitespace=nowarn -R "$fixed_index" - fi +# reset work tree +git diff-index -p --cached HEAD > "$fixed_index" +# If all changes were bad whitespace changes the patch is empty +# making git fail. Don't fail now: we fix the worktree first. +if [ -s "$fixed_index" ]; then git apply --whitespace=nowarn -R "$fixed_index"; fi - # Fix worktree +# Fix worktree +if [ -s "$tree" ]; then 1>&2 echo "Fixing unstaged changes..." git apply --whitespace=fix "$tree" git diff --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix + git diff --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true 1>&2 echo #newline +fi - if ! [ -s "$fixed_index" ] - then - 1>&2 echo "No changes after fixing whitespace issues!" - exit 1 - fi - - # Check that we did fix whitespace - if ! git diff-index --check --cached HEAD; - then - 1>&2 echo "Auto-fixing whitespace failed: errors remain." - 1>&2 echo "This may fix itself if you try again." - 1>&2 echo "(Consider whether the number of errors decreases after each run.)" - exit 1 - fi - 1>&2 echo "Whitespace issues fixed!" +if [ -s "$index" ] && ! [ -s "$fixed_index" ]; then + 1>&2 echo "Fixing whitespace and formatting issues cancelled all changes." + exit 1 +fi - # clean up temporary files - rm "$index" "$tree" "$fixed_index" +# Check that we did fix whitespace +if ! git diff-index --check --cached HEAD; then + 1>&2 echo "Auto-fixing whitespace failed: errors remain." + 1>&2 echo "This may fix itself if you try again." + 1>&2 echo "(Consider whether the number of errors decreases after each run.)" + exit 1 fi +1>&2 echo "Whitespace and formatting pass complete." + +# clean up temporary files +rm "$index" "$tree" "$fixed_index" diff --git a/dev/tools/update-compat.py b/dev/tools/update-compat.py index ddb0362186..666fb6cc91 100755 --- a/dev/tools/update-compat.py +++ b/dev/tools/update-compat.py @@ -1,6 +1,4 @@ #!/usr/bin/env python3 -from __future__ import with_statement -from __future__ import print_function import os, re, sys, subprocess from io import open diff --git a/doc/changelog/02-specification-language/11579-inductive-params.rst b/doc/changelog/02-specification-language/11579-inductive-params.rst new file mode 100644 index 0000000000..28bc8e9592 --- /dev/null +++ b/doc/changelog/02-specification-language/11579-inductive-params.rst @@ -0,0 +1,7 @@ +- **Fixed:** + More robust and expressive treatment of implicit inductive + parameters in inductive declarations (`#11579 + <https://github.com/coq/coq/pull/11579>`_, by Maxime Dénès, Gaëtan + Gilbert and Jasper Hugunin; fixes `#7253 + <https://github.com/coq/coq/pull/7253>`_ and `#11585 + <https://github.com/coq/coq/pull/11585>`_) diff --git a/doc/changelog/03-notations/11859-warn-inexact-float.rst b/doc/changelog/03-notations/11859-warn-inexact-float.rst new file mode 100644 index 0000000000..224ffdbe9b --- /dev/null +++ b/doc/changelog/03-notations/11859-warn-inexact-float.rst @@ -0,0 +1,6 @@ +- **Added:** + In primitive floats, print a warning when parsing a decimal value + that is not exactly a binary64 floating-point number. + For instance, parsing 0.1 will print a warning whereas parsing 0.5 won't. + (`#11859 <https://github.com/coq/coq/pull/11859>`_, + by Pierre Roux). diff --git a/doc/changelog/04-tactics/11018-lia-in-auto-with-zarith.rst b/doc/changelog/04-tactics/11018-lia-in-auto-with-zarith.rst new file mode 100644 index 0000000000..d510416990 --- /dev/null +++ b/doc/changelog/04-tactics/11018-lia-in-auto-with-zarith.rst @@ -0,0 +1,7 @@ +- **Changed:** The :g:`auto with zarith` tactic and variations (including :tacn:`intuition`) + may now call the :tacn:`lia` tactic instead of :tacn:`omega` + (when the `Omega` module is loaded); + more goals may be automatically solved, + fewer section variables will be captured spuriously + (`#11018 <https://github.com/coq/coq/pull/11018>`_, + by Vincent Laporte). diff --git a/doc/changelog/07-commands-and-options/11944-rm-searchabout-cmd.rst b/doc/changelog/07-commands-and-options/11944-rm-searchabout-cmd.rst new file mode 100644 index 0000000000..e409c638bb --- /dev/null +++ b/doc/changelog/07-commands-and-options/11944-rm-searchabout-cmd.rst @@ -0,0 +1,3 @@ +- **Removed:** Removed SearchAbout command that was deprecated in 8.5. + Use :cmd:`Search` instead. + (`#11944 <https://github.com/coq/coq/pull/11944>`_, by Jim Fehrle). diff --git a/doc/changelog/08-tools/10592-coqdoc-details.rst b/doc/changelog/08-tools/10592-coqdoc-details.rst new file mode 100644 index 0000000000..c5bdc1dbb0 --- /dev/null +++ b/doc/changelog/08-tools/10592-coqdoc-details.rst @@ -0,0 +1,5 @@ +- **Added:** + A new documentation environment ``details`` to make certain portion + of a Coq document foldable. See :ref:`coqdoc` + (`#10592 <https://github.com/coq/coq/pull/10592>`_, + by Thomas Letan). diff --git a/doc/changelog/10-standard-library/11725-cleanup-reals.rst b/doc/changelog/10-standard-library/11725-cleanup-reals.rst new file mode 100644 index 0000000000..02ee7e6c70 --- /dev/null +++ b/doc/changelog/10-standard-library/11725-cleanup-reals.rst @@ -0,0 +1,6 @@ +- **Changed:** + Use implicit arguments for ``ConstructiveReals``. Move ``ConstructiveReals`` + into new directory ``Abstract``. Remove imports of implementations inside + those ``Abstract`` files. Move implementation by means of Cauchy sequences in new directory ``Cauchy``. + (`#11725 <https://github.com/coq/coq/pull/11725>`_, + by Vincent Semeria). diff --git a/doc/changelog/10-standard-library/11880-iter.rst b/doc/changelog/10-standard-library/11880-iter.rst new file mode 100644 index 0000000000..be4e44ce4c --- /dev/null +++ b/doc/changelog/10-standard-library/11880-iter.rst @@ -0,0 +1,8 @@ +- **Added:** + Facts about ``N.iter`` and ``Pos.iter``: + + - ``N.iter_swap_gen``, ``N.iter_swap``, ``N.iter_succ``, ``N.iter_succ_r``, ``N.iter_add``, ``N.iter_ind``, ``N.iter_invariant``; + - ``Pos.iter_succ_r``, ``Pos.iter_ind``. + + (`#11880 <https://github.com/coq/coq/pull/11880>`_, + by Lysxia). diff --git a/doc/changelog/11-infrastructure-and-dependencies/11131-ci+back_to_ocaml_410.rst b/doc/changelog/11-infrastructure-and-dependencies/11131-ci+back_to_ocaml_410.rst new file mode 100644 index 0000000000..778d37e07b --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/11131-ci+back_to_ocaml_410.rst @@ -0,0 +1,7 @@ +- **Added:** + Bump official OCaml support and CI testing to 4.10.0 + (`#11131 <https://github.com/coq/coq/pull/11131>`_, + `#11123 <https://github.com/coq/coq/pull/11123>`_, + `#11102 <https://github.com/coq/coq/pull/11123>`_, + by Emilio Jesus Gallego Arias, Jacques-Henri Jourdan, + Guillaume Melquiond, and Guillaume Munch-Maccagnoni). diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 2fdca15552..8c4dc0e8a6 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,10 +1,6 @@ let edeclare ?hook ~name ~poly ~scope ~kind ~opaque ~udecl ~impargs sigma body tyopt = - let sigma, ce = DeclareDef.prepare_definition ~allow_evars:false - ~opaque ~poly sigma ~udecl ~types:tyopt ~body in - let uctx = Evd.evar_universe_context sigma in - let ubind = Evd.universe_binders sigma in - let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - DeclareDef.declare_definition ~name ~scope ~kind ~ubind ce ~impargs ?hook_data + DeclareDef.declare_definition ~name ~scope ~kind ~impargs ?hook + ~opaque ~poly ~udecl ~types:tyopt ~body sigma let declare_definition ~poly name sigma body = let udecl = UState.default_univ_decl in diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 5ca0d8b81f..7401aff48c 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -383,6 +383,10 @@ Changes in 8.11+beta1 <https://github.com/coq/coq/issues/3890>`_ and `#4638 <https://github.com/coq/coq/issues/4638>`_ by Maxime Dénès, review by Gaëtan Gilbert). +- **Changed:** + :cmd:`Fail` does not catch critical errors (including "stack overflow") + anymore (`#10173 <https://github.com/coq/coq/pull/10173>`_, + by Gaëtan Gilbert). - **Removed:** Undocumented :n:`Instance : !@type` syntax (`#10185 <https://github.com/coq/coq/pull/10185>`_, by Gaëtan Gilbert). diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index 39f2ccec29..acdd4408ed 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -1062,6 +1062,11 @@ Floating-point constants are parsed and pretty-printed as (17-digit) decimal constants. This ensures that the composition :math:`\text{parse} \circ \text{print}` amounts to the identity. +.. warn:: The constant @numeral is not a binary64 floating-point value. A closest value will be used and unambiguously printed @numeral. [inexact-float,parsing] + + Not all decimal constants are floating-point values. This warning + is generated when parsing such a constant (for instance ``0.1``). + .. example:: .. coqtop:: all diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index e5ff26520a..d61e5ddce7 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -637,470 +637,6 @@ See the man page of ``coqdep`` for more details and options. Both Dune and ``coq_makefile`` use ``coqdep`` to compute the dependencies among the files part of a Coq project. -.. _coqdoc: - -Documenting |Coq| files with coqdoc ------------------------------------ - -coqdoc is a documentation tool for the proof assistant |Coq|, similar to -``javadoc`` or ``ocamldoc``. The task of coqdoc is - - -#. to produce a nice |Latex| and/or HTML document from |Coq| source files, - readable for a human and not only for the proof assistant; -#. to help the user navigate his own (or third-party) sources. - - - -Principles -~~~~~~~~~~ - -Documentation is inserted into |Coq| files as *special comments*. Thus -your files will compile as usual, whether you use coqdoc or not. coqdoc -presupposes that the given |Coq| files are well-formed (at least -lexically). Documentation starts with ``(**``, followed by a space, and -ends with ``*)``. The documentation format is inspired by Todd -A. Coram’s *Almost Free Text (AFT)* tool: it is mainly ``ASCII`` text with -some syntax-light controls, described below. coqdoc is robust: it -shouldn’t fail, whatever the input is. But remember: “garbage in, -garbage out”. - - -|Coq| material inside documentation. -++++++++++++++++++++++++++++++++++++ - -|Coq| material is quoted between the delimiters ``[`` and ``]``. Square brackets -may be nested, the inner ones being understood as being part of the -quoted code (thus you can quote a term like ``fun x => u`` by writing ``[fun -x => u]``). Inside quotations, the code is pretty-printed in the same -way as it is in code parts. - -Preformatted vernacular is enclosed by ``[[`` and ``]]``. The former must be -followed by a newline and the latter must follow a newline. - - -Pretty-printing. -++++++++++++++++ - -coqdoc uses different faces for identifiers and keywords. The pretty- -printing of |Coq| tokens (identifiers or symbols) can be controlled -using one of the following commands: - -:: - - - (** printing *token* %...LATEX...% #...html...# *) - - -or - -:: - - - (** printing *token* $...LATEX math...$ #...html...# *) - - -It gives the |Latex| and HTML texts to be produced for the given |Coq| -token. Either the |Latex| or the HTML rule may be omitted, causing the -default pretty-printing to be used for this token. - -The printing for one token can be removed with - -:: - - - (** remove printing *token* *) - - -Initially, the pretty-printing table contains the following mapping: - -===== === ==== ===== === ==== ==== === -`->` → `<-` ← `*` × -`<=` ≤ `>=` ≥ `=>` ⇒ -`<>` ≠ `<->` ↔ `|-` ⊢ -`\\/` ∨ `/\\` ∧ `~` ¬ -===== === ==== ===== === ==== ==== === - -Any of these can be overwritten or suppressed using the printing -commands. - -.. note:: - - The recognition of tokens is done by a (``ocaml``) lex - automaton and thus applies the longest-match rule. For instance, `->~` - is recognized as a single token, where |Coq| sees two tokens. It is the - responsibility of the user to insert space between tokens *or* to give - pretty-printing rules for the possible combinations, e.g. - - :: - - (** printing ->~ %\ensuremath{\rightarrow\lnot}% *) - - - -Sections -++++++++ - -Sections are introduced by 1 to 4 asterisks at the beginning of a line -followed by a space and the title of the section. One asterisk is a section, -two a subsection, etc. - -.. example:: - - :: - - (** * Well-founded relations - - In this section, we introduce... *) - - -Lists. -++++++ - -List items are introduced by a leading dash. coqdoc uses whitespace to -determine the depth of a new list item and which text belongs in which -list items. A list ends when a line of text starts at or before the -level of indenting of the list’s dash. A list item’s dash must always -be the first non-space character on its line (so, in particular, a -list can not begin on the first line of a comment - start it on the -second line instead). - -.. example:: - - :: - - We go by induction on [n]: - - If [n] is 0... - - If [n] is [S n'] we require... - - two paragraphs of reasoning, and two subcases: - - - In the first case... - - In the second case... - - So the theorem holds. - - - -Rules. -++++++ - -More than 4 leading dashes produce a horizontal rule. - - -Emphasis. -+++++++++ - -Text can be italicized by enclosing it in underscores. A non-identifier -character must precede the leading underscore and follow the trailing -underscore, so that uses of underscores in names aren’t mistaken for -emphasis. Usually, these are spaces or punctuation. - -:: - - This sentence contains some _emphasized text_. - - - -Escaping to |Latex| and HTML. -+++++++++++++++++++++++++++++++ - -Pure |Latex| or HTML material can be inserted using the following -escape sequences: - - -+ ``$...LATEX stuff...$`` inserts some |Latex| material in math mode. - Simply discarded in HTML output. -+ ``%...LATEX stuff...%`` inserts some |Latex| material. Simply - discarded in HTML output. -+ ``#...HTML stuff...#`` inserts some HTML material. Simply discarded in - |Latex| output. - -.. note:: - to simply output the characters ``$``, ``%`` and ``#`` and escaping - their escaping role, these characters must be doubled. - - -Verbatim -++++++++ - -Verbatim material is introduced by a leading ``<<`` and closed by ``>>`` -at the beginning of a line. - -.. example:: - - :: - - Here is the corresponding caml code: - << - let rec fact n = - if n <= 1 then 1 else n * fact (n-1) - >> - - - -Hyperlinks -++++++++++ - -Hyperlinks can be inserted into the HTML output, so that any -identifier is linked to the place of its definition. - -``coqc file.v`` automatically dumps localization information in -``file.glob`` or appends it to a file specified using the option ``--dump-glob -file``. Take care of erasing this global file, if any, when starting -the whole compilation process. - -Then invoke coqdoc or ``coqdoc --glob-from file`` to tell coqdoc to look -for name resolutions in the file ``file`` (it will look in ``file.glob`` -by default). - -Identifiers from the |Coq| standard library are linked to the Coq website -`<http://coq.inria.fr/library/>`_. This behavior can be changed -using command line options ``--no-externals`` and ``--coqlib``; see below. - - -Hiding / Showing parts of the source. -+++++++++++++++++++++++++++++++++++++ - -Some parts of the source can be hidden using command line options ``-g`` -and ``-l`` (see below), or using such comments: - -:: - - - (* begin hide *) - *some Coq material* - (* end hide *) - - -Conversely, some parts of the source which would be hidden can be -shown using such comments: - -:: - - - (* begin show *) - *some Coq material* - (* end show *) - - -The latter cannot be used around some inner parts of a proof, but can -be used around a whole proof. - - -Usage -~~~~~ - -coqdoc is invoked on a shell command line as follows: -``coqdoc <options and files>``. -Any command line argument which is not an option is considered to be a -file (even if it starts with a ``-``). |Coq| files are identified by the -suffixes ``.v`` and ``.g`` and |Latex| files by the suffix ``.tex``. - - -:HTML output: This is the default output format. One HTML file is created for - each |Coq| file given on the command line, together with a file - ``index.html`` (unless ``option-no-index is passed``). The HTML pages use a - style sheet named ``style.css``. Such a file is distributed with coqdoc. -:|Latex| output: A single |Latex| file is created, on standard - output. It can be redirected to a file using the option ``-o``. The order of - files on the command line is kept in the final document. |Latex| - files given on the command line are copied ‘as is’ in the final - document . DVI and PostScript can be produced directly with the - options ``-dvi`` and ``-ps`` respectively. -:TEXmacs output: To translate the input files to TEXmacs format, - to be used by the TEXmacs |Coq| interface. - - - -Command line options -++++++++++++++++++++ - - -**Overall options** - - - :--HTML: Select a HTML output. - :--|Latex|: Select a |Latex| output. - :--dvi: Select a DVI output. - :--ps: Select a PostScript output. - :--texmacs: Select a TEXmacs output. - :--stdout: Write output to stdout. - :-o file, --output file: Redirect the output into the file ‘file’ - (meaningless with ``-html``). - :-d dir, --directory dir: Output files into directory ‘dir’ instead of - the current directory (option ``-d`` does not change the filename specified - with the option ``-o``, if any). - :--body-only: Suppress the header and trailer of the final document. - Thus, you can insert the resulting document into a larger one. - :-p string, --preamble string: Insert some material in the |Latex| - preamble, right before ``\begin{document}`` (meaningless with ``-html``). - :--vernac-file file,--tex-file file: Considers the file ‘file’ - respectively as a ``.v`` (or ``.g``) file or a ``.tex`` file. - :--files-from file: Read filenames to be processed from the file ‘file’ as if - they were given on the command line. Useful for program sources split - up into several directories. - :-q, --quiet: Be quiet. Do not print anything except errors. - :-h, --help: Give a short summary of the options and exit. - :-v, --version: Print the version and exit. - - - -**Index options** - - The default behavior is to build an index, for the HTML output only, - into ``index.html``. - - :--no-index: Do not output the index. - :--multi-index: Generate one page for each category and each letter in - the index, together with a top page ``index.html``. - :--index string: Make the filename of the index string instead of - “index”. Useful since “index.html” is special. - - - -**Table of contents option** - - :-toc, --table-of-contents: Insert a table of contents. For a |Latex| - output, it inserts a ``\tableofcontents`` at the beginning of the - document. For a HTML output, it builds a table of contents into - ``toc.html``. - :--toc-depth int: Only include headers up to depth ``int`` in the table of - contents. - - -**Hyperlink options** - - :--glob-from file: Make references using |Coq| globalizations from file - file. (Such globalizations are obtained with Coq option ``-dump-glob``). - :--no-externals: Do not insert links to the |Coq| standard library. - :--external url coqdir: Use given URL for linking references whose - name starts with prefix ``coqdir``. - :--coqlib url: Set base URL for the Coq standard library (default is - `<http://coq.inria.fr/library/>`_). This is equivalent to ``--external url - Coq``. - :-R dir coqdir: Recursively map physical directory dir to |Coq| logical - directory ``coqdir`` (similarly to |Coq| option ``-R``). - :-Q dir coqdir: Map physical directory dir to |Coq| logical - directory ``coqdir`` (similarly to |Coq| option ``-Q``). - - .. note:: - - options ``-R`` and ``-Q`` only have - effect on the files *following* them on the command line, so you will - probably need to put this option first. - - -**Title options** - - :-s , --short: Do not insert titles for the files. The default - behavior is to insert a title like “Library Foo” for each file. - :--lib-name string: Print “string Foo” instead of “Library Foo” in - titles. For example “Chapter” and “Module” are reasonable choices. - :--no-lib-name: Print just “Foo” instead of “Library Foo” in titles. - :--lib-subtitles: Look for library subtitles. When enabled, the - beginning of each file is checked for a comment of the form: - - :: - - (** * ModuleName : text *) - - where ``ModuleName`` must be the name of the file. If it is present, the - text is used as a subtitle for the module in appropriate places. - :-t string, --title string: Set the document title. - - -**Contents options** - - :-g, --gallina: Do not print proofs. - :-l, --light: Light mode. Suppress proofs (as with ``-g``) and the following commands: - - + [Recursive] Tactic Definition - + Hint / Hints - + Require - + Transparent / Opaque - + Implicit Argument / Implicits - + Section / Variable / Hypothesis / End - - - - The behavior of options ``-g`` and ``-l`` can be locally overridden using the - ``(* begin show *) … (* end show *)`` environment (see above). - - There are a few options that control the parsing of comments: - - :--parse-comments: Parse regular comments delimited by ``(*`` and ``*)`` as - well. They are typeset inline. - :--plain-comments: Do not interpret comments, simply copy them as - plain-text. - :--interpolate: Use the globalization information to typeset - identifiers appearing in |Coq| escapings inside comments. - -**Language options** - - - The default behavior is to assume ASCII 7 bit input files. - - :-latin1, --latin1: Select ISO-8859-1 input files. It is equivalent to - --inputenc latin1 --charset iso-8859-1. - :-utf8, --utf8: Set --inputenc utf8x for |Latex| output and--charset - utf-8 for HTML output. Also use Unicode replacements for a couple of - standard plain ASCII notations such as → for ``->`` and ∀ for ``forall``. |Latex| - UTF-8 support can be found - at `<http://www.ctan.org/pkg/unicode>`_. For the interpretation of Unicode - characters by |Latex|, extra packages which coqdoc does not provide - by default might be required, such as textgreek for some Greek letters - or ``stmaryrd`` for some mathematical symbols. If a Unicode character is - missing an interpretation in the utf8x input encoding, add - ``\DeclareUnicodeCharacter{code}{LATEX-interpretation}``. Packages - and declarations can be added with option ``-p``. - :--inputenc string: Give a |Latex| input encoding, as an option to |Latex| - package ``inputenc``. - :--charset string: Specify the HTML character set, to be inserted in - the HTML header. - - - -The coqdoc |Latex| style file -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In case you choose to produce a document without the default |Latex| -preamble (by using option ``--no-preamble``), then you must insert into -your own preamble the command - -:: - - \usepackage{coqdoc} - -The package optionally takes the argument ``[color]`` to typeset -identifiers with colors (this requires the ``xcolor`` package). - -Then you may alter the rendering of the document by redefining some -macros: - -:coqdockw, coqdocid, …: The one-argument macros for typesetting - keywords and identifiers. Defaults are sans-serif for keywords and - italic for identifiers.For example, if you would like a slanted font - for keywords, you may insert - - :: - - \renewcommand{\coqdockw}[1]{\textsl{#1}} - - - anywhere between ``\usepackage{coqdoc}`` and ``\begin{document}``. - - -:coqdocmodule: - One-argument macro for typesetting the title of a ``.v`` - file. Default is - - :: - - \newcommand{\coqdocmodule}[1]{\section*{Module #1}} - - and you may redefine it using ``\renewcommand``. - Embedded Coq phrases inside |Latex| documents --------------------------------------------- diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index c33d62532e..b22c5286fe 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -321,18 +321,6 @@ Requests to the environment Search (?x * _ + ?x * _)%Z outside OmegaLemmas. - .. cmdv:: SearchAbout - :name: SearchAbout - - .. deprecated:: 8.5 - - Up to |Coq| version 8.4, :cmd:`Search` had the behavior of current - :cmd:`SearchHead` and the behavior of current :cmd:`Search` was obtained with - command :cmd:`SearchAbout`. For compatibility, the deprecated name - :cmd:`SearchAbout` can still be used as a synonym of :cmd:`Search`. For - compatibility, the list of objects to search when using :cmd:`SearchAbout` - may also be enclosed by optional ``[ ]`` delimiters. - .. cmd:: SearchHead @term @@ -929,16 +917,17 @@ Quitting and debugging .. cmd:: Fail @command - For debugging scripts, sometimes it is desirable to know - whether a command or a tactic fails. If the given :n:`@command` - fails, the ``Fail`` statement succeeds, without changing the proof - state, and in interactive mode, the system - prints a message confirming the failure. - If the given :n:`@command` succeeds, the statement is an error, and - it prints a message indicating that the failure did not occur. + For debugging scripts, sometimes it is desirable to know whether a + command or a tactic fails. If the given :n:`@command` fails, then + :n:`Fail @command` succeeds (excepts in the case of + critical errors, like a "stack overflow"), without changing the + proof state, and in interactive mode, the system prints a message + confirming the failure. .. exn:: The command has not failed! - :undocumented: + + If the given :n:`@command` succeeds, then :n:`Fail @command` + fails with this error message. .. _controlling-display: diff --git a/doc/sphinx/using/tools/coqdoc.rst b/doc/sphinx/using/tools/coqdoc.rst new file mode 100644 index 0000000000..b4b14fb392 --- /dev/null +++ b/doc/sphinx/using/tools/coqdoc.rst @@ -0,0 +1,484 @@ +.. _coqdoc: + +Documenting |Coq| files with coqdoc +----------------------------------- + +coqdoc is a documentation tool for the proof assistant |Coq|, similar to +``javadoc`` or ``ocamldoc``. The task of coqdoc is + + +#. to produce a nice |Latex| and/or HTML document from |Coq| source files, + readable for a human and not only for the proof assistant; +#. to help the user navigate his own (or third-party) sources. + + + +Principles +~~~~~~~~~~ + +Documentation is inserted into |Coq| files as *special comments*. Thus +your files will compile as usual, whether you use coqdoc or not. coqdoc +presupposes that the given |Coq| files are well-formed (at least +lexically). Documentation starts with ``(**``, followed by a space, and +ends with ``*)``. The documentation format is inspired by Todd +A. Coram’s *Almost Free Text (AFT)* tool: it is mainly ``ASCII`` text with +some syntax-light controls, described below. coqdoc is robust: it +shouldn’t fail, whatever the input is. But remember: “garbage in, +garbage out”. + + +|Coq| material inside documentation. +++++++++++++++++++++++++++++++++++++ + +|Coq| material is quoted between the delimiters ``[`` and ``]``. Square brackets +may be nested, the inner ones being understood as being part of the +quoted code (thus you can quote a term like ``fun x => u`` by writing ``[fun +x => u]``). Inside quotations, the code is pretty-printed in the same +way as it is in code parts. + +Preformatted vernacular is enclosed by ``[[`` and ``]]``. The former must be +followed by a newline and the latter must follow a newline. + + +Pretty-printing. +++++++++++++++++ + +coqdoc uses different faces for identifiers and keywords. The pretty- +printing of |Coq| tokens (identifiers or symbols) can be controlled +using one of the following commands: + +:: + + + (** printing *token* %...LATEX...% #...html...# *) + + +or + +:: + + + (** printing *token* $...LATEX math...$ #...html...# *) + + +It gives the |Latex| and HTML texts to be produced for the given |Coq| +token. Either the |Latex| or the HTML rule may be omitted, causing the +default pretty-printing to be used for this token. + +The printing for one token can be removed with + +:: + + + (** remove printing *token* *) + + +Initially, the pretty-printing table contains the following mapping: + +===== === ==== ===== === ==== ==== === +`->` → `<-` ← `*` × +`<=` ≤ `>=` ≥ `=>` ⇒ +`<>` ≠ `<->` ↔ `|-` ⊢ +`\\/` ∨ `/\\` ∧ `~` ¬ +===== === ==== ===== === ==== ==== === + +Any of these can be overwritten or suppressed using the printing +commands. + +.. note:: + + The recognition of tokens is done by a (``ocaml``) lex + automaton and thus applies the longest-match rule. For instance, `->~` + is recognized as a single token, where |Coq| sees two tokens. It is the + responsibility of the user to insert space between tokens *or* to give + pretty-printing rules for the possible combinations, e.g. + + :: + + (** printing ->~ %\ensuremath{\rightarrow\lnot}% *) + + + +Sections +++++++++ + +Sections are introduced by 1 to 4 asterisks at the beginning of a line +followed by a space and the title of the section. One asterisk is a section, +two a subsection, etc. + +.. example:: + + :: + + (** * Well-founded relations + + In this section, we introduce... *) + + +Lists. +++++++ + +List items are introduced by a leading dash. coqdoc uses whitespace to +determine the depth of a new list item and which text belongs in which +list items. A list ends when a line of text starts at or before the +level of indenting of the list’s dash. A list item’s dash must always +be the first non-space character on its line (so, in particular, a +list can not begin on the first line of a comment - start it on the +second line instead). + +.. example:: + + :: + + We go by induction on [n]: + - If [n] is 0... + - If [n] is [S n'] we require... + + two paragraphs of reasoning, and two subcases: + + - In the first case... + - In the second case... + + So the theorem holds. + + + +Rules. +++++++ + +More than 4 leading dashes produce a horizontal rule. + + +Emphasis. ++++++++++ + +Text can be italicized by enclosing it in underscores. A non-identifier +character must precede the leading underscore and follow the trailing +underscore, so that uses of underscores in names aren’t mistaken for +emphasis. Usually, these are spaces or punctuation. + +:: + + This sentence contains some _emphasized text_. + + + +Escaping to |Latex| and HTML. ++++++++++++++++++++++++++++++++ + +Pure |Latex| or HTML material can be inserted using the following +escape sequences: + + ++ ``$...LATEX stuff...$`` inserts some |Latex| material in math mode. + Simply discarded in HTML output. ++ ``%...LATEX stuff...%`` inserts some |Latex| material. Simply + discarded in HTML output. ++ ``#...HTML stuff...#`` inserts some HTML material. Simply discarded in + |Latex| output. + +.. note:: + to simply output the characters ``$``, ``%`` and ``#`` and escaping + their escaping role, these characters must be doubled. + + +Verbatim +++++++++ + +Verbatim material is introduced by a leading ``<<`` and closed by ``>>`` +at the beginning of a line. + +.. example:: + + :: + + Here is the corresponding caml code: + << + let rec fact n = + if n <= 1 then 1 else n * fact (n-1) + >> + + + +Hyperlinks +++++++++++ + +Hyperlinks can be inserted into the HTML output, so that any +identifier is linked to the place of its definition. + +``coqc file.v`` automatically dumps localization information in +``file.glob`` or appends it to a file specified using the option ``--dump-glob +file``. Take care of erasing this global file, if any, when starting +the whole compilation process. + +Then invoke coqdoc or ``coqdoc --glob-from file`` to tell coqdoc to look +for name resolutions in the file ``file`` (it will look in ``file.glob`` +by default). + +Identifiers from the |Coq| standard library are linked to the Coq website +`<http://coq.inria.fr/library/>`_. This behavior can be changed +using command line options ``--no-externals`` and ``--coqlib``; see below. + + +Hiding / Showing parts of the source. ++++++++++++++++++++++++++++++++++++++ + +Some parts of the source can be hidden using command line options ``-g`` +and ``-l`` (see below), or using such comments: + +:: + + + (* begin hide *) + *some Coq material* + (* end hide *) + + +Conversely, some parts of the source which would be hidden can be +shown using such comments: + +:: + + + (* begin show *) + *some Coq material* + (* end show *) + + +The latter cannot be used around some inner parts of a proof, but can +be used around a whole proof. + +Lastly, it is possible to adopt a middle-ground approach when the +desired output is HTML, where a given snippet of Coq material is +hidden by default, but can be made visible with user interaction. + +:: + + + (* begin details *) + *some Coq material* + (* end details *) + + +There is also an alternative syntax available. + +:: + + + (* begin details : Some summary describing the snippet *) + *some Coq material* + (* end details *) + + +Usage +~~~~~ + +coqdoc is invoked on a shell command line as follows: +``coqdoc <options and files>``. +Any command line argument which is not an option is considered to be a +file (even if it starts with a ``-``). |Coq| files are identified by the +suffixes ``.v`` and ``.g`` and |Latex| files by the suffix ``.tex``. + + +:HTML output: This is the default output format. One HTML file is created for + each |Coq| file given on the command line, together with a file + ``index.html`` (unless ``option-no-index is passed``). The HTML pages use a + style sheet named ``style.css``. Such a file is distributed with coqdoc. +:|Latex| output: A single |Latex| file is created, on standard + output. It can be redirected to a file using the option ``-o``. The order of + files on the command line is kept in the final document. |Latex| + files given on the command line are copied ‘as is’ in the final + document . DVI and PostScript can be produced directly with the + options ``-dvi`` and ``-ps`` respectively. +:TEXmacs output: To translate the input files to TEXmacs format, + to be used by the TEXmacs |Coq| interface. + + + +Command line options +++++++++++++++++++++ + + +**Overall options** + + + :--HTML: Select a HTML output. + :--|Latex|: Select a |Latex| output. + :--dvi: Select a DVI output. + :--ps: Select a PostScript output. + :--texmacs: Select a TEXmacs output. + :--stdout: Write output to stdout. + :-o file, --output file: Redirect the output into the file ‘file’ + (meaningless with ``-html``). + :-d dir, --directory dir: Output files into directory ‘dir’ instead of + the current directory (option ``-d`` does not change the filename specified + with the option ``-o``, if any). + :--body-only: Suppress the header and trailer of the final document. + Thus, you can insert the resulting document into a larger one. + :-p string, --preamble string: Insert some material in the |Latex| + preamble, right before ``\begin{document}`` (meaningless with ``-html``). + :--vernac-file file,--tex-file file: Considers the file ‘file’ + respectively as a ``.v`` (or ``.g``) file or a ``.tex`` file. + :--files-from file: Read filenames to be processed from the file ‘file’ as if + they were given on the command line. Useful for program sources split + up into several directories. + :-q, --quiet: Be quiet. Do not print anything except errors. + :-h, --help: Give a short summary of the options and exit. + :-v, --version: Print the version and exit. + + + +**Index options** + + The default behavior is to build an index, for the HTML output only, + into ``index.html``. + + :--no-index: Do not output the index. + :--multi-index: Generate one page for each category and each letter in + the index, together with a top page ``index.html``. + :--index string: Make the filename of the index string instead of + “index”. Useful since “index.html” is special. + + + +**Table of contents option** + + :-toc, --table-of-contents: Insert a table of contents. For a |Latex| + output, it inserts a ``\tableofcontents`` at the beginning of the + document. For a HTML output, it builds a table of contents into + ``toc.html``. + :--toc-depth int: Only include headers up to depth ``int`` in the table of + contents. + + +**Hyperlink options** + + :--glob-from file: Make references using |Coq| globalizations from file + file. (Such globalizations are obtained with Coq option ``-dump-glob``). + :--no-externals: Do not insert links to the |Coq| standard library. + :--external url coqdir: Use given URL for linking references whose + name starts with prefix ``coqdir``. + :--coqlib url: Set base URL for the Coq standard library (default is + `<http://coq.inria.fr/library/>`_). This is equivalent to ``--external url + Coq``. + :-R dir coqdir: Recursively map physical directory dir to |Coq| logical + directory ``coqdir`` (similarly to |Coq| option ``-R``). + :-Q dir coqdir: Map physical directory dir to |Coq| logical + directory ``coqdir`` (similarly to |Coq| option ``-Q``). + + .. note:: + + options ``-R`` and ``-Q`` only have + effect on the files *following* them on the command line, so you will + probably need to put this option first. + + +**Title options** + + :-s , --short: Do not insert titles for the files. The default + behavior is to insert a title like “Library Foo” for each file. + :--lib-name string: Print “string Foo” instead of “Library Foo” in + titles. For example “Chapter” and “Module” are reasonable choices. + :--no-lib-name: Print just “Foo” instead of “Library Foo” in titles. + :--lib-subtitles: Look for library subtitles. When enabled, the + beginning of each file is checked for a comment of the form: + + :: + + (** * ModuleName : text *) + + where ``ModuleName`` must be the name of the file. If it is present, the + text is used as a subtitle for the module in appropriate places. + :-t string, --title string: Set the document title. + + +**Contents options** + + :-g, --gallina: Do not print proofs. + :-l, --light: Light mode. Suppress proofs (as with ``-g``) and the following commands: + + + [Recursive] Tactic Definition + + Hint / Hints + + Require + + Transparent / Opaque + + Implicit Argument / Implicits + + Section / Variable / Hypothesis / End + + + + The behavior of options ``-g`` and ``-l`` can be locally overridden using the + ``(* begin show *) … (* end show *)`` environment (see above). + + There are a few options that control the parsing of comments: + + :--parse-comments: Parse regular comments delimited by ``(*`` and ``*)`` as + well. They are typeset inline. + :--plain-comments: Do not interpret comments, simply copy them as + plain-text. + :--interpolate: Use the globalization information to typeset + identifiers appearing in |Coq| escapings inside comments. + +**Language options** + + + The default behavior is to assume ASCII 7 bit input files. + + :-latin1, --latin1: Select ISO-8859-1 input files. It is equivalent to + --inputenc latin1 --charset iso-8859-1. + :-utf8, --utf8: Set --inputenc utf8x for |Latex| output and--charset + utf-8 for HTML output. Also use Unicode replacements for a couple of + standard plain ASCII notations such as → for ``->`` and ∀ for ``forall``. |Latex| + UTF-8 support can be found + at `<http://www.ctan.org/pkg/unicode>`_. For the interpretation of Unicode + characters by |Latex|, extra packages which coqdoc does not provide + by default might be required, such as textgreek for some Greek letters + or ``stmaryrd`` for some mathematical symbols. If a Unicode character is + missing an interpretation in the utf8x input encoding, add + ``\DeclareUnicodeCharacter{code}{LATEX-interpretation}``. Packages + and declarations can be added with option ``-p``. + :--inputenc string: Give a |Latex| input encoding, as an option to |Latex| + package ``inputenc``. + :--charset string: Specify the HTML character set, to be inserted in + the HTML header. + + + +The coqdoc |Latex| style file +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In case you choose to produce a document without the default |Latex| +preamble (by using option ``--no-preamble``), then you must insert into +your own preamble the command + +:: + + \usepackage{coqdoc} + +The package optionally takes the argument ``[color]`` to typeset +identifiers with colors (this requires the ``xcolor`` package). + +Then you may alter the rendering of the document by redefining some +macros: + +:coqdockw, coqdocid, …: The one-argument macros for typesetting + keywords and identifiers. Defaults are sans-serif for keywords and + italic for identifiers.For example, if you would like a slanted font + for keywords, you may insert + + :: + + \renewcommand{\coqdockw}[1]{\textsl{#1}} + + + anywhere between ``\usepackage{coqdoc}`` and ``\begin{document}``. + + +:coqdocmodule: + One-argument macro for typesetting the title of a ``.v`` + file. Default is + + :: + + \newcommand{\coqdocmodule}[1]{\section*{Module #1}} + + and you may redefine it using ``\renewcommand``. diff --git a/doc/sphinx/using/tools/index.rst b/doc/sphinx/using/tools/index.rst index 4381c4d63d..dfe38dfce9 100644 --- a/doc/sphinx/using/tools/index.rst +++ b/doc/sphinx/using/tools/index.rst @@ -16,5 +16,6 @@ on the `Coq website <https://coq.inria.fr/user-interfaces.html>`_. ../../practical-tools/coq-commands ../../practical-tools/utilities + coqdoc ../../practical-tools/coqide ../../addendum/parallel-proof-processing diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 0f05237036..e64b4be454 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -528,13 +528,17 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> theories/Reals/Rdefinitions.v - theories/Reals/ConstructiveReals.v - theories/Reals/ConstructiveRealsMorphisms.v - theories/Reals/ConstructiveCauchyReals.v - theories/Reals/ConstructiveCauchyRealsMult.v + theories/Reals/Cauchy/ConstructiveCauchyReals.v + theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v + theories/Reals/Cauchy/ConstructiveCauchyAbs.v theories/Reals/ClassicalDedekindReals.v theories/Reals/Raxioms.v - theories/Reals/ConstructiveRealsLUB.v + theories/Reals/Abstract/ConstructiveReals.v + theories/Reals/Abstract/ConstructiveRealsMorphisms.v + theories/Reals/Abstract/ConstructiveLUB.v + theories/Reals/Abstract/ConstructiveAbs.v + theories/Reals/Abstract/ConstructiveLimits.v + theories/Reals/Abstract/ConstructiveSum.v theories/Reals/RIneq.v theories/Reals/DiscrR.v theories/Reals/ROrderedType.v @@ -579,7 +583,7 @@ through the <tt>Require Import</tt> command.</p> theories/Reals/Ranalysis5.v theories/Reals/Ranalysis_reg.v theories/Reals/Rcomplete.v - theories/Reals/ConstructiveRcomplete.v + theories/Reals/Cauchy/ConstructiveRcomplete.v theories/Reals/RiemannInt.v theories/Reals/RiemannInt_SF.v theories/Reals/Rpow_def.v diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index 7ae98f4cd2..4cde3809f0 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -110,6 +110,9 @@ Other command line arguments: * `-no-warn` suppresses printing of some warning messages +* `-no-update` puts updates to `fullGrammar` and `orderedGrammar` into new files named + `*.new`, leaving the originals unmodified. For use in Dune. + * `-short` limits processing to updating/verifying only the `fullGrammar` file * `-verbose` prints more messages about the grammar diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 88a5217652..60b845c4be 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -1125,10 +1125,6 @@ query_command: [ | WITH "SearchRewrite" constr_pattern in_or_out_modules | REPLACE "Search" searchabout_query searchabout_queries "." | WITH "Search" searchabout_query searchabout_queries -| REPLACE "SearchAbout" searchabout_query searchabout_queries "." -| WITH "SearchAbout" searchabout_query searchabout_queries -| REPLACE "SearchAbout" "[" LIST1 searchabout_query "]" in_or_out_modules "." -| WITH "SearchAbout" "[" LIST1 searchabout_query "]" in_or_out_modules ] vernac_toplevel: [ diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 0450aee2ec..eea1d5081d 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -32,6 +32,7 @@ type args = { fullGrammar : bool; check_tacs : bool; check_cmds : bool; + no_update: bool; show_warn : bool; verbose : bool; verify : bool; @@ -43,6 +44,7 @@ let default_args = { fullGrammar = false; check_tacs = false; check_cmds = false; + no_update = false; show_warn = true; verbose = false; verify = false; @@ -1574,7 +1576,7 @@ let reorder_grammar eg reordered_rules file = g_reorder eg !og.map !og.order -let finish_with_file old_file verify = +let finish_with_file old_file args = let files_eq f1 f2 = let chunksize = 8192 in (try @@ -1605,18 +1607,18 @@ let finish_with_file old_file verify = with Sys_error _ -> false) in - let temp_file = (old_file ^ "_temp") in + let temp_file = (old_file ^ ".new") in if !exit_code <> 0 then Sys.remove temp_file - else if verify then begin + else if args.verify then begin if not (files_eq old_file temp_file) then error "%s is not current\n" old_file; Sys.remove temp_file - end else + end else if not args.no_update then Sys.rename temp_file old_file let open_temp_bin file = - open_out_bin (sprintf "%s_temp" file) + open_out_bin (sprintf "%s.new" file) let match_cmd_regex = Str.regexp "[a-zA-Z0-9_ ]+" @@ -1829,7 +1831,7 @@ let process_rst g file args seen tac_prods cmd_prods = with End_of_file -> (); close_in old_rst; close_out new_rst; - finish_with_file file args.verify + finish_with_file file args let report_omitted_prods entries seen label split = let maybe_warn first last n = @@ -1877,7 +1879,7 @@ let process_grammar args = "DOC_GRAMMAR"; print_in_order out g `MLG !g.order StringSet.empty; close_out out; - finish_with_file (dir "fullGrammar") args.verify; + finish_with_file (dir "fullGrammar") args; if args.verbose then print_special_tokens g; @@ -1896,7 +1898,7 @@ let process_grammar args = "DOC_GRAMMAR"; print_in_order out g `MLG !g.order StringSet.empty; close_out out; - finish_with_file (dir "editedGrammar") args.verify; + finish_with_file (dir "editedGrammar") args; report_bad_nts g "editedGrammar" end; @@ -1911,11 +1913,13 @@ let process_grammar args = reorder_grammar g ordered_grammar "orderedGrammar"; print_in_order out g `MLG !g.order StringSet.empty; close_out out; - finish_with_file (dir "orderedGrammar") args.verify; + finish_with_file (dir "orderedGrammar") args; check_singletons g (* print_dominated g*) end; + let seen = ref { nts=NTMap.empty; tacs=NTMap.empty; tacvs=NTMap.empty; cmds=NTMap.empty; cmdvs=NTMap.empty } in + let args = { args with no_update = false } in (* always update rsts in place for now *) if !exit_code = 0 then begin let plist nt = let list = (List.map (fun t -> String.trim (prod_to_prodn t)) @@ -1923,17 +1927,20 @@ let process_grammar args = list, StringSet.of_list list in let tac_list, tac_prods = plist "simple_tactic" in let cmd_list, cmd_prods = plist "command" in - let seen = ref { nts=NTMap.empty; tacs=NTMap.empty; tacvs=NTMap.empty; cmds=NTMap.empty; cmdvs=NTMap.empty } in List.iter (fun file -> process_rst g file args seen tac_prods cmd_prods) args.rst_files; report_omitted_prods !g.order !seen.nts "Nonterminal" ""; let out = open_out (dir "updated_rsts") in close_out out; + end; + (* if args.check_tacs then report_omitted_prods tac_list !seen.tacs "Tactic" "\n "; if args.check_cmds then report_omitted_prods cmd_list !seen.cmds "Command" "\n "; *) + + if !exit_code = 0 then begin (* generate report on cmds or tacs *) let cmdReport outfile cmdStr cmd_nts cmds cmdvs = let rstCmds = StringSet.of_list (List.map (fun b -> let c, _ = b in c) (NTMap.bindings cmds)) in @@ -1942,7 +1949,7 @@ let process_grammar args = StringSet.union set (StringSet.of_list (List.map (fun p -> String.trim (prod_to_prodn p)) (NTMap.find nt !prodn_gram.map))) ) StringSet.empty cmd_nts in let allCmds = StringSet.union rstCmdvs (StringSet.union rstCmds gramCmds) in - let out = open_out_bin (dir outfile) in + let out = open_temp_bin (dir outfile) in StringSet.iter (fun c -> let rsts = StringSet.mem c rstCmds in let gram = StringSet.mem c gramCmds in @@ -1956,6 +1963,7 @@ let process_grammar args = fprintf out "%s%s %s\n" pfx var c) allCmds; close_out out; + finish_with_file (dir outfile) args; Printf.printf "# %s in rsts, gram, total = %d %d %d\n" cmdStr (StringSet.cardinal gramCmds) (StringSet.cardinal rstCmds) (StringSet.cardinal allCmds); in @@ -1973,7 +1981,7 @@ let process_grammar args = let out = open_temp_bin (dir "prodnGrammar") in print_in_order out prodn_gram `PRODN !prodn_gram.order StringSet.empty; close_out out; - finish_with_file (dir "prodnGrammar") args.verify + finish_with_file (dir "prodnGrammar") args end end @@ -1985,6 +1993,7 @@ let parse_args () = | "-check-cmds" -> { args with check_cmds = true } | "-check-tacs" -> { args with check_tacs = true } | "-no-warn" -> show_warn := false; { args with show_warn = true } + | "-no-update" -> { args with no_update = true } | "-short" -> { args with fullGrammar = true } | "-verbose" -> { args with verbose = true } | "-verify" -> { args with verify = true } diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index 3afa21f2cf..a533a6d367 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -5,26 +5,44 @@ (env (_ (binaries doc_grammar.exe))) (rule - (targets fullGrammar) + (alias check-gram) (deps - ; Main grammar - (glob_files %{project_root}/parsing/*.mlg) - (glob_files %{project_root}/toplevel/*.mlg) - (glob_files %{project_root}/vernac/*.mlg) - ; All plugins except SSReflect for now (mimicking what is done in Makefile.doc) - (glob_files %{project_root}/plugins/btauto/*.mlg) - (glob_files %{project_root}/plugins/cc/*.mlg) - (glob_files %{project_root}/plugins/derive/*.mlg) - (glob_files %{project_root}/plugins/extraction/*.mlg) - (glob_files %{project_root}/plugins/firstorder/*.mlg) - (glob_files %{project_root}/plugins/funind/*.mlg) - (glob_files %{project_root}/plugins/ltac/*.mlg) - (glob_files %{project_root}/plugins/micromega/*.mlg) - (glob_files %{project_root}/plugins/nsatz/*.mlg) - (glob_files %{project_root}/plugins/omega/*.mlg) - (glob_files %{project_root}/plugins/rtauto/*.mlg) - (glob_files %{project_root}/plugins/setoid_ring/*.mlg) - (glob_files %{project_root}/plugins/syntax/*.mlg)) + (:input + ; Main grammar + (glob_files %{project_root}/parsing/*.mlg) + (glob_files %{project_root}/toplevel/*.mlg) + (glob_files %{project_root}/vernac/*.mlg) + ; All plugins except SSReflect and Ltac2 for now (mimicking what is done in Makefile.doc) + (glob_files %{project_root}/plugins/btauto/*.mlg) + (glob_files %{project_root}/plugins/cc/*.mlg) + (glob_files %{project_root}/plugins/derive/*.mlg) + (glob_files %{project_root}/plugins/extraction/*.mlg) + (glob_files %{project_root}/plugins/firstorder/*.mlg) + (glob_files %{project_root}/plugins/funind/*.mlg) + (glob_files %{project_root}/plugins/ltac/*.mlg) + (glob_files %{project_root}/plugins/micromega/*.mlg) + (glob_files %{project_root}/plugins/nsatz/*.mlg) + (glob_files %{project_root}/plugins/omega/*.mlg) + (glob_files %{project_root}/plugins/rtauto/*.mlg) + (glob_files %{project_root}/plugins/setoid_ring/*.mlg) + (glob_files %{project_root}/plugins/syntax/*.mlg) + ; Sphinx files + (glob_files %{project_root}/doc/sphinx/language/*.rst) + (glob_files %{project_root}/doc/sphinx/proof-engine/*.rst) + (glob_files %{project_root}/doc/sphinx/user-extensions/*.rst) + (glob_files %{project_root}/doc/sphinx/practical-tools/*.rst) + (glob_files %{project_root}/doc/sphinx/addendum/*.rst) + (glob_files %{project_root}/doc/sphinx/language/core/*.rst) + (glob_files %{project_root}/doc/sphinx/language/extensions/*.rst) + (glob_files %{project_root}/doc/sphinx/proofs/writing-proofs/*.rst) + (glob_files %{project_root}/doc/sphinx/proofs/automatic-tactics/*.rst) + (glob_files %{project_root}/doc/sphinx/proofs/creating-tactics/*.rst) + (glob_files %{project_root}/doc/sphinx/using/libraries/*.rst) + (glob_files %{project_root}/doc/sphinx/using/tools/*.rst)) + common.edit_mlg + orderedGrammar) (action - (chdir %{project_root} (run doc_grammar -short -no-warn %{deps}))) - (mode promote)) + (progn + (chdir %{project_root} (run doc_grammar -check-cmds -no-update %{input})) + (diff? fullGrammar fullGrammar.new) + (diff? orderedGrammar orderedGrammar.new)))) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 241cf48cf1..272d17bb35 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -1244,8 +1244,6 @@ query_command: [ | "SearchPattern" constr_pattern in_or_out_modules "." | "SearchRewrite" constr_pattern in_or_out_modules "." | "Search" searchabout_query searchabout_queries "." -| "SearchAbout" searchabout_query searchabout_queries "." -| "SearchAbout" "[" LIST1 searchabout_query "]" in_or_out_modules "." ] printable: [ @@ -2454,8 +2452,6 @@ as_or_and_ipat: [ eqn_ipat: [ | "eqn" ":" naming_intropattern -| "_eqn" ":" naming_intropattern -| "_eqn" | ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index 38e7b781df..0c9d7a853b 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -918,8 +918,6 @@ command: [ | "SearchPattern" one_term OPT ne_in_or_out_modules | "SearchRewrite" one_term OPT ne_in_or_out_modules | "Search" searchabout_query OPT searchabout_queries -| "SearchAbout" searchabout_query OPT searchabout_queries -| "SearchAbout" "[" LIST1 searchabout_query "]" OPT ne_in_or_out_modules | "Time" command | "Redirect" string command | "Timeout" num command @@ -1441,8 +1439,6 @@ as_or_and_ipat: [ eqn_ipat: [ | "eqn" ":" naming_intropattern -| "_eqn" ":" naming_intropattern -| "_eqn" ] as_name: [ diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index 0024d70466..d6951fff6d 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -8,8 +8,6 @@ open Util (* Functorial interface *) -module type GLexerType = Plexing.Lexer - type norec type mayrec @@ -20,6 +18,7 @@ module type S = sig module Parsable : sig type t val make : ?loc:Loc.t -> char Stream.t -> t + val comments : t -> ((int * int) * string) list end val tokens : string -> (string option * int) list @@ -27,6 +26,7 @@ module type S = sig module Entry : sig type 'a t val make : string -> 'a t + val create : string -> 'a t val parse : 'a t -> Parsable.t -> 'a val name : 'a t -> string val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a t @@ -51,7 +51,7 @@ module type S = sig val self : ('self, mayrec, 'self) t val next : ('self, mayrec, 'self) t val token : 'c pattern -> ('self, norec, 'c) t - val rules : warning:(string -> unit) option -> 'a Rules.t list -> ('self, norec, 'a) t + val rules : 'a Rules.t list -> ('self, norec, 'a) t end and Rule : sig @@ -77,21 +77,39 @@ module type S = sig val make : ('a, _, 'f, Loc.t -> 'a) Rule.t -> 'f -> 'a t end - module Unsafe : - sig + type 'a single_extend_statement = + string option * Gramext.g_assoc option * 'a Production.t list + + type 'a extend_statement = + { pos : Gramext.position option + ; data : 'a single_extend_statement list + } + + val generalize_symbol : ('a, 'tr, 'c) Symbol.t -> ('a, norec, 'c) Symbol.t option + + val mk_rule : 'a pattern list -> string Rules.t + + (* Used in custom entries, should tweak? *) + val level_of_nonterm : ('a, norec, 'c) Symbol.t -> string option + +end + +module type ExtS = sig + + include S + + val safe_extend : 'a Entry.t -> 'a extend_statement -> unit + val safe_delete_rule : 'a Entry.t -> 'a Production.t -> unit + + module Unsafe : sig val clear_entry : 'a Entry.t -> unit end - val safe_extend : warning:(string -> unit) option -> - 'a Entry.t -> Gramext.position option -> - (string option * Gramext.g_assoc option * 'a Production.t list) - list -> - unit - val safe_delete_rule : 'a Entry.t -> ('a, _, 'f, 'r) Rule.t -> unit + end (* Implementation *) -module GMake (L : GLexerType) = struct +module GMake (L : Plexing.S) = struct type te = L.te type 'c pattern = 'c L.pattern @@ -324,7 +342,7 @@ let and_and_tree (type s tr' trt tr trn trs trb f) (ar : (tr', trt, tr) ty_and_r | MayRec2, _, MayRec -> MayRec2 | MayRec2, _, NoRec -> MayRec2 | NoRec2, NoRec3, NoRec -> NoRec2 -let insert_tree (type s trs trt tr p k a) ~warning entry_name (ar : (trs, trt, tr) ty_and_ex) (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, tr, a) ty_tree = +let insert_tree (type s trs trt tr p k a) entry_name (ar : (trs, trt, tr) ty_and_ex) (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, tr, a) ty_tree = let rec insert : type trs trt tr p f k. (trs, trt, tr) ty_and_ex -> (s, trs, p) ty_symbols -> (p, k, f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree = fun ar symbols pf tree action -> match symbols, pf with @@ -338,15 +356,15 @@ let insert_tree (type s trs trt tr p k a) ~warning entry_name (ar : (trs, trt, t | NR10, Node (_, n) -> Node (MayRec3, node n) | NR11, Node (NoRec3, n) -> Node (NoRec3, node n) | NR11, LocAct (old_action, action_list) -> - begin match warning with - | None -> () - | Some warn_fn -> + (* What to do about this warning? For now it is disabled *) + if false then + begin let msg = "<W> Grammar extension: " ^ (if entry_name = "" then "" else "in ["^entry_name^"%s], ") ^ "some rule has been masked" in - warn_fn msg - end; + Feedback.msg_warning (Pp.str msg) + end; LocAct (action, old_action :: action_list) | NR11, DeadEnd -> LocAct (action, []) and insert_in_tree : type trs trs' trs'' trt tr a p f k. (trs'', trt, tr) ty_and_ex -> (trs, trs', trs'') ty_and_rec -> (s, trs, a) ty_symbol -> (s, trs', p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree = @@ -405,14 +423,14 @@ let insert_tree (type s trs trt tr p k a) ~warning entry_name (ar : (trs, trt, t in insert ar gsymbols pf tree action -let insert_tree_norec (type s p k a) ~warning entry_name (gsymbols : (s, norec, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, norec, a) ty_tree) : (s, norec, a) ty_tree = - insert_tree ~warning entry_name NR11 gsymbols pf action tree +let insert_tree_norec (type s p k a) entry_name (gsymbols : (s, norec, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, norec, a) ty_tree) : (s, norec, a) ty_tree = + insert_tree entry_name NR11 gsymbols pf action tree -let insert_tree (type s trs trt p k a) ~warning entry_name (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, a) ty_mayrec_tree = +let insert_tree (type s trs trt p k a) entry_name (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, a) ty_mayrec_tree = let MayRecNR ar = and_symbols_tree gsymbols tree in - MayRecTree (insert_tree ~warning entry_name ar gsymbols pf action tree) + MayRecTree (insert_tree entry_name ar gsymbols pf action tree) -let srules (type self a) ~warning (rl : a ty_rules list) : (self, norec, a) ty_symbol = +let srules (type self a) (rl : a ty_rules list) : (self, norec, a) ty_symbol = let rec retype_tree : type s a. (s, norec, a) ty_tree -> (self, norec, a) ty_tree = function | Node (NoRec3, {node = s; son = son; brother = bro}) -> @@ -439,7 +457,7 @@ let srules (type self a) ~warning (rl : a ty_rules list) : (self, norec, a) ty_s (fun tree (TRules (symbols, action)) -> let symbols = retype_rule symbols in let AnyS (symbols, pf) = get_symbols symbols in - insert_tree_norec ~warning "" symbols pf action tree) + insert_tree_norec "" symbols pf action tree) DeadEnd rl in Stree t @@ -449,19 +467,19 @@ let is_level_labelled n (Level lev) = Some n1 -> n = n1 | None -> false -let insert_level (type s tr p k) ~warning entry_name (symbols : (s, tr, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = +let insert_level (type s tr p k) entry_name (symbols : (s, tr, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = match symbols with | TCns (_, Sself, symbols) -> let Level slev = slev in let RelS pf = pf in - let MayRecTree lsuffix = insert_tree ~warning entry_name symbols pf action slev.lsuffix in + let MayRecTree lsuffix = insert_tree entry_name symbols pf action slev.lsuffix in Level {assoc = slev.assoc; lname = slev.lname; lsuffix = lsuffix; lprefix = slev.lprefix} | _ -> let Level slev = slev in - let MayRecTree lprefix = insert_tree ~warning entry_name symbols pf action slev.lprefix in + let MayRecTree lprefix = insert_tree entry_name symbols pf action slev.lprefix in Level {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; lprefix = lprefix} @@ -475,34 +493,27 @@ let empty_lev lname assoc = Level {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} -let change_lev ~warning (Level lev) n lname assoc = +let change_lev (Level lev) n lname assoc = let a = match assoc with None -> lev.assoc | Some a -> if a <> lev.assoc then - begin - match warning with - | None -> () - | Some warn_fn -> - warn_fn ("<W> Changing associativity of level \""^n^"\"") - end; - a + Feedback.msg_warning (Pp.str ("<W> Changing associativity of level \""^n^"\"")); + a in - begin match lname with - Some n -> - if lname <> lev.lname then - begin match warning with - | None -> () - | Some warn_fn -> - warn_fn ("<W> Level label \""^n^"\" ignored") - end; - | None -> () + begin + match lname with + | Some n -> + (* warning disabled; it was in the past *) + if false && lname <> lev.lname then + Feedback.msg_warning (Pp.str ("<W> Level label \""^n^"\" ignored")) + | None -> () end; Level {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix} -let get_level ~warning entry position levs = +let get_level entry position levs = match position with Some First -> [], empty_lev, levs | Some Last -> levs, empty_lev, [] @@ -515,7 +526,7 @@ let get_level ~warning entry position levs = flush stderr; failwith "Grammar.extend" | lev :: levs -> - if is_level_labelled n lev then [], change_lev ~warning lev n, levs + if is_level_labelled n lev then [], change_lev lev n, levs else let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 in @@ -550,7 +561,7 @@ let get_level ~warning entry position levs = get levs | None -> match levs with - lev :: levs -> [], change_lev ~warning lev "<top>", levs + lev :: levs -> [], change_lev lev "<top>", levs | [] -> [], empty_lev, [] let change_to_self0 (type s) (type trec) (type a) (entry : s ty_entry) : (s, trec, a) ty_symbol -> (s, a) ty_mayrec_symbol = @@ -600,7 +611,7 @@ let insert_tokens gram symbols = in linsert symbols -let levels_of_rules ~warning entry position rules = +let levels_of_rules entry position rules = let elev = match entry.edesc with Dlevels elev -> elev @@ -612,7 +623,7 @@ let levels_of_rules ~warning entry position rules = match rules with | [] -> elev | _ -> - let (levs1, make_lev, levs2) = get_level ~warning entry position elev in + let (levs1, make_lev, levs2) = get_level entry position elev in let (levs, _) = List.fold_left (fun (levs, make_lev) (lname, assoc, level) -> @@ -623,7 +634,7 @@ let levels_of_rules ~warning entry position rules = let MayRecRule symbols = change_to_self entry symbols in let AnyS (symbols, pf) = get_symbols symbols in insert_tokens egram symbols; - insert_level ~warning entry.ename symbols pf action lev) + insert_level entry.ename symbols pf action lev) lev level in lev :: levs, empty_lev) @@ -1479,8 +1490,8 @@ let init_entry_functions entry = let f = continue_parser_of_entry entry in entry.econtinue <- f; f lev bp a strm) -let extend_entry ~warning entry position rules = - let elev = levels_of_rules ~warning entry position rules in +let extend_entry entry position rules = + let elev = levels_of_rules entry position rules in entry.edesc <- Dlevels elev; init_entry_functions entry (* Deleting a rule *) @@ -1508,7 +1519,7 @@ module Parsable = struct { pa_chr_strm : char Stream.t ; pa_tok_strm : L.te Stream.t ; pa_loc_func : Plexing.location_function - } + ; lexer_state : L.State.t ref } let parse_parsable entry p = let efun = entry.estart 0 in @@ -1544,9 +1555,26 @@ module Parsable = struct let loc = Stream.count cs, Stream.count cs + 1 in restore (); Ploc.raise (Ploc.make_unlined loc) exc + let parse_parsable e p = + L.State.set !(p.lexer_state); + try + let c = parse_parsable e p in + p.lexer_state := L.State.get (); + c + with Ploc.Exc (loc,e) -> + L.State.drop (); + let loc' = Loc.get_loc (Exninfo.info e) in + let loc = match loc' with None -> loc | Some loc -> loc in + Loc.raise ~loc e + let make ?loc cs = + let lexer_state = ref (L.State.init ()) in + L.State.set !lexer_state; let (ts, lf) = L.tok_func ?loc cs in - {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} + lexer_state := L.State.get (); + {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf; lexer_state} + + let comments p = L.State.get_comments !(p.lexer_state) end @@ -1557,6 +1585,7 @@ module Entry = struct econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); edesc = Dlevels []} + let create = make let parse (e : 'a t) p : 'a = Parsable.parse_parsable e p let parse_token_stream (e : 'a t) ts : 'a = @@ -1589,7 +1618,7 @@ module rec Symbol : sig val self : ('self, mayrec, 'self) t val next : ('self, mayrec, 'self) t val token : 'c pattern -> ('self, norec, 'c) t - val rules : warning:(string -> unit) option -> 'a Rules.t list -> ('self, norec, 'a) t + val rules : 'a Rules.t list -> ('self, norec, 'a) t end = struct @@ -1604,7 +1633,7 @@ end = struct let self = Sself let next = Snext let token tok = Stoken tok - let rules ~warning (t : 'a Rules.t list) = srules ~warning t + let rules (t : 'a Rules.t list) = srules t end and Rule : sig @@ -1656,14 +1685,87 @@ module Unsafe = struct end -let safe_extend ~warning (e : 'a Entry.t) pos - (r : - (string option * Gramext.g_assoc option * 'a ty_production list) - list) = - extend_entry ~warning e pos r +type 'a single_extend_statement = + string option * Gramext.g_assoc option * 'a ty_production list + +type 'a extend_statement = + { pos : Gramext.position option + ; data : 'a single_extend_statement list + } -let safe_delete_rule e r = +let safe_extend (e : 'a Entry.t) { pos; data } = + extend_entry e pos data + +let safe_delete_rule e (TProd (r,_act)) = let AnyS (symbols, _) = get_symbols r in delete_rule e symbols +let level_of_nonterm sym = match sym with + | Snterml (_,l) -> Some l + | _ -> None + +exception SelfSymbol + +let rec generalize_symbol : + type a tr s. (s, tr, a) Symbol.t -> (s, norec, a) ty_symbol = + function + | Stoken tok -> + Stoken tok + | Slist1 e -> + Slist1 (generalize_symbol e) + | Slist1sep (e, sep, b) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + Slist1sep (e, sep, b) + | Slist0 e -> + Slist0 (generalize_symbol e) + | Slist0sep (e, sep, b) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + Slist0sep (e, sep, b) + | Sopt e -> + Sopt (generalize_symbol e) + | Sself -> + raise SelfSymbol + | Snext -> + raise SelfSymbol + | Snterm e -> + Snterm e + | Snterml (e, l) -> + Snterml (e, l) + | Stree r -> + Stree (generalize_tree r) +and generalize_tree : type a tr s . + (s, tr, a) ty_tree -> (s, norec, a) ty_tree = fun r -> + match r with + | Node (fi, n) -> + let fi = match fi with + | NoRec3 -> NoRec3 + | MayRec3 -> raise SelfSymbol + in + let n = match n with + | { node; son; brother } -> + let node = generalize_symbol node in + let son = generalize_tree son in + let brother = generalize_tree brother in + { node; son; brother } + in + Node (fi, n) + | LocAct _ as r -> r + | DeadEnd as r -> r + +let generalize_symbol s = + try Some (generalize_symbol s) + with SelfSymbol -> None + +let rec mk_rule tok = + match tok with + | [] -> + let stop_e = Rule.stop in + TRules (stop_e, fun _ -> (* dropped anyway: *) "") + | tkn :: rem -> + let TRules (r, f) = mk_rule rem in + let r = Rule.next_norec r (Symbol.token tkn) in + TRules (r, fun _ -> f) + end diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index f0423a92af..33006f6f65 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -15,8 +15,7 @@ rule "an entry cannot call an entry of another grammar" by normal OCaml typing. *) -module type GLexerType = Plexing.Lexer - (** The input signature for the functor [Grammar.GMake]: [te] is the +(** The input signature for the functor [Grammar.GMake]: [te] is the type of the tokens. *) type norec @@ -29,6 +28,7 @@ module type S = sig module Parsable : sig type t val make : ?loc:Loc.t -> char Stream.t -> t + val comments : t -> ((int * int) * string) list end val tokens : string -> (string option * int) list @@ -36,6 +36,7 @@ module type S = sig module Entry : sig type 'a t val make : string -> 'a t + val create : string -> 'a t (* compat *) val parse : 'a t -> Parsable.t -> 'a val name : 'a t -> string val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a t @@ -60,7 +61,7 @@ module type S = sig val self : ('self, mayrec, 'self) t val next : ('self, mayrec, 'self) t val token : 'c pattern -> ('self, norec, 'c) t - val rules : warning:(string -> unit) option -> 'a Rules.t list -> ('self, norec, 'a) t + val rules : 'a Rules.t list -> ('self, norec, 'a) t end and Rule : sig @@ -86,17 +87,37 @@ module type S = sig val make : ('a, _, 'f, Loc.t -> 'a) Rule.t -> 'f -> 'a t end - module Unsafe : - sig + type 'a single_extend_statement = + string option * Gramext.g_assoc option * 'a Production.t list + + type 'a extend_statement = + { pos : Gramext.position option + ; data : 'a single_extend_statement list + } + + val generalize_symbol : ('a, 'tr, 'c) Symbol.t -> ('a, norec, 'c) Symbol.t option + + val mk_rule : 'a pattern list -> string Rules.t + + (* Used in custom entries, should tweak? *) + val level_of_nonterm : ('a, norec, 'c) Symbol.t -> string option + +end + +(* Interface private to clients *) +module type ExtS = sig + + include S + + val safe_extend : 'a Entry.t -> 'a extend_statement -> unit + val safe_delete_rule : 'a Entry.t -> 'a Production.t -> unit + + module Unsafe : sig val clear_entry : 'a Entry.t -> unit end - val safe_extend : warning:(string -> unit) option -> - 'a Entry.t -> Gramext.position option -> - (string option * Gramext.g_assoc option * 'a Production.t list) - list -> - unit - val safe_delete_rule : 'a Entry.t -> ('a, _, 'f, 'r) Rule.t -> unit + end + (** Signature type of the functor [Grammar.GMake]. The types and functions are almost the same than in generic interface, but: - Grammars are not values. Functions holding a grammar as parameter @@ -107,5 +128,4 @@ end type (instead of (string * string)); the module parameter must specify a way to show them as (string * string) *) -module GMake (L : GLexerType) : - S with type te = L.te and type 'c pattern = 'c L.pattern +module GMake (L : Plexing.S) : ExtS with type te = L.te and type 'c pattern = 'c L.pattern diff --git a/gramlib/plexing.ml b/gramlib/plexing.ml index e881ab3350..ce3e38ff08 100644 --- a/gramlib/plexing.ml +++ b/gramlib/plexing.ml @@ -5,7 +5,7 @@ type location_function = int -> Loc.t type 'te lexer_func = ?loc:Loc.t -> char Stream.t -> 'te Stream.t * location_function -module type Lexer = sig +module type S = sig type te type 'c pattern val tok_pattern_eq : 'a pattern -> 'b pattern -> ('a, 'b) Util.eq option @@ -15,4 +15,15 @@ module type Lexer = sig val tok_removing : 'c pattern -> unit val tok_match : 'c pattern -> te -> 'c val tok_text : 'c pattern -> string + + (* State for the comments, at some point we should make it functional *) + module State : sig + type t + val init : unit -> t + val set : t -> unit + val get : unit -> t + val drop : unit -> unit + val get_comments : t -> ((int * int) * string) list + end + end diff --git a/gramlib/plexing.mli b/gramlib/plexing.mli index 521eba7446..0c190af635 100644 --- a/gramlib/plexing.mli +++ b/gramlib/plexing.mli @@ -15,7 +15,7 @@ and location_function = int -> Loc.t (** The type of a function giving the location of a token in the source from the token number in the stream (starting from zero). *) -module type Lexer = sig +module type S = sig type te type 'c pattern val tok_pattern_eq : 'a pattern -> 'b pattern -> ('a, 'b) Util.eq option @@ -25,4 +25,15 @@ module type Lexer = sig val tok_removing : 'c pattern -> unit val tok_match : 'c pattern -> te -> 'c val tok_text : 'c pattern -> string + + (* State for the comments, at some point we should make it functional *) + module State : sig + type t + val init : unit -> t + val set : t -> unit + val get : unit -> t + val drop : unit -> unit + val get_comments : t -> ((int * int) * string) list + end + end diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index c5883cef0d..711986c2b2 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -207,7 +207,6 @@ let state_preserving = [ "Recursive Extraction Library"; "Search"; - "SearchAbout (* deprecated *)"; "SearchHead"; "SearchPattern"; "SearchRewrite"; diff --git a/ide/microPG.ml b/ide/microPG.ml index 46d3316ef6..5a4871b70a 100644 --- a/ide/microPG.ml +++ b/ide/microPG.ml @@ -289,7 +289,6 @@ let pg = insert pg "Proof General" [mC,_c,"c"; mC,_a,"a"] [ mkE _p "p" "Print" (Callback (fun gui -> command gui "Print")); mkE _c "c" "Check" (Callback (fun gui -> command gui "Check")); mkE _b "b" "About" (Callback (fun gui -> command gui "About")); - mkE _a "a" "Search About" (Callback (fun gui -> command gui "SearchAbout")); mkE _o "o" "Search Pattern" (Callback (fun gui->command gui "SearchPattern")); mkE _l "l" "Locate" (Callback (fun gui -> command gui "Locate")); mkE _Return "RET" "match template" (Action("Templates","match")); diff --git a/interp/constrintern.ml b/interp/constrintern.ml index a071ba7ec9..905d9f1e5b 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -48,7 +48,7 @@ open NumTok types and recursive definitions and of projection names in records *) type var_internalization_type = - | Inductive of Id.t list (* list of params *) * bool (* true = check for possible capture *) + | Inductive | Recursive | Method | Variable @@ -57,9 +57,6 @@ type var_internalization_data = (* type of the "free" variable, for coqdoc, e.g. while typing the constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) var_internalization_type * - (* impargs to automatically add to the variable, e.g. for "JMeq A a B b" - in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) - Id.t list * (* signature of impargs of the variable *) Impargs.implicit_status list * (* subscopes of the args of the variable *) @@ -180,20 +177,9 @@ let parsing_explicit = ref false let empty_internalization_env = Id.Map.empty -let compute_explicitable_implicit imps = function - | Inductive (params,_) -> - (* In inductive types, the parameters are fixed implicit arguments *) - let sub_impl,_ = List.chop (List.length params) imps in - let sub_impl' = List.filter is_status_implicit sub_impl in - List.map name_of_implicit sub_impl' - | Recursive | Method | Variable -> - (* Unable to know in advance what the implicit arguments will be *) - [] - let compute_internalization_data env sigma ty typ impl = let impl = compute_implicits_with_manual env sigma typ (is_implicit_args()) impl in - let expls_impl = compute_explicitable_implicit impl ty in - (ty, expls_impl, impl, compute_arguments_scope sigma typ) + (ty, impl, compute_arguments_scope sigma typ) let compute_internalization_env env sigma ?(impls=empty_internalization_env) ty = List.fold_left3 @@ -355,7 +341,7 @@ let impls_binder_list = let impls_type_list n ?(args = []) = let rec aux acc n c = match DAst.get c with | GProd (na,bk,_,c) -> aux (build_impls n bk na acc) (n+1) c - | _ -> (Variable,[],List.rev acc,[]) + | _ -> (Variable,List.rev acc,[]) in aux args n let impls_term_list n ?(args = []) = @@ -365,7 +351,7 @@ let impls_term_list n ?(args = []) = let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in let n,acc' = List.fold_left (fun (n,acc) (na, bk, _, _) -> (n+1,build_impls n bk na acc)) (n,acc) args.(nb) in aux acc' n bds.(nb) - |_ -> (Variable,[],List.rev acc,[]) + |_ -> (Variable,List.rev acc,[]) in aux args n (* Check if in binder "(x1 x2 .. xn : t)", none of x1 .. xn-1 occurs in t *) @@ -429,20 +415,6 @@ let locate_if_hole ?loc na c = match DAst.get c with with Not_found -> DAst.make ?loc @@ GHole (Evar_kinds.BinderType na, naming, arg)) | _ -> c -let reset_hidden_inductive_implicit_test env = - { env with impls = Id.Map.map (function - | (Inductive (params,_),b,c,d) -> (Inductive (params,false),b,c,d) - | x -> x) env.impls } - -let check_hidden_implicit_parameters ?loc id impls = - if Id.Map.exists (fun _ -> function - | (Inductive (indparams,check),_,_,_) when check -> Id.List.mem id indparams - | _ -> false) impls - then - user_err ?loc (Id.print id ++ strbrk " is already used as name of " ++ - strbrk "a parameter of the inductive type; bound variables in " ++ - strbrk "the type of a constructor shall use a different name.") - let pure_push_name_env (id,implargs) env = {env with ids = Id.Set.add id env.ids; @@ -456,7 +428,6 @@ let push_name_env ntnvars implargs env = | { loc; v = Anonymous } -> env | { loc; v = Name id } -> - check_hidden_implicit_parameters ?loc id env.impls ; if Id.Map.is_empty ntnvars && Id.equal id ldots_var then error_ldots_var ?loc; set_var_scope ?loc id false (env.tmp_scope,env.scopes) ntnvars; @@ -492,7 +463,7 @@ let intern_generalized_binder intern_type ntnvars let ty' = intern_type {env with ids = ids; unb = true} ty in let fvs = Implicit_quantifiers.generalizable_vars_of_glob_constr ~bound:ids ~allowed:ids' ty' in let env' = List.fold_left - (fun env {loc;v=x} -> push_name_env ntnvars (Variable,[],[],[])(*?*) env (make ?loc @@ Name x)) + (fun env {loc;v=x} -> push_name_env ntnvars (Variable,[],[])(*?*) env (make ?loc @@ Name x)) env fvs in let b' = check_implicit_meaningful ?loc b' env in let bl = List.map @@ -559,7 +530,7 @@ let intern_cases_pattern_as_binder ?loc ntnvars env p = user_err ?loc (str "Unsupported nested \"as\" clause."); il,disjpat in - let env = List.fold_right (fun {loc;v=id} env -> push_name_env ntnvars (Variable,[],[],[]) env (make ?loc @@ Name id)) il env in + let env = List.fold_right (fun {loc;v=id} env -> push_name_env ntnvars (Variable,[],[]) env (make ?loc @@ Name id)) il env in let na = alias_of_pat (List.hd disjpat) in let ienv = Name.fold_right Id.Set.remove na env.ids in let id = Namegen.next_name_away_with_default "pat" na ienv in @@ -615,7 +586,7 @@ let intern_generalization intern env ntnvars loc bk ak c = GLambda (Name id, bk, DAst.make ?loc:loc' @@ GHole (Evar_kinds.BinderType (Name id), IntroAnonymous, None), acc)) in List.fold_right (fun ({loc;v=id} as lid) (env, acc) -> - let env' = push_name_env ntnvars (Variable,[],[],[]) env CAst.(make @@ Name id) in + let env' = push_name_env ntnvars (Variable,[],[]) env CAst.(make @@ Name id) in (env', abs lid acc)) fvs (env,c) in c' @@ -706,7 +677,7 @@ let traverse_binder intern_pat ntnvars (terms,_,binders,_ as subst) avoid (renam if onlyident then (* Do not try to interpret a variable as a constructor *) let na = out_patvar pat in - let env = push_name_env ntnvars (Variable,[],[],[]) env (make ?loc:pat.loc na) in + let env = push_name_env ntnvars (Variable,[],[]) env (make ?loc:pat.loc na) in (renaming,env), None, na else (* Interpret as a pattern *) @@ -909,9 +880,6 @@ let instantiate_notation_constr loc intern intern_pat ntnvars subst infos c = try let pat,(onlyident,scopes) = Id.Map.find id binders in let env = set_env_scopes env scopes in - (* We deactivate impls to avoid the check on hidden parameters *) - (* and since we are only interested in the pattern as a term *) - let env = reset_hidden_inductive_implicit_test env in if onlyident then term_of_name (out_patvar pat) else @@ -1015,7 +983,7 @@ let intern_notation intern env ntnvars loc ntn fullargs = (* Discriminating between bound variables and global references *) let string_of_ty = function - | Inductive _ -> "ind" + | Inductive -> "ind" | Recursive -> "def" | Method -> "meth" | Variable -> "var" @@ -1031,27 +999,25 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = if Id.Map.mem id ntnvars then begin if not (Id.Map.mem id env.impls) then set_var_scope ?loc id true (env.tmp_scope,env.scopes) ntnvars; - gvar (loc,id) us, [], [], [] + gvar (loc,id) us, [], [] end else (* Is [id] registered with implicit arguments *) try - let ty,expl_impls,impls,argsc = Id.Map.find id env.impls in - let expl_impls = List.map - (fun id -> CAst.make ?loc @@ CRef (qualid_of_ident ?loc id,None), Some (make ?loc @@ ExplByName id)) expl_impls in + let ty,impls,argsc = Id.Map.find id env.impls in let tys = string_of_ty ty in Dumpglob.dump_reference ?loc "<>" (Id.to_string id) tys; - gvar (loc,id) us, make_implicits_list impls, argsc, expl_impls + gvar (loc,id) us, make_implicits_list impls, argsc with Not_found -> (* Is [id] bound in current term or is an ltac var bound to constr *) if Id.Set.mem id env.ids || Id.Set.mem id ltacvars.ltac_vars then - gvar (loc,id) us, [], [], [] + gvar (loc,id) us, [], [] else if Id.equal id ldots_var (* Is [id] the special variable for recursive notations? *) then if Id.Map.is_empty ntnvars then error_ldots_var ?loc - else gvar (loc,id) us, [], [], [] + else gvar (loc,id) us, [], [] else if Id.Set.mem id ltacvars.ltac_bound then (* Is [id] bound to a free name in ltac (this is an ltac error message) *) user_err ?loc ~hdr:"intern_var" @@ -1067,17 +1033,17 @@ let intern_var env (ltacvars,ntnvars) namedctx loc id us = let scopes = find_arguments_scope ref in Dumpglob.dump_secvar ?loc id; (* this raises Not_found when not a section variable *) (* Someday we should stop relying on Dumglob raising exceptions *) - DAst.make ?loc @@ GRef (ref, us), impls, scopes, [] + DAst.make ?loc @@ GRef (ref, us), impls, scopes with e when CErrors.noncritical e -> (* [id] a goal variable *) - gvar (loc,id) us, [], [], [] + gvar (loc,id) us, [], [] let find_appl_head_data c = match DAst.get c with | GRef (ref,_) -> let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in - c, impls, scopes, [] + c, impls, scopes | GApp (r, l) -> begin match DAst.get r with | GRef (ref,_) -> @@ -1085,10 +1051,10 @@ let find_appl_head_data c = let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in c, (if n = 0 then [] else List.map (drop_first_implicits n) impls), - List.skipn_at_least n scopes,[] - | _ -> c,[],[],[] + List.skipn_at_least n scopes + | _ -> c,[],[] end - | _ -> c,[],[],[] + | _ -> c,[],[] let error_not_enough_arguments ?loc = user_err ?loc (str "Abbreviation is not applied enough.") @@ -1196,13 +1162,12 @@ let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us try let r, realref, args2 = intern_qualid ~no_secvar:true qid intern env ntnvars us args in check_applied_projection isproj realref qid; - let x, imp, scopes, l = find_appl_head_data r in - (x,imp,scopes,l), args2 + find_appl_head_data r, args2 with Not_found -> (* Extra allowance for non globalizing functions *) if !interning_grammar || env.unb then (* check_applied_projection ?? *) - (gvar (loc,qualid_basename qid) us, [], [], []), args + (gvar (loc,qualid_basename qid) us, [], []), args else Nametab.error_global_not_found qid else let r,realref,args2 = @@ -1210,11 +1175,10 @@ let intern_applied_reference ~isproj intern env namedctx (_, ntnvars as lvar) us with Not_found -> Nametab.error_global_not_found qid in check_applied_projection isproj realref qid; - let x, imp, scopes, l = find_appl_head_data r in - (x,imp,scopes,l), args2 + find_appl_head_data r, args2 let interp_reference vars r = - let (r,_,_,_),_ = + let (r,_,_),_ = intern_applied_reference ~isproj:None (fun _ -> error_not_enough_arguments ?loc:None) {ids = Id.Set.empty; unb = false ; tmp_scope = None; scopes = []; impls = empty_internalization_env; @@ -1882,18 +1846,6 @@ let intern_ind_pattern genv ntnvars scopes pat = (**********************************************************************) (* Utilities for application *) -let merge_impargs l args = - let test x = function - | (_, Some {v=y}) -> explicitation_eq x y - | _ -> false - in - List.fold_right (fun a l -> - match a with - | (_, Some {v=ExplByName id as x}) when - List.exists (test x) args -> l - | _ -> a::l) - l args - let get_implicit_name n imps = Some (Impargs.name_of_implicit (List.nth imps (n-1))) @@ -1954,11 +1906,11 @@ let extract_explicit_arg imps args = let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = let rec intern env = CAst.with_loc_val (fun ?loc -> function | CRef (ref,us) -> - let (c,imp,subscopes,l),_ = + let (c,imp,subscopes),_ = intern_applied_reference ~isproj:None intern env (Environ.named_context_val globalenv) lvar us [] ref in - apply_impargs c env imp subscopes l loc + apply_impargs c env imp subscopes [] loc | CFix ({ CAst.loc = locid; v = iddef}, dl) -> let lf = List.map (fun ({CAst.v = id},_,_,_,_) -> id) dl in @@ -2053,8 +2005,8 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = | CNotation (_,(InConstrEntrySomeLevel,"( _ )"),([a],[],[],[])) -> intern env a | CNotation (_,ntn,args) -> let c = intern_notation intern env ntnvars loc ntn args in - let x, impl, scopes, l = find_appl_head_data c in - apply_impargs x env impl scopes l loc + let x, impl, scopes = find_appl_head_data c in + apply_impargs x env impl scopes [] loc | CGeneralization (b,a,c) -> intern_generalization intern env ntnvars loc b a c | CPrim p -> @@ -2063,7 +2015,7 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = intern {env with tmp_scope = None; scopes = find_delimiters_scope ?loc key :: env.scopes} e | CAppExpl ((isproj,ref,us), args) -> - let (f,_,args_scopes,_),args = + let (f,_,args_scopes),args = let args = List.map (fun a -> (a,None)) args in intern_applied_reference ~isproj intern env (Environ.named_context_val globalenv) lvar us args ref @@ -2074,25 +2026,24 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = smart_gapp f loc (intern_args env args_scopes (List.map fst args)) | CApp ((isproj,f), args) -> - let isproj,f,args = match f.CAst.v with - (* Compact notations like "t.(f args') args" *) - | CApp ((Some _ as isproj',f), args') when not (Option.has_some isproj) -> - isproj',f,args'@args - (* Don't compact "(f args') args" to resolve implicits separately *) - | _ -> isproj,f,args in - let (c,impargs,args_scopes,l),args = - match f.CAst.v with - | CRef (ref,us) -> - intern_applied_reference ~isproj intern env - (Environ.named_context_val globalenv) lvar us args ref - | CNotation (_,ntn,ntnargs) -> - assert (Option.is_empty isproj); - let c = intern_notation intern env ntnvars loc ntn ntnargs in - let x, impl, scopes, l = find_appl_head_data c in - (x,impl,scopes,l), args - | _ -> assert (Option.is_empty isproj); (intern_no_implicit env f,[],[],[]), args in - apply_impargs c env impargs args_scopes - (merge_impargs l args) loc + let isproj,f,args = match f.CAst.v with + (* Compact notations like "t.(f args') args" *) + | CApp ((Some _ as isproj',f), args') when not (Option.has_some isproj) -> + isproj',f,args'@args + (* Don't compact "(f args') args" to resolve implicits separately *) + | _ -> isproj,f,args in + let (c,impargs,args_scopes),args = + match f.CAst.v with + | CRef (ref,us) -> + intern_applied_reference ~isproj intern env + (Environ.named_context_val globalenv) lvar us args ref + | CNotation (_,ntn,ntnargs) -> + assert (Option.is_empty isproj); + let c = intern_notation intern env ntnvars loc ntn ntnargs in + find_appl_head_data c, args + | _ -> assert (Option.is_empty isproj); (intern_no_implicit env f,[],[]), args in + apply_impargs c env impargs args_scopes + args loc | CRecord fs -> let st = Evar_kinds.Define (not (Program.get_proofs_transparency ())) in @@ -2133,9 +2084,10 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = List.rev_append match_td matchs) tms ([],Id.Set.empty,Id.Map.empty,[]) in let env' = Id.Set.fold - (fun var bli -> push_name_env ntnvars (Variable,[],[],[]) bli (CAst.make @@ Name var)) + (fun var bli -> push_name_env ntnvars (Variable,[],[]) bli (CAst.make @@ Name var)) (Id.Set.union ex_ids as_in_vars) - (reset_hidden_inductive_implicit_test (restart_lambda_binders env)) in + (restart_lambda_binders env) + in (* PatVars before a real pattern do not need to be matched *) let stripped_match_from_in = let rec aux = function @@ -2170,17 +2122,17 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = (* "in" is None so no match to add *) let ((b',(na',_)),_,_) = intern_case_item env' Id.Set.empty (b,na,None) in let p' = Option.map (fun u -> - let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env') + let env'' = push_name_env ntnvars (Variable,[],[]) env' (CAst.make na') in intern_type (slide_binders env'') u) po in DAst.make ?loc @@ GLetTuple (List.map (fun { CAst.v } -> v) nal, (na', p'), b', - intern (List.fold_left (push_name_env ntnvars (Variable,[],[],[])) (reset_hidden_inductive_implicit_test env) nal) c) + intern (List.fold_left (push_name_env ntnvars (Variable,[],[])) env nal) c) | CIf (c, (na,po), b1, b2) -> let env' = reset_tmp_scope env in let ((c',(na',_)),_,_) = intern_case_item env' Id.Set.empty (c,na,None) in (* no "in" no match to ad too *) let p' = Option.map (fun p -> - let env'' = push_name_env ntnvars (Variable,[],[],[]) (reset_hidden_inductive_implicit_test env) + let env'' = push_name_env ntnvars (Variable,[],[]) env (CAst.make na') in intern_type (slide_binders env'') p) po in DAst.make ?loc @@ @@ -2478,22 +2430,23 @@ let interp_open_constr ?(expected_type=WithoutTypeConstraint) env sigma c = (* Not all evars expected to be resolved and computation of implicit args *) -let interp_constr_evars_gen_impls ?(program_mode=false) env sigma +let interp_constr_evars_gen_impls ?(flags=Pretyping.all_no_fail_flags) env sigma ?(impls=empty_internalization_env) expected_type c = let c = intern_gen expected_type ~impls env sigma c in let imps = Implicit_quantifiers.implicits_of_glob_constr ~with_products:(expected_type == IsType) c in - let flags = { Pretyping.all_no_fail_flags with program_mode } in let sigma, c = understand_tcc ~flags env sigma ~expected_type c in sigma, (c, imps) -let interp_constr_evars_impls ?program_mode env sigma ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls ?program_mode env sigma ~impls WithoutTypeConstraint c +let interp_constr_evars_impls ?(program_mode=false) env sigma ?(impls=empty_internalization_env) c = + let flags = { Pretyping.all_no_fail_flags with program_mode } in + interp_constr_evars_gen_impls ~flags env sigma ~impls WithoutTypeConstraint c -let interp_casted_constr_evars_impls ?program_mode env evdref ?(impls=empty_internalization_env) c typ = - interp_constr_evars_gen_impls ?program_mode env evdref ~impls (OfType typ) c +let interp_casted_constr_evars_impls ?(program_mode=false) env evdref ?(impls=empty_internalization_env) c typ = + let flags = { Pretyping.all_no_fail_flags with program_mode } in + interp_constr_evars_gen_impls ~flags env evdref ~impls (OfType typ) c -let interp_type_evars_impls ?program_mode env sigma ?(impls=empty_internalization_env) c = - interp_constr_evars_gen_impls ?program_mode env sigma ~impls IsType c +let interp_type_evars_impls ?(flags=Pretyping.all_no_fail_flags) env sigma ?(impls=empty_internalization_env) c = + interp_constr_evars_gen_impls ~flags env sigma ~impls IsType c (* Not all evars expected to be resolved, with side-effect on evars *) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 9d36bf2151..9f06f16258 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -38,7 +38,7 @@ open Pretyping of [env] *) type var_internalization_type = - | Inductive of Id.t list (* list of params *) * bool (* true = check for possible capture *) + | Inductive | Recursive | Method | Variable @@ -48,10 +48,6 @@ type var_internalization_data = (* type of the "free" variable, for coqdoc, e.g. while typing the constructor of JMeq, "JMeq" behaves as a variable of type Inductive *) - Id.t list * - (* impargs to automatically add to the variable, e.g. for "JMeq A a B b" - in implicit mode, this is [A;B] and this adds (A:=A) and (B:=B) *) - Impargs.implicit_status list * (* signature of impargs of the variable *) Notation_term.scope_name option list (* subscopes of the args of the variable *) @@ -132,7 +128,7 @@ val interp_casted_constr_evars_impls : ?program_mode:bool -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> types -> evar_map * (constr * Impargs.manual_implicits) -val interp_type_evars_impls : ?program_mode:bool -> env -> evar_map -> +val interp_type_evars_impls : ?flags:inference_flags -> env -> evar_map -> ?impls:internalization_env -> constr_expr -> evar_map * (types * Impargs.manual_implicits) diff --git a/kernel/float64.ml b/kernel/float64.ml index 299f53e8ab..53fc13b04b 100644 --- a/kernel/float64.ml +++ b/kernel/float64.ml @@ -21,12 +21,19 @@ let is_neg_infinity f = f = neg_infinity (* Printing a binary64 float in 17 decimal places and parsing it again will yield the same float. We assume [to_string_raw] is not given a - [nan] as input. *) + [nan] or an infinity as input. *) let to_string_raw f = Printf.sprintf "%.17g" f (* OCaml gives a sign to nan values which should not be displayed as - all NaNs are considered equal here *) -let to_string f = if is_nan f then "nan" else to_string_raw f + all NaNs are considered equal here. + OCaml prints infinities as "inf" (resp. "-inf") + but we want "infinity" (resp. "neg_infinity"). *) +let to_string f = + if is_nan f then "nan" + else if is_infinity f then "infinity" + else if is_neg_infinity f then "neg_infinity" + else to_string_raw f + let of_string = float_of_string (* Compiles a float to OCaml code *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 469d5ccaa2..7574d7b21e 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -354,7 +354,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (match kind a1, kind a2 with | (Sort s1, Sort s2) -> if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (Sort)."); + (* May happen because we convert application right to left *) + raise NotConvertible; sort_cmp_universes (info_env infos.cnv_inf) cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if Int.equal n m @@ -471,7 +472,8 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (FProd (x1, c1, c2, e), FProd (_, c'1, c'2, e')) -> if not (is_empty_stack v1 && is_empty_stack v2) then - anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); + (* May happen because we convert application right to left *) + raise NotConvertible; (* Luo's system *) let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in diff --git a/kernel/vars.ml b/kernel/vars.ml index 4c66f1574f..a4465c293b 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -169,9 +169,6 @@ let subst_of_rel_context_instance sign l = | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match.") in aux [] (List.rev sign) l -let adjust_subst_to_rel_context sign l = - List.rev (subst_of_rel_context_instance sign l) - let adjust_rel_to_rel_context sign n = let rec aux sign = let open RelDecl in diff --git a/kernel/vars.mli b/kernel/vars.mli index 52a6159f0a..0aac5ed4ce 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -72,9 +72,6 @@ type substl = constr list [c₁], as if usable for [substl]. *) val subst_of_rel_context_instance : Constr.rel_context -> constr list -> substl -(** For compatibility: returns the substitution reversed *) -val adjust_subst_to_rel_context : Constr.rel_context -> constr list -> constr list - (** Take an index in an instance of a context and returns its index wrt to the full context (e.g. 2 in [x:A;y:=b;z:C] is 3, i.e. a reference to z) *) val adjust_rel_to_rel_context : ('a, 'b) Context.Rel.pt -> int -> int diff --git a/lib/flags.ml b/lib/flags.ml index 2832ddd27a..1d9d6d49bc 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -82,3 +82,11 @@ let get_inline_level () = !inline_level let profile_ltac = ref false let profile_ltac_cutoff = ref 2.0 + +let native_compiler = ref None +let get_native_compiler () = match !native_compiler with +| None -> assert false +| Some b -> b +let set_native_compiler b = + let () = assert (!native_compiler == None) in + native_compiler := Some b diff --git a/lib/flags.mli b/lib/flags.mli index a68be196d7..30d1b5b2bd 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -90,6 +90,11 @@ val without_option : bool ref -> ('a -> 'b) -> 'a -> 'b (** Temporarily extends the reference to a list *) val with_extra_values : 'c list ref -> 'c list -> ('a -> 'b) -> 'a -> 'b +(** Native compilation flag *) +val get_native_compiler : unit -> bool +val set_native_compiler : bool -> unit +(** Must be set exactly once at initialization time. *) + (** Level of inlining during a functor application *) val set_inline_level : int -> unit val get_inline_level : unit -> int diff --git a/lib/system.ml b/lib/system.ml index 68410e322a..d7f5fa26ab 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -11,7 +11,6 @@ (* $Id$ *) open Pp -open Util include Minisys @@ -42,15 +41,7 @@ let all_subdirs ~unix_path:root = (* Caching directory contents for efficient syntactic equality of file names even on case-preserving but case-insensitive file systems *) -module StrMod = struct - type t = string - let compare = compare -end - -module StrMap = Map.Make(StrMod) -module StrSet = Set.Make(StrMod) - -let dirmap = ref StrMap.empty +let dirmap = ref CString.Map.empty let make_dir_table dir = let entries = @@ -59,8 +50,8 @@ let make_dir_table dir = with Sys_error _ -> warn_cannot_open_dir dir; [||] in - let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in - Array.fold_left filter_dotfiles StrSet.empty entries + let filter_dotfiles s f = if f.[0] = '.' then s else CString.Set.add f s in + Array.fold_left filter_dotfiles CString.Set.empty entries (** Don't trust in interactive mode (the default) *) let trust_file_cache = ref false @@ -68,20 +59,20 @@ let trust_file_cache = ref false let exists_in_dir_respecting_case dir bf = let cache_dir dir = let contents = make_dir_table dir in - dirmap := StrMap.add dir contents !dirmap; + dirmap := CString.Map.add dir contents !dirmap; contents in let contents, fresh = try (* in batch mode, assume the directory content is still fresh *) - StrMap.find dir !dirmap, !trust_file_cache + CString.Map.find dir !dirmap, !trust_file_cache with Not_found -> (* in batch mode, we are not yet sure the directory exists *) - if !trust_file_cache && not (exists_dir dir) then StrSet.empty, true + if !trust_file_cache && not (exists_dir dir) then CString.Set.empty, true else cache_dir dir, true in - StrSet.mem bf contents || + CString.Set.mem bf contents || not fresh && (* rescan, there is a new file we don't know about *) - StrSet.mem bf (cache_dir dir) + CString.Set.mem bf (cache_dir dir) let file_exists_respecting_case path f = (* This function ensures that a file with expected lowercase/uppercase diff --git a/library/libnames.ml b/library/libnames.ml index 6f55a8dc3d..88b2e41855 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -78,9 +78,6 @@ let dirpath_of_string s = in DirPath.make path -module Dirset = Set.Make(DirPath) -module Dirmap = Map.Make(DirPath) - (*s Section paths are absolute names *) type full_path = { diff --git a/library/libnames.mli b/library/libnames.mli index 23792e54c2..a384510879 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Util open Names (** {6 Dirpaths } *) @@ -34,9 +33,6 @@ val is_dirpath_prefix_of : DirPath.t -> DirPath.t -> bool val is_dirpath_suffix_of : DirPath.t -> DirPath.t -> bool -module Dirset : Set.S with type elt = DirPath.t -module Dirmap : Map.ExtS with type key = DirPath.t and module Set := Dirset - (** {6 Full paths are {e absolute} paths of declarations } *) type full_path diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index a39da96a53..85640cabba 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -392,22 +392,6 @@ let comments = ref [] let current_comment = Buffer.create 8192 let between_commands = ref true -(* The state of the lexer visible from outside *) -type lexer_state = int option * string * bool * ((int * int) * string) list - -let init_lexer_state () = (None,"",true,[]) -let set_lexer_state (o,s,b,c) = - comment_begin := o; - Buffer.clear current_comment; Buffer.add_string current_comment s; - between_commands := b; - comments := c -let get_lexer_state () = - (!comment_begin, Buffer.contents current_comment, !between_commands, !comments) -let drop_lexer_state () = - set_lexer_state (init_lexer_state ()) - -let get_comment_state (_,_,_,c) = c - let real_push_char c = Buffer.add_char current_comment c (* Add a char if it is between two commands, if it is a newline or @@ -851,6 +835,24 @@ module MakeLexer (Diff : sig val mode : bool end) = struct let tok_removing = (fun _ -> ()) let tok_match = Tok.match_pattern let tok_text = token_text + + (* The state of the lexer visible from outside *) + module State = struct + + type t = int option * string * bool * ((int * int) * string) list + + let init () = (None,"",true,[]) + let set (o,s,b,c) = + comment_begin := o; + Buffer.clear current_comment; Buffer.add_string current_comment s; + between_commands := b; + comments := c + let get () = + (!comment_begin, Buffer.contents current_comment, !between_commands, !comments) + let drop () = set (init ()) + let get_comments (_,_,_,c) = c + + end end module Lexer = MakeLexer (struct let mode = false end) diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index 2c1284c4db..ac2c5bcfe2 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -55,7 +55,7 @@ val terminal_numeral : string -> NumTok.Unsigned.t Tok.p (** The lexer of Coq: *) module Lexer : - Gramlib.Grammar.GLexerType with type te = Tok.t and type 'c pattern = 'c Tok.p + Gramlib.Plexing.S with type te = Tok.t and type 'c pattern = 'c Tok.p module Error : sig type t @@ -63,15 +63,6 @@ module Error : sig val to_string : t -> string end -(* Mainly for comments state, etc... *) -type lexer_state - -val init_lexer_state : unit -> lexer_state -val set_lexer_state : lexer_state -> unit -val get_lexer_state : unit -> lexer_state -val drop_lexer_state : unit -> unit -val get_comment_state : lexer_state -> ((int * int) * string) list - (** Create a lexer. true enables alternate handling for computing diffs. It ensures that, ignoring white space, the concatenated tokens equal the input string. Specifically: @@ -81,5 +72,6 @@ as if it was unquoted, possibly becoming multiple tokens it was not in a comment, possibly becoming multiple tokens - return any unrecognized Ascii or UTF-8 character as a string *) + module LexerDiff : - Gramlib.Grammar.GLexerType with type te = Tok.t and type 'c pattern = 'c Tok.p + Gramlib.Plexing.S with type te = Tok.t and type 'c pattern = 'c Tok.p diff --git a/parsing/extend.ml b/parsing/extend.ml index 20297fa156..fadfb6c5f4 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -10,8 +10,6 @@ (** Entry keys for constr notations *) -type 'a entry = 'a Gramlib.Grammar.GMake(CLexer.Lexer).Entry.t - type side = Left | Right type production_position = @@ -77,36 +75,3 @@ type ('a,'b,'c) ty_user_symbol = | TUopt : ('a,'b,'c) ty_user_symbol -> ('a option, 'b option, 'c option) ty_user_symbol | TUentry : ('a, 'b, 'c) Genarg.ArgT.tag -> ('a,'b,'c) ty_user_symbol | TUentryl : ('a, 'b, 'c) Genarg.ArgT.tag * int -> ('a,'b,'c) ty_user_symbol - -(** {5 Type-safe grammar extension} *) - -(* Should be merged with gramlib's implementation *) - -type norec = Gramlib.Grammar.norec -type mayrec = Gramlib.Grammar.mayrec - -type ('self, 'trec, 'a) symbol = -| Atoken : 'c Tok.p -> ('self, norec, 'c) symbol -| Alist1 : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a list) symbol -| Alist1sep : ('self, 'trec, 'a) symbol * ('self, norec, _) symbol - -> ('self, 'trec, 'a list) symbol -| Alist0 : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a list) symbol -| Alist0sep : ('self, 'trec, 'a) symbol * ('self, norec, _) symbol - -> ('self, 'trec, 'a list) symbol -| Aopt : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a option) symbol -| Aself : ('self, mayrec, 'self) symbol -| Anext : ('self, mayrec, 'self) symbol -| Aentry : 'a entry -> ('self, norec, 'a) symbol -| Aentryl : 'a entry * string -> ('self, norec, 'a) symbol -| Arules : 'a rules list -> ('self, norec, 'a) symbol - -and ('self, 'trec, _, 'r) rule = -| Stop : ('self, norec, 'r, 'r) rule -| Next : ('self, _, 'a, 'r) rule * ('self, _, 'b) symbol -> ('self, mayrec, 'b -> 'a, 'r) rule -| NextNoRec : ('self, norec, 'a, 'r) rule * ('self, norec, 'b) symbol -> ('self, norec, 'b -> 'a, 'r) rule - -and 'a rules = -| Rules : (_, norec, 'act, Loc.t -> 'a) rule * 'act -> 'a rules - -type 'a production_rule = -| Rule : ('a, _, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index b3f997e1b3..5b0562fb0d 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -10,113 +10,11 @@ open CErrors open Util -open Extend open Genarg open Gramlib (** The parser of Coq *) -module G : sig - - include Grammar.S with type te = Tok.t and type 'c pattern = 'c Tok.p - -(* where Grammar.S - -module type S = - sig - type te = 'x; - type parsable = 'x; - value parsable : Stream.t char -> parsable; - value tokens : string -> list (string * int); - value glexer : Plexing.lexer te; - value set_algorithm : parse_algorithm -> unit; - module Entry : - sig - type e 'a = 'y; - value create : string -> e 'a; - value parse : e 'a -> parsable -> 'a; - value parse_token_stream : e 'a -> Stream.t te -> 'a; - value name : e 'a -> string; - value of_parser : string -> (Stream.t te -> 'a) -> e 'a; - value print : Format.formatter -> e 'a -> unit; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - end - ; - module Unsafe : - sig - value gram_reinit : Plexing.lexer te -> unit; - value clear_entry : Entry.e 'a -> unit; - end - ; - value extend : - Entry.e 'a -> option Gramext.position -> - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol te) * Gramext.g_action)) -> - unit; - value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit; - end - *) - - type coq_parsable - - val coq_parsable : ?loc:Loc.t -> char Stream.t -> coq_parsable - val entry_create : string -> 'a entry - val entry_parse : 'a entry -> coq_parsable -> 'a - - val comment_state : coq_parsable -> ((int * int) * string) list - -end with type 'a Entry.t = 'a Extend.entry = struct - - include Grammar.GMake(CLexer.Lexer) - - type coq_parsable = Parsable.t * CLexer.lexer_state ref - - let coq_parsable ?loc c = - let state = ref (CLexer.init_lexer_state ()) in - CLexer.set_lexer_state !state; - let a = Parsable.make ?loc c in - state := CLexer.get_lexer_state (); - (a,state) - - let entry_create = Entry.make - - let entry_parse e (p,state) = - CLexer.set_lexer_state !state; - try - let c = Entry.parse e p in - state := CLexer.get_lexer_state (); - c - with Ploc.Exc (loc,e) -> - CLexer.drop_lexer_state (); - let loc' = Loc.get_loc (Exninfo.info e) in - let loc = match loc' with None -> loc | Some loc -> loc in - Loc.raise ~loc e - - let comment_state (p,state) = - CLexer.get_comment_state !state - -end - -module Parsable = -struct - type t = G.coq_parsable - let make = G.coq_parsable - let comment_state = G.comment_state -end - -module Entry = -struct - - type 'a t = 'a Grammar.GMake(CLexer.Lexer).Entry.t - - let create = G.Entry.make - let parse = G.entry_parse - let print = G.Entry.print - let of_parser = G.Entry.of_parser - let name = G.Entry.name - let parse_token_stream = G.Entry.parse_token_stream - -end +include Grammar.GMake(CLexer.Lexer) module Lookahead = struct @@ -187,100 +85,21 @@ end In [single_extend_statement], first two parameters are name and assoc iff a level is created *) -(** Binding general entry keys to symbol *) - -let rec symbol_of_prod_entry_key : type s tr a. (s, tr, a) symbol -> (s, tr, a) G.Symbol.t = -function -| Atoken t -> G.Symbol.token t -| Alist1 s -> - let s = symbol_of_prod_entry_key s in - G.Symbol.list1 s -| Alist1sep (s,sep) -> - let s = symbol_of_prod_entry_key s in - let sep = symbol_of_prod_entry_key sep in - G.Symbol.list1sep s sep false -| Alist0 s -> - let s = symbol_of_prod_entry_key s in - G.Symbol.list0 s -| Alist0sep (s,sep) -> - let s = symbol_of_prod_entry_key s in - let sep = symbol_of_prod_entry_key sep in - G.Symbol.list0sep s sep false -| Aopt s -> - let s = symbol_of_prod_entry_key s in - G.Symbol.opt s -| Aself -> G.Symbol.self -| Anext -> G.Symbol.next -| Aentry e -> G.Symbol.nterm e -| Aentryl (e, n) -> G.Symbol.nterml e n -| Arules rs -> - let warning msg = Feedback.msg_warning Pp.(str msg) in - G.Symbol.rules ~warning:(Some warning) (List.map symbol_of_rules rs) - -and symbol_of_rule : type s tr a r. (s, tr, a, Loc.t -> r) Extend.rule -> (s, tr, a, Loc.t -> r) G.Rule.t = function -| Stop -> - G.Rule.stop -| Next (r, s) -> - let r = symbol_of_rule r in - let s = symbol_of_prod_entry_key s in - G.Rule.next r s -| NextNoRec (r, s) -> - let r = symbol_of_rule r in - let s = symbol_of_prod_entry_key s in - G.Rule.next_norec r s - -and symbol_of_rules : type a. a Extend.rules -> a G.Rules.t = function -| Rules (r, act) -> - let symb = symbol_of_rule r in - G.Rules.make symb act - -(** FIXME: This is a hack around a deficient camlp5 API *) -type 'a any_production = AnyProduction : ('a, 'tr, 'f, Loc.t -> 'a) G.Rule.t * 'f -> 'a any_production - -let of_coq_production_rule : type a. a Extend.production_rule -> a any_production = function -| Rule (toks, act) -> - AnyProduction (symbol_of_rule toks, act) - -let of_coq_single_extend_statement (lvl, assoc, rule) = - (lvl, assoc, List.map of_coq_production_rule rule) - -let of_coq_extend_statement (pos, st) = - (pos, List.map of_coq_single_extend_statement st) - -let fix_extend_statement (pos, st) = - let fix_single_extend_statement (lvl, assoc, rules) = - let fix_production_rule (AnyProduction (s, act)) = G.Production.make s act in - (lvl, assoc, List.map fix_production_rule rules) - in - (pos, List.map fix_single_extend_statement st) - (** Type of reinitialization data *) type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position -type 'a single_extend_statement = - string option * - (* Level *) - Gramlib.Gramext.g_assoc option * - (* Associativity *) - 'a production_rule list - (* Symbol list with the interpretation function *) - -type 'a extend_statement = - Gramlib.Gramext.position option * - 'a single_extend_statement list - type extend_rule = | ExtendRule : 'a Entry.t * 'a extend_statement -> extend_rule | ExtendRuleReinit : 'a Entry.t * gram_reinit * 'a extend_statement -> extend_rule module EntryCommand = Dyn.Make () -module EntryData = struct type _ t = Ex : 'b G.Entry.t String.Map.t -> ('a * 'b) t end +module EntryData = struct type _ t = Ex : 'b Entry.t String.Map.t -> ('a * 'b) t end module EntryDataMap = EntryCommand.Map(EntryData) type ext_kind = | ByGrammar of extend_rule | ByEXTEND of (unit -> unit) * (unit -> unit) - | ByEntry : ('a * 'b) EntryCommand.tag * string * 'b G.Entry.t -> ext_kind + | ByEntry : ('a * 'b) EntryCommand.tag * string * 'b Entry.t -> ext_kind (** The list of extensions *) @@ -290,49 +109,37 @@ let camlp5_entries = ref EntryDataMap.empty (** Deletion *) -let grammar_delete e (pos,rls) = +let grammar_delete e { pos; data } = List.iter (fun (n,ass,lev) -> - List.iter (fun (AnyProduction (pil,_)) -> G.safe_delete_rule e pil) (List.rev lev)) - (List.rev rls) + List.iter (fun pil -> safe_delete_rule e pil) (List.rev lev)) + (List.rev data) -let grammar_delete_reinit e reinit (pos, rls) = - grammar_delete e (pos, rls); +let grammar_delete_reinit e reinit ({ pos; data } as d)= + grammar_delete e d; let a, ext = reinit in let lev = match pos with | Some (Gramext.Level n) -> n | _ -> assert false in - let warning msg = Feedback.msg_warning Pp.(str msg) in - (G.safe_extend ~warning:(Some warning) e) (Some ext) [Some lev,Some a,[]] + let ext = { pos = Some ext; data = [Some lev,Some a,[]] } in + safe_extend e ext (** Extension *) let grammar_extend e ext = - let ext = of_coq_extend_statement ext in let undo () = grammar_delete e ext in - let pos, ext = fix_extend_statement ext in - let redo () = G.safe_extend ~warning:None e pos ext in + let redo () = safe_extend e ext in camlp5_state := ByEXTEND (undo, redo) :: !camlp5_state; redo () let grammar_extend_sync e ext = camlp5_state := ByGrammar (ExtendRule (e, ext)) :: !camlp5_state; - let pos, ext = fix_extend_statement (of_coq_extend_statement ext) in - G.safe_extend ~warning:None e pos ext + safe_extend e ext let grammar_extend_sync_reinit e reinit ext = camlp5_state := ByGrammar (ExtendRuleReinit (e, reinit, ext)) :: !camlp5_state; - let pos, ext = fix_extend_statement (of_coq_extend_statement ext) in - G.safe_extend ~warning:None e pos ext - -(** The apparent parser of Coq; encapsulate G to keep track - of the extensions. *) - -module Gram = - struct - include G - end + safe_extend e ext (** Remove extensions @@ -344,11 +151,11 @@ let rec remove_grammars n = match !camlp5_state with | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove.") | ByGrammar (ExtendRuleReinit (g, reinit, ext)) :: t -> - grammar_delete_reinit g reinit (of_coq_extend_statement ext); + grammar_delete_reinit g reinit ext; camlp5_state := t; remove_grammars (n-1) | ByGrammar (ExtendRule (g, ext)) :: t -> - grammar_delete g (of_coq_extend_statement ext); + grammar_delete g ext; camlp5_state := t; remove_grammars (n-1) | ByEXTEND (undo,redo)::t -> @@ -358,7 +165,7 @@ let rec remove_grammars n = redo(); camlp5_state := ByEXTEND (undo,redo) :: !camlp5_state | ByEntry (tag, name, e) :: t -> - G.Unsafe.clear_entry e; + Unsafe.clear_entry e; camlp5_state := t; let EntryData.Ex entries = try EntryDataMap.find tag !camlp5_entries @@ -373,19 +180,19 @@ let make_rule r = [None, None, r] (** An entry that checks we reached the end of the input. *) let eoi_entry en = - let e = Entry.create ((Gram.Entry.name en) ^ "_eoi") in - let symbs = G.Rule.next (G.Rule.next G.Rule.stop (G.Symbol.nterm en)) (G.Symbol.token Tok.PEOI) in + let e = Entry.make ((Entry.name en) ^ "_eoi") in + let symbs = Rule.next (Rule.next Rule.stop (Symbol.nterm en)) (Symbol.token Tok.PEOI) in let act = fun _ x loc -> x in - let warning msg = Feedback.msg_warning Pp.(str msg) in - Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.Production.make symbs act]); + let ext = { pos = None; data = make_rule [Production.make symbs act] } in + safe_extend e ext; e let map_entry f en = - let e = Entry.create ((Gram.Entry.name en) ^ "_map") in - let symbs = G.Rule.next G.Rule.stop (G.Symbol.nterm en) in + let e = Entry.make ((Entry.name en) ^ "_map") in + let symbs = Rule.next Rule.stop (Symbol.nterm en) in let act = fun x loc -> f x in - let warning msg = Feedback.msg_warning Pp.(str msg) in - Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.Production.make symbs act]); + let ext = { pos = None; data = make_rule [Production.make symbs act] } in + safe_extend e ext; e (* Parse a string, does NOT check if the entire string was read @@ -393,7 +200,7 @@ let map_entry f en = let parse_string f ?loc x = let strm = Stream.of_string x in - Gram.entry_parse f (Gram.coq_parsable ?loc strm) + Entry.parse f (Parsable.make ?loc strm) type gram_universe = string @@ -414,7 +221,7 @@ let get_univ u = let new_entry u s = let ename = u ^ ":" ^ s in - let e = Entry.create ename in + let e = Entry.make ename in e let make_gen_entry u s = new_entry u s @@ -530,13 +337,11 @@ module Module = let module_type = Entry.create "module_type" end -let epsilon_value (type s tr a) f (e : (s, tr, a) symbol) = - let s = symbol_of_prod_entry_key e in - let r = G.Production.make (G.Rule.next G.Rule.stop s) (fun x _ -> f x) in - let ext = [None, None, [r]] in - let entry = Gram.entry_create "epsilon" in - let warning msg = Feedback.msg_warning Pp.(str msg) in - let () = G.safe_extend ~warning:(Some warning) entry None ext in +let epsilon_value (type s tr a) f (e : (s, tr, a) Symbol.t) = + let r = Production.make (Rule.next Rule.stop e) (fun x _ -> f x) in + let entry = Entry.make "epsilon" in + let ext = { pos = None; data = [None, None, [r]] } in + let () = safe_extend entry ext in try Some (parse_string entry "") with _ -> None (** Synchronized grammar extensions *) @@ -594,14 +399,14 @@ let extend_grammar_command tag g = let nb = List.length rules in grammar_stack := (GramExt (nb, GrammarCommand.Dyn (tag, g)), st) :: !grammar_stack -let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) : b Gram.Entry.t list = +let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) : b Entry.t list = let EntryInterp.Ex modify = EntryInterpMap.find tag !entry_interp in let grammar_state = match !grammar_stack with | [] -> GramState.empty | (_, st) :: _ -> st in let (names, st) = modify g grammar_state in - let entries = List.map (fun name -> Gram.entry_create name) names in + let entries = List.map (fun name -> Entry.make name) names in let iter name e = camlp5_state := ByEntry (tag, name, e) :: !camlp5_state; let EntryData.Ex old = @@ -627,7 +432,7 @@ let extend_dyn_grammar (e, _) = match e with (** Registering extra grammar *) -type any_entry = AnyEntry : 'a Gram.Entry.t -> any_entry +type any_entry = AnyEntry : 'a Entry.t -> any_entry let grammar_names : any_entry list String.Map.t ref = ref String.Map.empty diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 87c7f168ce..90088be307 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -9,30 +9,13 @@ (************************************************************************) open Names -open Extend open Genarg open Constrexpr open Libnames (** The parser of Coq *) -module Parsable : -sig - type t - val make : ?loc:Loc.t -> char Stream.t -> t - (* Get comment parsing information from the Lexer *) - val comment_state : t -> ((int * int) * string) list -end - -module Entry : sig - type 'a t = 'a Extend.entry - val create : string -> 'a t - val parse : 'a t -> Parsable.t -> 'a - val print : Format.formatter -> 'a t -> unit - val of_parser : string -> (Gramlib.Plexing.location_function -> Tok.t Stream.t -> 'a) -> 'a t - val parse_token_stream : 'a t -> Tok.t Stream.t -> 'a - val name : 'a t -> string -end +include Gramlib.Grammar.S with type te = Tok.t and type 'a pattern = 'a Tok.p module Lookahead : sig type t @@ -222,24 +205,11 @@ module Module : val module_type : module_ast Entry.t end -val epsilon_value : ('a -> 'self) -> ('self, _, 'a) Extend.symbol -> 'self option +(** {5 Type-safe grammar extension} *) -(** {5 Extending the parser without synchronization} *) +val epsilon_value : ('a -> 'self) -> ('self, _, 'a) Symbol.t -> 'self option -type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position -(** Type of reinitialization data *) - -type 'a single_extend_statement = - string option * - (* Level *) - Gramlib.Gramext.g_assoc option * - (* Associativity *) - 'a production_rule list - (* Symbol list with the interpretation function *) - -type 'a extend_statement = - Gramlib.Gramext.position option * - 'a single_extend_statement list +(** {5 Extending the parser without synchronization} *) val grammar_extend : 'a Entry.t -> 'a extend_statement -> unit (** Extend the grammar of Coq, without synchronizing it with the backtracking @@ -257,6 +227,9 @@ type 'a grammar_command (** Type of synchronized parsing extensions. The ['a] type should be marshallable. *) +type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position +(** Type of reinitialization data *) + type extend_rule = | ExtendRule : 'a Entry.t * 'a extend_statement -> extend_rule | ExtendRuleReinit : 'a Entry.t * gram_reinit * 'a extend_statement -> extend_rule diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 446026c4c8..d38c3c869b 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -39,7 +39,7 @@ let build_newrecursive lnameargsardef = List.fold_left (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> let arityc = Constrexpr_ops.mkCProdN binders rtype in - let arity,ctx = Constrintern.interp_type env0 sigma arityc in + let arity,_ctx = Constrintern.interp_type env0 sigma arityc in let evd = Evd.from_env env0 in let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in @@ -164,7 +164,7 @@ let prepare_body { Vernacexpr.binders } rt = let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') -let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = +let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = (* First we get the type of the old graph principle *) let mutr_nparams = (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)).Tactics.nparams in (* let time1 = System.get_time () in *) @@ -199,7 +199,7 @@ let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_ (* end; *) let open Proof_global in - let { name; entries } = Lemmas.pf_fold (close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x)) lemma in + let { entries } = Lemmas.pf_fold (close_proof ~opaque ~keep_body_ucst_separate:false) lemma in match entries with | [entry] -> entry, hook @@ -235,7 +235,6 @@ let change_property_sort evd toSort princ princName = (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) let generate_functional_principle (evd: Evd.evar_map ref) - interactive_proof old_princ_type sorts new_princ_name funs i proof_tac = try @@ -283,27 +282,25 @@ let generate_functional_principle (evd: Evd.evar_map ref) register_with_sort Sorts.InSet in let entry, hook = - build_functional_principle evd interactive_proof old_princ_type new_sorts funs i + build_functional_principle evd old_princ_type new_sorts funs i proof_tac hook in (* Pr 1278 : Don't forget to close the goal if an error is raised !!!! *) let uctx = Evd.evar_universe_context sigma in - let hook_data = hook, uctx, [] in - let _ : Names.GlobRef.t = DeclareDef.declare_definition - ~name:new_princ_name ~hook_data + let _ : Names.GlobRef.t = DeclareDef.declare_entry + ~name:new_princ_name ~hook ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~kind:Decls.(IsProof Theorem) - ~ubind:UnivNames.empty_binders ~impargs:[] - entry in + ~uctx entry in () with e when CErrors.noncritical e -> raise (Defining_principle e) let generate_principle (evd:Evd.evar_map ref) pconstants on_error - is_general do_built fix_rec_l recdefs interactive_proof + is_general do_built fix_rec_l recdefs (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> Tacmach.tactic) : unit = let names = List.map (function { Vernacexpr.fname = {CAst.v=name} } -> name) fix_rec_l in @@ -336,7 +333,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in let _ = List.map_i - (fun i x -> + (fun i _x -> let env = Global.env () in let princ = Indrec.lookup_eliminator env (ind_kn,i) (Sorts.InProp) in let evd = ref (Evd.from_env env) in @@ -347,7 +344,6 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let princ_type = EConstr.Unsafe.to_constr princ_type in generate_functional_principle evd - interactive_proof princ_type None None @@ -375,7 +371,6 @@ let register_struct is_rec fixpoint_exprl = | None -> CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in ComDefinition.do_definition - ~program_mode:false ~name:fname.CAst.v ~poly:false ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) @@ -413,7 +408,7 @@ let register_struct is_rec fixpoint_exprl = None,evd,List.rev rev_pconstants let generate_correction_proof_wf f_ref tcc_lemma_ref - is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation + is_mes functional_ref eq_ref rec_arg_num rec_arg_type relation (_: int) (_:Names.Constant.t array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref,functional_ref,eq_ref) @@ -431,7 +426,7 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion *) -let generate_type evd g_to_f f graph i = +let generate_type evd g_to_f f graph = let open Context.Rel.Declaration in let open EConstr in let open EConstr.Vars in @@ -499,7 +494,7 @@ let generate_type evd g_to_f f graph i = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle evd f = - let f_as_constant,u = match EConstr.kind !evd f with + let f_as_constant, _u = match EConstr.kind !evd f with | Constr.Const c' -> c' | _ -> CErrors.user_err Pp.(str "Must be used with a function") in @@ -546,7 +541,7 @@ let rec generate_fresh_id x avoid i = let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in id::(generate_fresh_id x (id::avoid) (pred i)) -let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = let open Constr in let open EConstr in let open Context.Rel.Declaration in @@ -1141,7 +1136,7 @@ let get_funs_constant mp = to prevent Reset strange thing *) let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params,l_fixes = List.split (List.map Term.decompose_lam l_bodies) in + let l_params, _l_fixes = List.split (List.map Term.decompose_lam l_bodies) in (* all the parameters must be equal*) let _check_params = let first_params = List.hd l_params in @@ -1241,7 +1236,7 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef in let entry, _hook = try - build_functional_principle ~opaque evd false + build_functional_principle ~opaque evd first_type (Array.of_list sorts) this_block_funs @@ -1262,7 +1257,7 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef let sorts = Array.of_list sorts in List.map (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types in - let first_princ_body,first_princ_type = Declare.(entry.proof_entry_body, entry.proof_entry_type) in + let first_princ_body = entry.Declare.proof_entry_body in let ctxt,fix = Term.decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) let (idxs,_),(_,ta,_ as decl) = Constr.destFix fix in let other_result = @@ -1292,7 +1287,6 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef let entry, _hook = build_functional_principle evd - false (List.nth other_princ_types (!i - 1)) (Array.of_list sorts) this_block_funs @@ -1331,9 +1325,8 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> - (* let const_of_f,u = destConst f_constr in *) let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd false f_constr graph i + generate_type evd false f_constr graph in let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; @@ -1368,7 +1361,7 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = ) in let proving_tac = - prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos + prove_fun_correct !evd graphs_constr schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> @@ -1398,8 +1391,8 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd true f_constr graph i + let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = + generate_type evd true f_constr graph in let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; @@ -1415,7 +1408,7 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = in let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in - let mib,mip = Global.lookup_inductive graph_ind in + let mib, _mip = Global.lookup_inductive graph_ind in let sigma, scheme = (Indrec.build_mutual_induction_scheme (Global.env ()) !evd (Array.to_list @@ -1485,7 +1478,7 @@ let derive_inversion fix_names = *) List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; try - let evd', lind = + let _evd', lind = List.fold_right (fun id (evd,l) -> let evd,id = @@ -1536,11 +1529,11 @@ let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf in let eq = Constrexpr_ops.mkCProdN args unbounded_eq in let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type - nb_args relation = + _nb_args relation = try pre_hook [fconst] (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes - functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation + functional_ref eq_ref rec_arg_num rec_arg_type relation ); derive_inversion [fname] with e when CErrors.noncritical e -> @@ -1562,7 +1555,7 @@ let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt w | None -> begin match args with - | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],k,t)] -> t,x + | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],_k,t)] -> t,x | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") end | Some wf_args -> @@ -1570,7 +1563,7 @@ let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt w match List.find (function - | Constrexpr.CLocalAssum(l,k,t) -> + | Constrexpr.CLocalAssum(l,_k,t) -> List.exists (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) l @@ -1578,7 +1571,7 @@ let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt w ) args with - | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args + | Constrexpr.CLocalAssum(_,_k,t) -> t,wf_args | _ -> assert false with Not_found -> assert false in @@ -1626,7 +1619,7 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro let lemma, _is_struct = match fixpoint_exprl with | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs; binders; rtype; body_def } as fixpoint_expr = + let { Vernacexpr.fname; univs = _; binders; rtype; body_def } as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false @@ -1645,13 +1638,12 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro register_built fixpoint_exprl recdefs - true in if register_built then register_wf interactive_proof fname.CAst.v rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false else None, false | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs; binders; rtype; body_def} as fixpoint_expr = + let { Vernacexpr.fname; univs = _; binders; rtype; body_def} as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false @@ -1672,7 +1664,6 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro register_built fixpoint_exprl recdefs - true in if register_built then register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt @@ -1690,7 +1681,7 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro let fixpoint_exprl = recompute_binder_list fixpoint_exprl in let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in (* ok all the expressions are structural *) - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let recdefs, _rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in let lemma,evd,pconstants = if register_built @@ -1706,7 +1697,6 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro register_built fixpoint_exprl recdefs - interactive_proof (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); if register_built then begin derive_inversion fix_names; end; @@ -2067,7 +2057,6 @@ let build_case_scheme fa = *) generate_functional_principle (ref (Evd.from_env (Global.env ()))) - false scheme_type (Some ([|sorts|])) (Some princ_name) diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 9b80cbd803..7b1aa7a07a 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -47,7 +47,7 @@ DECLARE PLUGIN "ltac_plugin" let with_delayed_uconstr ist c tac = let flags = { - Pretyping.use_typeclasses = false; + Pretyping.use_typeclasses = Pretyping.NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; @@ -345,7 +345,7 @@ open EConstr open Vars let constr_flags () = { - Pretyping.use_typeclasses = true; + Pretyping.use_typeclasses = Pretyping.UseTC; Pretyping.solve_unification_constraints = Pfedit.use_unification_heuristics (); Pretyping.fail_evar = false; Pretyping.expand_evars = true; @@ -375,22 +375,22 @@ let refine_tac ist simple with_classes c = TACTIC EXTEND refine | [ "refine" uconstr(c) ] -> - { refine_tac ist false true c } + { refine_tac ist false Pretyping.UseTC c } END TACTIC EXTEND simple_refine | [ "simple" "refine" uconstr(c) ] -> - { refine_tac ist true true c } + { refine_tac ist true Pretyping.UseTC c } END TACTIC EXTEND notcs_refine | [ "notypeclasses" "refine" uconstr(c) ] -> - { refine_tac ist false false c } + { refine_tac ist false Pretyping.NoUseTC c } END TACTIC EXTEND notcs_simple_refine | [ "simple" "notypeclasses" "refine" uconstr(c) ] -> - { refine_tac ist true false c } + { refine_tac ist true Pretyping.NoUseTC c } END (* Solve unification constraints using heuristics or fail if any remain *) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 3c30c881fb..b4527694ae 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -53,7 +53,7 @@ END let eval_uconstrs ist cs = let flags = { - Pretyping.use_typeclasses = false; + Pretyping.use_typeclasses = Pretyping.NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 4af5699317..4127d28bae 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -44,11 +44,11 @@ let coincide s pat off = !break let atactic n = - if n = 5 then Aentry Pltac.binder_tactic - else Aentryl (Pltac.tactic_expr, string_of_int n) + if n = 5 then Pcoq.Symbol.nterm Pltac.binder_tactic + else Pcoq.Symbol.nterml Pltac.tactic_expr (string_of_int n) type entry_name = EntryName : - 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, _, 'a) Extend.symbol -> entry_name + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, _, 'a) Pcoq.Symbol.t -> entry_name (** Quite ad-hoc *) let get_tacentry n m = @@ -57,8 +57,8 @@ let get_tacentry n m = && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) in - if check_lvl n then EntryName (rawwit Tacarg.wit_tactic, Aself) - else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Anext) + if check_lvl n then EntryName (rawwit Tacarg.wit_tactic, Pcoq.Symbol.self) + else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Pcoq.Symbol.next) else EntryName (rawwit Tacarg.wit_tactic, atactic n) let get_separator = function @@ -140,23 +140,23 @@ let head_is_ident tg = match tg.tacgram_prods with let rec prod_item_of_symbol lev = function | Extend.Ulist1 s -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist1 e) + EntryName (Rawwit (ListArg typ), Pcoq.Symbol.list1 e) | Extend.Ulist0 s -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist0 e) + EntryName (Rawwit (ListArg typ), Pcoq.Symbol.list0 e) | Extend.Ulist1sep (s, sep) -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist1sep (e, Atoken (CLexer.terminal sep))) + EntryName (Rawwit (ListArg typ), Pcoq.Symbol.list1sep e (Pcoq.Symbol.token (CLexer.terminal sep)) false) | Extend.Ulist0sep (s, sep) -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist0sep (e, Atoken (CLexer.terminal sep))) + EntryName (Rawwit (ListArg typ), Pcoq.Symbol.list0sep e (Pcoq.Symbol.token (CLexer.terminal sep)) false) | Extend.Uopt s -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (OptArg typ), Aopt e) + EntryName (Rawwit (OptArg typ), Pcoq.Symbol.opt e) | Extend.Uentry arg -> let ArgT.Any tag = arg in let wit = ExtraArg tag in - EntryName (Rawwit wit, Extend.Aentry (genarg_grammar wit)) + EntryName (Rawwit wit, Pcoq.Symbol.nterm (genarg_grammar wit)) | Extend.Uentryl (s, n) -> let ArgT.Any tag = s in assert (coincide (ArgT.repr tag) "tactic" 0); @@ -191,7 +191,7 @@ let add_tactic_entry (kn, ml, tg) state = in let prods = List.map map tg.tacgram_prods in let rules = make_rule mkact prods in - let r = ExtendRule (entry, (pos, [(None, None, [rules])])) in + let r = ExtendRule (entry, { pos; data=[(None, None, [rules])]}) in ([r], state) let tactic_grammar = @@ -399,23 +399,29 @@ let create_ltac_quotation name cast (e, l) = in let () = ltac_quotations := String.Set.add name !ltac_quotations in let entry = match l with - | None -> Aentry e - | Some l -> Aentryl (e, string_of_int l) + | None -> Pcoq.Symbol.nterm e + | Some l -> Pcoq.Symbol.nterml e (string_of_int l) in (* let level = Some "1" in *) let level = None in let assoc = None in let rule = - Next (Next (Next (Next (Next (Stop, - Atoken (CLexer.terminal name)), - Atoken (CLexer.terminal ":")), - Atoken (CLexer.terminal "(")), - entry), - Atoken (CLexer.terminal ")")) + Pcoq.( + Rule.next + (Rule.next + (Rule.next + (Rule.next + (Rule.next + Rule.stop + (Symbol.token (CLexer.terminal name))) + (Symbol.token (CLexer.terminal ":"))) + (Symbol.token (CLexer.terminal "("))) + entry) + (Symbol.token (CLexer.terminal ")"))) in let action _ v _ _ _ loc = cast (Some loc, v) in - let gram = (level, assoc, [Rule (rule, action)]) in - Pcoq.grammar_extend Pltac.tactic_arg (None, [gram]) + let gram = (level, assoc, [Pcoq.Production.make rule action]) in + Pcoq.grammar_extend Pltac.tactic_arg {pos=None; data=[gram]} (** Command *) @@ -759,7 +765,7 @@ let argument_extend (type a b c) ~name (arg : (a, b, c) tactic_argument) = e | Vernacextend.Arg_rules rules -> let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in - let () = Pcoq.grammar_extend e (None, [(None, None, rules)]) in + let () = Pcoq.grammar_extend e {pos=None; data=[(None, None, rules)]} in e in let (rpr, gpr, tpr) = arg.arg_printer in diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 9e0b9d3254..b0e26e1def 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -546,7 +546,7 @@ let interp_gen kind ist pattern_mode flags env sigma c = (evd,c) let constr_flags () = { - use_typeclasses = true; + use_typeclasses = UseTC; solve_unification_constraints = true; fail_evar = true; expand_evars = true; @@ -564,7 +564,7 @@ let interp_constr = interp_constr_gen WithoutTypeConstraint let interp_type = interp_constr_gen IsType let open_constr_use_classes_flags () = { - use_typeclasses = true; + use_typeclasses = UseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; @@ -573,7 +573,7 @@ let open_constr_use_classes_flags () = { } let open_constr_no_classes_flags () = { - use_typeclasses = false; + use_typeclasses = NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; @@ -582,7 +582,7 @@ let open_constr_no_classes_flags () = { } let pure_open_constr_flags = { - use_typeclasses = false; + use_typeclasses = NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = false; diff --git a/plugins/micromega/.ocamlformat b/plugins/micromega/.ocamlformat new file mode 100644 index 0000000000..a22a2ff88c --- /dev/null +++ b/plugins/micromega/.ocamlformat @@ -0,0 +1 @@ +disable=false diff --git a/plugins/micromega/.ocamlformat-ignore b/plugins/micromega/.ocamlformat-ignore new file mode 100644 index 0000000000..157a987754 --- /dev/null +++ b/plugins/micromega/.ocamlformat-ignore @@ -0,0 +1 @@ +micromega.ml diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 01b12474dd..e0b083a70a 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -239,7 +239,7 @@ let interp_refine ist gl rc = } in let kind = Pretyping.OfType (pf_concl gl) in let flags = { - Pretyping.use_typeclasses = true; + Pretyping.use_typeclasses = Pretyping.UseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index df6189f212..4b78e64d98 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -402,7 +402,7 @@ let rec interp_search_about args accu = match args with | [] -> accu | (flag, arg) :: rem -> fun gr env typ -> - let ans = Search.search_about_filter arg gr env typ in + let ans = Search.search_filter arg gr env typ in (if flag then ans else not ans) && interp_search_about rem accu gr env typ let interp_search_arg arg = diff --git a/plugins/syntax/float_syntax.ml b/plugins/syntax/float_syntax.ml index dadce9a9ea..e0a9906689 100644 --- a/plugins/syntax/float_syntax.ml +++ b/plugins/syntax/float_syntax.ml @@ -22,8 +22,56 @@ let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) (*** Parsing for float in digital notation ***) +let warn_inexact_float = + CWarnings.create ~name:"inexact-float" ~category:"parsing" + (fun (sn, f) -> + Pp.strbrk + (Printf.sprintf + "The constant %s is not a binary64 floating-point value. \ + A closest value will be used and unambiguously printed %s." + sn (Float64.to_string f))) + let interp_float ?loc n = - DAst.make ?loc (GFloat (Float64.of_string (NumTok.Signed.to_string n))) + let sn = NumTok.Signed.to_string n in + let f = Float64.of_string sn in + (* return true when f is not exactly equal to n, + this is only used to decide whether or not to display a warning + and does not play any actual role in the parsing *) + let inexact () = match Float64.classify f with + | Float64.(PInf | NInf | NaN) -> true + | Float64.(PZero | NZero) -> not (NumTok.Signed.is_zero n) + | Float64.(PNormal | NNormal | PSubn | NSubn) -> + let m, e = + let (_, i), f, e = NumTok.Signed.to_decimal_and_exponent n in + let i = NumTok.UnsignedNat.to_string i in + let f = match f with + | None -> "" | Some f -> NumTok.UnsignedNat.to_string f in + let e = match e with + | None -> "0" | Some e -> NumTok.SignedNat.to_string e in + Bigint.of_string (i ^ f), + (try int_of_string e with Failure _ -> 0) - String.length f in + let m', e' = + let m', e' = Float64.frshiftexp f in + let m' = Float64.normfr_mantissa m' in + let e' = Uint63.to_int_min e' 4096 - Float64.eshift - 53 in + Bigint.of_string (Uint63.to_string m'), + e' in + let c2, c5 = Bigint.(of_int 2, of_int 5) in + (* check m*5^e <> m'*2^e' *) + let check m e m' e' = + not (Bigint.(equal (mult m (pow c5 e)) (mult m' (pow c2 e')))) in + (* check m*5^e*2^e' <> m' *) + let check' m e e' m' = + not (Bigint.(equal (mult (mult m (pow c5 e)) (pow c2 e')) m')) in + (* we now have to check m*10^e <> m'*2^e' *) + if e >= 0 then + if e <= e' then check m e m' (e' - e) + else check' m e (e - e') m' + else (* e < 0 *) + if e' <= e then check m' (-e) m (e - e') + else check' m' (-e) (e' - e) m in + if inexact () then warn_inexact_float ?loc (sn, f); + DAst.make ?loc (GFloat f) (* Pretty printing is already handled in constrextern.ml *) diff --git a/pretyping/coercionops.ml b/pretyping/coercionops.ml index d6458e1409..49401a9937 100644 --- a/pretyping/coercionops.ml +++ b/pretyping/coercionops.ml @@ -67,8 +67,6 @@ end module ClTypMap = Map.Make(ClTyp) -module IntMap = Map.Make(Int) - let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 type inheritance_path = coe_info_typ list @@ -97,13 +95,13 @@ struct module Index = struct include Int let print = Pp.int end - type 'a t = { v : (cl_typ * 'a) IntMap.t; s : int; inv : int ClTypMap.t } - let empty = { v = IntMap.empty; s = 0; inv = ClTypMap.empty } + type 'a t = { v : (cl_typ * 'a) Int.Map.t; s : int; inv : int ClTypMap.t } + let empty = { v = Int.Map.empty; s = 0; inv = ClTypMap.empty } let mem y b = ClTypMap.mem y b.inv - let map x b = IntMap.find x b.v - let revmap y b = let n = ClTypMap.find y b.inv in (n, snd (IntMap.find n b.v)) + let map x b = Int.Map.find x b.v + let revmap y b = let n = ClTypMap.find y b.inv in (n, snd (Int.Map.find n b.v)) let add x y b = - { v = IntMap.add b.s (x,y) b.v; s = b.s+1; inv = ClTypMap.add x b.s b.inv } + { v = Int.Map.add b.s (x,y) b.v; s = b.s+1; inv = ClTypMap.add x b.s b.inv } let dom b = List.rev (ClTypMap.fold (fun x _ acc -> x::acc) b.inv []) end diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 7be34d4cf1..f989dae4c9 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -496,8 +496,8 @@ let stop_profiler m_pid = let native_norm env sigma c ty = let c = EConstr.Unsafe.to_constr c in let ty = EConstr.Unsafe.to_constr ty in - if not Coq_config.native_compiler then - user_err Pp.(str "Native_compute reduction has been disabled at configure time.") + if not (Flags.get_native_compiler ()) then + user_err Pp.(str "Native_compute reduction has been disabled.") else (* Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index ded159e484..015c26531a 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -189,8 +189,10 @@ let interp_sort_info ?loc evd l = type inference_hook = env -> evar_map -> Evar.t -> (evar_map * constr) option +type use_typeclasses = NoUseTC | UseTCForConv | UseTC + type inference_flags = { - use_typeclasses : bool; + use_typeclasses : use_typeclasses; solve_unification_constraints : bool; fail_evar : bool; expand_evars : bool; @@ -231,7 +233,7 @@ let frozen_and_pending_holes (sigma, sigma') = end in FrozenProgress data -let apply_typeclasses ~program_mode env sigma frozen fail_evar = +let apply_typeclasses ~program_mode ~fail_evar env sigma frozen = let filter_frozen = match frozen with | FrozenId map -> fun evk -> Evar.Map.mem evk map | FrozenProgress (lazy (frozen, _)) -> fun evk -> Evar.Set.mem evk frozen @@ -270,7 +272,7 @@ let apply_heuristics env sigma fail_evar = let check_typeclasses_instances_are_solved ~program_mode env current_sigma frozen = (* Naive way, call resolution again with failure flag *) - apply_typeclasses ~program_mode env current_sigma frozen true + apply_typeclasses ~program_mode ~fail_evar:true env current_sigma frozen let check_extra_evars_are_solved env current_sigma frozen = match frozen with | FrozenId _ -> () @@ -312,9 +314,9 @@ let solve_remaining_evars ?hook flags env ?initial sigma = let program_mode = flags.program_mode in let frozen = frozen_and_pending_holes (initial, sigma) in let sigma = - if flags.use_typeclasses - then apply_typeclasses ~program_mode env sigma frozen false - else sigma + match flags.use_typeclasses with + | UseTC -> apply_typeclasses ~program_mode ~fail_evar:false env sigma frozen + | NoUseTC | UseTCForConv -> sigma in let sigma = match hook with | None -> sigma @@ -1287,21 +1289,25 @@ let ise_pretype_gen flags env sigma lvar kind c = if program_mode then ProgramNaming else KeepUserNameAndRenameExistingButSectionNames in let env = GlobEnv.make ~hypnaming env sigma lvar in + let use_tc = match flags.use_typeclasses with + | NoUseTC -> false + | UseTC | UseTCForConv -> true + in let sigma', c', c'_ty = match kind with | WithoutTypeConstraint | UnknownIfTermOrType -> - let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses empty_tycon env sigma c in + let sigma, j = pretype ~program_mode ~poly use_tc empty_tycon env sigma c in sigma, j.uj_val, j.uj_type | OfType exptyp -> - let sigma, j = pretype ~program_mode ~poly flags.use_typeclasses (mk_tycon exptyp) env sigma c in + let sigma, j = pretype ~program_mode ~poly use_tc (mk_tycon exptyp) env sigma c in sigma, j.uj_val, j.uj_type | IsType -> - let sigma, tj = pretype_type ~program_mode ~poly flags.use_typeclasses empty_valcon env sigma c in + let sigma, tj = pretype_type ~program_mode ~poly use_tc empty_valcon env sigma c in sigma, tj.utj_val, mkSort tj.utj_type in process_inference_flags flags !!env sigma (sigma',c',c'_ty) let default_inference_flags fail = { - use_typeclasses = true; + use_typeclasses = UseTC; solve_unification_constraints = true; fail_evar = fail; expand_evars = true; @@ -1310,7 +1316,7 @@ let default_inference_flags fail = { } let no_classes_no_fail_inference_flags = { - use_typeclasses = false; + use_typeclasses = NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index abbb745161..8be7b1477b 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -44,8 +44,17 @@ type typing_constraint = | OfType of types (** A term of the expected type *) | WithoutTypeConstraint (** A term of unknown expected type *) +type use_typeclasses = NoUseTC | UseTCForConv | UseTC +(** Typeclasses are used in 2 ways: + +- through the "Typeclass Resolution For Conversion" option, if a + conversion problem fails we try again after resolving typeclasses + (UseTCForConv and UseTC) +- after pretyping we resolve typeclasses (UseTC) (in [solve_remaining_evars]) +*) + type inference_flags = { - use_typeclasses : bool; + use_typeclasses : use_typeclasses; solve_unification_constraints : bool; fail_evar : bool; expand_evars : bool; diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 1e4b537117..8bb268a92e 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -622,9 +622,8 @@ type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = evar_map -> constr -> constr * constr list -type contextual_state_reduction_function = +type state_reduction_function = env -> evar_map -> state -> state -type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state let pr_state env sigma (tm,sk) = @@ -716,7 +715,7 @@ let reducible_mind_case sigma c = match EConstr.kind sigma c with f x := t. End M. Definition f := u. and say goodbye to any hope of refolding M.f this way ... *) -let magicaly_constant_of_fixbody env sigma reference bd = function +let magically_constant_of_fixbody env sigma reference bd = function | Name.Anonymous -> bd | Name.Name id -> let open UnivProblem in @@ -758,7 +757,7 @@ let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbo | Some e -> match reference with | None -> bd - | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in + | Some r -> magically_constant_of_fixbody e sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -800,7 +799,7 @@ let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies | Some e -> match reference with | None -> bd - | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind).binder_name in + | Some r -> magically_constant_of_fixbody e sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -1571,10 +1570,6 @@ let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = (* Special-Purpose Reduction *) (********************************************************************) -let whd_meta sigma c = match EConstr.kind sigma c with - | Meta p -> (try meta_value sigma p with Not_found -> c) - | _ -> c - let default_plain_instance_ident = Id.of_string "H" (* Try to replace all metas. Does not replace metas in the metas' values @@ -1810,70 +1805,3 @@ let meta_instance sigma b = let nf_meta sigma c = let cl = mk_freelisted c in meta_instance sigma { cl with rebus = cl.rebus } - -(* Instantiate metas that create beta/iota redexes *) - -let meta_reducible_instance evd b = - let fm = b.freemetas in - let fold mv accu = - let fvalue = try meta_opt_fvalue evd mv with Not_found -> None in - match fvalue with - | None -> accu - | Some (g, (_, s)) -> Metamap.add mv (g.rebus, s) accu - in - let metas = Metaset.fold fold fm Metamap.empty in - let rec irec u = - let u = whd_betaiota Evd.empty u (* FIXME *) in - match EConstr.kind evd u with - | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> - let m = destMeta evd (strip_outer_cast evd c) in - (match - try - let g, s = Metamap.find m metas in - let is_coerce = match s with CoerceToType -> true | _ -> false in - if isConstruct evd g || not is_coerce then Some g else None - with Not_found -> None - with - | Some g -> irec (mkCase (ci,p,g,bl)) - | None -> mkCase (ci,irec p,c,Array.map irec bl)) - | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> - let m = destMeta evd (strip_outer_cast evd f) in - (match - try - let g, s = Metamap.find m metas in - let is_coerce = match s with CoerceToType -> true | _ -> false in - if isLambda evd g || not is_coerce then Some g else None - with Not_found -> None - with - | Some g -> irec (mkApp (g,l)) - | None -> mkApp (f,Array.map irec l)) - | Meta m -> - (try let g, s = Metamap.find m metas in - let is_coerce = match s with CoerceToType -> true | _ -> false in - if not is_coerce then irec g else u - with Not_found -> u) - | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) (* What if two nested casts? *) -> - let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) (* idem *) in - (match - try - let g, s = Metamap.find m metas in - let is_coerce = match s with CoerceToType -> true | _ -> false in - if isConstruct evd g || not is_coerce then Some g else None - with Not_found -> None - with - | Some g -> irec (mkProj (p,g)) - | None -> mkProj (p,c)) - | _ -> EConstr.map evd irec u - in - if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus - else irec b.rebus - -let betazetaevar_applist sigma n c l = - let rec stacklam n env t stack = - if Int.equal n 0 then applist (substl env t, stack) else - match EConstr.kind sigma t, stack with - | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack - | Evar _, _ -> applist (substl env t, stack) - | _ -> anomaly (Pp.str "Not enough lambda/let's.") in - stacklam n [] c l diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5202380a13..243a2745f0 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -139,9 +139,8 @@ type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = evar_map -> constr -> constr * constr list -type contextual_state_reduction_function = +type state_reduction_function = env -> evar_map -> state -> state -type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state val pr_state : env -> evar_map -> state -> Pp.t @@ -203,8 +202,8 @@ val whd_nored_state : local_state_reduction_function val whd_beta_state : local_state_reduction_function val whd_betaiota_state : local_state_reduction_function val whd_betaiotazeta_state : local_state_reduction_function -val whd_all_state : contextual_state_reduction_function -val whd_allnolet_state : contextual_state_reduction_function +val whd_all_state : state_reduction_function +val whd_allnolet_state : state_reduction_function val whd_betalet_state : local_state_reduction_function (** {6 Head normal forms } *) @@ -309,13 +308,6 @@ val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> TransparentState.t -> ?catch_incon:bool -> ?pb:conv_pb -> ?ts:TransparentState.t -> env -> evar_map -> constr -> constr -> evar_map option -(** {6 Special-Purpose Reduction Functions } *) - -val whd_meta : local_reduction_function -val plain_instance : evar_map -> constr Metamap.t -> constr -> constr -val instance : evar_map -> constr Metamap.t -> constr -> constr -val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr - (** {6 Heuristic for Conversion with Evar } *) val whd_betaiota_deltazeta_for_iota_state : @@ -324,4 +316,3 @@ val whd_betaiota_deltazeta_for_iota_state : (** {6 Meta-related reduction functions } *) val meta_instance : evar_map -> constr freelisted -> constr val nf_meta : evar_map -> constr -> constr -val meta_reducible_instance : evar_map -> constr freelisted -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 821c57d033..1f091c3df8 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -97,6 +97,16 @@ let decomp_sort env sigma t = let destSort sigma s = ESorts.kind sigma (destSort sigma s) +let betazetaevar_applist sigma n c l = + let rec stacklam n env t stack = + if Int.equal n 0 then applist (substl env t, stack) else + match EConstr.kind sigma t, stack with + | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl + | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack + | Evar _, _ -> applist (substl env t, stack) + | _ -> anomaly (Pp.str "Not enough lambda/let's.") in + stacklam n [] c l + let retype ?(polyprop=true) sigma = let rec type_of env cstr = match EConstr.kind sigma cstr with diff --git a/pretyping/unification.ml b/pretyping/unification.ml index ec3fb0758e..90dde01915 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -87,6 +87,12 @@ let occur_meta_or_undefined_evar evd c = | _ -> Constr.iter occrec c in try occrec c; false with Occur | Not_found -> true +let whd_meta sigma c = match EConstr.kind sigma c with + | Meta p -> + (try Evd.meta_value sigma p with Not_found -> c) + (* Not recursive, for some reason *) + | _ -> c + let occur_meta_evd sigma mv c = let rec occrec c = (* Note: evars are not instantiated by terms with metas *) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 64068724af..d4da93cc5b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -73,7 +73,7 @@ let type_constructor mind mib u (ctx, typ) params = if Int.equal ndecls 0 then ctyp else let _,ctyp = decompose_prod_n_assum ndecls ctyp in - substl (List.rev (adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params))) + substl (subst_of_rel_context_instance mib.mind_params_ctxt (Array.to_list params)) ctyp diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index fb91ea7b5c..3a6424ba9f 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -85,8 +85,6 @@ let log_out_ch = ref stdout let cprintf s = cfprintf !log_out_ch s [@@@ocaml.warning "+32"] -module StringMap = Map.Make(String);; - let tokenize_string s = (* todo: cLexer changes buff as it proceeds. Seems like that should be saved, too. But I don't understand how it's used--it looks like things get appended to it but @@ -98,18 +96,17 @@ let tokenize_string s = else stream_tok ((Tok.extract_string true e) :: acc) str in - let st = CLexer.get_lexer_state () in + let st = CLexer.Lexer.State.get () in try let istr = Stream.of_string s in let lex = CLexer.LexerDiff.tok_func istr in let toks = stream_tok [] (fst lex) in - CLexer.set_lexer_state st; + CLexer.Lexer.State.set st; toks with exn -> - CLexer.set_lexer_state st; + CLexer.Lexer.State.set st; raise (Diff_Failure "Input string is not lexable");; - type hyp_info = { idents: string list; rhs_pp: Pp.t; @@ -124,22 +121,22 @@ type hyp_info = { let diff_hyps o_line_idents o_map n_line_idents n_map = let rv : Pp.t list ref = ref [] in - let is_done ident map = (StringMap.find ident map).done_ in + let is_done ident map = (CString.Map.find ident map).done_ in let exists ident map = - try let _ = StringMap.find ident map in true + try let _ = CString.Map.find ident map in true with Not_found -> false in let contains l ident = try [List.find (fun x -> x = ident) l] with Not_found -> [] in let output old_ids_uo new_ids = (* use the order from the old line in case it's changed in the new *) let old_ids = if old_ids_uo = [] then [] else - let orig = (StringMap.find (List.hd old_ids_uo) o_map).idents in + let orig = (CString.Map.find (List.hd old_ids_uo) o_map).idents in List.concat (List.map (contains orig) old_ids_uo) in let setup ids map = if ids = [] then ("", Pp.mt ()) else let open Pp in - let rhs_pp = (StringMap.find (List.hd ids) map).rhs_pp in + let rhs_pp = (CString.Map.find (List.hd ids) map).rhs_pp in let pp_ids = List.map (fun x -> str x) ids in let hyp_pp = List.fold_left (fun l1 l2 -> l1 ++ str ", " ++ l2) (List.hd pp_ids) (List.tl pp_ids) ++ rhs_pp in (string_of_ppcmds hyp_pp, hyp_pp) @@ -151,11 +148,11 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = let hyp_diffs = diff_str ~tokenize_string o_line n_line in let (has_added, has_removed) = has_changes hyp_diffs in if show_removed () && has_removed then begin - List.iter (fun x -> (StringMap.find x o_map).done_ <- true) old_ids; + List.iter (fun x -> (CString.Map.find x o_map).done_ <- true) old_ids; rv := (add_diff_tags `Removed o_pp hyp_diffs) :: !rv; end; if n_line <> "" then begin - List.iter (fun x -> (StringMap.find x n_map).done_ <- true) new_ids; + List.iter (fun x -> (CString.Map.find x n_map).done_ <- true) new_ids; rv := (add_diff_tags `Added n_pp hyp_diffs) :: !rv end in @@ -166,14 +163,14 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = match dtype with | `Removed -> if dtype = `Removed then begin - let o_idents = (StringMap.find ident o_map).idents in + let o_idents = (CString.Map.find ident o_map).idents in (* only show lines that have all idents removed here; other removed idents appear later *) if show_removed () && not (is_done ident o_map) && List.for_all (fun x -> not (exists x n_map)) o_idents then output (List.rev o_idents) [] end | _ -> begin (* Added or Common case *) - let n_idents = (StringMap.find ident n_map).idents in + let n_idents = (CString.Map.find ident n_map).idents in (* Process a new hyp line, possibly splitting it. Duplicates some of process_ident iteration, but easier to understand this way *) @@ -184,13 +181,13 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = let fst_omap_idents = ref None in let add ids id map = ids := id :: !ids; - (StringMap.find id map).done_ <- true in + (CString.Map.find id map).done_ <- true in (* get identifiers shared by one old and one new line, plus other Added in new and other Removed in old *) let process_split ident3 = if not (is_done ident3 n_map) then begin - let this_omap_idents = try Some (StringMap.find ident3 o_map).idents + let this_omap_idents = try Some (CString.Map.find ident3 o_map).idents with Not_found -> None in if !fst_omap_idents = None then fst_omap_idents := this_omap_idents; @@ -290,7 +287,7 @@ map will contain: concl_pp is the conclusion as a Pp.t *) let goal_info goal sigma = - let map = ref StringMap.empty in + let map = ref CString.Map.empty in let line_idents = ref [] in let build_hyp_info env sigma hyp = let (names, body, ty) = hyp in @@ -308,7 +305,7 @@ let goal_info goal sigma = let rhs_pp = mid ++ str " : " ++ ts in let make_entry () = { idents; rhs_pp; done_ = false } in - List.iter (fun ident -> map := (StringMap.add ident (make_entry ()) !map); ()) idents + List.iter (fun ident -> map := (CString.Map.add ident (make_entry ()) !map); ()) idents in try @@ -339,7 +336,7 @@ let unwrap g_s = let goal = Evd.sig_it g_s in let sigma = Refiner.project g_s in goal_info goal sigma - | None -> ([], StringMap.empty, Pp.mt ()) + | None -> ([], CString.Map.empty, Pp.mt ()) let diff_goal_ide og_s ng nsigma = diff_goal_info (unwrap og_s) (goal_info ng nsigma) @@ -405,7 +402,7 @@ the call to db_goal_map and entering the following: (conj (conj ?Goal0 ?Goal1) ?Goal) <--- goal 4 is still the rightmost goal in the proof *) let match_goals ot nt = - let nevar_to_oevar = ref StringMap.empty in + let nevar_to_oevar = ref CString.Map.empty in (* ogname is "" when there is no difference on the current path. It's set to the old goal's evar name once a rewritten goal is found, at which point the code only searches for the replacing goals @@ -514,7 +511,7 @@ let match_goals ot nt = | CPatVar _, CPatVar _ -> () | CEvar (n,l), CEvar (n2,l2) -> let oevar = if ogname = "" then Id.to_string n else ogname in - nevar_to_oevar := StringMap.add (Id.to_string n2) oevar !nevar_to_oevar; + nevar_to_oevar := CString.Map.add (Id.to_string n2) oevar !nevar_to_oevar; iter2 (fun x x2 -> let (_, g) = x and (_, g2) = x2 in constr_expr ogname g g2) l l2 | CEvar (n,l), nt' -> (* pass down the old goal evar name *) @@ -641,16 +638,16 @@ let make_goal_map_i op np = (* >= 2 removals, >= 1 addition, need to match *) let nevar_to_oevar = match_goals (Some (to_constr op)) (to_constr np) in - let oevar_to_og = ref StringMap.empty in + let oevar_to_og = ref CString.Map.empty in let Proof.{sigma=osigma} = Proof.data op in - List.iter (fun og -> oevar_to_og := StringMap.add (goal_to_evar og osigma) og !oevar_to_og) + List.iter (fun og -> oevar_to_og := CString.Map.add (goal_to_evar og osigma) og !oevar_to_og) (Goal.Set.elements rem_gs); let Proof.{sigma=nsigma} = Proof.data np in let get_og ng = let nevar = goal_to_evar ng nsigma in - let oevar = StringMap.find nevar nevar_to_oevar in - let og = StringMap.find oevar !oevar_to_og in + let oevar = CString.Map.find nevar nevar_to_oevar in + let og = CString.Map.find oevar !oevar_to_og in og in Goal.Set.iter (fun ng -> diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index 83e721d3d5..24b171770a 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -83,11 +83,4 @@ type hyp_info = { mutable done_: bool; } -module StringMap : -sig - type +'a t - val empty: hyp_info t - val add : string -> hyp_info -> hyp_info t -> hyp_info t -end - -val diff_hyps : string list list -> hyp_info StringMap.t -> string list list -> hyp_info StringMap.t -> Pp.t list +val diff_hyps : string list list -> hyp_info CString.Map.t -> string list list -> hyp_info CString.Map.t -> Pp.t list diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 83ef91bfd9..37d54a4eea 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -249,6 +249,63 @@ let clenv_dependent ce = clenv_dependent_gen false ce (******************************************************************) +(* Instantiate metas that create beta/iota redexes *) + +let meta_reducible_instance evd b = + let fm = b.freemetas in + let fold mv accu = + let fvalue = try meta_opt_fvalue evd mv with Not_found -> None in + match fvalue with + | None -> accu + | Some (g, (_, s)) -> Metamap.add mv (g.rebus, s) accu + in + let metas = Metaset.fold fold fm Metamap.empty in + let rec irec u = + let u = whd_betaiota Evd.empty u (* FIXME *) in + match EConstr.kind evd u with + | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> + let m = destMeta evd (strip_outer_cast evd c) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isConstruct evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkCase (ci,p,g,bl)) + | None -> mkCase (ci,irec p,c,Array.map irec bl)) + | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> + let m = destMeta evd (strip_outer_cast evd f) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isLambda evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkApp (g,l)) + | None -> mkApp (f,Array.map irec l)) + | Meta m -> + (try let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if not is_coerce then irec g else u + with Not_found -> u) + | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) (* What if two nested casts? *) -> + let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) (* idem *) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isConstruct evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkProj (p,g)) + | None -> mkProj (p,c)) + | _ -> EConstr.map evd irec u + in + if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus + else irec b.rebus + let clenv_unify ?(flags=default_unify_flags ()) cv_pb t1 t2 clenv = { clenv with evd = w_unify ~flags clenv.env clenv.evd cv_pb t1 t2 } diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 000b34ed0a..53254e9511 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -50,7 +50,7 @@ let w_refine (evk,evi) (ltac_var,rawc) env sigma = let env = Evd.evar_filtered_env env evi in let sigma',typed_c = let flags = { - Pretyping.use_typeclasses = true; + Pretyping.use_typeclasses = Pretyping.UseTC; Pretyping.solve_unification_constraints = true; Pretyping.fail_evar = false; Pretyping.expand_evars = true; diff --git a/proofs/goal.ml b/proofs/goal.ml index ede68e63b9..b1f8fd3e97 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -131,4 +131,4 @@ module V82 = struct end -module Set = Set.Make(struct type t = goal let compare = Evar.compare end) +module Set = Evar.Set diff --git a/stm/stm.ml b/stm/stm.ml index 62556d38ff..5b88ee3d68 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1501,7 +1501,7 @@ end = struct (* {{{ *) let wall_clock2 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); - let p = PG_compat.return_proof ~allow_partial:drop_pt () in + let p = if drop_pt then PG_compat.return_partial_proof () else PG_compat.return_proof () in if drop_pt then feedback ~id Complete; p) @@ -1522,15 +1522,15 @@ end = struct (* {{{ *) let st = State.freeze () in if not drop then begin let checked_proof = Future.chain future_proof (fun p -> - let opaque = Proof_global.Opaque in (* Unfortunately close_future_proof and friends are not pure so we need to set the state manually here *) State.unfreeze st; let pobject, _info = - PG_compat.close_future_proof ~opaque ~feedback_id:stop (Future.from_val ~fix_exn p) in + PG_compat.close_future_proof ~feedback_id:stop (Future.from_val ~fix_exn p) in let st = Vernacstate.freeze_interp_state ~marshallable:false in + let opaque = Proof_global.Opaque in stm_qed_delay_proof ~st ~id:stop ~proof:pobject ~info:(Lemmas.Info.make ()) ~loc ~control:[] (Proved (opaque,None))) in ignore(Future.join checked_proof); @@ -1661,14 +1661,14 @@ end = struct (* {{{ *) try Reach.known_state ~doc:dummy_doc (* XXX should be document *) ~cache:false stop; if drop then - let _proof = PG_compat.return_proof ~allow_partial:true () in + let _proof = PG_compat.return_partial_proof () in `OK_ADMITTED else begin let opaque = Proof_global.Opaque in (* The original terminator, a hook, has not been saved in the .vio*) let proof, _info = - PG_compat.close_proof ~opaque ~keep_body_ucst_separate:true (fun x -> x) in + PG_compat.close_proof ~opaque ~keep_body_ucst_separate:true in let info = Lemmas.Info.make () in @@ -2479,13 +2479,13 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = ~drop_pt exn_info block_stop, ref false in qed.fproof <- Some (Some fp, cancel); - let opaque = match keep' with - | VtKeepAxiom | VtKeepOpaque -> - Proof_global.Opaque (* Admitted -> Opaque should be OK. *) - | VtKeepDefined -> Proof_global.Transparent + let () = match keep' with + | VtKeepAxiom | VtKeepOpaque -> () + | VtKeepDefined -> + CErrors.anomaly (Pp.str "Cannot delegate transparent proofs, this is a bug in the STM.") in let proof, info = - PG_compat.close_future_proof ~opaque ~feedback_id:id fp in + PG_compat.close_future_proof ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in @@ -2518,9 +2518,11 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepOpaque -> Opaque | VtKeepDefined -> Transparent | VtKeepAxiom -> assert false in - Some(PG_compat.close_proof ~opaque - ~keep_body_ucst_separate:false - (State.exn_on id ~valid:eop)) in + try Some (PG_compat.close_proof ~opaque ~keep_body_ucst_separate:false) + with exn -> + let iexn = Exninfo.capture exn in + Exninfo.iraise (State.exn_on id ~valid:eop iexn) + in if keep <> VtKeep VtKeepAxiom then reach view.next; let wall_clock2 = Unix.gettimeofday () in diff --git a/tactics/declare.ml b/tactics/declare.ml index 5e6f78be6f..324007930a 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -187,14 +187,14 @@ let record_aux env s_ty s_bo = let default_univ_entry = Monomorphic_entry Univ.ContextSet.empty -let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types - ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) body = - { proof_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); - proof_entry_secctx = None; +let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?feedback_id ?section_vars ?types + ?(univs=default_univ_entry) ?(eff=Evd.empty_side_effects) ?(univsbody=Univ.ContextSet.empty) body = + { proof_entry_body = Future.from_val ?fix_exn ((body,univsbody), eff); + proof_entry_secctx = section_vars; proof_entry_type = types; proof_entry_universes = univs; proof_entry_opaque = opaque; - proof_entry_feedback = None; + proof_entry_feedback = feedback_id; proof_entry_inline_code = inline} let pure_definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types diff --git a/tactics/declare.mli b/tactics/declare.mli index 0068b9842a..615cffeae7 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -59,9 +59,14 @@ val definition_entry : ?fix_exn:Future.fix_exn -> ?opaque:bool -> ?inline:bool + -> ?feedback_id:Stateid.t + -> ?section_vars:Id.Set.t -> ?types:types -> ?univs:Entries.universes_entry -> ?eff:Evd.side_effects + -> ?univsbody:Univ.ContextSet.t + (** Universe-constraints attached to the body-only, used in + vio-delayed opaque constants and private poly universes *) -> constr -> Evd.side_effects proof_entry diff --git a/tactics/pfedit.ml b/tactics/pfedit.ml index b228a04298..22d0ce5328 100644 --- a/tactics/pfedit.ml +++ b/tactics/pfedit.ml @@ -122,7 +122,7 @@ let build_constant_by_tactic ~name ?(opaque=Proof_global.Transparent) ~uctx ~sig let pf = Proof_global.start_proof ~name ~poly ~udecl:UState.default_univ_decl evd goals in let pf, status = by tac pf in let open Proof_global in - let { entries; uctx } = close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pf in + let { entries; uctx } = close_proof ~opaque ~keep_body_ucst_separate:false pf in match entries with | [entry] -> entry, status, uctx diff --git a/tactics/proof_global.ml b/tactics/proof_global.ml index 623e6b8a42..d7dcc13e79 100644 --- a/tactics/proof_global.ml +++ b/tactics/proof_global.ml @@ -18,9 +18,9 @@ module NamedDecl = Context.Named.Declaration type proof_object = { name : Names.Id.t + (* [name] only used in the STM *) ; entries : Evd.side_effects Declare.proof_entry list ; uctx: UState.t - ; udecl : UState.universe_decl } type opacity_flag = Opaque | Transparent @@ -118,8 +118,7 @@ let set_used_variables ps l = Environ.fold_named_context aux env ~init:(ctx,ctx_set) in if not (Option.is_empty ps.section_vars) then CErrors.user_err Pp.(str "Used section variables can be declared only once"); - (* EJGA: This is always empty thus we should modify the type *) - (ctx, []), { ps with section_vars = Some (Context.Named.to_vars ctx) } + ctx, { ps with section_vars = Some (Context.Named.to_vars ctx) } let get_open_goals ps = let Proof.{ goals; stack; shelf } = Proof.data ps.proof in @@ -141,110 +140,8 @@ let private_poly_univs = in fun () -> !b -let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now - (fpl : closed_proof_output Future.computation) ps = - let { section_vars; proof; udecl; initial_euctx } = ps in - let Proof.{ name; poly; entry } = Proof.data proof in - let opaque = match opaque with Opaque -> true | Transparent -> false in - let constrain_variables ctx = - UState.constrain_variables (fst (UState.context_set initial_euctx)) ctx - in - let fpl, univs = Future.split2 fpl in - let uctx = if poly || now then Future.force univs else initial_euctx in - (* Because of dependent subgoals at the beginning of proofs, we could - have existential variables in the initial types of goals, we need to - normalise them for the kernel. *) - let subst_evar k = - let { Proof.sigma } = Proof.data proof in - Evd.existential_opt_value0 sigma k in - let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar - (UState.subst uctx) in - - let make_body = - if poly || now then - let make_body t (c, eff) = - let body = c in - let allow_deferred = - not poly && (keep_body_ucst_separate || - not (Safe_typing.empty_private_constants = eff.Evd.seff_private)) - in - let typ = if allow_deferred then t else nf t in - let used_univs_body = Vars.universes_of_constr body in - let used_univs_typ = Vars.universes_of_constr typ in - if allow_deferred then - let initunivs = UState.univ_entry ~poly initial_euctx in - let ctx = constrain_variables uctx in - (* For vi2vo compilation proofs are computed now but we need to - complement the univ constraints of the typ with the ones of - the body. So we keep the two sets distinct. *) - let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx_body = UState.restrict ctx used_univs in - let univs = UState.check_mono_univ_decl ctx_body udecl in - (initunivs, typ), ((body, univs), eff) - else if poly && opaque && private_poly_univs () then - let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let universes = UState.restrict uctx used_univs in - let typus = UState.restrict universes used_univs_typ in - let udecl = UState.check_univ_decl ~poly typus udecl in - let ubody = Univ.ContextSet.diff - (UState.context_set universes) - (UState.context_set typus) - in - (udecl, typ), ((body, ubody), eff) - else - (* Since the proof is computed now, we can simply have 1 set of - constraints in which we merge the ones for the body and the ones - for the typ. We recheck the declaration after restricting with - the actually used universes. - TODO: check if restrict is really necessary now. *) - let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx = UState.restrict uctx used_univs in - let univs = UState.check_univ_decl ~poly ctx udecl in - (univs, typ), ((body, Univ.ContextSet.empty), eff) - in - fun t p -> Future.split2 (Future.chain p (make_body t)) - else - fun t p -> - (* Already checked the univ_decl for the type universes when starting the proof. *) - let univctx = UState.univ_entry ~poly:false uctx in - let t = nf t in - Future.from_val (univctx, t), - Future.chain p (fun (pt,eff) -> - (* Deferred proof, we already checked the universe declaration with - the initial universes, ensure that the final universes respect - the declaration as well. If the declaration is non-extensible, - this will prevent the body from adding universes and constraints. *) - let univs = Future.force univs in - let univs = constrain_variables univs in - let used_univs = Univ.LSet.union - (Vars.universes_of_constr t) - (Vars.universes_of_constr pt) - in - let univs = UState.restrict univs used_univs in - let univs = UState.check_mono_univ_decl univs udecl in - (pt,univs),eff) - in - let entry_fn p (_, t) = - let t = EConstr.Unsafe.to_constr t in - let univstyp, body = make_body t p in - let univs, typ = Future.force univstyp in - Declare.delayed_definition_entry ~opaque ?feedback_id ?section_vars ~univs ~types:typ body - in - let entries = Future.map2 entry_fn fpl (Proofview.initial_goals entry) in - { name; entries; uctx; udecl } - -let return_proof ?(allow_partial=false) ps = - let { proof } = ps in - if allow_partial then begin - let proofs = Proof.partial_proof proof in - let Proof.{sigma=evd} = Proof.data proof in - let eff = Evd.eval_side_effects evd in - (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate - side-effects... This may explain why one need to uniquize side-effects - thereafter... *) - let proofs = List.map (fun c -> EConstr.Unsafe.to_constr c, eff) proofs in - proofs, Evd.evar_universe_context evd - end else +(* XXX: This is still separate from close_proof below due to drop_pt in the STM *) +let return_proof { proof } = let Proof.{name=pid;entry} = Proof.data proof in let initial_goals = Proofview.initial_goals entry in let evd = Proof.return ~pid proof in @@ -266,16 +163,122 @@ let return_proof ?(allow_partial=false) ps = code-paths that generate several proof entries are derive and equations and so far there is no code in the CI that will actually call those and do a side-effect, TTBOMK *) - let proofs = - List.map (fun (c, _) -> (proof_opt c, eff)) initial_goals in - proofs, Evd.evar_universe_context evd + (* EJGA: likely the right solution is to attach side effects to the first constant only? *) + let proofs = List.map (fun (c, _) -> (proof_opt c, eff)) initial_goals in + proofs, Evd.evar_universe_context evd -let close_future_proof ~opaque ~feedback_id ps proof = - close_proof ~opaque ~keep_body_ucst_separate:true ~feedback_id ~now:false proof ps +let close_proof ~opaque ~keep_body_ucst_separate ps = + let elist, uctx = return_proof ps in + let { section_vars; proof; udecl; initial_euctx } = ps in + let { Proof.name; poly; entry; sigma } = Proof.data proof in + let opaque = match opaque with Opaque -> true | Transparent -> false in + + (* Because of dependent subgoals at the beginning of proofs, we could + have existential variables in the initial types of goals, we need to + normalise them for the kernel. *) + let subst_evar k = Evd.existential_opt_value0 sigma k in + let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst uctx) in -let close_proof ~opaque ~keep_body_ucst_separate fix_exn ps = - close_proof ~opaque ~keep_body_ucst_separate ~now:true - (Future.from_val ~fix_exn (return_proof ps)) ps + let make_entry (body, eff) (_, typ) = + let allow_deferred = + not poly && (keep_body_ucst_separate || + not (Safe_typing.empty_private_constants = eff.Evd.seff_private)) + in + (* EJGA: Why are we doing things this way? *) + let typ = EConstr.Unsafe.to_constr typ in + let typ = if allow_deferred then typ else nf typ in + (* EJGA: End "Why are we doing things this way?" *) + + let used_univs_body = Vars.universes_of_constr body in + let used_univs_typ = Vars.universes_of_constr typ in + let used_univs = Univ.LSet.union used_univs_body used_univs_typ in + let utyp, ubody = + if allow_deferred then + let utyp = UState.univ_entry ~poly initial_euctx in + let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in + (* For vi2vo compilation proofs are computed now but we need to + complement the univ constraints of the typ with the ones of + the body. So we keep the two sets distinct. *) + let uctx_body = UState.restrict uctx used_univs in + let ubody = UState.check_mono_univ_decl uctx_body udecl in + utyp, ubody + else if poly && opaque && private_poly_univs () then + let universes = UState.restrict uctx used_univs in + let typus = UState.restrict universes used_univs_typ in + let utyp = UState.check_univ_decl ~poly typus udecl in + let ubody = Univ.ContextSet.diff + (UState.context_set universes) + (UState.context_set typus) + in + utyp, ubody + else + (* Since the proof is computed now, we can simply have 1 set of + constraints in which we merge the ones for the body and the ones + for the typ. We recheck the declaration after restricting with + the actually used universes. + TODO: check if restrict is really necessary now. *) + let ctx = UState.restrict uctx used_univs in + let utyp = UState.check_univ_decl ~poly ctx udecl in + utyp, Univ.ContextSet.empty + in + Declare.definition_entry ~opaque ?section_vars ~univs:utyp ~univsbody:ubody ~types:typ ~eff body + in + let entries = CList.map2 make_entry elist (Proofview.initial_goals entry) in + { name; entries; uctx } + +let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.computation) = + let { section_vars; proof; udecl; initial_euctx } = ps in + let { Proof.name; poly; entry; sigma } = Proof.data proof in + + (* We don't allow poly = true in this path *) + if poly then + CErrors.anomaly (Pp.str "Cannot delay universe-polymorphic constants."); + + let fpl, uctx = Future.split2 fpl in + (* Because of dependent subgoals at the beginning of proofs, we could + have existential variables in the initial types of goals, we need to + normalise them for the kernel. *) + let subst_evar k = Evd.existential_opt_value0 sigma k in + let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar (UState.subst initial_euctx) in + + (* We only support opaque proofs, this will be enforced by using + different entries soon *) + let opaque = true in + let make_entry p (_, types) = + (* Already checked the univ_decl for the type universes when starting the proof. *) + let univs = UState.univ_entry ~poly:false initial_euctx in + let types = nf (EConstr.Unsafe.to_constr types) in + + Future.chain p (fun (pt,eff) -> + (* Deferred proof, we already checked the universe declaration with + the initial universes, ensure that the final universes respect + the declaration as well. If the declaration is non-extensible, + this will prevent the body from adding universes and constraints. *) + let uctx = Future.force uctx in + let uctx = UState.constrain_variables (fst (UState.context_set initial_euctx)) uctx in + let used_univs = Univ.LSet.union + (Vars.universes_of_constr types) + (Vars.universes_of_constr pt) + in + let univs = UState.restrict uctx used_univs in + let univs = UState.check_mono_univ_decl univs udecl in + (pt,univs),eff) + |> Declare.delayed_definition_entry ~opaque ~feedback_id ?section_vars ~univs ~types + in + let entries = Future.map2 make_entry fpl (Proofview.initial_goals entry) in + { name; entries; uctx = initial_euctx } + +let close_future_proof = close_proof_delayed + +let return_partial_proof { proof } = + let proofs = Proof.partial_proof proof in + let Proof.{sigma=evd} = Proof.data proof in + let eff = Evd.eval_side_effects evd in + (* ppedrot: FIXME, this is surely wrong. There is no reason to duplicate + side-effects... This may explain why one need to uniquize side-effects + thereafter... *) + let proofs = List.map (fun c -> EConstr.Unsafe.to_constr c, eff) proofs in + proofs, Evd.evar_universe_context evd let update_global_env = map_proof (fun p -> diff --git a/tactics/proof_global.mli b/tactics/proof_global.mli index e1c75c0649..874708ded8 100644 --- a/tactics/proof_global.mli +++ b/tactics/proof_global.mli @@ -33,8 +33,6 @@ type proof_object = (** list of the proof terms (in a form suitable for definitions). *) ; uctx: UState.t (** universe state *) - ; udecl : UState.universe_decl - (** universe declaration *) } type opacity_flag = Opaque | Transparent @@ -69,7 +67,7 @@ val update_global_env : t -> t (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) -val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> t -> proof_object +val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> t -> proof_object (* Intermediate step necessary to delegate the future. * Both access the current proof state. The former is supposed to be @@ -77,11 +75,13 @@ val close_proof : opaque:opacity_flag -> keep_body_ucst_separate:bool -> Future. type closed_proof_output -(* If allow_partial is set (default no) then an incomplete proof - * is allowed (no error), and a warn is given if the proof is complete. *) -val return_proof : ?allow_partial:bool -> t -> closed_proof_output -val close_future_proof : opaque:opacity_flag -> feedback_id:Stateid.t -> t -> - closed_proof_output Future.computation -> proof_object +(** Requires a complete proof. *) +val return_proof : t -> closed_proof_output + +(** An incomplete proof is allowed (no error), and a warn is given if + the proof is complete. *) +val return_partial_proof : t -> closed_proof_output +val close_future_proof : feedback_id:Stateid.t -> t -> closed_proof_output Future.computation -> proof_object val get_open_goals : t -> int @@ -93,7 +93,6 @@ val map_fold_proof_endline : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) val set_endline_tactic : Genarg.glob_generic_argument -> t -> t (** Sets the section variables assumed by the proof, returns its closure - * (w.r.t. type dependencies and let-ins covered by it) + a list of - * ids to be cleared *) + * (w.r.t. type dependencies and let-ins covered by it) *) val set_used_variables : t -> - Names.Id.t list -> (Constr.named_context * Names.lident list) * t + Names.Id.t list -> Constr.named_context * t diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index 250c80d9a5..db09a2e69e 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -37,7 +37,7 @@ let warn_native_compute_disabled = strbrk "native_compute disabled at configure time; falling back to vm_compute.") let cbv_native env sigma c = - if Coq_config.native_compiler then + if Flags.get_native_compiler () then let ctyp = Retyping.get_type_of env sigma c in Nativenorm.native_norm env sigma c ctyp else diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 30ca024a2f..c79aca3d3c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1223,7 +1223,7 @@ let rec intros_move = function or a term with bindings *) let tactic_infer_flags with_evar = { - Pretyping.use_typeclasses = true; + Pretyping.use_typeclasses = Pretyping.UseTC; Pretyping.solve_unification_constraints = true; Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true; diff --git a/test-suite/Makefile b/test-suite/Makefile index 0d8a6ebed7..eade52b6eb 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -38,7 +38,8 @@ ROOT='$(shell cd ..; pwd)' ifneq ($(wildcard ../_build),) BIN:=$(ROOT)/_build/install/default/bin/ -COQLIB:=$(ROOT)/_build/install/default/lib/coq +# COQLIB is an env variable so no quotes +COQLIB:=$(shell cd ..; pwd)/_build/install/default/lib/coq else BIN := $(ROOT)/bin/ diff --git a/test-suite/bugs/closed/HoTT_coq_010.v b/test-suite/bugs/closed/HoTT_coq_010.v index 42b1244fb5..caa7373f5e 100644 --- a/test-suite/bugs/closed/HoTT_coq_010.v +++ b/test-suite/bugs/closed/HoTT_coq_010.v @@ -1,3 +1,3 @@ -SearchAbout and. +Search and. (* Anomaly: Mismatched instance and context when building universe substitution. Please report. *) diff --git a/test-suite/bugs/closed/bug_11585.v b/test-suite/bugs/closed/bug_11585.v new file mode 100644 index 0000000000..6294668323 --- /dev/null +++ b/test-suite/bugs/closed/bug_11585.v @@ -0,0 +1,3 @@ +Fail Inductive type {type : Type} : Type := T : type. + +Inductive type {type : Type} : Type := T . diff --git a/test-suite/bugs/closed/bug_11941.v b/test-suite/bugs/closed/bug_11941.v new file mode 100644 index 0000000000..87cb462991 --- /dev/null +++ b/test-suite/bugs/closed/bug_11941.v @@ -0,0 +1,5 @@ +Inductive Box A := box (_:A). +Inductive unit := tt. +Definition t := unit. +Record foo := { bar : Box t }. +Fail Scheme Equality for foo. diff --git a/test-suite/bugs/closed/bug_3900.v b/test-suite/bugs/closed/bug_3900.v index 6be2161c2f..ddede74acc 100644 --- a/test-suite/bugs/closed/bug_3900.v +++ b/test-suite/bugs/closed/bug_3900.v @@ -9,5 +9,5 @@ Variable Pmor : forall s d : obj, morphism A (projT1 s) (projT1 d) -> Type. Class Foo (x : Type) := { _ : forall y, y }. Local Instance ishset_pmor {s d m} : Foo (Pmor s d m). Proof. -SearchAbout ((forall _ _, _) -> Foo _). +Search ((forall _ _, _) -> Foo _). Abort. diff --git a/test-suite/bugs/closed/bug_5233.v b/test-suite/bugs/closed/bug_5233.v index 06286c740d..63e33b63f7 100644 --- a/test-suite/bugs/closed/bug_5233.v +++ b/test-suite/bugs/closed/bug_5233.v @@ -1,2 +1,5 @@ (* Implicit arguments on type were missing for recursive records *) Inductive foo {A : Type} : Type := { Foo : foo }. + +(* Implicit arguments can be overidden *) +Inductive bar {A : Type} : Type := { Bar : @bar (A*A) }. diff --git a/test-suite/output/FloatExtraction.out b/test-suite/output/FloatExtraction.out index cfd6633752..dd8189c56f 100644 --- a/test-suite/output/FloatExtraction.out +++ b/test-suite/output/FloatExtraction.out @@ -1,3 +1,17 @@ +File "stdin", line 25, characters 8-12: +Warning: The constant 0.01 is not a binary64 floating-point value. A closest +value will be used and unambiguously printed 0.01. [inexact-float,parsing] +File "stdin", line 25, characters 20-25: +Warning: The constant -0.01 is not a binary64 floating-point value. A closest +value will be used and unambiguously printed -0.01. [inexact-float,parsing] +File "stdin", line 25, characters 27-35: +Warning: The constant 1.7e+308 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed 1.6999999999999999e+308. +[inexact-float,parsing] +File "stdin", line 25, characters 37-46: +Warning: The constant -1.7e-308 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed +-1.7000000000000002e-308. [inexact-float,parsing] (** val infinity : Float64.t **) diff --git a/test-suite/output/FloatSyntax.out b/test-suite/output/FloatSyntax.out index 668a55977d..7941d2e647 100644 --- a/test-suite/output/FloatSyntax.out +++ b/test-suite/output/FloatSyntax.out @@ -4,8 +4,16 @@ : float (-2.5)%float : float +File "stdin", line 9, characters 6-13: +Warning: The constant 2.5e123 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed 2.4999999999999999e+123. +[inexact-float,parsing] 2.4999999999999999e+123%float : float +File "stdin", line 10, characters 7-16: +Warning: The constant -2.5e-123 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed +-2.5000000000000001e-123. [inexact-float,parsing] (-2.5000000000000001e-123)%float : float (2 + 2)%float @@ -18,14 +26,34 @@ : float -2.5 : float +File "stdin", line 19, characters 6-13: +Warning: The constant 2.5e123 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed 2.4999999999999999e+123. +[inexact-float,parsing] 2.4999999999999999e+123 : float +File "stdin", line 20, characters 7-16: +Warning: The constant -2.5e-123 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed +-2.5000000000000001e-123. [inexact-float,parsing] -2.5000000000000001e-123 : float 2 + 2 : float 2.5 + 2.5 : float +File "stdin", line 24, characters 6-11: +Warning: The constant 1e309 is not a binary64 floating-point value. A closest +value will be used and unambiguously printed infinity. +[inexact-float,parsing] +infinity + : float +File "stdin", line 25, characters 6-12: +Warning: The constant -1e309 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed neg_infinity. +[inexact-float,parsing] +neg_infinity + : float 2 : nat 2%float diff --git a/test-suite/output/FloatSyntax.v b/test-suite/output/FloatSyntax.v index 85f611352c..eca712db10 100644 --- a/test-suite/output/FloatSyntax.v +++ b/test-suite/output/FloatSyntax.v @@ -21,6 +21,9 @@ Check (-2.5e-123). Check (2 + 2). Check (2.5 + 2.5). +Check 1e309. +Check -1e309. + Open Scope nat_scope. Check 2. diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index ff2556c5dc..e6c2806433 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -1,6 +1,10 @@ The command has indeed failed with message: -Last occurrence of "list'" must have "A" as 1st argument in - "A -> list' A -> list' (A * A)%type". +In environment +list' : Set -> Set +A : Set +a : A +l : list' A +Unable to unify "list' (A * A)%type" with "list' A". Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x Arguments foo _%type_scope diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out index 4f09f00c56..bdfa8afb6a 100644 --- a/test-suite/output/PatternsInBinders.out +++ b/test-suite/output/PatternsInBinders.out @@ -4,7 +4,7 @@ fun '(x, y) => (y, x) : A * B -> B * A forall '(x, y), swap (x, y) = (y, x) : Prop -proj_informative = fun '(exist _ x _) => x : A +proj_informative = fun '(exist _ x _) => x : {x : A | P x} -> A foo = fun '(Bar n b tt p) => if b then n + p else n - p : Foo -> nat @@ -29,8 +29,7 @@ exists '(x, y) '(z, w), swap (x, y) = (z, w) ∀ '(x, y), swap (x, y) = (y, x) : Prop both_z = -fun pat : nat * nat => -let '(n, p) as x := pat return (F x) in (Z n, Z p) : F (n, p) +fun pat : nat * nat => let '(n, p) as x := pat return (F x) in (Z n, Z p) : forall pat : nat * nat, F pat fun '(x, y) '(z, t) => swap (x, y) = (z, t) : A * B -> B * A -> Prop diff --git a/test-suite/success/ConversionOrder.v b/test-suite/success/ConversionOrder.v new file mode 100644 index 0000000000..1e0b4dbf23 --- /dev/null +++ b/test-suite/success/ConversionOrder.v @@ -0,0 +1,16 @@ +(* The kernel may convert application arguments right to left, + resulting in ill-typed terms, but should be robust to them. *) + +Inductive Hide := hide : forall A, A -> Hide. + +Lemma foo : (hide Type Type) = (hide (nat -> Type) (fun x : nat => Type)). +Proof. + Fail reflexivity. + match goal with |- ?l = _ => exact_no_check (eq_refl l) end. + Fail Defined. +Abort. + +Definition HideMore (_:Hide) := 0. + +Definition foo : HideMore (hide Type Type) = HideMore (hide (nat -> Type) (fun x : nat => Type)) + := eq_refl. diff --git a/test-suite/success/InductiveVsImplicitsVsTC.v b/test-suite/success/InductiveVsImplicitsVsTC.v new file mode 100644 index 0000000000..a98de32b70 --- /dev/null +++ b/test-suite/success/InductiveVsImplicitsVsTC.v @@ -0,0 +1,26 @@ +Module NoConv. + Class C := {}. + + Definition useC {c:C} := nat. + + Inductive foo {a b : C} := CC : useC -> foo. + (* If TC search runs before parameter unification it will pick the + wrong instance for the first parameter. + + useC makes sure we don't completely skip TC search. + *) +End NoConv. + +Module ForConv. + + Class Bla := { bla : Type }. + + Instance bli : Bla := { bla := nat }. + + Inductive vs := C : forall x : bla, x = 2 -> vs. + (* here we need to resolve TC to pass the conversion problem if we + combined with the previous example it would fail as TC resolution + for conversion is unrestricted and so would resolve the + conclusion too early. *) + +End ForConv. diff --git a/test-suite/success/search.v b/test-suite/success/search.v new file mode 100644 index 0000000000..92de43e052 --- /dev/null +++ b/test-suite/success/search.v @@ -0,0 +1,35 @@ + +(** Test of the different syntaxes of Search *) + +Search plus. +Search plus mult. +Search "plus_n". +Search plus "plus_n". +Search "*". +Search "*" "+". + +Search plus inside Peano. +Search plus mult inside Peano. +Search "plus_n" inside Peano. +Search plus "plus_n" inside Peano. +Search "*" inside Peano. +Search "*" "+" inside Peano. + +Search plus outside Peano Logic. +Search plus mult outside Peano Logic. +Search "plus_n" outside Peano Logic. +Search plus "plus_n" outside Peano Logic. +Search "*" outside Peano Logic. +Search "*" "+" outside Peano Logic. + +Search -"*" "+" outside Logic. +Search -"*"%nat "+"%nat outside Logic. + + +(** The example in the Reference Manual *) + +Require Import ZArith. + +Search Z.mul Z.add "distr". +Search "+"%Z "*"%Z "distr" -positive -Prop. +Search (?x * _ + ?x * _)%Z outside OmegaLemmas. diff --git a/test-suite/success/searchabout.v b/test-suite/success/searchabout.v deleted file mode 100644 index 9edfd82556..0000000000 --- a/test-suite/success/searchabout.v +++ /dev/null @@ -1,60 +0,0 @@ - -(** Test of the different syntaxes of SearchAbout, in particular - with and without the [ ... ] delimiters *) - -SearchAbout plus. -SearchAbout plus mult. -SearchAbout "plus_n". -SearchAbout plus "plus_n". -SearchAbout "*". -SearchAbout "*" "+". - -SearchAbout plus inside Peano. -SearchAbout plus mult inside Peano. -SearchAbout "plus_n" inside Peano. -SearchAbout plus "plus_n" inside Peano. -SearchAbout "*" inside Peano. -SearchAbout "*" "+" inside Peano. - -SearchAbout plus outside Peano Logic. -SearchAbout plus mult outside Peano Logic. -SearchAbout "plus_n" outside Peano Logic. -SearchAbout plus "plus_n" outside Peano Logic. -SearchAbout "*" outside Peano Logic. -SearchAbout "*" "+" outside Peano Logic. - -SearchAbout -"*" "+" outside Logic. -SearchAbout -"*"%nat "+"%nat outside Logic. - -SearchAbout [plus]. -SearchAbout [plus mult]. -SearchAbout ["plus_n"]. -SearchAbout [plus "plus_n"]. -SearchAbout ["*"]. -SearchAbout ["*" "+"]. - -SearchAbout [plus] inside Peano. -SearchAbout [plus mult] inside Peano. -SearchAbout ["plus_n"] inside Peano. -SearchAbout [plus "plus_n"] inside Peano. -SearchAbout ["*"] inside Peano. -SearchAbout ["*" "+"] inside Peano. - -SearchAbout [plus] outside Peano Logic. -SearchAbout [plus mult] outside Peano Logic. -SearchAbout ["plus_n"] outside Peano Logic. -SearchAbout [plus "plus_n"] outside Peano Logic. -SearchAbout ["*"] outside Peano Logic. -SearchAbout ["*" "+"] outside Peano Logic. - -SearchAbout [-"*" "+"] outside Logic. -SearchAbout [-"*"%nat "+"%nat] outside Logic. - - -(** The example in the Reference Manual *) - -Require Import ZArith. - -SearchAbout Z.mul Z.add "distr". -SearchAbout "+"%Z "*"%Z "distr" -positive -Prop. -SearchAbout (?x * _ + ?x * _)%Z outside OmegaLemmas. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 6126d9c37d..71ba3e645d 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -43,5 +43,5 @@ Numeral Notation nat Nat.of_uint Nat.to_uint : nat_scope (abstract after 5001). (* Printing/Parsing of bytes *) Export Byte.ByteSyntaxNotations. -(* Default substrings not considered by queries like SearchAbout *) +(* Default substrings not considered by queries like Search *) Add Search Blacklist "_subproof" "_subterm" "Private_". diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index f0011fe147..d68c32b371 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -943,6 +943,64 @@ Proof. destruct p; simpl; trivial. Qed. +(** ** Properties of [iter] *) + +Lemma iter_swap_gen : forall A B (f:A -> B) (g:A -> A) (h:B -> B), + (forall a, f (g a) = h (f a)) -> forall n a, + f (iter n g a) = iter n h (f a). +Proof. + destruct n; simpl; intros; rewrite ?H; trivial. + now apply Pos.iter_swap_gen. +Qed. + +Theorem iter_swap : + forall n (A:Type) (f:A -> A) (x:A), + iter n f (f x) = f (iter n f x). +Proof. + intros. symmetry. now apply iter_swap_gen. +Qed. + +Theorem iter_succ : + forall n (A:Type) (f:A -> A) (x:A), + iter (succ n) f x = f (iter n f x). +Proof. + destruct n; intros; simpl; trivial. + now apply Pos.iter_succ. +Qed. + +Theorem iter_succ_r : + forall n (A:Type) (f:A -> A) (x:A), + iter (succ n) f x = iter n f (f x). +Proof. + intros; now rewrite iter_succ, iter_swap. +Qed. + +Theorem iter_add : + forall p q (A:Type) (f:A -> A) (x:A), + iter (p+q) f x = iter p f (iter q f x). +Proof. + induction p using peano_ind; intros; trivial. + now rewrite add_succ_l, !iter_succ, IHp. +Qed. + +Theorem iter_ind : + forall (A:Type) (f:A -> A) (a:A) (P:N -> A -> Prop), + P 0 a -> + (forall n a', P n a' -> P (succ n) (f a')) -> + forall n, P n (iter n f a). +Proof. + induction n using peano_ind; trivial. + rewrite iter_succ; auto. +Qed. + +Theorem iter_invariant : + forall (n:N) (A:Type) (f:A -> A) (Inv:A -> Prop), + (forall x:A, Inv x -> Inv (f x)) -> + forall x:A, Inv x -> Inv (iter n f x). +Proof. + intros; apply iter_ind with (P := fun _ => Inv); trivial. +Qed. + End N. Bind Scope N_scope with N.t N. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 1c790a37a0..f6b2544b6e 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -2226,7 +2226,7 @@ Section Int31_Specs. < ([|iter312_sqrt n rec ih il j|] + 1) ^ 2. Proof. revert rec ih il j; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n. - intros rec ih il j Hi Hj Hij Hrec; apply sqrt312_step_correct; auto with zarith. + intros rec ih il j Hi Hj Hij Hrec; apply sqrt312_step_correct. 1-3: lia. intros; apply Hrec. 2: rewrite Z.pow_0_r. 1-3: lia. intros n Hrec rec ih il j Hi Hj Hij HHrec. apply sqrt312_step_correct; auto. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index a8c645deb2..c4f738ac39 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -1316,9 +1316,8 @@ Lemma iter_sqrt_correct n rec i j: 0 < φ i -> 0 < φ j -> φ (iter_sqrt n rec i j) ^ 2 <= φ i < (φ (iter_sqrt n rec i j) + 1) ^ 2. Proof. revert rec i j; elim n; unfold iter_sqrt; fold iter_sqrt; clear n. - intros rec i j Hi Hj Hij H31 Hrec; apply sqrt_step_correct; auto with zarith. - intros; apply Hrec; auto with zarith. - rewrite Zpower_0_r; auto with zarith. + intros rec i j Hi Hj Hij H31 Hrec; apply sqrt_step_correct. 1-4: lia. + intros; apply Hrec; only 2: rewrite Zpower_0_r; auto with zarith. intros n Hrec rec i j Hi Hj Hij H31 HHrec. apply sqrt_step_correct; auto. intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. @@ -1516,9 +1515,8 @@ Lemma iter2_sqrt_correct n rec ih il j: < (φ (iter2_sqrt n rec ih il j) + 1) ^ 2. Proof. revert rec ih il j; elim n; unfold iter2_sqrt; fold iter2_sqrt; clear n. - intros rec ih il j Hi Hj Hij Hrec; apply sqrt2_step_correct; auto with zarith. - intros; apply Hrec; auto with zarith. - rewrite Zpower_0_r; auto with zarith. + intros rec ih il j Hi Hj Hij Hrec; apply sqrt2_step_correct. 1-3: lia. + intros; apply Hrec; only 2: rewrite Zpower_0_r; auto with zarith. intros n Hrec rec ih il j Hi Hj Hij HHrec. apply sqrt2_step_correct; auto. intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index 99e77fd596..387ab75362 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -597,6 +597,13 @@ Proof. now rewrite !IHp, iter_swap. Qed. +Theorem iter_succ_r : + forall p (A:Type) (f:A -> A) (x:A), + iter f x (succ p) = iter f (f x) p. +Proof. + intros; now rewrite iter_succ, iter_swap. +Qed. + Theorem iter_add : forall p q (A:Type) (f:A -> A) (x:A), iter f x (p+q) = iter f (iter f x q) p. @@ -606,14 +613,22 @@ Proof. now rewrite add_succ_l, !iter_succ, IHp. Qed. +Theorem iter_ind : + forall (A:Type) (f:A -> A) (a:A) (P:positive -> A -> Prop), + P 1 (f a) -> + (forall p a', P p a' -> P (succ p) (f a')) -> + forall p, P p (iter f a p). +Proof. + induction p using peano_ind; trivial. + rewrite iter_succ; auto. +Qed. + Theorem iter_invariant : forall (p:positive) (A:Type) (f:A -> A) (Inv:A -> Prop), (forall x:A, Inv x -> Inv (f x)) -> forall x:A, Inv x -> Inv (iter f x p). Proof. - induction p as [p IHp|p IHp|]; simpl; trivial. - intros A f Inv H x H0. apply H, IHp, IHp; trivial. - intros A f Inv H x H0. apply IHp, IHp; trivial. + intros; apply iter_ind with (P := fun _ => Inv); auto. Qed. (** ** Properties of power *) diff --git a/theories/Reals/Abstract/ConstructiveAbs.v b/theories/Reals/Abstract/ConstructiveAbs.v new file mode 100644 index 0000000000..d357ad2d54 --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveAbs.v @@ -0,0 +1,950 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +Require Import QArith. +Require Import Qabs. +Require Import ConstructiveReals. + +Local Open Scope ConstructiveReals. + +(** Properties of constructive absolute value (defined in + ConstructiveReals.CRabs). + Definition of minimum, maximum and their properties. *) + +Instance CRabs_morph + : forall {R : ConstructiveReals}, + CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CReq R)) (CRabs R). +Proof. + intros R x y [H H0]. split. + - rewrite <- CRabs_def. split. + + apply (CRle_trans _ x). apply H. + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1. apply CRle_refl. + + apply (CRle_trans _ (CRopp R x)). intro abs. + apply CRopp_lt_cancel in abs. contradiction. + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1. apply CRle_refl. + - rewrite <- CRabs_def. split. + + apply (CRle_trans _ y). apply H0. + pose proof (CRabs_def R y (CRabs R y)) as [_ H1]. + apply H1. apply CRle_refl. + + apply (CRle_trans _ (CRopp R y)). intro abs. + apply CRopp_lt_cancel in abs. contradiction. + pose proof (CRabs_def R y (CRabs R y)) as [_ H1]. + apply H1. apply CRle_refl. +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRabs R) + with signature CReq R ==> CReq R + as CRabs_morph_prop. +Proof. + intros. apply CRabs_morph, H. +Qed. + +Lemma CRabs_right : forall {R : ConstructiveReals} (x : CRcarrier R), + 0 <= x -> CRabs R x == x. +Proof. + intros. split. + - pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1, CRle_refl. + - rewrite <- CRabs_def. split. apply CRle_refl. + apply (CRle_trans _ (CRzero R)). 2: exact H. + apply (CRle_trans _ (CRopp R (CRzero R))). + intro abs. apply CRopp_lt_cancel in abs. contradiction. + apply (CRplus_le_reg_l (CRzero R)). + apply (CRle_trans _ (CRzero R)). apply CRplus_opp_r. + apply CRplus_0_r. +Qed. + +Lemma CRabs_opp : forall {R : ConstructiveReals} (x : CRcarrier R), + CRabs R (- x) == CRabs R x. +Proof. + intros. split. + - rewrite <- CRabs_def. split. + + pose proof (CRabs_def R (CRopp R x) (CRabs R (CRopp R x))) as [_ H1]. + specialize (H1 (CRle_refl (CRabs R (CRopp R x)))) as [_ H1]. + apply (CRle_trans _ (CRopp R (CRopp R x))). + 2: exact H1. apply (CRopp_involutive x). + + pose proof (CRabs_def R (CRopp R x) (CRabs R (CRopp R x))) as [_ H1]. + apply H1, CRle_refl. + - rewrite <- CRabs_def. split. + + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1, CRle_refl. + + apply (CRle_trans _ x). apply CRopp_involutive. + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1, CRle_refl. +Qed. + +Lemma CRabs_minus_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs R (x - y) == CRabs R (y - x). +Proof. + intros R x y. setoid_replace (x - y) with (-(y-x)). + rewrite CRabs_opp. reflexivity. unfold CRminus. + rewrite CRopp_plus_distr, CRplus_comm, CRopp_involutive. + reflexivity. +Qed. + +Lemma CRabs_left : forall {R : ConstructiveReals} (x : CRcarrier R), + x <= 0 -> CRabs R x == - x. +Proof. + intros. rewrite <- CRabs_opp. apply CRabs_right. + rewrite <- CRopp_0. apply CRopp_ge_le_contravar, H. +Qed. + +Lemma CRabs_triang : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs R (x + y) <= CRabs R x + CRabs R y. +Proof. + intros. rewrite <- CRabs_def. split. + - apply (CRle_trans _ (CRplus R (CRabs R x) y)). + apply CRplus_le_compat_r. + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1, CRle_refl. + apply CRplus_le_compat_l. + pose proof (CRabs_def R y (CRabs R y)) as [_ H1]. + apply H1, CRle_refl. + - apply (CRle_trans _ (CRplus R (CRopp R x) (CRopp R y))). + apply CRopp_plus_distr. + apply (CRle_trans _ (CRplus R (CRabs R x) (CRopp R y))). + apply CRplus_le_compat_r. + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1, CRle_refl. + apply CRplus_le_compat_l. + pose proof (CRabs_def R y (CRabs R y)) as [_ H1]. + apply H1, CRle_refl. +Qed. + +Lemma CRabs_le : forall {R : ConstructiveReals} (a b:CRcarrier R), + (-b <= a /\ a <= b) -> CRabs R a <= b. +Proof. + intros. pose proof (CRabs_def R a b) as [H0 _]. + apply H0. split. apply H. destruct H. + rewrite <- (CRopp_involutive b). + apply CRopp_ge_le_contravar. exact H. +Qed. + +Lemma CRabs_triang_inv : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs R x - CRabs R y <= CRabs R (x - y). +Proof. + intros. apply (CRplus_le_reg_r (CRabs R y)). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l. + rewrite CRplus_0_r. + apply (CRle_trans _ (CRabs R (x - y + y))). + setoid_replace (x - y + y) with x. apply CRle_refl. + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l. + rewrite CRplus_0_r. reflexivity. + apply CRabs_triang. +Qed. + +Lemma CRabs_triang_inv2 : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs R (CRabs R x - CRabs R y) <= CRabs R (x - y). +Proof. + intros. apply CRabs_le. split. + 2: apply CRabs_triang_inv. + apply (CRplus_le_reg_r (CRabs R y)). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l. + rewrite CRplus_0_r. fold (x - y). + rewrite CRplus_comm, CRabs_minus_sym. + apply (CRle_trans _ _ _ (CRabs_triang_inv y (y-x))). + setoid_replace (y - (y - x)) with x. apply CRle_refl. + unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc. + rewrite CRplus_opp_r, CRplus_0_l. apply CRopp_involutive. +Qed. + +Lemma CR_of_Q_abs : forall {R : ConstructiveReals} (q : Q), + CRabs R (CR_of_Q R q) == CR_of_Q R (Qabs q). +Proof. + intros. destruct (Qlt_le_dec 0 q). + - apply (CReq_trans _ (CR_of_Q R q)). + apply CRabs_right. apply (CRle_trans _ (CR_of_Q R 0)). + apply CR_of_Q_zero. apply CR_of_Q_le. apply Qlt_le_weak, q0. + apply CR_of_Q_morph. symmetry. apply Qabs_pos, Qlt_le_weak, q0. + - apply (CReq_trans _ (CR_of_Q R (-q))). + apply (CReq_trans _ (CRabs R (CRopp R (CR_of_Q R q)))). + apply CReq_sym, CRabs_opp. + 2: apply CR_of_Q_morph; symmetry; apply Qabs_neg, q0. + apply (CReq_trans _ (CRopp R (CR_of_Q R q))). + 2: apply CReq_sym, CR_of_Q_opp. + apply CRabs_right. apply (CRle_trans _ (CR_of_Q R 0)). + apply CR_of_Q_zero. + apply (CRle_trans _ (CR_of_Q R (-q))). apply CR_of_Q_le. + apply (Qplus_le_l _ _ q). ring_simplify. exact q0. + apply CR_of_Q_opp. +Qed. + +Lemma CRle_abs : forall {R : ConstructiveReals} (x : CRcarrier R), + x <= CRabs R x. +Proof. + intros. pose proof (CRabs_def R x (CRabs R x)) as [_ H]. + apply H, CRle_refl. +Qed. + +Lemma CRabs_pos : forall {R : ConstructiveReals} (x : CRcarrier R), + 0 <= CRabs R x. +Proof. + intros. intro abs. destruct (CRltLinear R). clear p. + specialize (s _ x _ abs). destruct s. + exact (CRle_abs x c). rewrite CRabs_left in abs. + rewrite <- CRopp_0 in abs. apply CRopp_lt_cancel in abs. + exact (CRlt_asym _ _ abs c). apply CRlt_asym, c. +Qed. + +Lemma CRabs_appart_0 : forall {R : ConstructiveReals} (x : CRcarrier R), + 0 < CRabs R x -> x ≶ 0. +Proof. + intros. destruct (CRltLinear R). clear p. + pose proof (s _ x _ H) as [pos|neg]. + right. exact pos. left. + destruct (CR_Q_dense R _ _ neg) as [q [H0 H1]]. + destruct (Qlt_le_dec 0 q). + - destruct (s (CR_of_Q R (-q)) x 0). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. + apply (Qplus_lt_l _ _ q). ring_simplify. exact q0. + exfalso. pose proof (CRabs_def R x (CR_of_Q R q)) as [H2 _]. + apply H2. clear H2. split. apply CRlt_asym, H0. + 2: exact H1. rewrite <- Qopp_involutive, CR_of_Q_opp. + apply CRopp_ge_le_contravar, CRlt_asym, c. exact c. + - apply (CRlt_le_trans _ _ _ H0). + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. exact q0. +Qed. + + +(* The proof by cases on the signs of x and y applies constructively, + because of the positivity hypotheses. *) +Lemma CRabs_mult : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs R (x * y) == CRabs R x * CRabs R y. +Proof. + intro R. + assert (forall (x y : CRcarrier R), + x ≶ 0 + -> y ≶ 0 + -> CRabs R (x * y) == CRabs R x * CRabs R y) as prep. + { intros. destruct H, H0. + + rewrite CRabs_right, CRabs_left, CRabs_left. + rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r, CRopp_involutive. + reflexivity. + apply CRlt_asym, c0. apply CRlt_asym, c. + setoid_replace (x*y) with (- x * - y). + apply CRlt_asym, CRmult_lt_0_compat. + rewrite <- CRopp_0. apply CRopp_gt_lt_contravar, c. + rewrite <- CRopp_0. apply CRopp_gt_lt_contravar, c0. + rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r, CRopp_involutive. + reflexivity. + + rewrite CRabs_left, CRabs_left, CRabs_right. + rewrite <- CRopp_mult_distr_l. reflexivity. + apply CRlt_asym, c0. apply CRlt_asym, c. + rewrite <- (CRmult_0_l y). + apply CRmult_le_compat_r_half. exact c0. + apply CRlt_asym, c. + + rewrite CRabs_left, CRabs_right, CRabs_left. + rewrite <- CRopp_mult_distr_r. reflexivity. + apply CRlt_asym, c0. apply CRlt_asym, c. + rewrite <- (CRmult_0_r x). + apply CRmult_le_compat_l_half. + exact c. apply CRlt_asym, c0. + + rewrite CRabs_right, CRabs_right, CRabs_right. reflexivity. + apply CRlt_asym, c0. apply CRlt_asym, c. + apply CRlt_asym, CRmult_lt_0_compat; assumption. } + split. + - intro abs. + assert (0 < CRabs R x * CRabs R y). + { apply (CRle_lt_trans _ (CRabs R (x*y))). + apply CRabs_pos. exact abs. } + pose proof (CRmult_pos_appart_zero _ _ H). + rewrite CRmult_comm in H. + apply CRmult_pos_appart_zero in H. + destruct H. 2: apply (CRabs_pos y c). + destruct H0. 2: apply (CRabs_pos x c0). + apply CRabs_appart_0 in c. + apply CRabs_appart_0 in c0. + rewrite (prep x y) in abs. + exact (CRlt_asym _ _ abs abs). exact c0. exact c. + - intro abs. + assert (0 < CRabs R (x * y)). + { apply (CRle_lt_trans _ (CRabs R x * CRabs R y)). + rewrite <- (CRmult_0_l (CRabs R y)). + apply CRmult_le_compat_r. + apply CRabs_pos. apply CRabs_pos. exact abs. } + apply CRabs_appart_0 in H. destruct H. + + apply CRopp_gt_lt_contravar in c. + rewrite CRopp_0, CRopp_mult_distr_l in c. + pose proof (CRmult_pos_appart_zero _ _ c). + rewrite CRmult_comm in c. + apply CRmult_pos_appart_zero in c. + rewrite (prep x y) in abs. + exact (CRlt_asym _ _ abs abs). + destruct H. left. apply CRopp_gt_lt_contravar in c0. + rewrite CRopp_involutive, CRopp_0 in c0. exact c0. + right. apply CRopp_gt_lt_contravar in c0. + rewrite CRopp_involutive, CRopp_0 in c0. exact c0. + destruct c. right. exact c. left. exact c. + + pose proof (CRmult_pos_appart_zero _ _ c). + rewrite CRmult_comm in c. + apply CRmult_pos_appart_zero in c. + rewrite (prep x y) in abs. + exact (CRlt_asym _ _ abs abs). + destruct H. right. exact c0. left. exact c0. + destruct c. right. exact c. left. exact c. +Qed. + +Lemma CRabs_lt : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs _ x < y -> prod (x < y) (-x < y). +Proof. + split. + - apply (CRle_lt_trans _ _ _ (CRle_abs x)), H. + - apply (CRle_lt_trans _ _ _ (CRle_abs (-x))). + rewrite CRabs_opp. exact H. +Qed. + +Lemma CRabs_def1 : forall {R : ConstructiveReals} (x y : CRcarrier R), + x < y -> -x < y -> CRabs _ x < y. +Proof. + intros. destruct (CRltLinear R), p. + destruct (s x (CRabs R x) y H). 2: exact c0. + rewrite CRabs_left. exact H0. intro abs. + rewrite CRabs_right in c0. exact (CRlt_asym x x c0 c0). + apply CRlt_asym, abs. +Qed. + +Lemma CRabs_def2 : forall {R : ConstructiveReals} (x a:CRcarrier R), + CRabs _ x <= a -> (x <= a) /\ (- a <= x). +Proof. + split. + - exact (CRle_trans _ _ _ (CRle_abs _) H). + - rewrite <- (CRopp_involutive x). + apply CRopp_ge_le_contravar. + rewrite <- CRabs_opp in H. + exact (CRle_trans _ _ _ (CRle_abs _) H). +Qed. + + +(* Minimum *) + +Definition CRmin {R : ConstructiveReals} (x y : CRcarrier R) : CRcarrier R + := (x + y - CRabs _ (y - x)) * CR_of_Q _ (1#2). + +Lemma CRmin_lt_r : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y < y -> CRmin x y == x. +Proof. + intros. unfold CRmin. unfold CRmin in H. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left; apply CR_of_Q_pos; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l, CRmult_1_r. + rewrite CRabs_right. unfold CRminus. + rewrite CRopp_plus_distr, CRplus_assoc, <- (CRplus_assoc y). + rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity. + apply (CRmult_lt_compat_r (CR_of_Q R 2)) in H. + 2: apply CR_of_Q_pos; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult in H. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in H. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r in H. + rewrite CRmult_comm, (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_r, + CRmult_1_l in H. + intro abs. rewrite CRabs_left in H. + unfold CRminus in H. + rewrite CRopp_involutive, CRplus_comm in H. + rewrite CRplus_assoc, <- (CRplus_assoc (-x)), CRplus_opp_l in H. + rewrite CRplus_0_l in H. exact (CRlt_asym _ _ H H). + apply CRlt_asym, abs. +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : CRmin + with signature (CReq R) ==> (CReq R) ==> (CReq R) + as CRmin_morph. +Proof. + intros. unfold CRmin. + apply CRmult_morph. 2: reflexivity. + unfold CRminus. + rewrite H, H0. reflexivity. +Qed. + +Instance CRmin_morphT + : forall {R : ConstructiveReals}, + CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (@CRmin R). +Proof. + intros R x y H z t H0. + rewrite H, H0. reflexivity. +Qed. + +Lemma CRmin_l : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y <= x. +Proof. + intros. unfold CRmin. + apply (CRmult_le_reg_r (CR_of_Q R 2)). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_r (CRabs _ (y + - x)+ -x)). + rewrite CRplus_assoc, <- (CRplus_assoc (-CRabs _ (y + - x))). + rewrite CRplus_opp_l, CRplus_0_l. + rewrite (CRplus_comm x), CRplus_assoc, CRplus_opp_l, CRplus_0_r. + apply CRle_abs. +Qed. + +Lemma CRmin_r : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y <= y. +Proof. + intros. unfold CRmin. + apply (CRmult_le_reg_r (CR_of_Q R 2)). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite (CRplus_comm x). + unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite <- (CRopp_involutive y), <- CRopp_plus_distr, <- CRopp_plus_distr. + apply CRopp_ge_le_contravar. rewrite CRabs_opp, CRplus_comm. + apply CRle_abs. +Qed. + +Lemma CRnegPartAbsMin : forall {R : ConstructiveReals} (x : CRcarrier R), + CRmin 0 x == (x - CRabs _ x) * (CR_of_Q _ (1#2)). +Proof. + intros. unfold CRmin. unfold CRminus. rewrite CRplus_0_l. + apply CRmult_morph. 2: reflexivity. rewrite CRopp_0, CRplus_0_r. reflexivity. +Qed. + +Lemma CRmin_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y == CRmin y x. +Proof. + intros. unfold CRmin. apply CRmult_morph. 2: reflexivity. + rewrite CRabs_minus_sym. unfold CRminus. + rewrite (CRplus_comm x y). reflexivity. +Qed. + +Lemma CRmin_mult : + forall {R : ConstructiveReals} (p q r : CRcarrier R), + 0 <= r -> CRmin (r * p) (r * q) == r * CRmin p q. +Proof. + intros R p q r H. unfold CRmin. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_right r). 2: exact H. + rewrite <- CRmult_assoc. apply CRmult_morph. 2: reflexivity. + unfold CRminus. rewrite CRopp_mult_distr_r. + do 2 rewrite <- CRmult_plus_distr_l. reflexivity. + unfold CRminus. rewrite CRopp_mult_distr_r. + rewrite <- CRmult_plus_distr_l. reflexivity. +Qed. + +Lemma CRmin_plus : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x + CRmin y z == CRmin (x + y) (x + z). +Proof. + intros. unfold CRmin. + unfold CRminus. setoid_replace (x + z + - (x + y)) with (z-y). + apply (CRmult_eq_reg_r (CR_of_Q _ 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_plus_distr_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + do 3 rewrite (CRplus_assoc x). apply CRplus_morph. reflexivity. + do 2 rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite (CRplus_comm x). apply CRplus_assoc. + rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. + apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. + apply CRplus_0_l. +Qed. + +Lemma CRmin_left : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= y -> CRmin x y == x. +Proof. + intros. unfold CRmin. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRabs_right. unfold CRminus. rewrite CRopp_plus_distr. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. apply CRopp_involutive. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat. + exact H. apply CRle_refl. +Qed. + +Lemma CRmin_right : forall {R : ConstructiveReals} (x y : CRcarrier R), + y <= x -> CRmin x y == y. +Proof. + intros. unfold CRmin. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRabs_left. unfold CRminus. do 2 rewrite CRopp_plus_distr. + rewrite (CRplus_comm x y). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + do 2 rewrite CRopp_involutive. + rewrite CRplus_comm, CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat. + exact H. apply CRle_refl. +Qed. + +Lemma CRmin_lt : forall {R : ConstructiveReals} (x y z : CRcarrier R), + z < x -> z < y -> z < CRmin x y. +Proof. + intros. unfold CRmin. + apply (CRmult_lt_reg_r (CR_of_Q R 2)). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + apply (CRplus_lt_reg_l _ (CRabs _ (y - x) - (z*CR_of_Q R 2))). + unfold CRminus. rewrite CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_r. + rewrite (CRplus_comm (CRabs R (y + - x))). + rewrite (CRplus_comm (x+y)), CRplus_assoc. + rewrite <- (CRplus_assoc (CRabs R (y + - x))), CRplus_opp_r, CRplus_0_l. + rewrite <- (CRplus_comm (x+y)). + apply CRabs_def1. + - unfold CRminus. rewrite <- (CRplus_comm y), CRplus_assoc. + apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l R (-x)). + rewrite CRopp_mult_distr_l. + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym. + apply CRopp_gt_lt_contravar, H. + apply CRopp_gt_lt_contravar, H. + - rewrite CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_comm, CRplus_assoc. + apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l R (-y)). + rewrite CRopp_mult_distr_l. + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym. + apply CRopp_gt_lt_contravar, H0. + apply CRopp_gt_lt_contravar, H0. +Qed. + +Lemma CRmin_contract : forall {R : ConstructiveReals} (x y a : CRcarrier R), + CRabs _ (CRmin x a - CRmin y a) <= CRabs _ (x - y). +Proof. + intros. unfold CRmin. + unfold CRminus. rewrite CRopp_mult_distr_l, <- CRmult_plus_distr_r. + rewrite (CRabs_morph + _ ((x - y + (CRabs _ (a - y) - CRabs _ (a - x))) * CR_of_Q R (1 # 2))). + rewrite CRabs_mult, (CRabs_right (CR_of_Q R (1 # 2))). + 2: rewrite <- CR_of_Q_zero; apply CR_of_Q_le; discriminate. + apply (CRle_trans _ + ((CRabs _ (x - y) * 1 + CRabs _ (x-y) * 1) + * CR_of_Q R (1 # 2))). + apply CRmult_le_compat_r. + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. + apply (CRle_trans + _ (CRabs _ (x - y) + CRabs _ (CRabs _ (a - y) - CRabs _ (a - x)))). + apply CRabs_triang. rewrite CRmult_1_r. apply CRplus_le_compat_l. + rewrite (CRabs_morph (x-y) ((a-y)-(a-x))). + apply CRabs_triang_inv2. + unfold CRminus. rewrite (CRplus_comm (a + - y)). + rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, CRopp_plus_distr, <- CRplus_assoc. + rewrite CRplus_opp_r, CRopp_involutive, CRplus_0_l. + reflexivity. + rewrite <- CRmult_plus_distr_l, <- CR_of_Q_one. + rewrite <- (CR_of_Q_plus R 1 1). + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. apply CRle_refl. + unfold CRminus. apply CRmult_morph. 2: reflexivity. + do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc. rewrite CRplus_comm, CRopp_plus_distr. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRopp_plus_distr. rewrite (CRplus_comm (-a)). + rewrite CRplus_assoc, <- (CRplus_assoc (-a)), CRplus_opp_l. + rewrite CRplus_0_l, CRopp_involutive. reflexivity. +Qed. + +Lemma CRmin_glb : forall {R : ConstructiveReals} (x y z:CRcarrier R), + z <= x -> z <= y -> z <= CRmin x y. +Proof. + intros. unfold CRmin. + apply (CRmult_le_reg_r (CR_of_Q R 2)). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + apply (CRplus_le_reg_l (CRabs _ (y-x) - (z*CR_of_Q R 2))). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + rewrite (CRplus_comm (CRabs R (y + - x) + - (z * CR_of_Q R 2))). + rewrite CRplus_assoc, <- (CRplus_assoc (- CRabs R (y + - x))). + rewrite CRplus_opp_l, CRplus_0_l. + apply CRabs_le. split. + - do 2 rewrite CRopp_plus_distr. + rewrite CRopp_involutive, (CRplus_comm y), CRplus_assoc. + apply CRplus_le_compat_l, (CRplus_le_reg_l y). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_compat; exact H0. + - rewrite (CRplus_comm x), CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite CRopp_mult_distr_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. + apply CRplus_le_compat; apply CRopp_ge_le_contravar; exact H. +Qed. + +Lemma CRmin_assoc : forall {R : ConstructiveReals} (a b c : CRcarrier R), + CRmin a (CRmin b c) == CRmin (CRmin a b) c. +Proof. + split. + - apply CRmin_glb. + + apply (CRle_trans _ (CRmin a b)). + apply CRmin_l. apply CRmin_l. + + apply CRmin_glb. + apply (CRle_trans _ (CRmin a b)). + apply CRmin_l. apply CRmin_r. apply CRmin_r. + - apply CRmin_glb. + + apply CRmin_glb. apply CRmin_l. + apply (CRle_trans _ (CRmin b c)). + apply CRmin_r. apply CRmin_l. + + apply (CRle_trans _ (CRmin b c)). + apply CRmin_r. apply CRmin_r. +Qed. + +Lemma CRlt_min : forall {R : ConstructiveReals} (x y z : CRcarrier R), + z < CRmin x y -> prod (z < x) (z < y). +Proof. + intros. destruct (CR_Q_dense R _ _ H) as [q qmaj]. + destruct qmaj. + split. + - apply (CRlt_le_trans _ (CR_of_Q R q) _ c). + intro abs. apply (CRlt_asym _ _ c0). + apply (CRle_lt_trans _ x). apply CRmin_l. exact abs. + - apply (CRlt_le_trans _ (CR_of_Q R q) _ c). + intro abs. apply (CRlt_asym _ _ c0). + apply (CRle_lt_trans _ y). apply CRmin_r. exact abs. +Qed. + + + +(* Maximum *) + +Definition CRmax {R : ConstructiveReals} (x y : CRcarrier R) : CRcarrier R + := (x + y + CRabs _ (y - x)) * CR_of_Q _ (1#2). + +Add Parametric Morphism {R : ConstructiveReals} : CRmax + with signature (CReq R) ==> (CReq R) ==> (CReq R) + as CRmax_morph. +Proof. + intros. unfold CRmax. + apply CRmult_morph. 2: reflexivity. unfold CRminus. + rewrite H, H0. reflexivity. +Qed. + +Instance CRmax_morphT + : forall {R : ConstructiveReals}, + CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (@CRmax R). +Proof. + intros R x y H z t H0. + rewrite H, H0. reflexivity. +Qed. + +Lemma CRmax_lub : forall {R : ConstructiveReals} (x y z:CRcarrier R), + x <= z -> y <= z -> CRmax x y <= z. +Proof. + intros. unfold CRmax. + apply (CRmult_le_reg_r (CR_of_Q _ 2)). rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + apply (CRplus_le_reg_l (-x-y)). + rewrite <- CRplus_assoc. unfold CRminus. + rewrite <- CRopp_plus_distr, CRplus_opp_l, CRplus_0_l. + apply CRabs_le. split. + - repeat rewrite CRopp_plus_distr. + do 2 rewrite CRopp_involutive. + rewrite (CRplus_comm x), CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRopp_plus_distr. + apply CRplus_le_compat; apply CRopp_ge_le_contravar; assumption. + - rewrite (CRplus_comm y), CRopp_plus_distr, CRplus_assoc. + apply CRplus_le_compat_l. + apply (CRplus_le_reg_l y). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + apply CRplus_le_compat; assumption. +Qed. + +Lemma CRmax_l : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= CRmax x y. +Proof. + intros. unfold CRmax. + apply (CRmult_le_reg_r (CR_of_Q R 2)). rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + setoid_replace 2%Q with (1+1)%Q. rewrite CR_of_Q_plus, CR_of_Q_one. + rewrite CRmult_plus_distr_l, CRmult_1_r, CRplus_assoc. + apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-y)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite CRabs_minus_sym, CRplus_comm. + apply CRle_abs. reflexivity. +Qed. + +Lemma CRmax_r : forall {R : ConstructiveReals} (x y : CRcarrier R), + y <= CRmax x y. +Proof. + intros. unfold CRmax. + apply (CRmult_le_reg_r (CR_of_Q _ 2)). rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite (CRplus_comm x). + rewrite CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite CRplus_comm. apply CRle_abs. +Qed. + +Lemma CRposPartAbsMax : forall {R : ConstructiveReals} (x : CRcarrier R), + CRmax 0 x == (x + CRabs _ x) * (CR_of_Q R (1#2)). +Proof. + intros. unfold CRmax. unfold CRminus. rewrite CRplus_0_l. + apply CRmult_morph. 2: reflexivity. rewrite CRopp_0, CRplus_0_r. reflexivity. +Qed. + +Lemma CRmax_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmax x y == CRmax y x. +Proof. + intros. unfold CRmax. + rewrite CRabs_minus_sym. apply CRmult_morph. + 2: reflexivity. rewrite (CRplus_comm x y). reflexivity. +Qed. + +Lemma CRmax_plus : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x + CRmax y z == CRmax (x + y) (x + z). +Proof. + intros. unfold CRmax. + setoid_replace (x + z - (x + y)) with (z-y). + apply (CRmult_eq_reg_r (CR_of_Q _ 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_plus_distr_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. + do 3 rewrite (CRplus_assoc x). apply CRplus_morph. reflexivity. + do 2 rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite (CRplus_comm x). apply CRplus_assoc. + unfold CRminus. rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. + apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. + apply CRplus_0_l. +Qed. + +Lemma CRmax_left : forall {R : ConstructiveReals} (x y : CRcarrier R), + y <= x -> CRmax x y == x. +Proof. + intros. unfold CRmax. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRabs_left. unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. reflexivity. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r. exact H. +Qed. + +Lemma CRmax_right : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= y -> CRmax x y == y. +Proof. + intros. unfold CRmax. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite (CRplus_comm x y). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRabs_right. unfold CRminus. rewrite CRplus_comm. + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r. exact H. +Qed. + +Lemma CRmax_contract : forall {R : ConstructiveReals} (x y a : CRcarrier R), + CRabs _ (CRmax x a - CRmax y a) <= CRabs _ (x - y). +Proof. + intros. unfold CRmax. + rewrite (CRabs_morph + _ ((x - y + (CRabs _ (a - x) - CRabs _ (a - y))) * CR_of_Q R (1 # 2))). + rewrite CRabs_mult, (CRabs_right (CR_of_Q R (1 # 2))). + 2: rewrite <- CR_of_Q_zero; apply CR_of_Q_le; discriminate. + apply (CRle_trans + _ ((CRabs _ (x - y) * 1 + CRabs _ (x-y) * 1) + * CR_of_Q R (1 # 2))). + apply CRmult_le_compat_r. + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. + apply (CRle_trans + _ (CRabs _ (x - y) + CRabs _ (CRabs _ (a - x) - CRabs _ (a - y)))). + apply CRabs_triang. rewrite CRmult_1_r. apply CRplus_le_compat_l. + rewrite (CRabs_minus_sym x y). + rewrite (CRabs_morph (y-x) ((a-x)-(a-y))). + apply CRabs_triang_inv2. + unfold CRminus. rewrite (CRplus_comm (a + - x)). + rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, CRopp_plus_distr, <- CRplus_assoc. + rewrite CRplus_opp_r, CRopp_involutive, CRplus_0_l. + reflexivity. + rewrite <- CRmult_plus_distr_l, <- CR_of_Q_one. + rewrite <- (CR_of_Q_plus R 1 1). + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. apply CRle_refl. + unfold CRminus. rewrite CRopp_mult_distr_l. + rewrite <- CRmult_plus_distr_r. apply CRmult_morph. 2: reflexivity. + do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc. rewrite CRplus_comm, CRopp_plus_distr. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRopp_plus_distr. rewrite (CRplus_comm (-a)). + rewrite CRplus_assoc, <- (CRplus_assoc (-a)), CRplus_opp_l. + rewrite CRplus_0_l. apply CRplus_comm. +Qed. + +Lemma CRmax_lub_lt : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x < z -> y < z -> CRmax x y < z. +Proof. + intros. unfold CRmax. + apply (CRmult_lt_reg_r (CR_of_Q R 2)). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + apply (CRplus_lt_reg_l _ (-y -x)). unfold CRminus. + rewrite CRplus_assoc, <- (CRplus_assoc (-x)), <- (CRplus_assoc (-x)). + rewrite CRplus_opp_l, CRplus_0_l, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + apply CRabs_def1. + - rewrite (CRplus_comm y), (CRplus_comm (-y)), CRplus_assoc. + apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l _ y). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym, H0. exact H0. + - rewrite CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_assoc. apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l _ x). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym, H. exact H. +Qed. + +Lemma CRmax_assoc : forall {R : ConstructiveReals} (a b c : CRcarrier R), + CRmax a (CRmax b c) == CRmax (CRmax a b) c. +Proof. + split. + - apply CRmax_lub. + + apply CRmax_lub. apply CRmax_l. + apply (CRle_trans _ (CRmax b c)). + apply CRmax_l. apply CRmax_r. + + apply (CRle_trans _ (CRmax b c)). + apply CRmax_r. apply CRmax_r. + - apply CRmax_lub. + + apply (CRle_trans _ (CRmax a b)). + apply CRmax_l. apply CRmax_l. + + apply CRmax_lub. + apply (CRle_trans _ (CRmax a b)). + apply CRmax_r. apply CRmax_l. apply CRmax_r. +Qed. + +Lemma CRmax_min_mult_neg : + forall {R : ConstructiveReals} (p q r:CRcarrier R), + r <= 0 -> CRmax (r * p) (r * q) == r * CRmin p q. +Proof. + intros R p q r H. unfold CRmin, CRmax. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_left r), <- CRmult_assoc. + apply CRmult_morph. 2: reflexivity. unfold CRminus. + rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r, + CRmult_plus_distr_l, CRmult_plus_distr_l. + reflexivity. exact H. + unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. +Qed. + +Lemma CRlt_max : forall {R : ConstructiveReals} (x y z : CRcarrier R), + CRmax x y < z -> prod (x < z) (y < z). +Proof. + intros. destruct (CR_Q_dense R _ _ H) as [q qmaj]. + destruct qmaj. + split. + - apply (CRlt_le_trans _ (CR_of_Q R q)). + apply (CRle_lt_trans _ (CRmax x y)). apply CRmax_l. exact c. + apply CRlt_asym, c0. + - apply (CRlt_le_trans _ (CR_of_Q R q)). + apply (CRle_lt_trans _ (CRmax x y)). apply CRmax_r. exact c. + apply CRlt_asym, c0. +Qed. + +Lemma CRmax_mult : + forall {R : ConstructiveReals} (p q r:CRcarrier R), + 0 <= r -> CRmax (r * p) (r * q) == r * CRmax p q. +Proof. + intros R p q r H. unfold CRmin, CRmax. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_right r), <- CRmult_assoc. + apply CRmult_morph. 2: reflexivity. + rewrite CRmult_plus_distr_l, CRmult_plus_distr_l. + reflexivity. exact H. + unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. +Qed. + +Lemma CRmin_max_mult_neg : + forall {R : ConstructiveReals} (p q r:CRcarrier R), + r <= 0 -> CRmin (r * p) (r * q) == r * CRmax p q. +Proof. + intros R p q r H. unfold CRmin, CRmax. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_left r), <- CRmult_assoc. + apply CRmult_morph. 2: reflexivity. unfold CRminus. + rewrite CRopp_mult_distr_l, CRopp_involutive, + CRmult_plus_distr_l, CRmult_plus_distr_l. + reflexivity. exact H. + unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. +Qed. diff --git a/theories/Reals/Abstract/ConstructiveLUB.v b/theories/Reals/Abstract/ConstructiveLUB.v new file mode 100644 index 0000000000..4ae24de154 --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveLUB.v @@ -0,0 +1,413 @@ +(************************************************************************) +(* * 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 Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveAbs. +Require Import ConstructiveLimits. +Require Import Logic.ConstructiveEpsilon. + +Local Open Scope ConstructiveReals. + +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 {R : ConstructiveReals} + (E:CRcarrier R -> Prop) (m:CRcarrier R) + := forall x:CRcarrier R, E x -> x <= m. + +Definition is_lub {R : ConstructiveReals} + (E:CRcarrier R -> Prop) (m:CRcarrier R) := + is_upper_bound E m /\ (forall b:CRcarrier R, is_upper_bound E b -> m <= b). + +Lemma CRlt_lpo_dec : forall {R : ConstructiveReals} (x y : CRcarrier R), + (forall (P : nat -> Prop), (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}) + -> sum (x < y) (y <= x). +Proof. + intros R x y lpo. + assert (forall (z:CRcarrier R) (n : nat), z < z + CR_of_Q R (1 # Pos.of_nat (S n))). + { intros. apply (CRle_lt_trans _ (z+0)). + rewrite CRplus_0_r. apply CRle_refl. apply CRplus_lt_compat_l. + apply CR_of_Q_pos. reflexivity. } + pose (fun n:nat => let (q,_) := CR_Q_dense + R x (x + CR_of_Q R (1 # Pos.of_nat (S n))) (H x n) + in q) + as xn. + pose (fun n:nat => let (q,_) := CR_Q_dense + R y (y + CR_of_Q R (1 # Pos.of_nat (S n))) (H y n) + in q) + as yn. + destruct (lpo (fun n => Qle (yn n) (xn n + (1 # Pos.of_nat (S n))))). + - intro n. destruct (Q_dec (yn n) (xn n + (1 # Pos.of_nat (S n)))). + destruct s. left. apply Qlt_le_weak, q. + right. apply (Qlt_not_le _ _ q). left. + rewrite q. apply Qle_refl. + - left. destruct s as [n nmaj]. apply Qnot_le_lt in nmaj. + apply (CRlt_le_trans _ (CR_of_Q R (xn n))). + unfold xn. + destruct (CR_Q_dense R x (x + CR_of_Q R (1 # Pos.of_nat (S n))) (H x n)). + exact (fst p). apply (CRle_trans _ (CR_of_Q R (yn n - (1 # Pos.of_nat (S n))))). + apply CR_of_Q_le. rewrite <- (Qplus_le_l _ _ (1# Pos.of_nat (S n))). + ring_simplify. apply Qlt_le_weak, nmaj. + unfold yn. + destruct (CR_Q_dense R y (y + CR_of_Q R (1 # Pos.of_nat (S n))) (H y n)). + unfold Qminus. rewrite CR_of_Q_plus, CR_of_Q_opp. + apply (CRplus_le_reg_r (CR_of_Q R (1 # Pos.of_nat (S n)))). + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + apply CRlt_asym, (snd p). + - right. apply (CR_cv_le (fun n => CR_of_Q R (yn n)) + (fun n => CR_of_Q R (xn n) + CR_of_Q R (1 # Pos.of_nat (S n)))). + + intro n. rewrite <- CR_of_Q_plus. apply CR_of_Q_le. exact (q n). + + intro p. exists (Pos.to_nat p). intros. + unfold yn. + destruct (CR_Q_dense R y (y + CR_of_Q R (1 # Pos.of_nat (S i))) (H y i)). + rewrite CRabs_right. apply (CRplus_le_reg_r y). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + rewrite CRplus_comm. + apply (CRle_trans _ (y + CR_of_Q R (1 # Pos.of_nat (S i)))). + apply CRlt_asym, (snd p0). apply CRplus_le_compat_l. + apply CR_of_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. + apply le_S, H0. discriminate. rewrite <- (CRplus_opp_r y). + apply CRplus_le_compat_r, CRlt_asym, p0. + + apply (CR_cv_proper _ (x+0)). 2: rewrite CRplus_0_r; reflexivity. + apply CR_cv_plus. + intro p. exists (Pos.to_nat p). intros. + unfold xn. + destruct (CR_Q_dense R x (x + CR_of_Q R (1 # Pos.of_nat (S i))) (H x i)). + rewrite CRabs_right. apply (CRplus_le_reg_r x). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + rewrite CRplus_comm. + apply (CRle_trans _ (x + CR_of_Q R (1 # Pos.of_nat (S i)))). + apply CRlt_asym, (snd p0). apply CRplus_le_compat_l. + apply CR_of_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. + apply le_S, H0. discriminate. rewrite <- (CRplus_opp_r x). + apply CRplus_le_compat_r, CRlt_asym, p0. + intro p. exists (Pos.to_nat p). intros. + unfold CRminus. rewrite CRopp_0, CRplus_0_r, CRabs_right. + apply CR_of_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. + apply le_S, H0. discriminate. + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. +Qed. + +Lemma is_upper_bound_dec : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop) (x:CRcarrier R), + sig_forall_dec_T + -> sig_not_dec_T + -> { is_upper_bound E x } + { ~is_upper_bound E x }. +Proof. + intros R E x lpo sig_not_dec. + destruct (sig_not_dec (~exists y:CRcarrier R, E y /\ CRltProp R x y)). + - left. intros y H. + destruct (CRlt_lpo_dec x y lpo). 2: exact c. + exfalso. apply n. intro abs. apply abs. clear abs. + exists y. split. exact H. apply CRltForget. exact c. + - right. intro abs. apply n. intros [y [H H0]]. + specialize (abs y H). apply CRltEpsilon in H0. contradiction. +Qed. + +Lemma is_upper_bound_epsilon : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop), + sig_forall_dec_T + -> sig_not_dec_T + -> (exists x:CRcarrier R, is_upper_bound E x) + -> { n:nat | is_upper_bound E (CR_of_Q R (Z.of_nat n # 1)) }. +Proof. + intros R 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 (CRup_nat x) as [n nmaj]. exists n. + intros y ey. specialize (H y ey). + apply (CRle_trans _ x _ H). apply CRlt_asym, nmaj. +Qed. + +Lemma is_upper_bound_not_epsilon : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop), + sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CRcarrier R, E x) + -> { m:nat | ~is_upper_bound E (-CR_of_Q R (Z.of_nat m # 1)) }. +Proof. + intros R E lpo sig_not_dec H. + apply constructive_indefinite_ground_description_nat. + - intro n. + destruct (is_upper_bound_dec E (-CR_of_Q R (Z.of_nat n # 1)) lpo sig_not_dec). + right. intro abs. contradiction. left. exact n0. + - destruct H as [x H]. destruct (CRup_nat (-x)) as [n H0]. + exists n. intro abs. specialize (abs x H). + apply abs. rewrite <- (CRopp_involutive x). + apply CRopp_gt_lt_contravar. 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 {R : ConstructiveReals} (upcut : DedekindDecCut), + { x : CRcarrier R + | forall r:Q, (x < CR_of_Q R r -> DDupcut upcut r) + /\ (CR_of_Q R 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 (CR_cauchy R (fun n:nat => CR_of_Q R (proj1_sig (DDcut_limit + upcut (1#Pos.of_nat n) (eq_refl _))))). + { intros p. exists (Pos.to_nat p). intros 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 (CRabs_le). split. + - intros. unfold CRminus. + rewrite <- CR_of_Q_opp, <- CR_of_Q_opp, <- CR_of_Q_plus. + apply CR_of_Q_le. + apply (Qplus_le_l _ _ x0). ring_simplify. + setoid_replace (-1 * (1 # p) + x0)%Q with (x0 - (1 # p))%Q. + 2: ring. apply (Qle_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 H1 in H0. inversion H0. + apply Qlt_le_weak, (DDlow_below_up upcut). apply a. apply a0. + - unfold CRminus. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus. + apply CR_of_Q_le. + apply (Qplus_le_l _ _ (x0-(1#p))). ring_simplify. + setoid_replace (x -1 * (1 # p))%Q with (x - (1 # p))%Q. + 2: ring. apply (Qle_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 H1 in H0. inversion H0. + apply Qlt_le_weak, (DDlow_below_up upcut). apply a0. apply a. } + apply CR_complete in H0. destruct H0 as [l lcv]. + exists l. split. + - intros. (* find an upper point between the limit and r *) + destruct (CR_cv_open_above _ (CR_of_Q R r) l lcv H0) as [p pmaj]. + specialize (pmaj p (le_refl p)). + unfold proj1_sig in pmaj. + destruct (DDcut_limit upcut (1 # Pos.of_nat p) eq_refl) as [q qmaj]. + apply (DDinterval upcut q). 2: apply qmaj. + destruct (Q_dec q r). destruct s. apply Qlt_le_weak, q0. + exfalso. apply (CR_of_Q_lt R) in q0. exact (CRlt_asym _ _ pmaj q0). + rewrite q0. apply Qle_refl. + - intros H0 abs. + assert ((CR_of_Q R r+l) * CR_of_Q R (1#2) < l). + { apply (CRmult_lt_reg_r (CR_of_Q R 2)). + apply CR_of_Q_pos. reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult, (CR_of_Q_plus R 1 1). + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_plus_distr_l, CRmult_1_r, CRmult_1_r. + apply CRplus_lt_compat_r. exact H0. } + destruct (CR_cv_open_below _ _ l lcv H1) as [p pmaj]. + assert (0 < (l-CR_of_Q R r) * CR_of_Q R (1#2)). + { apply CRmult_lt_0_compat. rewrite <- (CRplus_opp_r (CR_of_Q R r)). + apply CRplus_lt_compat_r. exact H0. apply CR_of_Q_pos. reflexivity. } + destruct (CRup_nat (CRinv R _ (inr H2))) as [i imaj]. + destruct i. exfalso. simpl in imaj. + rewrite CR_of_Q_zero in imaj. + exact (CRlt_asym _ _ imaj (CRinv_0_lt_compat R _ (inr H2) H2)). + specialize (pmaj (max (S i) (S p)) (le_trans p (S p) _ (le_S p p (le_refl p)) (Nat.le_max_r (S i) (S p)))). + unfold proj1_sig in pmaj. + destruct (DDcut_limit upcut (1 # Pos.of_nat (max (S i) (S p))) eq_refl) + as [q qmaj]. + destruct qmaj. apply H4. clear H4. + apply (DDinterval upcut r). 2: exact abs. + apply (Qplus_le_l _ _ (1 # Pos.of_nat (Init.Nat.max (S i) (S p)))). + ring_simplify. apply (Qle_trans _ (r + (1 # Pos.of_nat (S i)))). + rewrite Qplus_le_r. unfold Qle,Qnum,Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. + apply Nat.le_max_l. discriminate. discriminate. + apply (CRmult_lt_compat_l ((l - CR_of_Q R r) * CR_of_Q R (1 # 2))) in imaj. + rewrite CRinv_r in imaj. 2: exact H2. + destruct (Q_dec (r+(1#Pos.of_nat (S i))) q). destruct s. + apply Qlt_le_weak, q0. 2: rewrite q0; apply Qle_refl. + exfalso. apply (CR_of_Q_lt R) in q0. + apply (CRlt_asym _ _ pmaj). apply (CRlt_le_trans _ _ _ q0). + apply (CRplus_le_reg_l (-CR_of_Q R r)). + rewrite CR_of_Q_plus, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + apply (CRmult_lt_compat_r (CR_of_Q R (1 # Pos.of_nat (S i)))) in imaj. + rewrite CRmult_1_l in imaj. + apply (CRle_trans _ ( + (l - CR_of_Q R r) * CR_of_Q R (1 # 2) * CR_of_Q R (Z.of_nat (S i) # 1) * + CR_of_Q R (1 # Pos.of_nat (S i)))). + apply CRlt_asym, imaj. rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((Z.of_nat (S i) # 1) * (1 # Pos.of_nat (S i)))%Q with 1%Q. + rewrite CR_of_Q_one, CRmult_1_r. + unfold CRminus. rewrite CRmult_plus_distr_r, (CRplus_comm (-CR_of_Q R r)). + rewrite (CRplus_comm (CR_of_Q R r)), CRmult_plus_distr_r. + rewrite CRplus_assoc. apply CRplus_le_compat_l. + rewrite <- CR_of_Q_mult, <- CR_of_Q_opp, <- CR_of_Q_mult, <- CR_of_Q_plus. + apply CR_of_Q_le. ring_simplify. apply Qle_refl. + unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + rewrite Z.mul_1_l, Pos.mul_1_l. unfold Z.of_nat. + apply f_equal. apply Pos.of_nat_succ. apply CR_of_Q_pos. reflexivity. +Qed. + +Lemma is_upper_bound_glb : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop), + sig_not_dec_T + -> sig_forall_dec_T + -> (exists x : CRcarrier R, E x) + -> (exists x : CRcarrier R, is_upper_bound E x) + -> { x : CRcarrier R + | forall r:Q, (x < CR_of_Q R r -> is_upper_bound E (CR_of_Q R r)) + /\ (CR_of_Q R r < x -> ~is_upper_bound E (CR_of_Q R r)) }. +Proof. + intros R 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 (CR_of_Q R 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 (CRle_lt_trans _ (CR_of_Q R r)). 2: exact abs. + apply CR_of_Q_le. exact H0. } + assert (upcut (Z.of_nat a # 1)%Q). + { intros x Ex. exact (luba x Ex). } + assert (~upcut (- Z.of_nat b # 1)%Q). + { intros abs. apply glbb. intros x Ex. + specialize (abs x Ex). rewrite <- CR_of_Q_opp. + 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 R (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 {R : ConstructiveReals} + (E:CRcarrier R -> Prop) (sig_forall_dec : sig_forall_dec_T) + (sig_not_dec : sig_not_dec_T) + (Einhab : exists x : CRcarrier R, E x) + (Ebound : exists x : CRcarrier R, 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 (CR_Q_dense R 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 (CR_Q_dense R 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 (CRlt_trans _ (CR_of_Q R q) _ qmaj abs2). +Qed. + +Lemma sig_lub : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop), + sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CRcarrier R, E x) + -> (exists x : CRcarrier R, is_upper_bound E x) + -> { u : CRcarrier R | is_lub E u }. +Proof. + intros R 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. + +Definition CRis_upper_bound {R : ConstructiveReals} (E:CRcarrier R -> Prop) (m:CRcarrier R) + := forall x:CRcarrier R, E x -> CRlt R m x -> False. + +Lemma CR_sig_lub : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop), + (forall x y : CRcarrier R, CReq R x y -> (E x <-> E y)) + -> sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CRcarrier R, E x) + -> (exists x : CRcarrier R, CRis_upper_bound E x) + -> { u : CRcarrier R | CRis_upper_bound E u /\ + forall y:CRcarrier R, CRis_upper_bound E y -> CRlt R y u -> False }. +Proof. + intros. exact (sig_lub E X X0 H0 H1). +Qed. diff --git a/theories/Reals/Abstract/ConstructiveLimits.v b/theories/Reals/Abstract/ConstructiveLimits.v new file mode 100644 index 0000000000..4a40cc8cb3 --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveLimits.v @@ -0,0 +1,933 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import QArith Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveAbs. +Require Import ConstructiveSum. + +Local Open Scope ConstructiveReals. + + +(** Definitions and basic properties of limits of real sequences + and series. *) + + +Lemma CR_cv_extens + : forall {R : ConstructiveReals} (xn yn : nat -> CRcarrier R) (l : CRcarrier R), + (forall n:nat, xn n == yn n) + -> CR_cv R xn l + -> CR_cv R yn l. +Proof. + intros. intro p. specialize (H0 p) as [n nmaj]. exists n. + intros. specialize (nmaj i H0). + apply (CRle_trans _ (CRabs R (CRminus R (xn i) l))). + 2: exact nmaj. rewrite <- CRabs_def. split. + - apply (CRle_trans _ (CRminus R (xn i) l)). + apply CRplus_le_compat_r. specialize (H i) as [H _]. exact H. + pose proof (CRabs_def R (CRminus R (xn i) l) (CRabs R (CRminus R (xn i) l))) + as [_ H1]. + apply H1. apply CRle_refl. + - apply (CRle_trans _ (CRopp R (CRminus R (xn i) l))). + intro abs. apply CRopp_lt_cancel, CRplus_lt_reg_r in abs. + specialize (H i) as [_ H]. contradiction. + pose proof (CRabs_def R (CRminus R (xn i) l) (CRabs R (CRminus R (xn i) l))) + as [_ H1]. + apply H1. apply CRle_refl. +Qed. + +Lemma CR_cv_opp : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) (l : CRcarrier R), + CR_cv R xn l + -> CR_cv R (fun n => - xn n) (- l). +Proof. + intros. intro p. specialize (H p) as [n nmaj]. + exists n. intros. specialize (nmaj i H). + apply (CRle_trans _ (CRabs R (CRminus R (xn i) l))). + 2: exact nmaj. clear nmaj H. + unfold CRminus. rewrite <- CRopp_plus_distr, CRabs_opp. + apply CRle_refl. +Qed. + +Lemma CR_cv_plus : forall {R : ConstructiveReals} (xn yn : nat -> CRcarrier R) (a b : CRcarrier R), + CR_cv R xn a + -> CR_cv R yn b + -> CR_cv R (fun n => xn n + yn n) (a + b). +Proof. + intros. intro p. + specialize (H (2*p)%positive) as [i imaj]. + specialize (H0 (2*p)%positive) as [j jmaj]. + exists (max i j). intros. + apply (CRle_trans + _ (CRabs R (CRplus R (CRminus R (xn i0) a) (CRminus R (yn i0) b)))). + apply CRabs_morph. + - unfold CRminus. + do 2 rewrite <- (Radd_assoc (CRisRing R)). + apply CRplus_morph. reflexivity. rewrite CRopp_plus_distr. + destruct (CRisRing R). rewrite Radd_comm, <- Radd_assoc. + apply CRplus_morph. reflexivity. + rewrite Radd_comm. reflexivity. + - apply (CRle_trans _ _ _ (CRabs_triang _ _)). + apply (CRle_trans _ (CRplus R (CR_of_Q R (1 # 2*p)) (CR_of_Q R (1 # 2*p)))). + apply CRplus_le_compat. apply imaj, (le_trans _ _ _ (Nat.le_max_l _ _) H). + apply jmaj, (le_trans _ _ _ (Nat.le_max_r _ _) H). + apply (CRle_trans _ (CR_of_Q R ((1 # 2 * p) + (1 # 2 * p)))). + apply CR_of_Q_plus. apply CR_of_Q_le. + rewrite Qinv_plus_distr. setoid_replace (1 + 1 # 2 * p) with (1 # p). + apply Qle_refl. reflexivity. +Qed. + +Lemma CR_cv_unique : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) + (a b : CRcarrier R), + CR_cv R xn a + -> CR_cv R xn b + -> a == b. +Proof. + intros. assert (CR_cv R (fun _ => CRzero R) (CRminus R b a)). + { apply (CR_cv_extens (fun n => CRminus R (xn n) (xn n))). + intro n. unfold CRminus. apply CRplus_opp_r. + apply CR_cv_plus. exact H0. apply CR_cv_opp, H. } + assert (forall q r : Q, 0 < q -> / q < r -> 1 < q * r)%Q. + { intros. apply (Qmult_lt_l _ _ q) in H3. + rewrite Qmult_inv_r in H3. exact H3. intro abs. + rewrite abs in H2. exact (Qlt_irrefl 0 H2). exact H2. } + clear H H0 xn. remember (CRminus R b a) as z. + assert (z == 0). split. + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H]]. + destruct (Qarchimedean (/(-q))) as [p pmaj]. + specialize (H1 p) as [n nmaj]. + specialize (nmaj n (le_refl n)). apply nmaj. + apply (CRlt_trans _ (CR_of_Q R (-q))). apply CR_of_Q_lt. + apply H2 in pmaj. + apply (Qmult_lt_r _ _ (1#p)) in pmaj. 2: reflexivity. + rewrite Qmult_1_l, <- Qmult_assoc in pmaj. + setoid_replace ((Z.pos p # 1) * (1 # p))%Q with 1%Q in pmaj. + rewrite Qmult_1_r in pmaj. exact pmaj. unfold Qeq, Qnum, Qden; simpl. + do 2 rewrite Pos.mul_1_r. reflexivity. + apply (Qplus_lt_l _ _ q). ring_simplify. + apply (lt_CR_of_Q R q 0). apply (CRlt_le_trans _ (CRzero R) _ H). + apply CR_of_Q_zero. + apply (CRlt_le_trans _ (CRopp R z)). + apply (CRle_lt_trans _ (CRopp R (CR_of_Q R q))). apply CR_of_Q_opp. + apply CRopp_gt_lt_contravar, H0. + apply (CRle_trans _ (CRabs R (CRopp R z))). + pose proof (CRabs_def R (CRopp R z) (CRabs R (CRopp R z))) as [_ H1]. + apply H1, CRle_refl. + apply CRabs_morph. unfold CRminus. symmetry. apply CRplus_0_l. + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H]]. + destruct (Qarchimedean (/q)) as [p pmaj]. + specialize (H1 p) as [n nmaj]. + specialize (nmaj n (le_refl n)). apply nmaj. + apply (CRlt_trans _ (CR_of_Q R q)). apply CR_of_Q_lt. + apply H2 in pmaj. + apply (Qmult_lt_r _ _ (1#p)) in pmaj. 2: reflexivity. + rewrite Qmult_1_l, <- Qmult_assoc in pmaj. + setoid_replace ((Z.pos p # 1) * (1 # p))%Q with 1%Q in pmaj. + rewrite Qmult_1_r in pmaj. exact pmaj. unfold Qeq, Qnum, Qden; simpl. + do 2 rewrite Pos.mul_1_r. reflexivity. + apply (lt_CR_of_Q R 0 q). apply (CRle_lt_trans _ (CRzero R)). + 2: exact H0. apply CR_of_Q_zero. + apply (CRlt_le_trans _ _ _ H). + apply (CRle_trans _ (CRabs R (CRopp R z))). + apply (CRle_trans _ (CRabs R z)). + pose proof (CRabs_def R z (CRabs R z)) as [_ H1]. + apply H1. apply CRle_refl. apply CRabs_opp. + apply CRabs_morph. unfold CRminus. symmetry. apply CRplus_0_l. + - subst z. apply (CRplus_eq_reg_l (CRopp R a)). + apply (CReq_trans _ (CRzero R)). apply CRplus_opp_l. + destruct (CRisRing R). + apply (CReq_trans _ (CRplus R b (CRopp R a))). apply CReq_sym, H. + apply Radd_comm. +Qed. + +Lemma CR_cv_eq : forall {R : ConstructiveReals} + (v u : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, u n == v n) + -> CR_cv R u s + -> CR_cv R v s. +Proof. + intros R v u s seq H1 p. specialize (H1 p) as [N H0]. + exists N. intros. unfold CRminus. rewrite <- seq. apply H0, H. +Qed. + +Lemma CR_cauchy_eq : forall {R : ConstructiveReals} + (un vn : nat -> CRcarrier R), + (forall n:nat, un n == vn n) + -> CR_cauchy R un + -> CR_cauchy R vn. +Proof. + intros. intro p. specialize (H0 p) as [n H0]. + exists n. intros. specialize (H0 i j H1 H2). + unfold CRminus in H0. rewrite <- CRabs_def. + rewrite <- CRabs_def in H0. + do 2 rewrite H in H0. exact H0. +Qed. + +Lemma CR_cv_proper : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (a b : CRcarrier R), + CR_cv R un a + -> a == b + -> CR_cv R un b. +Proof. + intros. intro p. specialize (H p) as [n H]. + exists n. intros. unfold CRminus. rewrite <- H0. apply H, H1. +Qed. + +Instance CR_cv_morph + : forall {R : ConstructiveReals} (un : nat -> CRcarrier R), CMorphisms.Proper + (CMorphisms.respectful (CReq R) CRelationClasses.iffT) (CR_cv R un). +Proof. + split. intros. apply (CR_cv_proper un x). exact H0. exact H. + intros. apply (CR_cv_proper un y). exact H0. symmetry. exact H. +Qed. + +Lemma Un_cv_nat_real : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (l : CRcarrier R), + CR_cv R un l + -> forall eps : CRcarrier R, + 0 < eps + -> { p : nat & forall i:nat, le p i -> CRabs R (un i - l) < eps }. +Proof. + intros. destruct (CR_archimedean R (CRinv R eps (inr H0))) as [k kmaj]. + assert (0 < CR_of_Q R (Z.pos k # 1)). + { rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. } + specialize (H k) as [p pmaj]. + exists p. intros. + apply (CRle_lt_trans _ (CR_of_Q R (1 # k))). + apply pmaj, H. + apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos k # 1))). exact H1. + rewrite <- CR_of_Q_mult. + apply (CRle_lt_trans _ 1). + rewrite <- CR_of_Q_one. apply CR_of_Q_le. + unfold Qle; simpl. do 2 rewrite Pos.mul_1_r. apply Z.le_refl. + apply (CRmult_lt_reg_r (CRinv R eps (inr H0))). + apply CRinv_0_lt_compat, H0. rewrite CRmult_1_l, CRmult_assoc. + rewrite CRinv_r, CRmult_1_r. exact kmaj. +Qed. + +Lemma Un_cv_real_nat : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (l : CRcarrier R), + (forall eps : CRcarrier R, + 0 < eps + -> { p : nat & forall i:nat, le p i -> CRabs R (un i - l) < eps }) + -> CR_cv R un l. +Proof. + intros. intros n. + specialize (H (CR_of_Q R (1#n))) as [p pmaj]. + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + exists p. intros. apply CRlt_asym. apply pmaj. apply H. +Qed. + +Definition series_cv {R : ConstructiveReals} + (un : nat -> CRcarrier R) (s : CRcarrier R) : Set + := CR_cv R (CRsum un) s. + +Definition series_cv_lim_lt {R : ConstructiveReals} + (un : nat -> CRcarrier R) (x : CRcarrier R) : Set + := { l : CRcarrier R & prod (series_cv un l) (l < x) }. + +Definition series_cv_le_lim {R : ConstructiveReals} + (x : CRcarrier R) (un : nat -> CRcarrier R) : Set + := { l : CRcarrier R & prod (series_cv un l) (x <= l) }. + +Lemma CR_cv_minus : + forall {R : ConstructiveReals} + (An Bn:nat -> CRcarrier R) (l1 l2:CRcarrier R), + CR_cv R An l1 -> CR_cv R Bn l2 + -> CR_cv R (fun i:nat => An i - Bn i) (l1 - l2). +Proof. + intros. apply CR_cv_plus. apply H. + intros p. specialize (H0 p) as [n H0]. exists n. + intros. setoid_replace (- Bn i - - l2) with (- (Bn i - l2)). + rewrite CRabs_opp. apply H0, H1. unfold CRminus. + rewrite CRopp_plus_distr, CRopp_involutive. reflexivity. +Qed. + +Lemma CR_cv_nonneg : + forall {R : ConstructiveReals} (An:nat -> CRcarrier R) (l:CRcarrier R), + CR_cv R An l + -> (forall n:nat, 0 <= An n) + -> 0 <= l. +Proof. + intros. intro abs. + destruct (Un_cv_nat_real _ l H (-l)) as [N H1]. + rewrite <- CRopp_0. apply CRopp_gt_lt_contravar. apply abs. + specialize (H1 N (le_refl N)). + pose proof (CRabs_def R (An N - l) (CRabs R (An N - l))) as [_ H2]. + apply (CRle_lt_trans _ _ _ (CRle_abs _)) in H1. + apply (H0 N). apply (CRplus_lt_reg_r (-l)). + rewrite CRplus_0_l. exact H1. +Qed. + +Lemma series_cv_unique : + forall {R : ConstructiveReals} (Un:nat -> CRcarrier R) (l1 l2:CRcarrier R), + series_cv Un l1 -> series_cv Un l2 -> l1 == l2. +Proof. + intros. apply (CR_cv_unique (CRsum Un)); assumption. +Qed. + +Lemma CR_cv_scale : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (a : CRcarrier R) (s : CRcarrier R), + CR_cv R u s -> CR_cv R (fun n => u n * a) (s * a). +Proof. + intros. intros n. + destruct (CR_archimedean R (1 + CRabs R a)). + destruct (H (n * x)%positive). + exists x0. intros. + unfold CRminus. rewrite CRopp_mult_distr_l. + rewrite <- CRmult_plus_distr_r. + apply (CRle_trans _ ((CR_of_Q R (1 # n * x)) * CRabs R a)). + rewrite CRabs_mult. apply CRmult_le_compat_r. apply CRabs_pos. + apply c0, H0. + setoid_replace (1 # n * x)%Q with ((1 # n) *(1# x))%Q. 2: reflexivity. + rewrite <- (CRmult_1_r (CR_of_Q R (1#n))). + rewrite CR_of_Q_mult, CRmult_assoc. + apply CRmult_le_compat_l. rewrite <- CR_of_Q_zero. + apply CR_of_Q_le. discriminate. intro abs. + apply (CRmult_lt_compat_l (CR_of_Q R (Z.pos x #1))) in abs. + rewrite CRmult_1_r, <- CRmult_assoc, <- CR_of_Q_mult in abs. + rewrite (CR_of_Q_morph R ((Z.pos x # 1) * (1 # x))%Q 1%Q) in abs. + rewrite CR_of_Q_one, CRmult_1_l in abs. + apply (CRlt_asym _ _ abs), (CRlt_trans _ (1 + CRabs R a)). + 2: exact c. rewrite <- CRplus_0_l, <- CRplus_assoc. + apply CRplus_lt_compat_r. rewrite CRplus_0_r. apply CRzero_lt_one. + unfold Qmult, Qeq, Qnum, Qden. ring_simplify. rewrite Pos.mul_1_l. + reflexivity. + apply (CRlt_trans _ (1+CRabs R a)). 2: exact c. + rewrite CRplus_comm. + rewrite <- (CRplus_0_r 0). apply CRplus_le_lt_compat. + apply CRabs_pos. apply CRzero_lt_one. +Qed. + +Lemma CR_cv_const : forall {R : ConstructiveReals} (a : CRcarrier R), + CR_cv R (fun n => a) a. +Proof. + intros a p. exists O. intros. + unfold CRminus. rewrite CRplus_opp_r. + rewrite CRabs_right. rewrite <- CR_of_Q_zero. + apply CR_of_Q_le. discriminate. apply CRle_refl. +Qed. + +Lemma Rcv_cauchy_mod : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (l : CRcarrier R), + CR_cv R un l -> CR_cauchy R un. +Proof. + intros. intros p. specialize (H (2*p)%positive) as [k H]. + exists k. intros n q H0 H1. + setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. + rewrite CR_of_Q_plus. + setoid_replace (un n - un q) with ((un n - l) - (un q - l)). + apply (CRle_trans _ _ _ (CRabs_triang _ _)). + apply CRplus_le_compat. + - apply H, H0. + - rewrite CRabs_opp. apply H. apply H1. + - unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. + reflexivity. rewrite CRplus_comm, CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. reflexivity. + - rewrite Qinv_plus_distr. reflexivity. +Qed. + +Lemma series_cv_eq : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, u n == v n) + -> series_cv u s + -> series_cv v s. +Proof. + intros. intros p. specialize (H0 p). destruct H0 as [N H0]. + exists N. intros. unfold CRminus. + rewrite <- (CRsum_eq u). apply H0, H1. intros. apply H. +Qed. + +Lemma CR_growing_transit : forall {R : ConstructiveReals} (un : nat -> CRcarrier R), + (forall n:nat, un n <= un (S n)) + -> forall n p : nat, le n p -> un n <= un p. +Proof. + induction p. + - intros. inversion H0. apply CRle_refl. + - intros. apply Nat.le_succ_r in H0. destruct H0. + apply (CRle_trans _ (un p)). apply IHp, H0. apply H. + subst n. apply CRle_refl. +Qed. + +Lemma growing_ineq : + forall {R : ConstructiveReals} (Un:nat -> CRcarrier R) (l:CRcarrier R), + (forall n:nat, Un n <= Un (S n)) + -> CR_cv R Un l -> forall n:nat, Un n <= l. +Proof. + intros. intro abs. + destruct (Un_cv_nat_real _ l H0 (Un n - l)) as [N H1]. + rewrite <- (CRplus_opp_r l). apply CRplus_lt_compat_r. exact abs. + specialize (H1 (max n N) (Nat.le_max_r _ _)). + apply (CRle_lt_trans _ _ _ (CRle_abs _)) in H1. + apply CRplus_lt_reg_r in H1. + apply (CR_growing_transit Un H n (max n N)). apply Nat.le_max_l. + exact H1. +Qed. + +Lemma CR_cv_open_below + : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (m l : CRcarrier R), + CR_cv R un l + -> m < l + -> { n : nat & forall i:nat, le n i -> m < un i }. +Proof. + intros. apply CRlt_minus in H0. + pose proof (Un_cv_nat_real _ l H (l-m) H0) as [n nmaj]. + exists n. intros. specialize (nmaj i H1). + apply CRabs_lt in nmaj. + destruct nmaj as [_ nmaj]. unfold CRminus in nmaj. + rewrite CRopp_plus_distr, CRopp_involutive, CRplus_comm in nmaj. + apply CRplus_lt_reg_l in nmaj. + apply (CRplus_lt_reg_l R (-m)). rewrite CRplus_opp_l. + apply (CRplus_lt_reg_r (-un i)). rewrite CRplus_0_l. + rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. exact nmaj. +Qed. + +Lemma CR_cv_open_above + : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (m l : CRcarrier R), + CR_cv R un l + -> l < m + -> { n : nat & forall i:nat, le n i -> un i < m }. +Proof. + intros. apply CRlt_minus in H0. + pose proof (Un_cv_nat_real _ l H (m-l) H0) as [n nmaj]. + exists n. intros. specialize (nmaj i H1). + apply CRabs_lt in nmaj. + destruct nmaj as [nmaj _]. apply CRplus_lt_reg_r in nmaj. + exact nmaj. +Qed. + +Lemma CR_cv_bound_down : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (A l : CRcarrier R) (N : nat), + (forall n:nat, le N n -> A <= u n) + -> CR_cv R u l + -> A <= l. +Proof. + intros. intro r. + apply (CRplus_lt_compat_r (-l)) in r. rewrite CRplus_opp_r in r. + destruct (Un_cv_nat_real _ l H0 (A - l) r) as [n H1]. + apply (H (n+N)%nat). + rewrite <- (plus_0_l N). rewrite Nat.add_assoc. + apply Nat.add_le_mono_r. apply le_0_n. + specialize (H1 (n+N)%nat). apply (CRplus_lt_reg_r (-l)). + assert (n + N >= n)%nat. rewrite <- (plus_0_r n). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. specialize (H1 H2). + apply (CRle_lt_trans _ (CRabs R (u (n + N)%nat - l))). + apply CRle_abs. assumption. +Qed. + +Lemma CR_cv_bound_up : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (A l : CRcarrier R) (N : nat), + (forall n:nat, le N n -> u n <= A) + -> CR_cv R u l + -> l <= A. +Proof. + intros. intro r. + apply (CRplus_lt_compat_r (-A)) in r. rewrite CRplus_opp_r in r. + destruct (Un_cv_nat_real _ l H0 (l-A) r) as [n H1]. + apply (H (n+N)%nat). + - rewrite <- (plus_0_l N). apply Nat.add_le_mono_r. apply le_0_n. + - specialize (H1 (n+N)%nat). apply (CRplus_lt_reg_l R (l - A - u (n+N)%nat)). + unfold CRminus. repeat rewrite CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_r, (CRplus_comm (-A)). + rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. + apply (CRle_lt_trans _ _ _ (CRle_abs _)). + fold (l - u (n+N)%nat). rewrite CRabs_minus_sym. apply H1. + rewrite <- (plus_0_r n). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. +Qed. + +Lemma series_cv_maj : forall {R : ConstructiveReals} + (un vn : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, CRabs R (un n) <= vn n) + -> series_cv vn s + -> { l : CRcarrier R & prod (series_cv un l) (l <= s) }. +Proof. + intros. destruct (CR_complete R (CRsum un)). + - intros n. + specialize (H0 (2*n)%positive) as [N maj]. + exists N. intros i j H0 H1. + apply (CRle_trans _ (CRsum vn (max i j) - CRsum vn (min i j))). + apply Abs_sum_maj. apply H. + setoid_replace (CRsum vn (max i j) - CRsum vn (min i j)) + with (CRabs R (CRsum vn (max i j) - (CRsum vn (min i j)))). + setoid_replace (CRsum vn (Init.Nat.max i j) - CRsum vn (Init.Nat.min i j)) + with (CRsum vn (Init.Nat.max i j) - s - (CRsum vn (Init.Nat.min i j) - s)). + apply (CRle_trans _ _ _ (CRabs_triang _ _)). + setoid_replace (1#n)%Q with ((1#2*n) + (1#2*n))%Q. + rewrite CR_of_Q_plus. + apply CRplus_le_compat. + apply maj. apply (le_trans _ i). assumption. apply Nat.le_max_l. + rewrite CRabs_opp. apply maj. + apply Nat.min_case. apply (le_trans _ i). assumption. apply le_refl. + assumption. rewrite Qinv_plus_distr. reflexivity. + unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. + reflexivity. rewrite CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_comm, CRplus_assoc, CRplus_opp_r, CRplus_0_r. + reflexivity. + rewrite CRabs_right. reflexivity. + rewrite <- (CRplus_opp_r (CRsum vn (Init.Nat.min i j))). + apply CRplus_le_compat. apply pos_sum_more. + intros. apply (CRle_trans _ (CRabs R (un k))). apply CRabs_pos. + apply H. apply (le_trans _ i). apply Nat.le_min_l. apply Nat.le_max_l. + apply CRle_refl. + - exists x. split. assumption. + (* x <= s *) + apply (CRplus_le_reg_r (-x)). rewrite CRplus_opp_r. + apply (CR_cv_bound_down (fun n => CRsum vn n - CRsum un n) _ _ 0). + intros. rewrite <- (CRplus_opp_r (CRsum un n)). + apply CRplus_le_compat. apply sum_Rle. + intros. apply (CRle_trans _ (CRabs R (un k))). + apply CRle_abs. apply H. apply CRle_refl. + apply CR_cv_plus. assumption. + apply CR_cv_opp. assumption. +Qed. + +Lemma series_cv_abs_lt + : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (l : CRcarrier R), + (forall n:nat, CRabs R (un n) <= vn n) + -> series_cv_lim_lt vn l + -> series_cv_lim_lt un l. +Proof. + intros. destruct H0 as [x [H0 H1]]. + destruct (series_cv_maj un vn x H H0) as [x0 H2]. + exists x0. split. apply H2. apply (CRle_lt_trans _ x). + apply H2. apply H1. +Qed. + +Definition series_cv_abs {R : ConstructiveReals} (u : nat -> CRcarrier R) + : CR_cauchy R (CRsum (fun n => CRabs R (u n))) + -> { l : CRcarrier R & series_cv u l }. +Proof. + intros. apply CR_complete in H. destruct H. + destruct (series_cv_maj u (fun k => CRabs R (u k)) x). + intro n. apply CRle_refl. assumption. exists x0. apply p. +Qed. + +Lemma series_cv_abs_eq + : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (a : CRcarrier R) + (cau : CR_cauchy R (CRsum (fun n => CRabs R (u n)))), + series_cv u a + -> (a == (let (l,_):= series_cv_abs u cau in l))%ConstructiveReals. +Proof. + intros. destruct (series_cv_abs u cau). + apply (series_cv_unique u). exact H. exact s. +Qed. + +Lemma series_cv_abs_cv + : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (cau : CR_cauchy R (CRsum (fun n => CRabs R (u n)))), + series_cv u (let (l,_):= series_cv_abs u cau in l). +Proof. + intros. destruct (series_cv_abs u cau). exact s. +Qed. + +Lemma series_cv_opp : forall {R : ConstructiveReals} + (s : CRcarrier R) (u : nat -> CRcarrier R), + series_cv u s + -> series_cv (fun n => - u n) (- s). +Proof. + intros. intros p. specialize (H p) as [N H]. + exists N. intros n H0. + setoid_replace (CRsum (fun n0 : nat => - u n0) n - - s) + with (-(CRsum (fun n0 : nat => u n0) n - s)). + rewrite CRabs_opp. + apply H, H0. unfold CRminus. + rewrite sum_opp. rewrite CRopp_plus_distr. reflexivity. +Qed. + +Lemma series_cv_scale : forall {R : ConstructiveReals} + (a : CRcarrier R) (s : CRcarrier R) (u : nat -> CRcarrier R), + series_cv u s + -> series_cv (fun n => (u n) * a) (s * a). +Proof. + intros. + apply (CR_cv_eq _ (fun n => CRsum u n * a)). + intro n. rewrite sum_scale. reflexivity. apply CR_cv_scale, H. +Qed. + +Lemma series_cv_plus : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (s t : CRcarrier R), + series_cv u s + -> series_cv v t + -> series_cv (fun n => u n + v n) (s + t). +Proof. + intros. apply (CR_cv_eq _ (fun n => CRsum u n + CRsum v n)). + intro n. symmetry. apply sum_plus. apply CR_cv_plus. exact H. exact H0. +Qed. + +Lemma series_cv_nonneg : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, 0 <= u n) -> series_cv u s -> 0 <= s. +Proof. + intros. apply (CRle_trans 0 (CRsum u 0)). apply H. + apply (growing_ineq (CRsum u)). intro n. simpl. + rewrite <- CRplus_0_r. apply CRplus_le_compat. + rewrite CRplus_0_r. apply CRle_refl. apply H. apply H0. +Qed. + +Lemma CR_cv_le : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (a b : CRcarrier R), + (forall n:nat, u n <= v n) + -> CR_cv R u a + -> CR_cv R v b + -> a <= b. +Proof. + intros. apply (CRplus_le_reg_r (-a)). rewrite CRplus_opp_r. + apply (CR_cv_bound_down (fun i:nat => v i - u i) _ _ 0). + intros. rewrite <- (CRplus_opp_l (u n)). + unfold CRminus. + rewrite (CRplus_comm (v n)). apply CRplus_le_compat_l. + apply H. apply CR_cv_plus. exact H1. apply CR_cv_opp, H0. +Qed. + +Lemma CR_cv_abs_cont : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (s : CRcarrier R), + CR_cv R u s + -> CR_cv R (fun n => CRabs R (u n)) (CRabs R s). +Proof. + intros. intros eps. specialize (H eps) as [N lim]. + exists N. intros n H. + apply (CRle_trans _ (CRabs R (u n - s))). apply CRabs_triang_inv2. + apply lim. assumption. +Qed. + +Lemma CR_cv_dist_cont : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (a s : CRcarrier R), + CR_cv R u s + -> CR_cv R (fun n => CRabs R (a - u n)) (CRabs R (a - s)). +Proof. + intros. apply CR_cv_abs_cont. + intros eps. specialize (H eps) as [N lim]. + exists N. intros n H. + setoid_replace (a - u n - (a - s)) with (s - (u n)). + specialize (lim n). + rewrite CRabs_minus_sym. + apply lim. assumption. + unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. + rewrite (CRplus_comm a), (CRplus_comm s). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. reflexivity. +Qed. + +Lemma series_cv_triangle : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (s sAbs : CRcarrier R), + series_cv u s + -> series_cv (fun n => CRabs R (u n)) sAbs + -> CRabs R s <= sAbs. +Proof. + intros. + apply (CR_cv_le (fun n => CRabs R (CRsum u n)) + (CRsum (fun n => CRabs R (u n)))). + intros. apply multiTriangleIneg. apply CR_cv_abs_cont. assumption. assumption. +Qed. + +Lemma CR_double : forall {R : ConstructiveReals} (x:CRcarrier R), + CR_of_Q R 2 * x == x + x. +Proof. + intros R x. rewrite (CR_of_Q_morph R 2 (1+1)). + 2: reflexivity. rewrite CR_of_Q_plus, CR_of_Q_one. + rewrite CRmult_plus_distr_r, CRmult_1_l. reflexivity. +Qed. + +Lemma GeoCvZero : forall {R : ConstructiveReals}, + CR_cv R (fun n:nat => CRpow (CR_of_Q R (1#2)) n) 0. +Proof. + intro R. assert (forall n:nat, INR n < CRpow (CR_of_Q R 2) n). + { induction n. unfold INR; simpl. rewrite CR_of_Q_zero. + apply CRzero_lt_one. unfold INR. fold (1+n)%nat. + rewrite Nat2Z.inj_add. + rewrite (CR_of_Q_morph R _ ((Z.of_nat 1 # 1) + (Z.of_nat n #1))). + 2: symmetry; apply Qinv_plus_distr. + rewrite CR_of_Q_plus. + replace (CRpow (CR_of_Q R 2) (1 + n)) + with (CR_of_Q R 2 * CRpow (CR_of_Q R 2) n). + 2: reflexivity. rewrite CR_double. + apply CRplus_le_lt_compat. + 2: exact IHn. simpl. rewrite CR_of_Q_one. + apply pow_R1_Rle. rewrite <- CR_of_Q_one. apply CR_of_Q_le. discriminate. } + intros p. exists (Pos.to_nat p). intros. + unfold CRminus. rewrite CRopp_0. rewrite CRplus_0_r. + rewrite CRabs_right. + 2: apply pow_le; rewrite <- CR_of_Q_zero; apply CR_of_Q_le; discriminate. + apply CRlt_asym. + apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos p # 1))). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. rewrite <- CR_of_Q_mult. + rewrite (CR_of_Q_morph R ((Z.pos p # 1) * (1 # p)) 1). + 2: unfold Qmult, Qeq, Qnum, Qden; ring_simplify; reflexivity. + apply (CRmult_lt_reg_r (CRpow (CR_of_Q R 2) i)). + apply pow_lt. simpl. rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt. reflexivity. + rewrite CRmult_assoc. rewrite pow_mult. + rewrite (pow_proper (CR_of_Q R (1 # 2) * CR_of_Q R 2) 1), pow_one. + rewrite CRmult_1_r, CR_of_Q_one, CRmult_1_l. + apply (CRle_lt_trans _ (INR i)). 2: exact (H i). clear H. + apply CR_of_Q_le. unfold Qle,Qnum,Qden. + do 2 rewrite Z.mul_1_r. + rewrite <- positive_nat_Z. apply Nat2Z.inj_le, H0. + rewrite <- CR_of_Q_mult. setoid_replace ((1#2)*2)%Q with 1%Q. + apply CR_of_Q_one. reflexivity. +Qed. + +Lemma GeoFiniteSum : forall {R : ConstructiveReals} (n:nat), + CRsum (CRpow (CR_of_Q R (1#2))) n == CR_of_Q R 2 - CRpow (CR_of_Q R (1#2)) n. +Proof. + induction n. + - unfold CRsum, CRpow. simpl (1%ConstructiveReals). + unfold CRminus. rewrite (CR_of_Q_morph R _ (1+1)). + rewrite CR_of_Q_plus, CR_of_Q_one, CRplus_assoc. + rewrite CRplus_opp_r, CRplus_0_r. reflexivity. reflexivity. + - setoid_replace (CRsum (CRpow (CR_of_Q R (1 # 2))) (S n)) + with (CRsum (CRpow (CR_of_Q R (1 # 2))) n + CRpow (CR_of_Q R (1 # 2)) (S n)). + 2: reflexivity. + rewrite IHn. clear IHn. unfold CRminus. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + apply (CRplus_eq_reg_l + (CRpow (CR_of_Q R (1 # 2)) n + CRpow (CR_of_Q R (1 # 2)) (S n))). + rewrite (CRplus_assoc _ _ (-CRpow (CR_of_Q R (1 # 2)) (S n))), + CRplus_opp_r, CRplus_0_r. + rewrite (CRplus_comm (CRpow (CR_of_Q R (1 # 2)) n)), CRplus_assoc. + rewrite <- (CRplus_assoc (CRpow (CR_of_Q R (1 # 2)) n)), CRplus_opp_r, + CRplus_0_l, <- CR_double. + setoid_replace (CRpow (CR_of_Q R (1 # 2)) (S n)) + with (CR_of_Q R (1 # 2) * CRpow (CR_of_Q R (1 # 2)) n). + 2: reflexivity. + rewrite <- CRmult_assoc, <- CR_of_Q_mult. + setoid_replace (2 * (1 # 2))%Q with 1%Q. + rewrite CR_of_Q_one. apply CRmult_1_l. reflexivity. +Qed. + +Lemma GeoHalfBelowTwo : forall {R : ConstructiveReals} (n:nat), + CRsum (CRpow (CR_of_Q R (1#2))) n < CR_of_Q R 2. +Proof. + intros. rewrite <- (CRplus_0_r (CR_of_Q R 2)), GeoFiniteSum. + apply CRplus_lt_compat_l. rewrite <- CRopp_0. + apply CRopp_gt_lt_contravar. + apply pow_lt. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. +Qed. + +Lemma GeoHalfTwo : forall {R : ConstructiveReals}, + series_cv (fun n => CRpow (CR_of_Q R (1#2)) n) (CR_of_Q R 2). +Proof. + intro R. + apply (CR_cv_eq _ (fun n => CR_of_Q R 2 - CRpow (CR_of_Q R (1 # 2)) n)). + - intro n. rewrite GeoFiniteSum. reflexivity. + - assert (forall n:nat, INR n < CRpow (CR_of_Q R 2) n). + { induction n. unfold INR; simpl. rewrite CR_of_Q_zero. + apply CRzero_lt_one. apply (CRlt_le_trans _ (CRpow (CR_of_Q R 2) n + 1)). + unfold INR. + rewrite Nat2Z.inj_succ, <- Z.add_1_l. + rewrite (CR_of_Q_morph R _ (1 + (Z.of_nat n #1))). + 2: symmetry; apply Qinv_plus_distr. rewrite CR_of_Q_plus. + rewrite CRplus_comm. rewrite CR_of_Q_one. + apply CRplus_lt_compat_r, IHn. + setoid_replace (CRpow (CR_of_Q R 2) (S n)) + with (CRpow (CR_of_Q R 2) n + CRpow (CR_of_Q R 2) n). + apply CRplus_le_compat. apply CRle_refl. + apply pow_R1_Rle. rewrite <- CR_of_Q_one. apply CR_of_Q_le. discriminate. + rewrite <- CR_double. reflexivity. } + intros n. exists (Pos.to_nat n). intros. + setoid_replace (CR_of_Q R 2 - CRpow (CR_of_Q R (1 # 2)) i - CR_of_Q R 2) + with (- CRpow (CR_of_Q R (1 # 2)) i). + rewrite CRabs_opp. rewrite CRabs_right. + assert (0 < CR_of_Q R 2). + { rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. } + rewrite (pow_proper _ (CRinv R (CR_of_Q R 2) (inr H1))). + rewrite pow_inv. apply CRlt_asym. + apply (CRmult_lt_reg_l (CRpow (CR_of_Q R 2) i)). apply pow_lt, H1. + rewrite CRinv_r. + apply (CRmult_lt_reg_r (CR_of_Q R (Z.pos n#1))). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + rewrite CRmult_1_l, CRmult_assoc. + rewrite <- CR_of_Q_mult. + rewrite (CR_of_Q_morph R ((1 # n) * (Z.pos n # 1)) 1). 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. apply (CRle_lt_trans _ (INR i)). + 2: apply H. apply CR_of_Q_le. + unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. destruct i. + exfalso. inversion H0. pose proof (Pos2Nat.is_pos n). + rewrite H3 in H2. inversion H2. + apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. + apply (le_trans _ _ _ H0). rewrite SuccNat2Pos.id_succ. apply le_refl. + apply (CRmult_eq_reg_l (CR_of_Q R 2)). right. exact H1. + rewrite CRinv_r. rewrite <- CR_of_Q_mult. + setoid_replace (2 * (1 # 2))%Q with 1%Q. + apply CR_of_Q_one. reflexivity. + apply CRlt_asym, pow_lt. rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt. reflexivity. + unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_l. reflexivity. +Qed. + +Lemma series_cv_remainder_maj : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (s eps : CRcarrier R) + (N : nat), + series_cv u s + -> 0 < eps + -> (forall n:nat, 0 <= u n) + -> CRabs R (CRsum u N - s) <= eps + -> forall n:nat, CRsum (fun k=> u (N + S k)%nat) n <= eps. +Proof. + intros. pose proof (sum_assoc u N n). + rewrite <- (CRsum_eq (fun k : nat => u (S N + k)%nat)). + apply (CRplus_le_reg_l (CRsum u N)). rewrite <- H3. + apply (CRle_trans _ s). apply growing_ineq. + 2: apply H. + intro k. simpl. rewrite <- CRplus_0_r, CRplus_assoc. + apply CRplus_le_compat_l. rewrite CRplus_0_l. apply H1. + rewrite CRabs_minus_sym in H2. + rewrite CRplus_comm. apply (CRplus_le_reg_r (-CRsum u N)). + rewrite CRplus_assoc. rewrite CRplus_opp_r. rewrite CRplus_0_r. + apply (CRle_trans _ (CRabs R (s - CRsum u N))). apply CRle_abs. + assumption. intros. rewrite Nat.add_succ_r. reflexivity. +Qed. + +Lemma series_cv_abs_remainder : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (s sAbs : CRcarrier R) + (n : nat), + series_cv u s + -> series_cv (fun n => CRabs R (u n)) sAbs + -> CRabs R (CRsum u n - s) + <= sAbs - CRsum (fun n => CRabs R (u n)) n. +Proof. + intros. + apply (CR_cv_le (fun N => CRabs R (CRsum u n - (CRsum u (n + N)))) + (fun N => CRsum (fun n : nat => CRabs R (u n)) (n + N) + - CRsum (fun n : nat => CRabs R (u n)) n)). + - intro N. destruct N. rewrite plus_0_r. unfold CRminus. + rewrite CRplus_opp_r. rewrite CRplus_opp_r. + rewrite CRabs_right. apply CRle_refl. apply CRle_refl. + rewrite Nat.add_succ_r. + replace (S (n + N)) with (S n + N)%nat. 2: reflexivity. + unfold CRminus. rewrite sum_assoc. rewrite sum_assoc. + rewrite CRopp_plus_distr. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l, CRabs_opp. + rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. + rewrite CRplus_0_l. apply multiTriangleIneg. + - apply CR_cv_dist_cont. intros eps. + specialize (H eps) as [N lim]. + exists N. intros. rewrite plus_comm. apply lim. apply (le_trans N i). + assumption. rewrite <- (plus_0_r i). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. + - apply CR_cv_plus. 2: apply CR_cv_const. intros eps. + specialize (H0 eps) as [N lim]. + exists N. intros. rewrite plus_comm. apply lim. apply (le_trans N i). + assumption. rewrite <- (plus_0_r i). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. +Qed. + +Lemma series_cv_minus : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (s t : CRcarrier R), + series_cv u s + -> series_cv v t + -> series_cv (fun n => u n - v n) (s - t). +Proof. + intros. apply (CR_cv_eq _ (fun n => CRsum u n - CRsum v n)). + intro n. symmetry. unfold CRminus. rewrite sum_plus. + rewrite sum_opp. reflexivity. + apply CR_cv_plus. exact H. apply CR_cv_opp. exact H0. +Qed. + +Lemma series_cv_le : forall {R : ConstructiveReals} + (un vn : nat -> CRcarrier R) (a b : CRcarrier R), + (forall n:nat, un n <= vn n) + -> series_cv un a + -> series_cv vn b + -> a <= b. +Proof. + intros. apply (CRplus_le_reg_r (-a)). rewrite CRplus_opp_r. + apply (series_cv_nonneg (fun n => vn n - un n)). + intro n. apply (CRplus_le_reg_r (un n)). + rewrite CRplus_0_l. unfold CRminus. + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + apply H. apply series_cv_minus; assumption. +Qed. + +Lemma series_cv_series : forall {R : ConstructiveReals} + (u : nat -> nat -> CRcarrier R) (s : nat -> CRcarrier R) (n : nat), + (forall i:nat, le i n -> series_cv (u i) (s i)) + -> series_cv (fun i => CRsum (fun j => u j i) n) (CRsum s n). +Proof. + induction n. + - intros. simpl. specialize (H O). + apply (series_cv_eq (u O)). reflexivity. apply H. apply le_refl. + - intros. simpl. apply (series_cv_plus). 2: apply (H (S n)). + apply IHn. 2: apply le_refl. intros. apply H. + apply (le_trans _ n _ H0). apply le_S. apply le_refl. +Qed. + +Lemma CR_cv_shift : + forall {R : ConstructiveReals} f k l, + CR_cv R (fun n => f (n + k)%nat) l -> CR_cv R f l. +Proof. + intros. intros eps. + specialize (H eps) as [N Nmaj]. + exists (N+k)%nat. intros n H. + destruct (Nat.le_exists_sub k n). + apply (le_trans _ (N + k)). 2: exact H. + apply (le_trans _ (0 + k)). apply le_refl. + rewrite <- Nat.add_le_mono_r. apply le_0_n. + destruct H0. + subst n. apply Nmaj. unfold ge in H. + rewrite <- Nat.add_le_mono_r in H. exact H. +Qed. + +Lemma CR_cv_shift' : + forall {R : ConstructiveReals} f k l, + CR_cv R f l -> CR_cv R (fun n => f (n + k)%nat) l. +Proof. + intros R f' k l cvf eps; destruct (cvf eps) as [N Pn]. + exists N; intros n nN; apply Pn; auto with arith. +Qed. + +Lemma series_cv_shift : + forall {R : ConstructiveReals} (f : nat -> CRcarrier R) k l, + series_cv (fun n => f (S k + n)%nat) l + -> series_cv f (l + CRsum f k). +Proof. + intros. intro p. specialize (H p) as [n nmaj]. + exists (S k+n)%nat. intros. destruct (Nat.le_exists_sub (S k) i). + apply (le_trans _ (S k + 0)). rewrite Nat.add_0_r. apply le_refl. + apply (le_trans _ (S k + n)). apply Nat.add_le_mono_l, le_0_n. + exact H. destruct H0. subst i. + rewrite Nat.add_comm in H. rewrite <- Nat.add_le_mono_r in H. + specialize (nmaj x H). unfold CRminus. + rewrite Nat.add_comm, (sum_assoc f k x). + setoid_replace (CRsum f k + CRsum (fun k0 : nat => f (S k + k0)%nat) x - (l + CRsum f k)) + with (CRsum (fun k0 : nat => f (S k + k0)%nat) x - l). + exact nmaj. unfold CRminus. rewrite (CRplus_comm (CRsum f k)). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRplus_comm, CRopp_plus_distr, CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_r. reflexivity. +Qed. + +Lemma series_cv_shift' : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (s : CRcarrier R) (shift : nat), + series_cv un s + -> series_cv (fun n => un (n+shift)%nat) + (s - match shift with + | O => 0 + | S p => CRsum un p + end). +Proof. + intros. destruct shift as [|p]. + - unfold CRminus. rewrite CRopp_0. rewrite CRplus_0_r. + apply (series_cv_eq un). intros. + rewrite plus_0_r. reflexivity. apply H. + - apply (CR_cv_eq _ (fun n => CRsum un (n + S p) - CRsum un p)). + intros. rewrite plus_comm. unfold CRminus. + rewrite sum_assoc. simpl. rewrite CRplus_comm, <- CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_l. + apply CRsum_eq. intros. rewrite (plus_comm i). reflexivity. + apply CR_cv_plus. apply (CR_cv_shift' _ (S p) _ H). + intros n. exists (Pos.to_nat n). intros. + unfold CRminus. simpl. + rewrite CRopp_involutive, CRplus_opp_l. rewrite CRabs_right. + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. apply CRle_refl. +Qed. diff --git a/theories/Reals/Abstract/ConstructiveReals.v b/theories/Reals/Abstract/ConstructiveReals.v new file mode 100644 index 0000000000..d91fd1183a --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveReals.v @@ -0,0 +1,1149 @@ +(************************************************************************) +(* * 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 (see file ConstructiveRealsMorphisms). + For example it is implemented by the Cauchy reals in file + ConstructivecauchyReals and also implemented by 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). + + Any computation about constructive reals can be worked + in the fastest instance for it; we then transport the results + to all other instances by the isomorphisms. This way of working + is different from the usual interfaces, where we would rather + prove things abstractly, by quantifying universally on the instance. + + The functions of ConstructiveReals do not have a direct impact + on performance, because algorithms will be extracted from instances, + and because fast ConstructiveReals morphisms should be coded + manually. However, since instances are forced to implement + those functions, it is probable that they will also use them + in their algorithms. So those functions hint at what we think + will yield fast and small extracted programs. + + Constructive reals are setoids, which custom equality is defined as + x == y iff (x <= y /\ y <= x). + It is hard to quotient constructively to get the Leibniz equality + on the real numbers. In "Sheaves in Geometry and Logic", + MacLane and Moerdijk show a topos in which all functions R -> Z + are constant. Consequently all functions R -> Q are constant and + it is not possible to approximate real numbers by rational numbers. *) + + +Require Import QArith Qabs Qround. + +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). + +Structure ConstructiveReals : Type := + { + CRcarrier : Set; + + (* Put this order relation in sort Set rather than Prop, + to allow the definition of fast ConstructiveReals morphisms. + For example, the Cauchy reals do store information in + the proofs of CRlt, which is used in algorithms in sort Set. *) + CRlt : CRcarrier -> CRcarrier -> Set; + CRltLinear : isLinearOrder CRlt; + + CRle (x y : CRcarrier) := CRlt y x -> False; + CReq (x y : CRcarrier) := CRle y x /\ CRle x y; + CRapart (x y : CRcarrier) := sum (CRlt x y) (CRlt y x); + + (* The propositional truncation of CRlt. It facilitates proofs + when computations are not considered important, for example in + classical reals with extra logical axioms. *) + 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 CReq; + CRisRingExt : ring_eq_ext CRplus CRmult CRopp CReq; + + (* 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, CRapart x CRzero -> CRcarrier; + CRinv_l : forall (r:CRcarrier) (rnz : CRapart r CRzero), + CReq (CRmult (CRinv r rnz) r) CRone; + CRinv_0_lt_compat : forall (r : CRcarrier) (rnz : CRapart r CRzero), + CRlt CRzero r -> CRlt CRzero (CRinv r rnz); + + (* The initial field morphism (in characteristic zero). + The abstract definition by iteration of addition is + probably the slowest. Let each instance implement + a faster (and often simpler) version. *) + CR_of_Q : Q -> CRcarrier; + CR_of_Q_plus : forall q r : Q, CReq (CR_of_Q (q+r)) + (CRplus (CR_of_Q q) (CR_of_Q r)); + CR_of_Q_mult : forall q r : Q, CReq (CR_of_Q (q*r)) + (CRmult (CR_of_Q q) (CR_of_Q r)); + CR_of_Q_one : CReq (CR_of_Q 1) CRone; + CR_of_Q_lt : forall q r : Q, + Qlt q r -> CRlt (CR_of_Q q) (CR_of_Q r); + lt_CR_of_Q : forall q r : Q, + CRlt (CR_of_Q q) (CR_of_Q r) -> Qlt q r; + + (* This function is very fast in both the Cauchy and Dedekind + instances, because this rational number q is almost what + the proof of CRlt x y contains. + This function is also the heart of the computation of + constructive real numbers : it approximates x to any + requested precision y. *) + CR_Q_dense : forall x y : CRcarrier, CRlt x y -> + { q : Q & prod (CRlt x (CR_of_Q q)) + (CRlt (CR_of_Q q) y) }; + CR_archimedean : forall x : CRcarrier, + { n : positive & CRlt x (CR_of_Q (Z.pos n # 1)) }; + + CRminus (x y : CRcarrier) : CRcarrier + := CRplus x (CRopp y); + + (* Absolute value, CRabs x is the least upper bound + of the pair x, -x. *) + CRabs : CRcarrier -> CRcarrier; + CRabs_def : forall x y : CRcarrier, + (CRle x y /\ CRle (CRopp x) y) + <-> CRle (CRabs x) y; + + (* Definitions of convergence and Cauchy-ness. The formulas + with orderLe or CRlt are logically equivalent, the choice of + orderLe in sort Prop is a question of performance. + It is very rare to turn back to the strict order to + define functions in sort Set, so we prefer to discard + those proofs during extraction. And even in those rare cases, + it is easy to divide epsilon by 2 for example. *) + CR_cv (un : nat -> CRcarrier) (l : CRcarrier) : Set + := forall p:positive, + { n : nat | forall i:nat, le n i + -> CRle (CRabs (CRminus (un i) l)) + (CR_of_Q (1#p)) }; + CR_cauchy (un : nat -> CRcarrier) : Set + := forall p : positive, + { n : nat | forall i j:nat, le n i -> le n j + -> CRle (CRabs (CRminus (un i) (un j))) + (CR_of_Q (1#p)) }; + + (* For the Cauchy reals, this algorithm consists in building + a Cauchy sequence of rationals un : nat -> Q that has + the same limit as xn. For each n:nat, un n is a 1/n + rational approximation of a point of xn that has converged + within 1/n. *) + CR_complete : + forall xn : (nat -> CRcarrier), + CR_cauchy xn -> { l : CRcarrier & CR_cv xn l }; + }. + +Declare Scope ConstructiveReals. + +Delimit Scope ConstructiveReals with ConstructiveReals. + +Notation "x < y" := (CRlt _ x y) : ConstructiveReals. +Notation "x <= y" := (CRle _ x y) : ConstructiveReals. +Notation "x <= y <= z" := (CRle _ x y /\ CRle _ y z) : ConstructiveReals. +Notation "x < y < z" := (prod (CRlt _ x y) (CRlt _ y z)) : ConstructiveReals. +Notation "x == y" := (CReq _ x y) : ConstructiveReals. +Notation "x ≶ y" := (CRapart _ x y) (at level 70, no associativity) : ConstructiveReals. +Notation "0" := (CRzero _) : ConstructiveReals. +Notation "1" := (CRone _) : ConstructiveReals. +Notation "x + y" := (CRplus _ x y) : ConstructiveReals. +Notation "- x" := (CRopp _ x) : ConstructiveReals. +Notation "x - y" := (CRminus _ x y) : ConstructiveReals. +Notation "x * y" := (CRmult _ x y) : ConstructiveReals. +Notation "/ x" := (CRinv _ x) : ConstructiveReals. + +Local Open Scope ConstructiveReals. + +Lemma CRlt_asym : forall {R : ConstructiveReals} (x y : CRcarrier R), + x < y -> x <= y. +Proof. + intros. intro H0. destruct (CRltLinear R), p. + apply (f x y); assumption. +Qed. + +Lemma CRlt_proper + : forall R : ConstructiveReals, + CMorphisms.Proper + (CMorphisms.respectful (CReq R) + (CMorphisms.respectful (CReq R) CRelationClasses.iffT)) (CRlt R). +Proof. + intros R x y H x0 y0 H0. destruct H, H0. + destruct (CRltLinear R). split. + - intro. destruct (s x y x0). assumption. + contradiction. destruct (s y y0 x0). + assumption. assumption. contradiction. + - intro. destruct (s y x y0). assumption. + contradiction. destruct (s x x0 y0). + assumption. assumption. contradiction. +Qed. + +Lemma CRle_refl : forall {R : ConstructiveReals} (x : CRcarrier R), + x <= x. +Proof. + intros. intro H. destruct (CRltLinear R), p. + exact (f x x H H). +Qed. + +Lemma CRle_lt_trans : forall {R : ConstructiveReals} (r1 r2 r3 : CRcarrier R), + r1 <= r2 -> r2 < r3 -> r1 < r3. +Proof. + intros. destruct (CRltLinear R). + destruct (s r2 r1 r3 H0). contradiction. apply c. +Qed. + +Lemma CRlt_le_trans : forall {R : ConstructiveReals} (r1 r2 r3 : CRcarrier R), + r1 < r2 -> r2 <= r3 -> r1 < r3. +Proof. + intros. destruct (CRltLinear R). + destruct (s r1 r3 r2 H). apply c. contradiction. +Qed. + +Lemma CRle_trans : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x <= y -> y <= z -> x <= z. +Proof. + intros. intro abs. apply H0. + apply (CRlt_le_trans _ x); assumption. +Qed. + +Lemma CRlt_trans : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x < y -> y < z -> x < z. +Proof. + intros. apply (CRlt_le_trans _ y _ H). + apply CRlt_asym. exact H0. +Defined. + +Lemma CRlt_trans_flip : forall {R : ConstructiveReals} (x y z : CRcarrier R), + y < z -> x < y -> x < z. +Proof. + intros. apply (CRlt_le_trans _ y). exact H0. + apply CRlt_asym. exact H. +Defined. + +Lemma CReq_refl : forall {R : ConstructiveReals} (x : CRcarrier R), + x == x. +Proof. + split; apply CRle_refl. +Qed. + +Lemma CReq_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), + x == y -> y == x. +Proof. + intros. destruct H. split; intro abs; contradiction. +Qed. + +Lemma CReq_trans : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x == y -> y == z -> x == z. +Proof. + intros. destruct H,H0. destruct (CRltLinear R), p. split. + - intro abs. destruct (s _ y _ abs); contradiction. + - intro abs. destruct (s _ y _ abs); contradiction. +Qed. + +Add Parametric Relation {R : ConstructiveReals} : (CRcarrier R) (CReq R) + reflexivity proved by (CReq_refl) + symmetry proved by (CReq_sym) + transitivity proved by (CReq_trans) + as CReq_rel. + +Instance CReq_relT : forall {R : ConstructiveReals}, + CRelationClasses.Equivalence (CReq R). +Proof. + split. exact CReq_refl. exact CReq_sym. exact CReq_trans. +Qed. + +Instance CRlt_morph + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) CRelationClasses.iffT)) (CRlt R). +Proof. + intros R x y H x0 y0 H0. destruct H, H0. split. + - intro. destruct (CRltLinear R). destruct (s x y x0). assumption. + contradiction. destruct (s y y0 x0). + assumption. assumption. contradiction. + - intro. destruct (CRltLinear R). destruct (s y x y0). assumption. + contradiction. destruct (s x x0 y0). + assumption. assumption. contradiction. +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRle R) + with signature CReq R ==> CReq R ==> iff + as CRle_morph. +Proof. + intros. split. + - intros H1 H2. unfold CRle in H1. + rewrite <- H0 in H2. rewrite <- H in H2. contradiction. + - intros H1 H2. unfold CRle in H1. + rewrite H0 in H2. rewrite H in H2. contradiction. +Qed. + +Lemma CRplus_0_l : forall {R : ConstructiveReals} (x : CRcarrier R), + 0 + x == x. +Proof. + intros. destruct (CRisRing R). apply Radd_0_l. +Qed. + +Lemma CRplus_0_r : forall {R : ConstructiveReals} (x : CRcarrier R), + x + 0 == x. +Proof. + intros. destruct (CRisRing R). + transitivity (0 + x). + apply Radd_comm. apply Radd_0_l. +Qed. + +Lemma CRplus_opp_l : forall {R : ConstructiveReals} (x : CRcarrier R), + - x + x == 0. +Proof. + intros. destruct (CRisRing R). + transitivity (x + - x). + apply Radd_comm. apply Ropp_def. +Qed. + +Lemma CRplus_opp_r : forall {R : ConstructiveReals} (x : CRcarrier R), + x + - x == 0. +Proof. + intros. destruct (CRisRing R). apply Ropp_def. +Qed. + +Lemma CRopp_0 : forall {R : ConstructiveReals}, + CRopp R 0 == 0. +Proof. + intros. rewrite <- CRplus_0_r, CRplus_opp_l. + reflexivity. +Qed. + +Lemma CRplus_lt_compat_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 < r2 -> r1 + r < r2 + r. +Proof. + intros. destruct (CRisRing R). + apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) + (CRplus R r2 r) (CRplus R r2 r)). + apply CReq_refl. + apply (CRlt_proper R _ _ (CReq_refl _) _ (CRplus R r r2)). + apply Radd_comm. apply CRplus_lt_compat_l. exact H. +Qed. + +Lemma CRplus_lt_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 + r < r2 + r -> r1 < r2. +Proof. + intros. destruct (CRisRing R). + apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) + (CRplus R r2 r) (CRplus R r2 r)) in H. + 2: apply CReq_refl. + apply (CRlt_proper R _ _ (CReq_refl _) _ (CRplus R r r2)) in H. + apply CRplus_lt_reg_l in H. exact H. + apply Radd_comm. +Qed. + +Lemma CRplus_le_compat_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 <= r2 -> r + r1 <= r + r2. +Proof. + intros. intros abs. apply CRplus_lt_reg_l in abs. apply H. exact abs. +Qed. + +Lemma CRplus_le_compat_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 <= r2 -> r1 + r <= r2 + r. +Proof. + intros. intros abs. apply CRplus_lt_reg_r in abs. apply H. exact abs. +Qed. + +Lemma CRplus_le_compat : forall {R : ConstructiveReals} (r1 r2 r3 r4 : CRcarrier R), + r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4. +Proof. + intros. apply (CRle_trans _ (CRplus R r2 r3)). + apply CRplus_le_compat_r, H. apply CRplus_le_compat_l, H0. +Qed. + +Lemma CRle_minus : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= y -> 0 <= y - x. +Proof. + intros. rewrite <- (CRplus_opp_r x). + apply CRplus_le_compat_r. exact H. +Qed. + +Lemma CRplus_le_reg_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r + r1 <= r + r2 -> r1 <= r2. +Proof. + intros. intro abs. apply H. clear H. + apply CRplus_lt_compat_l. exact abs. +Qed. + +Lemma CRplus_le_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 + r <= r2 + r -> r1 <= r2. +Proof. + intros. intro abs. apply H. clear H. + apply CRplus_lt_compat_r. exact abs. +Qed. + +Lemma CRplus_lt_le_compat : + forall {R : ConstructiveReals} (r1 r2 r3 r4 : CRcarrier R), + r1 < r2 + -> r3 <= r4 + -> r1 + r3 < r2 + r4. +Proof. + intros. apply (CRlt_le_trans _ (CRplus R r2 r3)). + apply CRplus_lt_compat_r. exact H. intro abs. + apply CRplus_lt_reg_l in abs. contradiction. +Qed. + +Lemma CRplus_le_lt_compat : + forall {R : ConstructiveReals} (r1 r2 r3 r4 : CRcarrier R), + r1 <= r2 + -> r3 < r4 + -> r1 + r3 < r2 + r4. +Proof. + intros. apply (CRle_lt_trans _ (CRplus R r2 r3)). + apply CRplus_le_compat_r. exact H. + apply CRplus_lt_compat_l. exact H0. +Qed. + +Lemma CRplus_eq_reg_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r + r1 == r + r2 -> r1 == r2. +Proof. + intros. + destruct (CRisRingExt R). clear Rmul_ext Ropp_ext. + pose proof (Radd_ext + (CRopp R r) (CRopp R r) (CReq_refl _) + _ _ H). + destruct (CRisRing R). + apply (CReq_trans r1) in H0. + apply (CReq_trans _ _ _ H0). + transitivity ((- r + r) + r2). + apply Radd_assoc. transitivity (0 + r2). + apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. + apply Radd_0_l. apply CReq_sym. + transitivity (- r + r + r1). + apply Radd_assoc. + transitivity (0 + r1). + apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. + apply Radd_0_l. +Qed. + +Lemma CRplus_eq_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 + r == r2 + r -> r1 == r2. +Proof. + intros. apply (CRplus_eq_reg_l r). + transitivity (r1 + r). apply (Radd_comm (CRisRing R)). + transitivity (r2 + r). + exact H. apply (Radd_comm (CRisRing R)). +Qed. + +Lemma CRplus_assoc : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r + r1 + r2 == r + (r1 + r2). +Proof. + intros. symmetry. apply (Radd_assoc (CRisRing R)). +Qed. + +Lemma CRplus_comm : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + r1 + r2 == r2 + r1. +Proof. + intros. apply (Radd_comm (CRisRing R)). +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRplus R) + with signature CReq R ==> CReq R ==> CReq R + as CRplus_morph. +Proof. + apply (CRisRingExt R). +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRopp R) + with signature CReq R ==> CReq R + as CRopp_morph. +Proof. + apply (CRisRingExt R). +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRmult R) + with signature CReq R ==> CReq R ==> CReq R + as CRmult_morph. +Proof. + apply (CRisRingExt R). +Qed. + +Instance CRplus_morph_T + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (CRplus R). +Proof. + intros R x y H z t H1. apply CRplus_morph; assumption. +Qed. + +Instance CRmult_morph_T + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (CRmult R). +Proof. + intros R x y H z t H1. apply CRmult_morph; assumption. +Qed. + +Instance CRopp_morph_T + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CReq R)) (CRopp R). +Proof. + apply CRisRingExt. +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRminus R) + with signature (CReq R) ==> (CReq R) ==> (CReq R) + as CRminus_morph. +Proof. + intros. unfold CRminus. rewrite H,H0. reflexivity. +Qed. + +Instance CRminus_morph_T + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (CRminus R). +Proof. + intros R x y exy z t ezt. unfold CRminus. rewrite exy,ezt. reflexivity. +Qed. + +Lemma CRopp_involutive : forall {R : ConstructiveReals} (r : CRcarrier R), + - - r == r. +Proof. + intros. apply (CRplus_eq_reg_l (CRopp R r)). + transitivity (CRzero R). apply CRisRing. + apply CReq_sym. transitivity (r + - r). + apply CRisRing. apply CRisRing. +Qed. + +Lemma CRopp_gt_lt_contravar + : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + r2 < r1 -> - r1 < - r2. +Proof. + intros. apply (CRplus_lt_reg_l R r1). + destruct (CRisRing R). + apply (CRle_lt_trans _ (CRzero R)). apply Ropp_def. + apply (CRplus_lt_compat_l R (CRopp R r2)) in H. + apply (CRle_lt_trans _ (CRplus R (CRopp R r2) r2)). + apply (CRle_trans _ (CRplus R r2 (CRopp R r2))). + destruct (Ropp_def r2). exact H0. + destruct (Radd_comm r2 (CRopp R r2)). exact H1. + apply (CRlt_le_trans _ _ _ H). + destruct (Radd_comm r1 (CRopp R r2)). exact H0. +Qed. + +Lemma CRopp_lt_cancel : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + - r2 < - r1 -> r1 < r2. +Proof. + intros. apply (CRplus_lt_compat_r r1) in H. + rewrite (CRplus_opp_l r1) in H. + apply (CRplus_lt_compat_l R r2) in H. + rewrite CRplus_0_r, (Radd_assoc (CRisRing R)) in H. + rewrite CRplus_opp_r, (Radd_0_l (CRisRing R)) in H. + exact H. +Qed. + +Lemma CRopp_ge_le_contravar + : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + r2 <= r1 -> - r1 <= - r2. +Proof. + intros. intros abs. apply CRopp_lt_cancel in abs. contradiction. +Qed. + +Lemma CRopp_plus_distr : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + - (r1 + r2) == - r1 + - r2. +Proof. + intros. destruct (CRisRing R), (CRisRingExt R). + apply (CRplus_eq_reg_l (CRplus R r1 r2)). + transitivity (CRzero R). apply Ropp_def. + transitivity (r2 + r1 + (-r1 + -r2)). + transitivity (r2 + (r1 + (-r1 + -r2))). + transitivity (r2 + - r2). + apply CReq_sym. apply Ropp_def. apply Radd_ext. + apply CReq_refl. + transitivity (CRzero R + - r2). + apply CReq_sym, Radd_0_l. + transitivity (r1 + - r1 + - r2). + apply Radd_ext. 2: apply CReq_refl. apply CReq_sym, Ropp_def. + apply CReq_sym, Radd_assoc. apply Radd_assoc. + apply Radd_ext. 2: apply CReq_refl. apply Radd_comm. +Qed. + +Lemma CRmult_1_l : forall {R : ConstructiveReals} (r : CRcarrier R), + 1 * r == r. +Proof. + intros. destruct (CRisRing R). apply Rmul_1_l. +Qed. + +Lemma CRmult_1_r : forall {R : ConstructiveReals} (x : CRcarrier R), + x * 1 == x. +Proof. + intros. destruct (CRisRing R). transitivity (CRmult R 1 x). + apply Rmul_comm. apply Rmul_1_l. +Qed. + +Lemma CRmult_assoc : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r * r1 * r2 == r * (r1 * r2). +Proof. + intros. symmetry. apply (Rmul_assoc (CRisRing R)). +Qed. + +Lemma CRmult_comm : forall {R : ConstructiveReals} (r s : CRcarrier R), + r * s == s * r. +Proof. + intros. rewrite (Rmul_comm (CRisRing R) r). reflexivity. +Qed. + +Lemma CRmult_plus_distr_l : forall {R : ConstructiveReals} (r1 r2 r3 : CRcarrier R), + r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). +Proof. + intros. destruct (CRisRing R). + transitivity ((r2 + r3) * r1). + apply Rmul_comm. + transitivity ((r2 * r1) + (r3 * r1)). + apply Rdistr_l. + transitivity ((r1 * r2) + (r3 * r1)). + destruct (CRisRingExt R). apply Radd_ext. + apply Rmul_comm. apply CReq_refl. + destruct (CRisRingExt R). apply Radd_ext. + apply CReq_refl. apply Rmul_comm. +Qed. + +Lemma CRmult_plus_distr_r : forall {R : ConstructiveReals} (r1 r2 r3 : CRcarrier R), + (r2 + r3) * r1 == (r2 * r1) + (r3 * r1). +Proof. + intros. do 3 rewrite <- (CRmult_comm r1). + apply CRmult_plus_distr_l. +Qed. + +(* x == x+x -> x == 0 *) +Lemma CRzero_double : forall {R : ConstructiveReals} (x : CRcarrier R), + x == x + x -> x == 0. +Proof. + intros. + apply (CRplus_eq_reg_l x), CReq_sym. transitivity x. + apply CRplus_0_r. exact H. +Qed. + +Lemma CRmult_0_r : forall {R : ConstructiveReals} (x : CRcarrier R), + x * 0 == 0. +Proof. + intros. apply CRzero_double. + transitivity (x * (0 + 0)). + destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. + apply CReq_sym, CRplus_0_r. + destruct (CRisRing R). apply CRmult_plus_distr_l. +Qed. + +Lemma CRmult_0_l : forall {R : ConstructiveReals} (r : CRcarrier R), + 0 * r == 0. +Proof. + intros. rewrite CRmult_comm. apply CRmult_0_r. +Qed. + +Lemma CRopp_mult_distr_r : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + - (r1 * r2) == r1 * (- r2). +Proof. + intros. apply (CRplus_eq_reg_l (CRmult R r1 r2)). + destruct (CRisRing R). transitivity (CRzero R). apply Ropp_def. + transitivity (r1 * (r2 + - r2)). + 2: apply CRmult_plus_distr_l. + transitivity (r1 * 0). + apply CReq_sym, CRmult_0_r. + destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. + apply CReq_sym, Ropp_def. +Qed. + +Lemma CRopp_mult_distr_l : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + - (r1 * r2) == (- r1) * r2. +Proof. + intros. transitivity (r2 * - r1). + transitivity (- (r2 * r1)). + apply (Ropp_ext (CRisRingExt R)). + apply CReq_sym, (Rmul_comm (CRisRing R)). + apply CRopp_mult_distr_r. + apply CReq_sym, (Rmul_comm (CRisRing R)). +Qed. + +Lemma CRmult_lt_compat_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> r1 < r2 -> r1 * r < r2 * r. +Proof. + intros. apply (CRplus_lt_reg_r (CRopp R (CRmult R r1 r))). + apply (CRle_lt_trans _ (CRzero R)). + apply (Ropp_def (CRisRing R)). + apply (CRlt_le_trans _ (CRplus R (CRmult R r2 r) (CRmult R (CRopp R r1) r))). + apply (CRlt_le_trans _ (CRmult R (CRplus R r2 (CRopp R r1)) r)). + apply CRmult_lt_0_compat. 2: exact H. + apply (CRplus_lt_reg_r r1). + apply (CRle_lt_trans _ r1). apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans _ r2 _ H0). + apply (CRle_trans _ (CRplus R r2 (CRplus R (CRopp R r1) r1))). + apply (CRle_trans _ (CRplus R r2 (CRzero R))). + destruct (CRplus_0_r r2). exact H1. + apply CRplus_le_compat_l. destruct (CRplus_opp_l r1). exact H1. + destruct (Radd_assoc (CRisRing R) r2 (CRopp R r1) r1). exact H2. + destruct (CRisRing R). + destruct (Rdistr_l r2 (CRopp R r1) r). exact H2. + apply CRplus_le_compat_l. destruct (CRopp_mult_distr_l r1 r). + exact H1. +Qed. + +Lemma CRmult_lt_compat_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> r1 < r2 -> r * r1 < r * r2. +Proof. + intros. do 2 rewrite (CRmult_comm r). + apply CRmult_lt_compat_r; assumption. +Qed. + +Lemma CRinv_r : forall {R : ConstructiveReals} (r:CRcarrier R) + (rnz : r ≶ (CRzero R)), + r * (/ r) rnz == 1. +Proof. + intros. transitivity ((/ r) rnz * r). + apply (CRisRing R). apply CRinv_l. +Qed. + +Lemma CRmult_lt_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> r1 * r < r2 * r -> r1 < r2. +Proof. + intros. apply (CRmult_lt_compat_r ((/ r) (inr H))) in H0. + 2: apply CRinv_0_lt_compat, H. + apply (CRle_lt_trans _ ((r1 * r) * ((/ r) (inr H)))). + - clear H0. apply (CRle_trans _ (CRmult R r1 (CRone R))). + destruct (CRmult_1_r r1). exact H0. + apply (CRle_trans _ (CRmult R r1 (CRmult R r ((/ r) (inr H))))). + destruct (Rmul_ext (CRisRingExt R) r1 r1 (CReq_refl r1) + (r * ((/ r) (inr H))) 1). + apply CRinv_r. exact H0. + destruct (Rmul_assoc (CRisRing R) r1 r ((/ r) (inr H))). exact H1. + - apply (CRlt_le_trans _ ((r2 * r) * ((/ r) (inr H)))). + exact H0. clear H0. + apply (CRle_trans _ (r2 * 1)). + 2: destruct (CRmult_1_r r2); exact H1. + apply (CRle_trans _ (r2 * (r * ((/ r) (inr H))))). + destruct (Rmul_assoc (CRisRing R) r2 r ((/ r) (inr H))). exact H0. + destruct (Rmul_ext (CRisRingExt R) r2 r2 (CReq_refl r2) + (r * ((/ r) (inr H))) (CRone R)). + apply CRinv_r. exact H1. +Qed. + +Lemma CRmult_lt_reg_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> r * r1 < r * r2 -> r1 < r2. +Proof. + intros. + rewrite (Rmul_comm (CRisRing R) r r1) in H0. + rewrite (Rmul_comm (CRisRing R) r r2) in H0. + apply CRmult_lt_reg_r in H0. + exact H0. exact H. +Qed. + +Lemma CRmult_le_compat_l_half : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. intro abs. apply CRmult_lt_reg_l in abs. + contradiction. exact H. +Qed. + +Lemma CRmult_le_compat_r_half : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r + -> r1 <= r2 + -> r1 * r <= r2 * r. +Proof. + intros. intro abs. apply CRmult_lt_reg_r in abs. + contradiction. exact H. +Qed. + +Lemma CRmult_eq_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 ≶ r + -> r1 * r == r2 * r + -> r1 == r2. +Proof. + intros. destruct H0,H. + - split. + + intro abs. apply H0. apply CRmult_lt_compat_r. + exact c. exact abs. + + intro abs. apply H1. apply CRmult_lt_compat_r. + exact c. exact abs. + - split. + + intro abs. apply H1. apply CRopp_lt_cancel. + apply (CRle_lt_trans _ (CRmult R r1 (CRopp R r))). + apply CRopp_mult_distr_r. + apply (CRlt_le_trans _ (CRmult R r2 (CRopp R r))). + 2: apply CRopp_mult_distr_r. + apply CRmult_lt_compat_r. 2: exact abs. + apply (CRplus_lt_reg_r r). apply (CRle_lt_trans _ r). + apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans _ (CRzero R) _ c). + apply CRplus_opp_l. + + intro abs. apply H0. apply CRopp_lt_cancel. + apply (CRle_lt_trans _ (CRmult R r2 (CRopp R r))). + apply CRopp_mult_distr_r. + apply (CRlt_le_trans _ (CRmult R r1 (CRopp R r))). + 2: apply CRopp_mult_distr_r. + apply CRmult_lt_compat_r. 2: exact abs. + apply (CRplus_lt_reg_r r). apply (CRle_lt_trans _ r). + apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans _ (CRzero R) _ c). + apply CRplus_opp_l. +Qed. + +Lemma CRinv_1 : forall {R : ConstructiveReals} (onz : CRapart R 1 0), + (/ 1) onz == 1. +Proof. + intros. rewrite <- (CRmult_1_r ((/ 1) onz)). + rewrite CRinv_l. reflexivity. +Qed. + +Lemma CRmult_eq_reg_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r ≶ 0 + -> r * r1 == r * r2 + -> r1 == r2. +Proof. + intros. rewrite (Rmul_comm (CRisRing R)) in H0. + rewrite (Rmul_comm (CRisRing R) r) in H0. + apply CRmult_eq_reg_r in H0. exact H0. destruct H. + right. exact c. left. exact c. +Qed. + +Lemma CRinv_mult_distr : + forall {R : ConstructiveReals} (r1 r2 : CRcarrier R) + (r1nz : r1 ≶ 0) (r2nz : r2 ≶ 0) + (rmnz : (r1*r2) ≶ 0), + (/ (r1 * r2)) rmnz == (/ r1) r1nz * (/ r2) r2nz. +Proof. + intros. apply (CRmult_eq_reg_l r1). exact r1nz. + rewrite (Rmul_assoc (CRisRing R)). rewrite CRinv_r. rewrite CRmult_1_l. + apply (CRmult_eq_reg_l r2). exact r2nz. + rewrite CRinv_r. rewrite (Rmul_assoc (CRisRing R)). + rewrite (CRmult_comm r2 r1). rewrite CRinv_r. reflexivity. +Qed. + +Lemma CRinv_morph : forall {R : ConstructiveReals} (x y : CRcarrier R) + (rxnz : x ≶ 0) (rynz : y ≶ 0), + x == y + -> (/ x) rxnz == (/ y) rynz. +Proof. + intros. apply (CRmult_eq_reg_l x). exact rxnz. + rewrite CRinv_r, H, CRinv_r. reflexivity. +Qed. + +Lemma CRlt_minus : forall {R : ConstructiveReals} (x y : CRcarrier R), + x < y -> 0 < y - x. +Proof. + intros. rewrite <- (CRplus_opp_r x). + apply CRplus_lt_compat_r. exact H. +Qed. + +Lemma CR_of_Q_le : forall {R : ConstructiveReals} (r q : Q), + Qle r q + -> CR_of_Q R r <= CR_of_Q R q. +Proof. + intros. intro abs. apply lt_CR_of_Q in abs. + exact (Qlt_not_le _ _ abs H). +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CR_of_Q R) + with signature Qeq ==> CReq R + as CR_of_Q_morph. +Proof. + split; apply CR_of_Q_le; rewrite H; apply Qle_refl. +Qed. + +Lemma eq_inject_Q : forall {R : ConstructiveReals} (q r : Q), + CR_of_Q R q == CR_of_Q R r -> Qeq q r. +Proof. + intros. destruct H. destruct (Q_dec q r). destruct s. + exfalso. apply (CR_of_Q_lt R q r) in q0. contradiction. + exfalso. apply (CR_of_Q_lt R r q) in q0. contradiction. exact q0. +Qed. + +Instance CR_of_Q_morph_T + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful Qeq (CReq R)) (CR_of_Q R). +Proof. + intros R x y H. apply CR_of_Q_morph; assumption. +Qed. + +Lemma CR_of_Q_zero : forall {R : ConstructiveReals}, + CR_of_Q R 0 == 0. +Proof. + intros. apply CRzero_double. + transitivity (CR_of_Q R (0+0)). apply CR_of_Q_morph. + reflexivity. apply CR_of_Q_plus. +Qed. + +Lemma CR_of_Q_opp : forall {R : ConstructiveReals} (q : Q), + CR_of_Q R (-q) == - CR_of_Q R q. +Proof. + intros. apply (CRplus_eq_reg_l (CR_of_Q R q)). + transitivity (CRzero R). + transitivity (CR_of_Q R (q-q)). + apply CReq_sym, CR_of_Q_plus. + transitivity (CR_of_Q R 0). + apply CR_of_Q_morph. ring. apply CR_of_Q_zero. + apply CReq_sym. apply (CRisRing R). +Qed. + +Lemma CR_of_Q_pos : forall {R : ConstructiveReals} (q:Q), + Qlt 0 q -> 0 < CR_of_Q R q. +Proof. + intros. apply (CRle_lt_trans _ (CR_of_Q R 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. exact H. +Qed. + +Lemma CR_of_Q_inv : forall {R : ConstructiveReals} (q : Q) (qPos : Qlt 0 q), + CR_of_Q R (/q) + == (/ CR_of_Q R q) (inr (CR_of_Q_pos q qPos)). +Proof. + intros. + apply (CRmult_eq_reg_l (CR_of_Q R q)). + right. apply CR_of_Q_pos, qPos. + rewrite CRinv_r, <- CR_of_Q_mult, <- CR_of_Q_one. + apply CR_of_Q_morph. field. intro abs. + rewrite abs in qPos. exact (Qlt_irrefl 0 qPos). +Qed. + +Lemma CRmult_le_0_compat : forall {R : ConstructiveReals} (a b : CRcarrier R), + 0 <= a -> 0 <= b -> 0 <= a * b. +Proof. + (* Limit of (a + 1/n)*b when n -> infty. *) + intros. intro abs. + assert (0 < -(a*b)) as epsPos. + { rewrite <- CRopp_0. apply CRopp_gt_lt_contravar. exact abs. } + destruct (CR_archimedean R (b * ((/ -(a*b)) (inr epsPos)))) + as [n maj]. + assert (0 < CR_of_Q R (Z.pos n #1)) as nPos. + { rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. } + assert (b * (/ CR_of_Q R (Z.pos n #1)) (inr nPos) < -(a*b)). + { apply (CRmult_lt_reg_r (CR_of_Q R (Z.pos n #1))). apply nPos. + rewrite <- (Rmul_assoc (CRisRing R)), CRinv_l, CRmult_1_r. + apply (CRmult_lt_compat_r (-(a*b))) in maj. + rewrite CRmult_assoc, CRinv_l, CRmult_1_r in maj. + rewrite CRmult_comm. apply maj. apply epsPos. } + pose proof (CRmult_le_compat_l_half + (a + (/ CR_of_Q R (Z.pos n #1)) (inr nPos)) 0 b). + assert (0 + 0 < a + (/ CR_of_Q R (Z.pos n #1)) (inr nPos)). + { apply CRplus_le_lt_compat. apply H. apply CRinv_0_lt_compat. apply nPos. } + rewrite CRplus_0_l in H3. specialize (H2 H3 H0). + clear H3. rewrite CRmult_0_r in H2. + apply H2. clear H2. rewrite (Rdistr_l (CRisRing R)). + apply (CRplus_lt_compat_l R (a*b)) in H1. + rewrite CRplus_opp_r in H1. + rewrite (CRmult_comm ((/ CR_of_Q R (Z.pos n # 1)) (inr nPos))). + apply H1. +Qed. + +Lemma CRmult_le_compat_l : forall {R : ConstructiveReals} (r r1 r2:CRcarrier R), + 0 <= r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. apply (CRplus_le_reg_r (-(r*r1))). + rewrite CRplus_opp_r, CRopp_mult_distr_r. + rewrite <- CRmult_plus_distr_l. + apply CRmult_le_0_compat. exact H. + apply (CRplus_le_reg_r r1). + rewrite CRplus_0_l, CRplus_assoc, CRplus_opp_l, CRplus_0_r. + exact H0. +Qed. + +Lemma CRmult_le_compat_r : forall {R : ConstructiveReals} (r r1 r2:CRcarrier R), + 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r. +Proof. + intros. do 2 rewrite <- (CRmult_comm r). + apply CRmult_le_compat_l; assumption. +Qed. + +Lemma CRmult_pos_pos + : forall {R : ConstructiveReals} (x y : CRcarrier R), + 0 < x * y -> 0 <= x + -> 0 <= y -> 0 < x. +Proof. + intros. destruct (CRltLinear R). clear p. + specialize (s 0 x 1 (CRzero_lt_one R)) as [H2|H2]. + exact H2. apply CRlt_asym in H2. + apply (CRmult_le_compat_r y) in H2. + 2: exact H1. rewrite CRmult_1_l in H2. + apply (CRlt_le_trans _ _ _ H) in H2. + rewrite <- (CRmult_0_l y) in H. + apply CRmult_lt_reg_r in H. exact H. exact H2. +Qed. + +(* In particular x * y == 1 implies that 0 # x, 0 # y and + that x and y are inverses of each other. *) +Lemma CRmult_pos_appart_zero + : forall {R : ConstructiveReals} (x y : CRcarrier R), + 0 < x * y -> 0 ≶ x. +Proof. + intros. + (* Narrow cases to x < 1. *) + destruct (CRltLinear R). clear p. + pose proof (s 0 x 1 (CRzero_lt_one R)) as [H0|H0]. + left. exact H0. + (* In this case, linear order 0 y (x*y) decides. *) + destruct (s 0 y (x*y) H). + - left. rewrite <- (CRmult_0_l y) in H. apply CRmult_lt_reg_r in H. + exact H. exact c. + - right. apply CRopp_lt_cancel. rewrite CRopp_0. + apply (CRmult_pos_pos (-x) (-y)). + + rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r, CRopp_involutive. exact H. + + rewrite <- CRopp_0. apply CRopp_ge_le_contravar. + intro abs. rewrite <- (CRmult_0_r x) in H. + apply CRmult_lt_reg_l in H. rewrite <- (CRmult_1_l y) in c. + rewrite <- CRmult_assoc in c. apply CRmult_lt_reg_r in c. + rewrite CRmult_1_r in c. exact (CRlt_asym _ _ H0 c). + exact H. exact abs. + + intro abs. apply (CRmult_lt_compat_r y) in H0. + rewrite CRmult_1_l in H0. exact (CRlt_asym _ _ H0 c). + apply CRopp_lt_cancel. rewrite CRopp_0. exact abs. +Qed. + +Lemma CRmult_le_reg_l : + forall {R : ConstructiveReals} (x y z : CRcarrier R), + 0 < x -> x * y <= x * z -> y <= z. +Proof. + intros. intro abs. + apply (CRmult_lt_compat_l x) in abs. contradiction. + exact H. +Qed. + +Lemma CRmult_le_reg_r : + forall {R : ConstructiveReals} (x y z : CRcarrier R), + 0 < x -> y * x <= z * x -> y <= z. +Proof. + intros. intro abs. + apply (CRmult_lt_compat_r x) in abs. contradiction. exact H. +Qed. + +Definition CRup_nat {R : ConstructiveReals} (x : CRcarrier R) + : { n : nat & x < CR_of_Q R (Z.of_nat n #1) }. +Proof. + destruct (CR_archimedean R x). exists (Pos.to_nat x0). + rewrite positive_nat_Z. exact c. +Qed. + +Definition CRfloor {R : ConstructiveReals} (a : CRcarrier R) + : { p : Z & prod (CR_of_Q R (p#1) < a) + (a < CR_of_Q R (p#1) + CR_of_Q R 2) }. +Proof. + destruct (CR_Q_dense R (a - CR_of_Q R (1#2)) a) as [q qmaj]. + - apply (CRlt_le_trans _ (a-0)). apply CRplus_lt_compat_l. + apply CRopp_gt_lt_contravar. rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt. reflexivity. + unfold CRminus. rewrite CRopp_0, CRplus_0_r. apply CRle_refl. + - exists (Qfloor q). destruct qmaj. split. + apply (CRle_lt_trans _ (CR_of_Q R q)). 2: exact c0. + apply CR_of_Q_le. apply Qfloor_le. + apply (CRlt_le_trans _ (CR_of_Q R q + CR_of_Q R (1#2))). + apply (CRplus_lt_compat_r (CR_of_Q R (1 # 2))) in c. + unfold CRminus in c. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r in c. exact c. + rewrite (CR_of_Q_plus R 1 1), <- CRplus_assoc, <- (CR_of_Q_plus R _ 1). + apply CRplus_le_compat. apply CR_of_Q_le. + rewrite Qinv_plus_distr. apply Qlt_le_weak, Qlt_floor. + apply CR_of_Q_le. discriminate. +Qed. + +Lemma CRplus_appart_reg_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + (r + r1) ≶ (r + r2) -> r1 ≶ r2. +Proof. + intros. destruct H. + left. apply (CRplus_lt_reg_l R r), c. + right. apply (CRplus_lt_reg_l R r), c. +Qed. + +Lemma CRplus_appart_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + (r1 + r) ≶ (r2 + r) -> r1 ≶ r2. +Proof. + intros. destruct H. + left. apply (CRplus_lt_reg_r r), c. + right. apply (CRplus_lt_reg_r r), c. +Qed. + +Lemma CRmult_appart_reg_l + : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> (r * r1) ≶ (r * r2) -> r1 ≶ r2. +Proof. + intros. destruct H0. + left. exact (CRmult_lt_reg_l r _ _ H c). + right. exact (CRmult_lt_reg_l r _ _ H c). +Qed. + +Lemma CRmult_appart_reg_r + : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> (r1 * r) ≶ (r2 * r) -> r1 ≶ r2. +Proof. + intros. destruct H0. + left. exact (CRmult_lt_reg_r r _ _ H c). + right. exact (CRmult_lt_reg_r r _ _ H c). +Qed. + +Instance CRapart_morph + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) CRelationClasses.iffT)) (CRapart R). +Proof. + intros R x y H x0 y0 H0. destruct H, H0. split. + - intro. destruct H3. + left. apply (CRle_lt_trans _ x _ H). + apply (CRlt_le_trans _ x0 _ c), H2. + right. apply (CRle_lt_trans _ x0 _ H0). + apply (CRlt_le_trans _ x _ c), H1. + - intro. destruct H3. + left. apply (CRle_lt_trans _ y _ H1). + apply (CRlt_le_trans _ y0 _ c), H0. + right. apply (CRle_lt_trans _ y0 _ H2). + apply (CRlt_le_trans _ y _ c), H. +Qed. diff --git a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v new file mode 100644 index 0000000000..bc44668e2f --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v @@ -0,0 +1,1177 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) +(************************************************************************) + +(** Morphisms used to transport results from any instance of + ConstructiveReals to any other. + Between any two constructive reals structures R1 and R2, + all morphisms R1 -> R2 are extensionally equal. We will + further show that they exist, and so are isomorphisms. + The difference between two morphisms R1 -> R2 is therefore + the speed of computation. + + The canonical isomorphisms we provide here are often very slow, + when a new implementation of constructive reals is added, + it should define its own ad hoc isomorphisms for better speed. + + Apart from the speed, those unique isomorphisms also serve as + sanity checks of the interface ConstructiveReals : + it captures a concept with a strong notion of uniqueness. *) + +Require Import QArith. +Require Import Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveLimits. +Require Import ConstructiveAbs. +Require Import ConstructiveSum. + +Local Open Scope ConstructiveReals. + +Record ConstructiveRealsMorphism {R1 R2 : ConstructiveReals} : Set := + { + CRmorph : CRcarrier R1 -> CRcarrier R2; + CRmorph_rat : forall q : Q, + CRmorph (CR_of_Q R1 q) == CR_of_Q R2 q; + CRmorph_increasing : forall x y : CRcarrier R1, + CRlt R1 x y -> CRlt R2 (CRmorph x) (CRmorph y); + }. + + +Lemma CRmorph_increasing_inv + : forall {R1 R2 : ConstructiveReals} + (f : ConstructiveRealsMorphism) + (x y : CRcarrier R1), + CRlt R2 (CRmorph f x) (CRmorph f y) + -> CRlt R1 x y. +Proof. + intros. destruct (CR_Q_dense R2 _ _ H) as [q [H0 H1]]. + destruct (CR_Q_dense R2 _ _ H0) as [r [H2 H3]]. + apply lt_CR_of_Q, (CR_of_Q_lt R1) in H3. + destruct (CRltLinear R1). + destruct (s _ x _ H3). + - exfalso. apply (CRmorph_increasing f) in c. + destruct (CRmorph_rat f r) as [H4 _]. + apply (CRle_lt_trans _ _ _ H4) in c. clear H4. + exact (CRlt_asym _ _ c H2). + - clear H2 H3 r. apply (CRlt_trans _ _ _ c). clear c. + destruct (CR_Q_dense R2 _ _ H1) as [t [H2 H3]]. + apply lt_CR_of_Q, (CR_of_Q_lt R1) in H2. + destruct (s _ y _ H2). exact c. + exfalso. apply (CRmorph_increasing f) in c. + destruct (CRmorph_rat f t) as [_ H4]. + apply (CRlt_le_trans _ _ _ c) in H4. clear c. + exact (CRlt_asym _ _ H4 H3). +Qed. + +Lemma CRmorph_unique : forall {R1 R2 : ConstructiveReals} + (f g : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + CRmorph f x == CRmorph g x. +Proof. + split. + - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. + destruct (CRmorph_rat f q) as [H1 _]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + destruct (CRmorph_rat g q) as [_ H2]. + apply (CRle_lt_trans _ _ _ H2) in H0. clear H2. + apply CRmorph_increasing_inv in H0. + exact (CRlt_asym _ _ H0 H1). + - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. + destruct (CRmorph_rat f q) as [_ H1]. + apply (CRle_lt_trans _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + destruct (CRmorph_rat g q) as [H2 _]. + apply (CRlt_le_trans _ _ _ H) in H2. clear H. + apply CRmorph_increasing_inv in H2. + exact (CRlt_asym _ _ H0 H2). +Qed. + + +(* The identity is the only endomorphism of constructive reals. + For any ConstructiveReals R1, R2 and any morphisms + f : R1 -> R2 and g : R2 -> R1, + f and g are isomorphisms and are inverses of each other. *) +Lemma Endomorph_id + : forall {R : ConstructiveReals} (f : @ConstructiveRealsMorphism R R) + (x : CRcarrier R), + CRmorph f x == x. +Proof. + split. + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. + destruct (CRmorph_rat f q) as [H _]. + apply (CRlt_le_trans _ _ _ H0) in H. clear H0. + apply CRmorph_increasing_inv in H. + exact (CRlt_asym _ _ H1 H). + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. + destruct (CRmorph_rat f q) as [_ H]. + apply (CRle_lt_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + exact (CRlt_asym _ _ H1 H0). +Qed. + +Lemma CRmorph_proper + : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + x == y -> CRmorph f x == CRmorph f y. +Proof. + split. + - intro abs. apply CRmorph_increasing_inv in abs. + destruct H. contradiction. + - intro abs. apply CRmorph_increasing_inv in abs. + destruct H. contradiction. +Qed. + +Definition CRmorph_compose {R1 R2 R3 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (g : @ConstructiveRealsMorphism R2 R3) + : @ConstructiveRealsMorphism R1 R3. +Proof. + apply (Build_ConstructiveRealsMorphism + R1 R3 (fun x:CRcarrier R1 => CRmorph g (CRmorph f x))). + - intro q. apply (CReq_trans _ (CRmorph g (CR_of_Q R2 q))). + apply CRmorph_proper. apply CRmorph_rat. apply CRmorph_rat. + - intros. apply CRmorph_increasing. apply CRmorph_increasing. exact H. +Defined. + +Lemma CRmorph_le : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + x <= y -> CRmorph f x <= CRmorph f y. +Proof. + intros. intro abs. apply CRmorph_increasing_inv in abs. contradiction. +Qed. + +Lemma CRmorph_le_inv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRmorph f x <= CRmorph f y -> x <= y. +Proof. + intros. intro abs. apply (CRmorph_increasing f) in abs. contradiction. +Qed. + +Lemma CRmorph_zero : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2), + CRmorph f 0 == 0. +Proof. + intros. apply (CReq_trans _ (CRmorph f (CR_of_Q R1 0))). + apply CRmorph_proper. apply CReq_sym, CR_of_Q_zero. + apply (CReq_trans _ (CR_of_Q R2 0)). + apply CRmorph_rat. apply CR_of_Q_zero. +Qed. + +Lemma CRmorph_one : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2), + CRmorph f 1 == 1. +Proof. + intros. apply (CReq_trans _ (CRmorph f (CR_of_Q R1 1))). + apply CRmorph_proper. apply CReq_sym, CR_of_Q_one. + apply (CReq_trans _ (CR_of_Q R2 1)). + apply CRmorph_rat. apply CR_of_Q_one. +Qed. + +Lemma CRmorph_opp : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + CRmorph f (- x) == - CRmorph f x. +Proof. + split. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. + destruct (CRmorph_rat f q) as [H1 _]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply CRopp_gt_lt_contravar in H0. + destruct (@CR_of_Q_opp R2 q) as [H2 _]. + apply (CRlt_le_trans _ _ _ H0) in H2. clear H0. + pose proof (CRopp_involutive (CRmorph f x)) as [H _]. + apply (CRle_lt_trans _ _ _ H) in H2. clear H. + destruct (CRmorph_rat f (-q)) as [H _]. + apply (CRlt_le_trans _ _ _ H2) in H. clear H2. + apply CRmorph_increasing_inv in H. + destruct (@CR_of_Q_opp R1 q) as [_ H2]. + apply (CRlt_le_trans _ _ _ H) in H2. clear H. + apply CRopp_gt_lt_contravar in H2. + pose proof (CRopp_involutive (CR_of_Q R1 q)) as [H _]. + apply (CRle_lt_trans _ _ _ H) in H2. clear H. + exact (CRlt_asym _ _ H1 H2). + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. + destruct (CRmorph_rat f q) as [_ H1]. + apply (CRle_lt_trans _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + apply CRopp_gt_lt_contravar in H. + pose proof (CRopp_involutive (CRmorph f x)) as [_ H1]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + destruct (@CR_of_Q_opp R2 q) as [_ H2]. + apply (CRle_lt_trans _ _ _ H2) in H1. clear H2. + destruct (CRmorph_rat f (-q)) as [_ H]. + apply (CRle_lt_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + destruct (@CR_of_Q_opp R1 q) as [H2 _]. + apply (CRle_lt_trans _ _ _ H2) in H1. clear H2. + apply CRopp_gt_lt_contravar in H1. + pose proof (CRopp_involutive (CR_of_Q R1 q)) as [_ H]. + apply (CRlt_le_trans _ _ _ H1) in H. clear H1. + exact (CRlt_asym _ _ H0 H). +Qed. + +Lemma CRplus_pos_rat_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (q : Q), + Qlt 0 q -> CRlt R x (CRplus R x (CR_of_Q R q)). +Proof. + intros. + apply (CRle_lt_trans _ (CRplus R x (CRzero R))). apply CRplus_0_r. + apply CRplus_lt_compat_l. + apply (CRle_lt_trans _ (CR_of_Q R 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt. exact H. +Defined. + +Lemma CRplus_neg_rat_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (q : Q), + Qlt q 0 -> CRlt R (CRplus R x (CR_of_Q R q)) x. +Proof. + intros. + apply (CRlt_le_trans _ (CRplus R x (CRzero R))). 2: apply CRplus_0_r. + apply CRplus_lt_compat_l. + apply (CRlt_le_trans _ (CR_of_Q R 0)). + apply CR_of_Q_lt. exact H. apply CR_of_Q_zero. +Qed. + +Lemma CRmorph_plus_rat : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (q : Q), + CRmorph f (CRplus R1 x (CR_of_Q R1 q)) + == CRplus R2 (CRmorph f x) (CR_of_Q R2 q). +Proof. + split. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat f r) as [H1 _]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply (CRlt_asym _ _ H1). clear H1. + apply (CRplus_lt_reg_r (CRopp R1 (CR_of_Q R1 q))). + apply (CRlt_le_trans _ x). + apply (CRle_lt_trans _ (CR_of_Q R1 (r-q))). + apply (CRle_trans _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). + apply CRplus_le_compat_l. destruct (@CR_of_Q_opp R1 q). exact H. + destruct (CR_of_Q_plus R1 r (-q)). exact H. + apply (CRmorph_increasing_inv f). + apply (CRle_lt_trans _ (CR_of_Q R2 (r - q))). + apply CRmorph_rat. + apply (CRplus_lt_reg_r (CR_of_Q R2 q)). + apply (CRle_lt_trans _ (CR_of_Q R2 r)). 2: exact H0. + intro H. + destruct (CR_of_Q_plus R2 (r-q) q) as [H1 _]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + apply lt_CR_of_Q in H1. ring_simplify in H1. + exact (Qlt_not_le _ _ H1 (Qle_refl _)). + destruct (CRisRing R1). + apply (CRle_trans + _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). + apply (CRle_trans _ (CRplus R1 x (CRzero R1))). + destruct (CRplus_0_r x). exact H. + apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H. + destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). + exact H1. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat f r) as [_ H1]. + apply (CRle_lt_trans _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + apply (CRlt_asym _ _ H0). clear H0. + apply (CRplus_lt_reg_r (CRopp R1 (CR_of_Q R1 q))). + apply (CRle_lt_trans _ x). + destruct (CRisRing R1). + apply (CRle_trans + _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). + destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). + exact H0. + apply (CRle_trans _ (CRplus R1 x (CRzero R1))). + apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H1. + destruct (CRplus_0_r x). exact H1. + apply (CRlt_le_trans _ (CR_of_Q R1 (r-q))). + apply (CRmorph_increasing_inv f). + apply (CRlt_le_trans _ (CR_of_Q R2 (r - q))). + apply (CRplus_lt_reg_r (CR_of_Q R2 q)). + apply (CRlt_le_trans _ _ _ H). + 2: apply CRmorph_rat. + apply (CRle_trans _ (CR_of_Q R2 (r-q+q))). + intro abs. apply lt_CR_of_Q in abs. ring_simplify in abs. + exact (Qlt_not_le _ _ abs (Qle_refl _)). + destruct (CR_of_Q_plus R2 (r-q) q). exact H1. + apply (CRle_trans _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). + destruct (CR_of_Q_plus R1 r (-q)). exact H1. + apply CRplus_le_compat_l. destruct (@CR_of_Q_opp R1 q). exact H1. +Qed. + +Lemma CRmorph_plus : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRmorph f (CRplus R1 x y) + == CRplus R2 (CRmorph f x) (CRmorph f y). +Proof. + intros R1 R2 f. + assert (forall (x y : CRcarrier R1), + CRplus R2 (CRmorph f x) (CRmorph f y) + <= CRmorph f (CRplus R1 x y)). + { intros x y abs. destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat f r) as [H1 _]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply (CRlt_asym _ _ H1). clear H1. + destruct (CR_Q_dense R2 _ _ H0) as [q [H2 H3]]. + apply lt_CR_of_Q in H2. + assert (Qlt (r-q) 0) as epsNeg. + { apply (Qplus_lt_r _ _ q). ring_simplify. exact H2. } + destruct (CR_Q_dense R1 _ _ (CRplus_neg_rat_lt x (r-q) epsNeg)) + as [s [H4 H5]]. + apply (CRlt_trans _ (CRplus R1 (CR_of_Q R1 s) y)). + 2: apply CRplus_lt_compat_r, H5. + apply (CRmorph_increasing_inv f). + apply (CRlt_le_trans _ (CRplus R2 (CR_of_Q R2 s) (CRmorph f y))). + apply (CRmorph_increasing f) in H4. + destruct (CRmorph_plus_rat f x (r-q)) as [H _]. + apply (CRle_lt_trans _ _ _ H) in H4. clear H. + destruct (CRmorph_rat f s) as [_ H1]. + apply (CRlt_le_trans _ _ _ H4) in H1. clear H4. + apply (CRlt_trans + _ (CRplus R2 (CRplus R2 (CRmorph f x) (CR_of_Q R2 (r - q))) + (CRmorph f y))). + 2: apply CRplus_lt_compat_r, H1. + apply (CRlt_le_trans + _ (CRplus R2 (CRplus R2 (CR_of_Q R2 (r - q)) (CRmorph f x)) + (CRmorph f y))). + apply (CRlt_le_trans + _ (CRplus R2 (CR_of_Q R2 (r - q)) + (CRplus R2 (CRmorph f x) (CRmorph f y)))). + apply (CRle_lt_trans _ (CRplus R2 (CR_of_Q R2 (r - q)) (CR_of_Q R2 q))). + 2: apply CRplus_lt_compat_l, H3. + intro abs. + destruct (CR_of_Q_plus R2 (r-q) q) as [_ H4]. + apply (CRle_lt_trans _ _ _ H4) in abs. clear H4. + destruct (CRmorph_rat f r) as [_ H4]. + apply (CRlt_le_trans _ _ _ abs) in H4. clear abs. + apply lt_CR_of_Q in H4. ring_simplify in H4. + exact (Qlt_not_le _ _ H4 (Qle_refl _)). + destruct (CRisRing R2); apply Radd_assoc. + apply CRplus_le_compat_r. destruct (CRisRing R2). + destruct (Radd_comm (CRmorph f x) (CR_of_Q R2 (r - q))). + exact H. + intro abs. + destruct (CRmorph_plus_rat f y s) as [H _]. apply H. clear H. + apply (CRlt_le_trans _ (CRplus R2 (CR_of_Q R2 s) (CRmorph f y))). + apply (CRle_lt_trans _ (CRmorph f (CRplus R1 (CR_of_Q R1 s) y))). + apply CRmorph_proper. destruct (CRisRing R1); apply Radd_comm. + exact abs. destruct (CRisRing R2); apply Radd_comm. } + split. + - apply H. + - specialize (H (CRplus R1 x y) (CRopp R1 y)). + intro abs. apply H. clear H. + apply (CRle_lt_trans _ (CRmorph f x)). + apply CRmorph_proper. destruct (CRisRing R1). + apply (CReq_trans _ (CRplus R1 x (CRplus R1 y (CRopp R1 y)))). + apply CReq_sym, Radd_assoc. + apply (CReq_trans _ (CRplus R1 x (CRzero R1))). 2: apply CRplus_0_r. + destruct (CRisRingExt R1). apply Radd_ext. + apply CReq_refl. apply Ropp_def. + apply (CRplus_lt_reg_r (CRmorph f y)). + apply (CRlt_le_trans _ _ _ abs). clear abs. + apply (CRle_trans _ (CRplus R2 (CRmorph f (CRplus R1 x y)) (CRzero R2))). + destruct (CRplus_0_r (CRmorph f (CRplus R1 x y))). exact H. + apply (CRle_trans _ (CRplus R2 (CRmorph f (CRplus R1 x y)) + (CRplus R2 (CRmorph f (CRopp R1 y)) (CRmorph f y)))). + apply CRplus_le_compat_l. + apply (CRle_trans + _ (CRplus R2 (CRopp R2 (CRmorph f y)) (CRmorph f y))). + destruct (CRplus_opp_l (CRmorph f y)). exact H. + apply CRplus_le_compat_r. destruct (CRmorph_opp f y). exact H. + destruct (CRisRing R2). + destruct (Radd_assoc (CRmorph f (CRplus R1 x y)) + (CRmorph f (CRopp R1 y)) (CRmorph f y)). + exact H0. +Qed. + +Lemma CRmorph_mult_pos : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (n : nat), + CRmorph f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))) + == CRmult R2 (CRmorph f x) (CR_of_Q R2 (Z.of_nat n # 1)). +Proof. + induction n. + - simpl. destruct (CRisRingExt R1). + apply (CReq_trans _ (CRzero R2)). + + apply (CReq_trans _ (CRmorph f (CRzero R1))). + 2: apply CRmorph_zero. apply CRmorph_proper. + apply (CReq_trans _ (CRmult R1 x (CRzero R1))). + 2: apply CRmult_0_r. apply Rmul_ext. apply CReq_refl. apply CR_of_Q_zero. + + apply (CReq_trans _ (CRmult R2 (CRmorph f x) (CRzero R2))). + apply CReq_sym, CRmult_0_r. destruct (CRisRingExt R2). + apply Rmul_ext0. apply CReq_refl. apply CReq_sym, CR_of_Q_zero. + - destruct (CRisRingExt R1), (CRisRingExt R2). + apply (CReq_trans + _ (CRmorph f (CRplus R1 x (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). + apply CRmorph_proper. + apply (CReq_trans + _ (CRmult R1 x (CRplus R1 (CRone R1) (CR_of_Q R1 (Z.of_nat n # 1))))). + apply Rmul_ext. apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R1 (1 + (Z.of_nat n # 1)))). + apply CR_of_Q_morph. rewrite Nat2Z.inj_succ. unfold Z.succ. + rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. + apply (CReq_trans _ (CRplus R1 (CR_of_Q R1 1) (CR_of_Q R1 (Z.of_nat n # 1)))). + apply CR_of_Q_plus. apply Radd_ext. apply CR_of_Q_one. apply CReq_refl. + apply (CReq_trans _ (CRplus R1 (CRmult R1 x (CRone R1)) + (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))))). + apply CRmult_plus_distr_l. apply Radd_ext. apply CRmult_1_r. apply CReq_refl. + apply (CReq_trans + _ (CRplus R2 (CRmorph f x) + (CRmorph f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). + apply CRmorph_plus. + apply (CReq_trans + _ (CRplus R2 (CRmorph f x) + (CRmult R2 (CRmorph f x) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply Radd_ext0. apply CReq_refl. exact IHn. + apply (CReq_trans + _ (CRmult R2 (CRmorph f x) (CRplus R2 (CRone R2) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply (CReq_trans + _ (CRplus R2 (CRmult R2 (CRmorph f x) (CRone R2)) + (CRmult R2 (CRmorph f x) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply Radd_ext0. 2: apply CReq_refl. apply CReq_sym, CRmult_1_r. + apply CReq_sym, CRmult_plus_distr_l. + apply Rmul_ext0. apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R2 (1 + (Z.of_nat n # 1)))). + apply (CReq_trans _ (CRplus R2 (CR_of_Q R2 1) (CR_of_Q R2 (Z.of_nat n # 1)))). + apply Radd_ext0. apply CReq_sym, CR_of_Q_one. apply CReq_refl. + apply CReq_sym, CR_of_Q_plus. + apply CR_of_Q_morph. rewrite Nat2Z.inj_succ. unfold Z.succ. + rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. +Qed. + +Lemma NatOfZ : forall n : Z, { p : nat | n = Z.of_nat p \/ n = Z.opp (Z.of_nat p) }. +Proof. + intros [|p|n]. + - exists O. left. reflexivity. + - exists (Pos.to_nat p). left. rewrite positive_nat_Z. reflexivity. + - exists (Pos.to_nat n). right. rewrite positive_nat_Z. reflexivity. +Qed. + +Lemma CRmorph_mult_int : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (n : Z), + CRmorph f (CRmult R1 x (CR_of_Q R1 (n # 1))) + == CRmult R2 (CRmorph f x) (CR_of_Q R2 (n # 1)). +Proof. + intros. destruct (NatOfZ n) as [p [pos|neg]]. + - subst n. apply CRmorph_mult_pos. + - subst n. + apply (CReq_trans + _ (CRopp R2 (CRmorph f (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). + + apply (CReq_trans + _ (CRmorph f (CRopp R1 (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). + 2: apply CRmorph_opp. apply CRmorph_proper. + apply (CReq_trans _ (CRmult R1 x (CR_of_Q R1 (- (Z.of_nat p # 1))))). + destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. + apply CR_of_Q_morph. reflexivity. + apply (CReq_trans _ (CRmult R1 x (CRopp R1 (CR_of_Q R1 (Z.of_nat p # 1))))). + destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. + apply CR_of_Q_opp. apply CReq_sym, CRopp_mult_distr_r. + + apply (CReq_trans + _ (CRopp R2 (CRmult R2 (CRmorph f x) (CR_of_Q R2 (Z.of_nat p # 1))))). + destruct (CRisRingExt R2). apply Ropp_ext. apply CRmorph_mult_pos. + apply (CReq_trans + _ (CRmult R2 (CRmorph f x) (CRopp R2 (CR_of_Q R2 (Z.of_nat p # 1))))). + apply CRopp_mult_distr_r. destruct (CRisRingExt R2). + apply Rmul_ext. apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R2 (- (Z.of_nat p # 1)))). + apply CReq_sym, CR_of_Q_opp. apply CR_of_Q_morph. reflexivity. +Qed. + +Lemma CRmorph_mult_inv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (p : positive), + CRmorph f (CRmult R1 x (CR_of_Q R1 (1 # p))) + == CRmult R2 (CRmorph f x) (CR_of_Q R2 (1 # p)). +Proof. + intros. apply (CRmult_eq_reg_r (CR_of_Q R2 (Z.pos p # 1))). + left. apply (CRle_lt_trans _ (CR_of_Q R2 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + apply (CReq_trans _ (CRmorph f x)). + - apply (CReq_trans + _ (CRmorph f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (1 # p))) + (CR_of_Q R1 (Z.pos p # 1))))). + apply CReq_sym, CRmorph_mult_int. apply CRmorph_proper. + apply (CReq_trans + _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (1 # p)) + (CR_of_Q R1 (Z.pos p # 1))))). + destruct (CRisRing R1). apply CReq_sym, Rmul_assoc. + apply (CReq_trans _ (CRmult R1 x (CRone R1))). + apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R1 ((1#p) * (Z.pos p # 1)))). + apply CReq_sym, CR_of_Q_mult. + apply (CReq_trans _ (CR_of_Q R1 1)). + apply CR_of_Q_morph. reflexivity. apply CR_of_Q_one. + apply CRmult_1_r. + - apply (CReq_trans + _ (CRmult R2 (CRmorph f x) + (CRmult R2 (CR_of_Q R2 (1 # p)) (CR_of_Q R2 (Z.pos p # 1))))). + 2: apply (Rmul_assoc (CRisRing R2)). + apply (CReq_trans _ (CRmult R2 (CRmorph f x) (CRone R2))). + apply CReq_sym, CRmult_1_r. + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R2 1)). + apply CReq_sym, CR_of_Q_one. + apply (CReq_trans _ (CR_of_Q R2 ((1#p)*(Z.pos p # 1)))). + apply CR_of_Q_morph. reflexivity. apply CR_of_Q_mult. +Qed. + +Lemma CRmorph_mult_rat : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (q : Q), + CRmorph f (CRmult R1 x (CR_of_Q R1 q)) + == CRmult R2 (CRmorph f x) (CR_of_Q R2 q). +Proof. + intros. destruct q as [a b]. + apply (CReq_trans + _ (CRmult R2 (CRmorph f (CRmult R1 x (CR_of_Q R1 (a # 1)))) + (CR_of_Q R2 (1 # b)))). + - apply (CReq_trans + _ (CRmorph f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (a # 1))) + (CR_of_Q R1 (1 # b))))). + 2: apply CRmorph_mult_inv. apply CRmorph_proper. + apply (CReq_trans + _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (a # 1)) + (CR_of_Q R1 (1 # b))))). + apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R1 ((a#1)*(1#b)))). + apply CR_of_Q_morph. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. + apply CR_of_Q_mult. + apply (Rmul_assoc (CRisRing R1)). + - apply (CReq_trans + _ (CRmult R2 (CRmult R2 (CRmorph f x) (CR_of_Q R2 (a # 1))) + (CR_of_Q R2 (1 # b)))). + apply (Rmul_ext (CRisRingExt R2)). apply CRmorph_mult_int. + apply CReq_refl. + apply (CReq_trans + _ (CRmult R2 (CRmorph f x) + (CRmult R2 (CR_of_Q R2 (a # 1)) (CR_of_Q R2 (1 # b))))). + apply CReq_sym, (Rmul_assoc (CRisRing R2)). + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R2 ((a#1)*(1#b)))). + apply CReq_sym, CR_of_Q_mult. + apply CR_of_Q_morph. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. +Qed. + +Lemma CRmorph_mult_pos_pos_le : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRlt R1 (CRzero R1) y + -> CRmult R2 (CRmorph f x) (CRmorph f y) + <= CRmorph f (CRmult R1 x y). +Proof. + intros. intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. + destruct (CRmorph_rat f q) as [H3 _]. + apply (CRlt_le_trans _ _ _ H1) in H3. clear H1. + apply CRmorph_increasing_inv in H3. + apply (CRlt_asym _ _ H3). clear H3. + destruct (CR_Q_dense R2 _ _ H2) as [r [H1 H3]]. + apply lt_CR_of_Q in H1. + destruct (CR_archimedean R1 y) as [A Amaj]. + assert (/ ((r - q) * (1 # A)) * (q - r) == - (Z.pos A # 1))%Q as diveq. + { rewrite Qinv_mult_distr. setoid_replace (q-r)%Q with (-1*(r-q))%Q. + field_simplify. reflexivity. 2: field. + split. intro H4. inversion H4. intro H4. + apply Qlt_minus_iff in H1. rewrite H4 in H1. inversion H1. } + destruct (CR_Q_dense R1 (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A)))) x) + as [s [H4 H5]]. + - apply (CRlt_le_trans _ (CRplus R1 x (CRzero R1))). + 2: apply CRplus_0_r. apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l R1 (CR_of_Q R1 ((r-q) * (1#A)))). + apply (CRle_lt_trans _ (CRzero R1)). + apply (CRle_trans _ (CR_of_Q R1 ((r-q)*(1#A) + (q-r)*(1#A)))). + destruct (CR_of_Q_plus R1 ((r-q)*(1#A)) ((q-r)*(1#A))). + exact H0. apply (CRle_trans _ (CR_of_Q R1 0)). + 2: destruct (@CR_of_Q_zero R1); exact H4. + intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. + inversion H4. + apply (CRlt_le_trans _ (CR_of_Q R1 ((r - q) * (1 # A)))). + 2: apply CRplus_0_r. + apply (CRle_lt_trans _ (CR_of_Q R1 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. + rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. + apply Qlt_minus_iff in H1. exact H1. reflexivity. + - apply (CRmorph_increasing f) in H4. + destruct (CRmorph_plus f x (CR_of_Q R1 ((q-r) * (1#A)))) as [H6 _]. + apply (CRle_lt_trans _ _ _ H6) in H4. clear H6. + destruct (CRmorph_rat f s) as [_ H6]. + apply (CRlt_le_trans _ _ _ H4) in H6. clear H4. + apply (CRmult_lt_compat_r (CRmorph f y)) in H6. + destruct (Rdistr_l (CRisRing R2) (CRmorph f x) + (CRmorph f (CR_of_Q R1 ((q-r) * (1#A)))) + (CRmorph f y)) as [H4 _]. + apply (CRle_lt_trans _ _ _ H4) in H6. clear H4. + apply (CRle_lt_trans _ (CRmult R1 (CR_of_Q R1 s) y)). + 2: apply CRmult_lt_compat_r. 2: exact H. 2: exact H5. + apply (CRmorph_le_inv f). + apply (CRle_trans _ (CR_of_Q R2 q)). + destruct (CRmorph_rat f q). exact H4. + apply (CRle_trans _ (CRmult R2 (CR_of_Q R2 s) (CRmorph f y))). + apply (CRle_trans _ (CRplus R2 (CRmult R2 (CRmorph f x) (CRmorph f y)) + (CR_of_Q R2 (q-r)))). + apply (CRle_trans _ (CRplus R2 (CR_of_Q R2 r) (CR_of_Q R2 (q - r)))). + + apply (CRle_trans _ (CR_of_Q R2 (r + (q-r)))). + intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. + exact (Qlt_not_le q q H4 (Qle_refl q)). + destruct (CR_of_Q_plus R2 r (q-r)). exact H4. + + apply CRplus_le_compat_r. intro H4. + apply (CRlt_asym _ _ H3). exact H4. + + intro H4. apply (CRlt_asym _ _ H4). clear H4. + apply (CRlt_trans_flip _ _ _ H6). clear H6. + apply CRplus_lt_compat_l. + apply (CRlt_le_trans + _ (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) (CRmorph f y))). + apply (CRmult_lt_reg_l (CR_of_Q R2 (/((r-q)*(1#A))))). + apply (CRle_lt_trans _ (CR_of_Q R2 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt, Qinv_lt_0_compat. + rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. + apply Qlt_minus_iff in H1. exact H1. reflexivity. + apply (CRle_lt_trans _ (CRopp R2 (CR_of_Q R2 (Z.pos A # 1)))). + apply (CRle_trans _ (CR_of_Q R2 (-(Z.pos A # 1)))). + apply (CRle_trans _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) * (q - r)))). + destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) (q - r)). + exact H0. destruct (CR_of_Q_morph R2 (/ ((r - q) * (1 # A)) * (q - r)) + (-(Z.pos A # 1))). + exact diveq. intro H7. apply lt_CR_of_Q in H7. + rewrite diveq in H7. exact (Qlt_not_le _ _ H7 (Qle_refl _)). + destruct (@CR_of_Q_opp R2 (Z.pos A # 1)). exact H4. + apply (CRlt_le_trans _ (CRopp R2 (CRmorph f y))). + apply CRopp_gt_lt_contravar. + apply (CRlt_le_trans _ (CRmorph f (CR_of_Q R1 (Z.pos A # 1)))). + apply CRmorph_increasing. exact Amaj. + destruct (CRmorph_rat f (Z.pos A # 1)). exact H4. + apply (CRle_trans _ (CRmult R2 (CRopp R2 (CRone R2)) (CRmorph f y))). + apply (CRle_trans _ (CRopp R2 (CRmult R2 (CRone R2) (CRmorph f y)))). + destruct (Ropp_ext (CRisRingExt R2) (CRmorph f y) + (CRmult R2 (CRone R2) (CRmorph f y))). + apply CReq_sym, (Rmul_1_l (CRisRing R2)). exact H4. + destruct (CRopp_mult_distr_l (CRone R2) (CRmorph f y)). exact H4. + apply (CRle_trans _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((r - q) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A)))) + (CRmorph f y))). + apply CRmult_le_compat_r_half. + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + apply (CRle_trans _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) + * ((q - r) * (1 # A))))). + apply (CRle_trans _ (CR_of_Q R2 (-1))). + apply (CRle_trans _ (CRopp R2 (CR_of_Q R2 1))). + destruct (Ropp_ext (CRisRingExt R2) (CRone R2) (CR_of_Q R2 1)). + apply CReq_sym, CR_of_Q_one. exact H4. + destruct (@CR_of_Q_opp R2 1). exact H0. + destruct (CR_of_Q_morph R2 (-1) (/ ((r - q) * (1 # A)) * ((q - r) * (1 # A)))). + field. split. + intro H4. inversion H4. intro H4. apply Qlt_minus_iff in H1. + rewrite H4 in H1. inversion H1. exact H4. + destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) ((q - r) * (1 # A))). + exact H4. + destruct (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((r - q) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph f y)). + exact H0. + apply CRmult_le_compat_r_half. + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + destruct (CRmorph_rat f ((q - r) * (1 # A))). exact H0. + + apply (CRle_trans _ (CRmorph f (CRmult R1 y (CR_of_Q R1 s)))). + apply (CRle_trans _ (CRmult R2 (CRmorph f y) (CR_of_Q R2 s))). + destruct (Rmul_comm (CRisRing R2) (CRmorph f y) (CR_of_Q R2 s)). + exact H0. + destruct (CRmorph_mult_rat f y s). exact H0. + destruct (CRmorph_proper f (CRmult R1 y (CR_of_Q R1 s)) + (CRmult R1 (CR_of_Q R1 s) y)). + apply (Rmul_comm (CRisRing R1)). exact H4. + + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. +Qed. + +Lemma CRmorph_mult_pos_pos : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRlt R1 (CRzero R1) y + -> CRmorph f (CRmult R1 x y) + == CRmult R2 (CRmorph f x) (CRmorph f y). +Proof. + split. apply CRmorph_mult_pos_pos_le. exact H. + intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. + destruct (CRmorph_rat f q) as [_ H3]. + apply (CRle_lt_trans _ _ _ H3) in H2. clear H3. + apply CRmorph_increasing_inv in H2. + apply (CRlt_asym _ _ H2). clear H2. + destruct (CR_Q_dense R2 _ _ H1) as [r [H2 H3]]. + apply lt_CR_of_Q in H3. + destruct (CR_archimedean R1 y) as [A Amaj]. + destruct (CR_Q_dense R1 x (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A))))) + as [s [H4 H5]]. + - apply (CRle_lt_trans _ (CRplus R1 x (CRzero R1))). + apply CRplus_0_r. apply CRplus_lt_compat_l. + apply (CRle_lt_trans _ (CR_of_Q R1 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. + rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. + apply Qlt_minus_iff in H3. exact H3. reflexivity. + - apply (CRmorph_increasing f) in H5. + destruct (CRmorph_plus f x (CR_of_Q R1 ((q-r) * (1#A)))) as [_ H6]. + apply (CRlt_le_trans _ _ _ H5) in H6. clear H5. + destruct (CRmorph_rat f s) as [H5 _ ]. + apply (CRle_lt_trans _ _ _ H5) in H6. clear H5. + apply (CRmult_lt_compat_r (CRmorph f y)) in H6. + apply (CRlt_le_trans _ (CRmult R1 (CR_of_Q R1 s) y)). + apply CRmult_lt_compat_r. exact H. exact H4. clear H4. + apply (CRmorph_le_inv f). + apply (CRle_trans _ (CR_of_Q R2 q)). + 2: destruct (CRmorph_rat f q); exact H0. + apply (CRle_trans _ (CRmult R2 (CR_of_Q R2 s) (CRmorph f y))). + + apply (CRle_trans _ (CRmorph f (CRmult R1 y (CR_of_Q R1 s)))). + destruct (CRmorph_proper f (CRmult R1 (CR_of_Q R1 s) y) + (CRmult R1 y (CR_of_Q R1 s))). + apply (Rmul_comm (CRisRing R1)). exact H4. + apply (CRle_trans _ (CRmult R2 (CRmorph f y) (CR_of_Q R2 s))). + exact (proj2 (CRmorph_mult_rat f y s)). + destruct (Rmul_comm (CRisRing R2) (CR_of_Q R2 s) (CRmorph f y)). + exact H0. + + intro H5. apply (CRlt_asym _ _ H5). clear H5. + apply (CRlt_trans _ _ _ H6). clear H6. + apply (CRle_lt_trans + _ (CRplus R2 + (CRmult R2 (CRmorph f x) (CRmorph f y)) + (CRmult R2 (CRmorph f (CR_of_Q R1 ((q - r) * (1 # A)))) + (CRmorph f y)))). + apply (Rdistr_l (CRisRing R2)). + apply (CRle_lt_trans + _ (CRplus R2 (CR_of_Q R2 r) + (CRmult R2 (CRmorph f (CR_of_Q R1 ((q - r) * (1 # A)))) + (CRmorph f y)))). + apply CRplus_le_compat_r. intro H5. apply (CRlt_asym _ _ H5 H2). + clear H2. + apply (CRle_lt_trans + _ (CRplus R2 (CR_of_Q R2 r) + (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph f y)))). + apply CRplus_le_compat_l, CRmult_le_compat_r_half. + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + destruct (CRmorph_rat f ((q - r) * (1 # A))). exact H2. + apply (CRlt_le_trans _ (CRplus R2 (CR_of_Q R2 r) + (CR_of_Q R2 ((q - r))))). + apply CRplus_lt_compat_l. + * apply (CRmult_lt_reg_l (CR_of_Q R2 (/((q - r) * (1 # A))))). + apply (CRle_lt_trans _ (CR_of_Q R2 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt, Qinv_lt_0_compat. + rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. + apply Qlt_minus_iff in H3. exact H3. reflexivity. + apply (CRle_lt_trans _ (CRmorph f y)). + apply (CRle_trans _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((q - r) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A)))) + (CRmorph f y))). + exact (proj2 (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((q - r) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph f y))). + apply (CRle_trans _ (CRmult R2 (CRone R2) (CRmorph f y))). + apply CRmult_le_compat_r_half. + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + apply (CRle_trans + _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * ((q - r) * (1 # A))))). + exact (proj1 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) ((q - r) * (1 # A)))). + apply (CRle_trans _ (CR_of_Q R2 1)). + destruct (CR_of_Q_morph R2 (/ ((q - r) * (1 # A)) * ((q - r) * (1 # A))) 1). + field_simplify. reflexivity. split. + intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. + rewrite H5 in H3. inversion H3. exact H2. + destruct (CR_of_Q_one R2). exact H2. + destruct (Rmul_1_l (CRisRing R2) (CRmorph f y)). + intro H5. contradiction. + apply (CRlt_le_trans _ (CR_of_Q R2 (Z.pos A # 1))). + apply (CRlt_le_trans _ (CRmorph f (CR_of_Q R1 (Z.pos A # 1)))). + apply CRmorph_increasing. exact Amaj. + exact (proj2 (CRmorph_rat f (Z.pos A # 1))). + apply (CRle_trans _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * (q - r)))). + 2: exact (proj2 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) (q - r))). + destruct (CR_of_Q_morph R2 (Z.pos A # 1) (/ ((q - r) * (1 # A)) * (q - r))). + field_simplify. reflexivity. split. + intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. + rewrite H5 in H3. inversion H3. exact H2. + * apply (CRle_trans _ (CR_of_Q R2 (r + (q-r)))). + exact (proj1 (CR_of_Q_plus R2 r (q-r))). + destruct (CR_of_Q_morph R2 (r + (q-r)) q). ring. exact H2. + + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. +Qed. + +Lemma CRmorph_mult : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRmorph f (CRmult R1 x y) + == CRmult R2 (CRmorph f x) (CRmorph f y). +Proof. + intros. + destruct (CR_archimedean R1 (CRopp R1 y)) as [p pmaj]. + apply (CRplus_eq_reg_r (CRmult R2 (CRmorph f x) + (CR_of_Q R2 (Z.pos p # 1)))). + apply (CReq_trans _ (CRmorph f (CRmult R1 x (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). + - apply (CReq_trans _ (CRplus R2 (CRmorph f (CRmult R1 x y)) + (CRmorph f (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). + apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. + apply CReq_sym, CRmorph_mult_int. + apply (CReq_trans _ (CRmorph f (CRplus R1 (CRmult R1 x y) + (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). + apply CReq_sym, CRmorph_plus. apply CRmorph_proper. + apply CReq_sym, CRmult_plus_distr_l. + - apply (CReq_trans _ (CRmult R2 (CRmorph f x) + (CRmorph f (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). + apply CRmorph_mult_pos_pos. + apply (CRplus_lt_compat_l R1 y) in pmaj. + apply (CRle_lt_trans _ (CRplus R1 y (CRopp R1 y))). + 2: exact pmaj. apply (CRisRing R1). + apply (CReq_trans _ (CRmult R2 (CRmorph f x) + (CRplus R2 (CRmorph f y) (CR_of_Q R2 (Z.pos p # 1))))). + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans _ (CRplus R2 (CRmorph f y) + (CRmorph f (CR_of_Q R1 (Z.pos p # 1))))). + apply CRmorph_plus. + apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. + apply CRmorph_rat. + apply CRmult_plus_distr_l. +Qed. + +Lemma CRmorph_appart : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1) + (app : x ≶ y), + CRmorph f x ≶ CRmorph f y. +Proof. + intros. destruct app. + - left. apply CRmorph_increasing. exact c. + - right. apply CRmorph_increasing. exact c. +Defined. + +Lemma CRmorph_appart_zero : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) + (app : x ≶ 0), + CRmorph f x ≶ 0. +Proof. + intros. destruct app. + - left. apply (CRlt_le_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_increasing. exact c. + exact (proj2 (CRmorph_zero f)). + - right. apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + exact (proj1 (CRmorph_zero f)). + apply CRmorph_increasing. exact c. +Defined. + +Lemma CRmorph_inv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) + (xnz : x ≶ 0) + (fxnz : CRmorph f x ≶ 0), + CRmorph f ((/ x) xnz) + == (/ CRmorph f x) fxnz. +Proof. + intros. apply (CRmult_eq_reg_r (CRmorph f x)). + destruct fxnz. right. exact c. left. exact c. + apply (CReq_trans _ (CRone R2)). + 2: apply CReq_sym, CRinv_l. + apply (CReq_trans _ (CRmorph f (CRmult R1 ((/ x) xnz) x))). + apply CReq_sym, CRmorph_mult. + apply (CReq_trans _ (CRmorph f 1)). + apply CRmorph_proper. apply CRinv_l. + apply CRmorph_one. +Qed. + +Lemma CRmorph_sum : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (un : nat -> CRcarrier R1) (n : nat), + CRmorph f (CRsum un n) == + CRsum (fun n0 : nat => CRmorph f (un n0)) n. +Proof. + induction n. + - reflexivity. + - simpl. rewrite CRmorph_plus, IHn. reflexivity. +Qed. + +Lemma CRmorph_INR : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (n : nat), + CRmorph f (INR n) == INR n. +Proof. + induction n. + - apply CRmorph_rat. + - simpl. unfold INR. + rewrite (CRmorph_proper f _ (1 + CR_of_Q R1 (Z.of_nat n # 1))). + rewrite CRmorph_plus. unfold INR in IHn. + rewrite IHn. rewrite CRmorph_one, <- CR_of_Q_one, <- CR_of_Q_plus. + apply CR_of_Q_morph. rewrite Qinv_plus_distr. + unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. + rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. reflexivity. + rewrite <- CR_of_Q_one, <- CR_of_Q_plus. + apply CR_of_Q_morph. rewrite Qinv_plus_distr. + unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. + rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. reflexivity. +Qed. + +Lemma CRmorph_rat_cv + : forall {R1 R2 : ConstructiveReals} + (qn : nat -> Q), + CR_cauchy R1 (fun n => CR_of_Q R1 (qn n)) + -> CR_cauchy R2 (fun n => CR_of_Q R2 (qn n)). +Proof. + intros. intro p. destruct (H p) as [n nmaj]. + exists n. intros. specialize (nmaj i j H0 H1). + unfold CRminus. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus, CR_of_Q_abs. + unfold CRminus in nmaj. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus, CR_of_Q_abs in nmaj. + apply CR_of_Q_le. destruct (Q_dec (Qabs (qn i + - qn j)) (1#p)). + destruct s. apply Qlt_le_weak, q. exfalso. + apply (Qlt_not_le _ _ q). apply (CR_of_Q_lt R1) in q. contradiction. + rewrite q. apply Qle_refl. +Qed. + +Definition CR_Q_limit {R : ConstructiveReals} (x : CRcarrier R) (n:nat) + : { q:Q & x < CR_of_Q R q < x + CR_of_Q R (1 # Pos.of_nat n) }. +Proof. + apply (CR_Q_dense R x (x + CR_of_Q R (1 # Pos.of_nat n))). + rewrite <- (CRplus_0_r x). rewrite CRplus_assoc. + apply CRplus_lt_compat_l. rewrite CRplus_0_l. apply CR_of_Q_pos. + reflexivity. +Qed. + +Lemma CR_Q_limit_cv : forall {R : ConstructiveReals} (x : CRcarrier R), + CR_cv R (fun n => CR_of_Q R (let (q,_) := CR_Q_limit x n in q)) x. +Proof. + intros R x p. exists (Pos.to_nat p). + intros. destruct (CR_Q_limit x i). rewrite CRabs_right. + apply (CRplus_le_reg_r x). unfold CRminus. + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm. + apply (CRle_trans _ (x + CR_of_Q R (1 # Pos.of_nat i))). + apply CRlt_asym, p0. apply CRplus_le_compat_l, CR_of_Q_le. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. rewrite Nat2Pos.id. exact H. + destruct i. exfalso. inversion H. pose proof (Pos2Nat.is_pos p). + rewrite H1 in H0. inversion H0. discriminate. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r, CRlt_asym, p0. +Qed. + +(* We call this morphism slow to remind that it should only be used + for proofs, not for computations. *) +Definition SlowMorph {R1 R2 : ConstructiveReals} + : CRcarrier R1 -> CRcarrier R2 + := fun x => let (y,_) := CR_complete R2 _ (CRmorph_rat_cv _ (Rcv_cauchy_mod _ x (CR_Q_limit_cv x))) + in y. + +Lemma CauchyMorph_rat : forall {R1 R2 : ConstructiveReals} (q : Q), + SlowMorph (CR_of_Q R1 q) == CR_of_Q R2 q. +Proof. + intros. unfold SlowMorph. + destruct (CR_complete R2 _ + (CRmorph_rat_cv _ + (Rcv_cauchy_mod + (fun n : nat => CR_of_Q R1 (let (q0, _) := CR_Q_limit (CR_of_Q R1 q) n in q0)) + (CR_of_Q R1 q) (CR_Q_limit_cv (CR_of_Q R1 q))))). + apply (CR_cv_unique _ _ _ c). + intro p. exists (Pos.to_nat p). intros. + destruct (CR_Q_limit (CR_of_Q R1 q) i). rewrite CRabs_right. + apply (CRplus_le_reg_r (CR_of_Q R2 q)). unfold CRminus. + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm. + rewrite <- CR_of_Q_plus. apply CR_of_Q_le. + destruct (Q_dec x0 (q + (1 # p))%Q). destruct s. + apply Qlt_le_weak, q0. exfalso. pose proof (CR_of_Q_lt R1 _ _ q0). + apply (CRlt_asym _ _ H0). apply (CRlt_le_trans _ _ _ (snd p0)). clear H0. + rewrite <- CR_of_Q_plus. apply CR_of_Q_le. apply Qplus_le_r. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. rewrite Nat2Pos.id. exact H. + destruct i. exfalso. inversion H. pose proof (Pos2Nat.is_pos p). + rewrite H1 in H0. inversion H0. discriminate. + rewrite q0. apply Qle_refl. + rewrite <- (CRplus_opp_r (CR_of_Q R2 q)). apply CRplus_le_compat_r, CR_of_Q_le. + destruct (Q_dec q x0). destruct s. apply Qlt_le_weak, q0. + exfalso. apply (CRlt_asym _ _ (fst p0)). apply CR_of_Q_lt. exact q0. + rewrite q0. apply Qle_refl. +Qed. + +(* The increasing property of morphisms, when the left bound is rational. *) +Lemma SlowMorph_increasing_Qr + : forall {R1 R2 : ConstructiveReals} (x : CRcarrier R1) (q : Q), + CR_of_Q R1 q < x -> CR_of_Q R2 q < SlowMorph x. +Proof. + intros. + unfold SlowMorph; + destruct (CR_complete R2 _ + (CRmorph_rat_cv _ + (Rcv_cauchy_mod (fun n : nat => CR_of_Q R1 (let (q0, _) := CR_Q_limit x n in q0)) x + (CR_Q_limit_cv x)))). + destruct (CR_Q_dense R1 _ _ H) as [r [H0 H1]]. + apply lt_CR_of_Q in H0. + apply (CRlt_le_trans _ (CR_of_Q R2 r)). + apply CR_of_Q_lt, H0. + assert (forall n:nat, le O n -> CR_of_Q R2 r <= CR_of_Q R2 (let (q0, _) := CR_Q_limit x n in q0)). + { intros. apply CR_of_Q_le. destruct (CR_Q_limit x n). + destruct (Q_dec r x1). destruct s. apply Qlt_le_weak, q0. + exfalso. apply (CR_of_Q_lt R1) in q0. + apply (CRlt_asym _ _ q0). exact (CRlt_trans _ _ _ H1 (fst p)). + rewrite q0. apply Qle_refl. } + exact (CR_cv_bound_down _ _ _ O H2 c). +Qed. + +(* The increasing property of morphisms, when the right bound is rational. *) +Lemma SlowMorph_increasing_Ql + : forall {R1 R2 : ConstructiveReals} (x : CRcarrier R1) (q : Q), + x < CR_of_Q R1 q -> SlowMorph x < CR_of_Q R2 q. +Proof. + intros. + unfold SlowMorph; + destruct (CR_complete R2 _ + (CRmorph_rat_cv _ + (Rcv_cauchy_mod (fun n : nat => CR_of_Q R1 (let (q0, _) := CR_Q_limit x n in q0)) x + (CR_Q_limit_cv x)))). + assert (CR_cv R1 (fun n => CR_of_Q R1 (let (q0, _) := CR_Q_limit x n in q0) + + CR_of_Q R1 (1 # Pos.of_nat n)) x). + { apply (CR_cv_proper _ (x+0)). apply CR_cv_plus. apply CR_Q_limit_cv. + intro p. exists (Pos.to_nat p). intros. + unfold CRminus. rewrite CRopp_0, CRplus_0_r. rewrite CRabs_right. + apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. + apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. rewrite Nat2Pos.id. exact H0. + destruct i. inversion H0. pose proof (Pos2Nat.is_pos p). + rewrite H2 in H1. inversion H1. discriminate. + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. + rewrite CRplus_0_r. reflexivity. } + pose proof (CR_cv_open_above _ _ _ H0 H) as [n nmaj]. + apply (CRle_lt_trans _ (CR_of_Q R2 (let (q0, _) := CR_Q_limit x n in + q0 + (1 # Pos.of_nat n)))). + - apply (CR_cv_bound_up (fun n : nat => CR_of_Q R2 (let (q0, _) := CR_Q_limit x n in q0)) _ _ n). + 2: exact c. intros. destruct (CR_Q_limit x n0), (CR_Q_limit x n). + apply CR_of_Q_le, Qlt_le_weak. apply (lt_CR_of_Q R1). + apply (CRlt_le_trans _ _ _ (snd p)). + apply (CRle_trans _ (CR_of_Q R1 x2 + CR_of_Q R1 (1 # Pos.of_nat n0))). + apply CRplus_le_compat_r. apply CRlt_asym, p0. + rewrite <- CR_of_Q_plus. apply CR_of_Q_le. apply Qplus_le_r. + unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. + apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. + destruct n. destruct n0. apply le_refl. + rewrite (Nat2Pos.id (S n0)). apply le_n_S, le_0_n. discriminate. + destruct n0. exfalso; inversion H1. + rewrite Nat2Pos.id, Nat2Pos.id. exact H1. discriminate. discriminate. + - specialize (nmaj n (le_refl n)). + destruct (CR_Q_limit x n). apply CR_of_Q_lt. + rewrite <- CR_of_Q_plus in nmaj. apply lt_CR_of_Q in nmaj. exact nmaj. +Qed. + +Lemma SlowMorph_increasing : forall {R1 R2 : ConstructiveReals} (x y : CRcarrier R1), + x < y -> @SlowMorph R1 R2 x < SlowMorph y. +Proof. + intros. + destruct (CR_Q_dense R1 _ _ H) as [q [H0 H1]]. + apply (CRlt_trans _ (CR_of_Q R2 q)). + apply SlowMorph_increasing_Ql. exact H0. + apply SlowMorph_increasing_Qr. exact H1. +Qed. + + +(* We call this morphism slow to remind that it should only be used + for proofs, not for computations. *) +Definition SlowConstructiveRealsMorphism {R1 R2 : ConstructiveReals} + : @ConstructiveRealsMorphism R1 R2 + := Build_ConstructiveRealsMorphism + R1 R2 SlowMorph CauchyMorph_rat + SlowMorph_increasing. + +Lemma CRmorph_abs : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + CRabs R2 (CRmorph f x) == CRmorph f (CRabs R1 x). +Proof. + assert (forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + CRabs R2 (CRmorph f x) <= CRmorph f (CRabs R1 x)). + { intros. rewrite <- CRabs_def. split. + - apply CRmorph_le. + pose proof (CRabs_def _ x (CRabs R1 x)) as [_ H]. + apply H, CRle_refl. + - apply (CRle_trans _ (CRmorph f (CRopp R1 x))). + apply CRmorph_opp. apply CRmorph_le. + pose proof (CRabs_def _ x (CRabs R1 x)) as [_ H]. + apply H, CRle_refl. } + intros. split. 2: apply H. + apply (CRmorph_le_inv (@SlowConstructiveRealsMorphism R2 R1)). + apply (CRle_trans _ (CRabs R1 x)). + apply (Endomorph_id + (CRmorph_compose f (@SlowConstructiveRealsMorphism R2 R1))). + apply (CRle_trans + _ (CRabs R1 (CRmorph (@SlowConstructiveRealsMorphism R2 R1) (CRmorph f x)))). + apply CRabs_morph. + apply CReq_sym, (Endomorph_id + (CRmorph_compose f (@SlowConstructiveRealsMorphism R2 R1))). + apply H. +Qed. + +Lemma CRmorph_cv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (un : nat -> CRcarrier R1) + (l : CRcarrier R1), + CR_cv R1 un l + -> CR_cv R2 (fun n => CRmorph f (un n)) (CRmorph f l). +Proof. + intros. intro p. specialize (H p) as [n H]. + exists n. intros. specialize (H i H0). + unfold CRminus. rewrite <- CRmorph_opp, <- CRmorph_plus, CRmorph_abs. + rewrite <- (CRmorph_rat f (1#p)). apply CRmorph_le. exact H. +Qed. + +Lemma CRmorph_cauchy_reverse : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (un : nat -> CRcarrier R1), + CR_cauchy R2 (fun n => CRmorph f (un n)) + -> CR_cauchy R1 un. +Proof. + intros. intro p. specialize (H p) as [n H]. + exists n. intros. specialize (H i j H0 H1). + unfold CRminus in H. rewrite <- CRmorph_opp, <- CRmorph_plus, CRmorph_abs in H. + rewrite <- (CRmorph_rat f (1#p)) in H. + apply (CRmorph_le_inv f) in H. exact H. +Qed. + +Lemma CRmorph_min : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (a b : CRcarrier R1), + CRmorph f (CRmin a b) + == CRmin (CRmorph f a) (CRmorph f b). +Proof. + intros. unfold CRmin. + rewrite CRmorph_mult. apply CRmult_morph. + 2: apply CRmorph_rat. + unfold CRminus. do 2 rewrite CRmorph_plus. apply CRplus_morph. + apply CRplus_morph. reflexivity. reflexivity. + rewrite CRmorph_opp. apply CRopp_morph. + rewrite <- CRmorph_abs. apply CRabs_morph. + rewrite CRmorph_plus. apply CRplus_morph. + reflexivity. + rewrite CRmorph_opp. apply CRopp_morph, CRmorph_proper. reflexivity. +Qed. + +Lemma CRmorph_series_cv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (un : nat -> CRcarrier R1) + (l : CRcarrier R1), + series_cv un l + -> series_cv (fun n => CRmorph f (un n)) (CRmorph f l). +Proof. + intros. + apply (CR_cv_eq _ (fun n => CRmorph f (CRsum un n))). + intro n. apply CRmorph_sum. + apply CRmorph_cv, H. +Qed. diff --git a/theories/Reals/Abstract/ConstructiveSum.v b/theories/Reals/Abstract/ConstructiveSum.v new file mode 100644 index 0000000000..11c8e5d8a2 --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveSum.v @@ -0,0 +1,348 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import QArith Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveAbs. + +Local Open Scope ConstructiveReals. + + +(** + Definition and properties of finite sums and powers. +*) + +Fixpoint CRsum {R : ConstructiveReals} + (f:nat -> CRcarrier R) (N:nat) : CRcarrier R := + match N with + | O => f 0%nat + | S i => CRsum f i + f (S i) + end. + +Fixpoint CRpow {R : ConstructiveReals} (r:CRcarrier R) (n:nat) : CRcarrier R := + match n with + | O => 1 + | S n => r * (CRpow r n) + end. + +Lemma CRsum_eq : + forall {R : ConstructiveReals} (An Bn:nat -> CRcarrier R) (N:nat), + (forall i:nat, (i <= N)%nat -> An i == Bn i) -> + CRsum An N == CRsum Bn N. +Proof. + induction N. + - intros. exact (H O (le_refl _)). + - intros. simpl. apply CRplus_morph. apply IHN. + intros. apply H. apply (le_trans _ N _ H0), le_S, le_refl. + apply H, le_refl. +Qed. + +Lemma sum_eq_R0 : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (n : nat), + (forall k:nat, un k == 0) + -> CRsum un n == 0. +Proof. + induction n. + - intros. apply H. + - intros. simpl. rewrite IHn. rewrite H. apply CRplus_0_l. exact H. +Qed. + +Definition INR {R : ConstructiveReals} (n : nat) : CRcarrier R + := CR_of_Q R (Z.of_nat n # 1). + +Lemma sum_const : forall {R : ConstructiveReals} (a : CRcarrier R) (n : nat), + CRsum (fun _ => a) n == a * INR (S n). +Proof. + induction n. + - unfold INR. simpl. rewrite CR_of_Q_one, CRmult_1_r. reflexivity. + - simpl. rewrite IHn. unfold INR. + replace (Z.of_nat (S (S n))) with (Z.of_nat (S n) + 1)%Z. + rewrite <- Qinv_plus_distr, CR_of_Q_plus, CRmult_plus_distr_l. + apply CRplus_morph. reflexivity. rewrite CR_of_Q_one, CRmult_1_r. reflexivity. + replace 1%Z with (Z.of_nat 1). rewrite <- Nat2Z.inj_add. + apply f_equal. rewrite Nat.add_comm. reflexivity. reflexivity. +Qed. + +Lemma multiTriangleIneg : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (n : nat), + CRabs R (CRsum u n) <= CRsum (fun k => CRabs R (u k)) n. +Proof. + induction n. + - apply CRle_refl. + - simpl. apply (CRle_trans _ (CRabs R (CRsum u n) + CRabs R (u (S n)))). + apply CRabs_triang. apply CRplus_le_compat. apply IHn. + apply CRle_refl. +Qed. + +Lemma sum_assoc : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (n p : nat), + CRsum u (S n + p) + == CRsum u n + CRsum (fun k => u (S n + k)%nat) p. +Proof. + induction p. + - simpl. rewrite Nat.add_0_r. reflexivity. + - simpl. rewrite (Radd_assoc (CRisRing R)). apply CRplus_morph. + rewrite Nat.add_succ_r. + rewrite (CRsum_eq (fun k : nat => u (S (n + k))) (fun k : nat => u (S n + k)%nat)). + rewrite <- IHp. reflexivity. intros. reflexivity. reflexivity. +Qed. + +Lemma sum_Rle : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (n : nat), + (forall k, le k n -> un k <= vn k) + -> CRsum un n <= CRsum vn n. +Proof. + induction n. + - intros. apply H. apply le_refl. + - intros. simpl. apply CRplus_le_compat. apply IHn. + intros. apply H. apply (le_trans _ n _ H0). apply le_S, le_refl. + apply H. apply le_refl. +Qed. + +Lemma Abs_sum_maj : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R), + (forall n:nat, CRabs R (un n) <= (vn n)) + -> forall n p:nat, (CRabs R (CRsum un n - CRsum un p) <= + CRsum vn (Init.Nat.max n p) - CRsum vn (Init.Nat.min n p)). +Proof. + intros. destruct (le_lt_dec n p). + - destruct (Nat.le_exists_sub n p) as [k [maj _]]. assumption. + subst p. rewrite max_r. rewrite min_l. + setoid_replace (CRsum un n - CRsum un (k + n)) + with (-(CRsum un (k + n) - CRsum un n)). + rewrite CRabs_opp. + destruct k. simpl. unfold CRminus. rewrite CRplus_opp_r. + rewrite CRplus_opp_r. rewrite CRabs_right. + apply CRle_refl. apply CRle_refl. + replace (S k + n)%nat with (S n + k)%nat. + unfold CRminus. rewrite sum_assoc. rewrite sum_assoc. + rewrite CRplus_comm. + rewrite <- CRplus_assoc. rewrite CRplus_opp_l. + rewrite CRplus_0_l. rewrite CRplus_comm. + rewrite <- CRplus_assoc. rewrite CRplus_opp_l. + rewrite CRplus_0_l. + apply (CRle_trans _ (CRsum (fun k0 : nat => CRabs R (un (S n + k0)%nat)) k)). + apply multiTriangleIneg. apply sum_Rle. intros. + apply H. rewrite Nat.add_comm, Nat.add_succ_r. reflexivity. + unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, CRplus_comm. + reflexivity. assumption. assumption. + - destruct (Nat.le_exists_sub p n) as [k [maj _]]. unfold lt in l. + apply (le_trans p (S p)). apply le_S. apply le_refl. assumption. + subst n. rewrite max_l. rewrite min_r. + destruct k. simpl. unfold CRminus. rewrite CRplus_opp_r. + rewrite CRplus_opp_r. rewrite CRabs_right. apply CRle_refl. + apply CRle_refl. + replace (S k + p)%nat with (S p + k)%nat. unfold CRminus. + rewrite sum_assoc. rewrite sum_assoc. + rewrite CRplus_comm. + rewrite <- CRplus_assoc. rewrite CRplus_opp_l. + rewrite CRplus_0_l. rewrite CRplus_comm. + rewrite <- CRplus_assoc. rewrite CRplus_opp_l. + rewrite CRplus_0_l. + apply (CRle_trans _ (CRsum (fun k0 : nat => CRabs R (un (S p + k0)%nat)) k)). + apply multiTriangleIneg. apply sum_Rle. intros. + apply H. rewrite Nat.add_comm, Nat.add_succ_r. reflexivity. + apply (le_trans p (S p)). apply le_S. apply le_refl. assumption. + apply (le_trans p (S p)). apply le_S. apply le_refl. assumption. +Qed. + +Lemma cond_pos_sum : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (n : nat), + (forall k, 0 <= un k) + -> 0 <= CRsum un n. +Proof. + induction n. + - intros. apply H. + - intros. simpl. rewrite <- CRplus_0_r. + apply CRplus_le_compat. apply IHn, H. apply H. +Qed. + +Lemma pos_sum_more : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (n p : nat), + (forall k:nat, 0 <= u k) + -> le n p -> CRsum u n <= CRsum u p. +Proof. + intros. destruct (Nat.le_exists_sub n p H0). destruct H1. subst p. + rewrite plus_comm. + destruct x. rewrite plus_0_r. apply CRle_refl. rewrite Nat.add_succ_r. + replace (S (n + x)) with (S n + x)%nat. rewrite sum_assoc. + rewrite <- CRplus_0_r, CRplus_assoc. + apply CRplus_le_compat_l. rewrite CRplus_0_l. + apply cond_pos_sum. + intros. apply H. auto. +Qed. + +Lemma sum_opp : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (n : nat), + CRsum (fun k => - un k) n == - CRsum un n. +Proof. + induction n. + - reflexivity. + - simpl. rewrite IHn. rewrite CRopp_plus_distr. reflexivity. +Qed. + +Lemma sum_scale : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (a : CRcarrier R) (n : nat), + CRsum (fun k : nat => u k * a) n == CRsum u n * a. +Proof. + induction n. + - simpl. rewrite (Rmul_comm (CRisRing R)). reflexivity. + - simpl. rewrite IHn. rewrite CRmult_plus_distr_r. + apply CRplus_morph. reflexivity. + rewrite (Rmul_comm (CRisRing R)). reflexivity. +Qed. + +Lemma sum_plus : forall {R : ConstructiveReals} (u v : nat -> CRcarrier R) (n : nat), + CRsum (fun n0 : nat => u n0 + v n0) n == CRsum u n + CRsum v n. +Proof. + induction n. + - reflexivity. + - simpl. rewrite IHn. do 2 rewrite CRplus_assoc. + apply CRplus_morph. reflexivity. rewrite CRplus_comm, CRplus_assoc. + apply CRplus_morph. reflexivity. apply CRplus_comm. +Qed. + +Lemma decomp_sum : + forall {R : ConstructiveReals} (An:nat -> CRcarrier R) (N:nat), + (0 < N)%nat -> + CRsum An N == An 0%nat + CRsum (fun i:nat => An (S i)) (pred N). +Proof. + induction N. + - intros. exfalso. inversion H. + - intros _. destruct N. simpl. reflexivity. simpl. + rewrite IHN. rewrite CRplus_assoc. + apply CRplus_morph. reflexivity. reflexivity. + apply le_n_S, le_0_n. +Qed. + +Lemma reverse_sum : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (n : nat), + CRsum u n == CRsum (fun k => u (n-k)%nat) n. +Proof. + induction n. + - intros. reflexivity. + - rewrite (decomp_sum (fun k : nat => u (S n - k)%nat)). simpl. + rewrite CRplus_comm. apply CRplus_morph. reflexivity. assumption. + unfold lt. apply le_n_S. apply le_0_n. +Qed. + +Lemma Rplus_le_pos : forall {R : ConstructiveReals} (a b : CRcarrier R), + 0 <= b -> a <= a + b. +Proof. + intros. rewrite <- (CRplus_0_r a). rewrite CRplus_assoc. + apply CRplus_le_compat_l. rewrite CRplus_0_l. assumption. +Qed. + +Lemma selectOneInSum : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (n i : nat), + le i n + -> (forall k:nat, 0 <= u k) + -> u i <= CRsum u n. +Proof. + induction n. + - intros. inversion H. subst i. apply CRle_refl. + - intros. apply Nat.le_succ_r in H. destruct H. + apply (CRle_trans _ (CRsum u n)). apply IHn. assumption. assumption. + simpl. apply Rplus_le_pos. apply H0. + subst i. simpl. rewrite CRplus_comm. apply Rplus_le_pos. + apply cond_pos_sum. intros. apply H0. +Qed. + +Lemma splitSum : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) + (filter : nat -> bool) (n : nat), + CRsum un n + == CRsum (fun i => if filter i then un i else 0) n + + CRsum (fun i => if filter i then 0 else un i) n. +Proof. + induction n. + - simpl. destruct (filter O). symmetry; apply CRplus_0_r. + symmetry. apply CRplus_0_l. + - simpl. rewrite IHn. clear IHn. destruct (filter (S n)). + do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRplus_comm. apply CRplus_morph. reflexivity. rewrite CRplus_0_r. + reflexivity. rewrite CRplus_0_r. rewrite CRplus_assoc. reflexivity. +Qed. + + +(* Power *) + +Lemma pow_R1_Rle : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), + 1 <= x + -> 1 <= CRpow x n. +Proof. + induction n. + - intros. apply CRle_refl. + - intros. simpl. apply (CRle_trans _ (x * 1)). + rewrite CRmult_1_r. exact H. + apply CRmult_le_compat_l_half. apply (CRlt_le_trans _ 1). + apply CRzero_lt_one. exact H. + apply IHn. exact H. +Qed. + +Lemma pow_le : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), + 0 <= x + -> 0 <= CRpow x n. +Proof. + induction n. + - intros. apply CRlt_asym, CRzero_lt_one. + - intros. simpl. apply CRmult_le_0_compat. + exact H. apply IHn. exact H. +Qed. + +Lemma pow_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), + 0 < x + -> 0 < CRpow x n. +Proof. + induction n. + - intros. apply CRzero_lt_one. + - intros. simpl. apply CRmult_lt_0_compat. exact H. + apply IHn. exact H. +Qed. + +Lemma pow_mult : forall {R : ConstructiveReals} (x y : CRcarrier R) (n:nat), + CRpow x n * CRpow y n == CRpow (x*y) n. +Proof. + induction n. + - simpl. rewrite CRmult_1_r. reflexivity. + - simpl. rewrite <- IHn. do 2 rewrite <- (Rmul_assoc (CRisRing R)). + apply CRmult_morph. reflexivity. + rewrite <- (Rmul_comm (CRisRing R)). rewrite <- (Rmul_assoc (CRisRing R)). + apply CRmult_morph. reflexivity. + rewrite <- (Rmul_comm (CRisRing R)). reflexivity. +Qed. + +Lemma pow_one : forall {R : ConstructiveReals} (n:nat), + @CRpow R 1 n == 1. +Proof. + induction n. reflexivity. + transitivity (CRmult R 1 (CRpow 1 n)). reflexivity. + rewrite IHn. rewrite CRmult_1_r. reflexivity. +Qed. + +Lemma pow_proper : forall {R : ConstructiveReals} (x y : CRcarrier R) (n : nat), + x == y -> CRpow x n == CRpow y n. +Proof. + induction n. + - intros. reflexivity. + - intros. simpl. rewrite IHn, H. reflexivity. exact H. +Qed. + +Lemma pow_inv : forall {R : ConstructiveReals} (x : CRcarrier R) (xPos : 0 < x) (n : nat), + CRpow (CRinv R x (inr xPos)) n + == CRinv R (CRpow x n) (inr (pow_lt x n xPos)). +Proof. + induction n. + - rewrite CRinv_1. reflexivity. + - transitivity (CRinv R x (inr xPos) * CRpow (CRinv R x (inr xPos)) n). + reflexivity. rewrite IHn. + assert (0 < x * CRpow x n). + { apply CRmult_lt_0_compat. exact xPos. apply pow_lt, xPos. } + rewrite <- (CRinv_mult_distr _ _ _ _ (inr H)). + apply CRinv_morph. reflexivity. +Qed. + +Lemma pow_plus_distr : forall {R : ConstructiveReals} (x : CRcarrier R) (n p:nat), + CRpow x n * CRpow x p == CRpow x (n+p). +Proof. + induction n. + - intros. simpl. rewrite CRmult_1_l. reflexivity. + - intros. simpl. rewrite CRmult_assoc. apply CRmult_morph. + reflexivity. apply IHn. +Qed. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v new file mode 100644 index 0000000000..7e51b575ba --- /dev/null +++ b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v @@ -0,0 +1,887 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import QArith. +Require Import Qabs. +Require Import ConstructiveCauchyReals. +Require Import ConstructiveCauchyRealsMult. + +Local Open Scope CReal_scope. + + +(** + The constructive formulation of the absolute value on the real numbers. + This is followed by the constructive definitions of minimum and maximum, + as min x y := (x + y - |x-y|) / 2. +*) + + +(* If a rational sequence is Cauchy, then so is its absolute value. + This is how the constructive absolute value is defined. + A more abstract way to put it is the real numbers are the metric completion + of the rational numbers, so the uniformly continuous function + Qabs : Q -> Q + uniquely extends to a uniformly continuous function + CReal_abs : CReal -> CReal +*) +Lemma CauchyAbsStable : forall xn : nat -> Q, + QCauchySeq xn Pos.to_nat + -> QCauchySeq (fun n => Qabs (xn n)) Pos.to_nat. +Proof. + intros xn cau n p q H H0. + specialize (cau n p q H H0). + apply (Qle_lt_trans _ (Qabs (xn p - xn q))). + 2: exact cau. apply Qabs_Qle_condition. split. + 2: apply Qabs_triangle_reverse. + apply (Qplus_le_r _ _ (Qabs (xn q))). + rewrite <- Qabs_opp. + apply (Qle_trans _ _ _ (Qabs_triangle_reverse _ _)). + ring_simplify. + setoid_replace (-xn q - (xn p - xn q))%Q with (-(xn p))%Q. + 2: ring. rewrite Qabs_opp. apply Qle_refl. +Qed. + +Definition CReal_abs (x : CReal) : CReal + := let (xn, cau) := x in + exist _ (fun n => Qabs (xn n)) (CauchyAbsStable xn cau). + +Lemma CReal_neg_nth : forall (x : CReal) (n : positive), + (proj1_sig x (Pos.to_nat n) < -1#n)%Q + -> x < 0. +Proof. + intros. destruct x as [xn cau]; unfold proj1_sig in H. + apply Qlt_minus_iff in H. + setoid_replace ((-1 # n) + - xn (Pos.to_nat n))%Q + with (- ((1 # n) + xn (Pos.to_nat n)))%Q in H. + destruct (Qarchimedean (2 / (-((1#n) + xn (Pos.to_nat n))))) as [k kmaj]. + exists (Pos.max k n). simpl. unfold Qminus; rewrite Qplus_0_l. + specialize (cau n (Pos.to_nat n) (max (Pos.to_nat k) (Pos.to_nat n)) + (le_refl _) (Nat.le_max_r _ _)). + apply (Qle_lt_trans _ (2#k)). + unfold Qle, Qnum, Qden. + apply Z.mul_le_mono_nonneg_l. discriminate. + apply Pos2Z.pos_le_pos, Pos.le_max_l. + rewrite <- Pos2Nat.inj_max in cau. + apply (Qmult_lt_l _ _ (-((1 # n) + xn (Pos.to_nat n)))) in kmaj. + rewrite Qmult_div_r in kmaj. + apply (Qmult_lt_r _ _ (1 # k)) in kmaj. + rewrite <- Qmult_assoc in kmaj. + setoid_replace ((Z.pos k # 1) * (1 # k))%Q with 1%Q in kmaj. + rewrite Qmult_1_r in kmaj. + setoid_replace (2#k)%Q with (2 * (1 # k))%Q. 2: reflexivity. + apply (Qlt_trans _ _ _ kmaj). clear kmaj. + apply (Qplus_lt_l _ _ ((1#n) + xn (Pos.to_nat (Pos.max k n)))). + ring_simplify. rewrite Qplus_comm. + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat (Pos.max k n))))). + 2: exact cau. + rewrite <- Qabs_opp. + setoid_replace (- (xn (Pos.to_nat n) - xn (Pos.to_nat (Pos.max k n))))%Q + with (xn (Pos.to_nat (Pos.max k n)) + -1 * xn (Pos.to_nat n))%Q. + apply Qle_Qabs. ring. 2: reflexivity. + unfold Qmult, Qeq, Qnum, Qden. + rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_l. reflexivity. + 2: exact H. intro abs. rewrite abs in H. exact (Qlt_irrefl 0 H). + setoid_replace (-1 # n)%Q with (-(1#n))%Q. ring. reflexivity. +Qed. + +Lemma CReal_nonneg : forall (x : CReal) (n : positive), + 0 <= x -> (-1#n <= proj1_sig x (Pos.to_nat n))%Q. +Proof. + intros. destruct x as [xn cau]; unfold proj1_sig. + destruct (Qlt_le_dec (xn (Pos.to_nat n)) (-1#n)). + 2: exact q. exfalso. apply H. clear H. + apply (CReal_neg_nth _ n). exact q. +Qed. + +Lemma CReal_abs_right : forall x : CReal, 0 <= x -> CReal_abs x == x. +Proof. + intros. apply CRealEq_diff. intro n. + destruct x as [xn cau]; unfold CReal_abs, proj1_sig. + apply (CReal_nonneg _ n) in H. simpl in H. + rewrite Qabs_pos. + 2: unfold Qminus; rewrite <- Qle_minus_iff; apply Qle_Qabs. + destruct (Qlt_le_dec (xn (Pos.to_nat n)) 0). + - rewrite Qabs_neg. 2: apply Qlt_le_weak, q. + apply Qopp_le_compat in H. + apply (Qmult_le_l _ _ (1#2)). reflexivity. ring_simplify. + setoid_replace ((1 # 2) * (2 # n))%Q with (-(-1#n))%Q. + 2: reflexivity. + setoid_replace ((-2 # 2) * xn (Pos.to_nat n))%Q with (- xn (Pos.to_nat n))%Q. + exact H. ring. + - rewrite Qabs_pos. unfold Qminus. rewrite Qplus_opp_r. discriminate. exact q. +Qed. + +Lemma CReal_le_abs : forall x : CReal, x <= CReal_abs x. +Proof. + intros. intros [n nmaj]. destruct x as [xn cau]; simpl in nmaj. + apply (Qle_not_lt _ _ (Qle_Qabs (xn (Pos.to_nat n)))). + apply Qlt_minus_iff. apply (Qlt_trans _ (2#n)). + reflexivity. exact nmaj. +Qed. + +Lemma CReal_abs_pos : forall x : CReal, 0 <= CReal_abs x. +Proof. + intros. intros [n nmaj]. destruct x as [xn cau]; simpl in nmaj. + apply (Qle_not_lt _ _ (Qabs_nonneg (xn (Pos.to_nat n)))). + apply Qlt_minus_iff. apply (Qlt_trans _ (2#n)). + reflexivity. exact nmaj. +Qed. + +Lemma CReal_abs_opp : forall x : CReal, CReal_abs (-x) == CReal_abs x. +Proof. + intros. apply CRealEq_diff. intro n. + destruct x as [xn cau]; unfold CReal_abs, CReal_opp, proj1_sig. + rewrite Qabs_opp. unfold Qminus. rewrite Qplus_opp_r. + discriminate. +Qed. + +Lemma CReal_abs_left : forall x : CReal, x <= 0 -> CReal_abs x == -x. +Proof. + intros. + apply CReal_opp_ge_le_contravar in H. rewrite CReal_opp_0 in H. + rewrite <- CReal_abs_opp. apply CReal_abs_right, H. +Qed. + +Lemma CReal_abs_appart_0 : forall x : CReal, + 0 < CReal_abs x -> x # 0. +Proof. + intros x [n nmaj]. destruct x as [xn cau]; simpl in nmaj. + destruct (Qlt_le_dec (xn (Pos.to_nat n)) 0). + - left. exists n. simpl. rewrite Qabs_neg in nmaj. + apply (Qlt_le_trans _ _ _ nmaj). ring_simplify. apply Qle_refl. + apply Qlt_le_weak, q. + - right. exists n. simpl. rewrite Qabs_pos in nmaj. + exact nmaj. exact q. +Qed. + +Add Parametric Morphism : CReal_abs + with signature CRealEq ==> CRealEq + as CReal_abs_morph. +Proof. + intros. split. + - intro abs. destruct (CReal_abs_appart_0 y). + apply (CReal_le_lt_trans _ (CReal_abs x)). + apply CReal_abs_pos. apply abs. + rewrite CReal_abs_left, CReal_abs_left, H in abs. + exact (CRealLt_asym _ _ abs abs). apply CRealLt_asym, c. + rewrite H. apply CRealLt_asym, c. + rewrite CReal_abs_right, CReal_abs_right, H in abs. + exact (CRealLt_asym _ _ abs abs). apply CRealLt_asym, c. + rewrite H. apply CRealLt_asym, c. + - intro abs. destruct (CReal_abs_appart_0 x). + apply (CReal_le_lt_trans _ (CReal_abs y)). + apply CReal_abs_pos. apply abs. + rewrite CReal_abs_left, CReal_abs_left, H in abs. + exact (CRealLt_asym _ _ abs abs). apply CRealLt_asym, c. + rewrite <- H. apply CRealLt_asym, c. + rewrite CReal_abs_right, CReal_abs_right, H in abs. + exact (CRealLt_asym _ _ abs abs). apply CRealLt_asym, c. + rewrite <- H. apply CRealLt_asym, c. +Qed. + +Lemma CReal_abs_le : forall a b:CReal, -b <= a <= b -> CReal_abs a <= b. +Proof. + intros a b H [n nmaj]. destruct a as [an cau]; simpl in nmaj. + destruct (Qlt_le_dec (an (Pos.to_nat n)) 0). + - rewrite Qabs_neg in nmaj. destruct H. apply H. clear H H0. + exists n. simpl. + destruct b as [bn caub]; simpl; simpl in nmaj. + unfold Qminus. rewrite Qplus_comm. exact nmaj. + apply Qlt_le_weak, q. + - rewrite Qabs_pos in nmaj. destruct H. apply H0. clear H H0. + exists n. simpl. exact nmaj. exact q. +Qed. + +Lemma CReal_abs_minus_sym : forall x y : CReal, + CReal_abs (x - y) == CReal_abs (y - x). +Proof. + intros x y. setoid_replace (x - y) with (-(y-x)). + rewrite CReal_abs_opp. reflexivity. ring. +Qed. + +Lemma CReal_abs_lt : forall x y : CReal, + CReal_abs x < y -> prod (x < y) (-x < y). +Proof. + split. + - apply (CReal_le_lt_trans _ _ _ (CReal_le_abs x)), H. + - apply (CReal_le_lt_trans _ _ _ (CReal_le_abs (-x))). + rewrite CReal_abs_opp. exact H. +Qed. + +Lemma CReal_abs_triang : forall x y : CReal, + CReal_abs (x + y) <= CReal_abs x + CReal_abs y. +Proof. + intros. apply CReal_abs_le. split. + - setoid_replace (x + y) with (-(-x - y)). 2: ring. + apply CReal_opp_ge_le_contravar. + apply CReal_plus_le_compat; rewrite <- CReal_abs_opp; apply CReal_le_abs. + - apply CReal_plus_le_compat; apply CReal_le_abs. +Qed. + +Lemma CReal_abs_triang_inv : forall x y : CReal, + CReal_abs x - CReal_abs y <= CReal_abs (x - y). +Proof. + intros. apply (CReal_plus_le_reg_l (CReal_abs y)). + ring_simplify. rewrite CReal_plus_comm. + apply (CReal_le_trans _ (CReal_abs (x - y + y))). + setoid_replace (x - y + y) with x. apply CRealLe_refl. ring. + apply CReal_abs_triang. +Qed. + +Lemma CReal_abs_triang_inv2 : forall x y : CReal, + CReal_abs (CReal_abs x - CReal_abs y) <= CReal_abs (x - y). +Proof. + intros. apply CReal_abs_le. split. + 2: apply CReal_abs_triang_inv. + apply (CReal_plus_le_reg_r (CReal_abs y)). ring_simplify. + rewrite CReal_plus_comm, CReal_abs_minus_sym. + apply (CReal_le_trans _ _ _ (CReal_abs_triang_inv y (y-x))). + setoid_replace (y - (y - x)) with x. 2: ring. apply CRealLe_refl. +Qed. + +Lemma CReal_abs_gt : forall x : CReal, + x < CReal_abs x -> x < 0. +Proof. + intros x [n nmaj]. destruct x as [xn cau]; simpl in nmaj. + assert (xn (Pos.to_nat n) < 0)%Q. + { destruct (Qlt_le_dec (xn (Pos.to_nat n)) 0). exact q. + exfalso. rewrite Qabs_pos in nmaj. unfold Qminus in nmaj. + rewrite Qplus_opp_r in nmaj. inversion nmaj. exact q. } + rewrite Qabs_neg in nmaj. 2: apply Qlt_le_weak, H. + apply (CReal_neg_nth _ n). simpl. + ring_simplify in nmaj. + apply (Qplus_lt_l _ _ ((1#n) - xn (Pos.to_nat n))). + apply (Qmult_lt_l _ _ 2). reflexivity. ring_simplify. + setoid_replace (2 * (1 # n))%Q with (2 # n)%Q. 2: reflexivity. + rewrite <- Qplus_assoc. + setoid_replace ((2 # n) + 2 * (-1 # n))%Q with 0%Q. + rewrite Qplus_0_r. exact nmaj. + setoid_replace (2*(-1 # n))%Q with (-(2 # n))%Q. + rewrite Qplus_opp_r. reflexivity. reflexivity. +Qed. + +Lemma Rabs_def1 : forall x y : CReal, + x < y -> -x < y -> CReal_abs x < y. +Proof. + intros. apply CRealLt_above in H. apply CRealLt_above in H0. + destruct H as [i imaj]. destruct H0 as [j jmaj]. + exists (Pos.max i j). destruct x as [xn caux], y as [yn cauy]; simpl. + simpl in imaj, jmaj. + destruct (Qlt_le_dec (xn (Pos.to_nat (Pos.max i j))) 0). + - rewrite Qabs_neg. + specialize (jmaj (Pos.max i j) (Pos.le_max_r _ _)). + apply (Qle_lt_trans _ (2#j)). 2: exact jmaj. + unfold Qle, Qnum, Qden. + apply Z.mul_le_mono_nonneg_l. discriminate. + apply Pos2Z.pos_le_pos, Pos.le_max_r. + apply Qlt_le_weak, q. + - rewrite Qabs_pos. + specialize (imaj (Pos.max i j) (Pos.le_max_l _ _)). + apply (Qle_lt_trans _ (2#i)). 2: exact imaj. + unfold Qle, Qnum, Qden. + apply Z.mul_le_mono_nonneg_l. discriminate. + apply Pos2Z.pos_le_pos, Pos.le_max_l. + apply q. +Qed. + +(* The proof by cases on the signs of x and y applies constructively, + because of the positivity hypotheses. *) +Lemma CReal_abs_mult : forall x y : CReal, + CReal_abs (x * y) == CReal_abs x * CReal_abs y. +Proof. + assert (forall x y : CReal, + x # 0 + -> y # 0 + -> CReal_abs (x * y) == CReal_abs x * CReal_abs y) as prep. + { intros. destruct H, H0. + + rewrite CReal_abs_right, CReal_abs_left, CReal_abs_left. ring. + apply CRealLt_asym, c0. apply CRealLt_asym, c. + setoid_replace (x*y) with (- x * - y). + apply CRealLt_asym, CReal_mult_lt_0_compat. + rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar, c. + rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar, c0. ring. + + rewrite CReal_abs_left, CReal_abs_left, CReal_abs_right. ring. + apply CRealLt_asym, c0. apply CRealLt_asym, c. + rewrite <- (CReal_mult_0_l y). + apply CReal_mult_le_compat_r. + apply CRealLt_asym, c0. apply CRealLt_asym, c. + + rewrite CReal_abs_left, CReal_abs_right, CReal_abs_left. ring. + apply CRealLt_asym, c0. apply CRealLt_asym, c. + rewrite <- (CReal_mult_0_r x). + apply CReal_mult_le_compat_l. + apply CRealLt_asym, c. apply CRealLt_asym, c0. + + rewrite CReal_abs_right, CReal_abs_right, CReal_abs_right. ring. + apply CRealLt_asym, c0. apply CRealLt_asym, c. + apply CRealLt_asym, CReal_mult_lt_0_compat; assumption. } + split. + - intro abs. + assert (0 < CReal_abs x * CReal_abs y). + { apply (CReal_le_lt_trans _ (CReal_abs (x*y))). + apply CReal_abs_pos. exact abs. } + pose proof (CReal_mult_pos_appart_zero _ _ H). + rewrite CReal_mult_comm in H. + apply CReal_mult_pos_appart_zero in H. + destruct H. 2: apply (CReal_abs_pos y c). + destruct H0. 2: apply (CReal_abs_pos x c0). + apply CReal_abs_appart_0 in c. + apply CReal_abs_appart_0 in c0. + rewrite (prep x y) in abs. + exact (CRealLt_asym _ _ abs abs). exact c0. exact c. + - intro abs. + assert (0 < CReal_abs (x * y)). + { apply (CReal_le_lt_trans _ (CReal_abs x * CReal_abs y)). + rewrite <- (CReal_mult_0_l (CReal_abs y)). + apply CReal_mult_le_compat_r. + apply CReal_abs_pos. apply CReal_abs_pos. exact abs. } + apply CReal_abs_appart_0 in H. destruct H. + + apply CReal_opp_gt_lt_contravar in c. + rewrite CReal_opp_0, CReal_opp_mult_distr_l in c. + pose proof (CReal_mult_pos_appart_zero _ _ c). + rewrite CReal_mult_comm in c. + apply CReal_mult_pos_appart_zero in c. + rewrite (prep x y) in abs. + exact (CRealLt_asym _ _ abs abs). + destruct H. left. apply CReal_opp_gt_lt_contravar in c0. + rewrite CReal_opp_involutive, CReal_opp_0 in c0. exact c0. + right. apply CReal_opp_gt_lt_contravar in c0. + rewrite CReal_opp_involutive, CReal_opp_0 in c0. exact c0. + destruct c. right. exact c. left. exact c. + + pose proof (CReal_mult_pos_appart_zero _ _ c). + rewrite CReal_mult_comm in c. + apply CReal_mult_pos_appart_zero in c. + rewrite (prep x y) in abs. + exact (CRealLt_asym _ _ abs abs). + destruct H. right. exact c0. left. exact c0. + destruct c. right. exact c. left. exact c. +Qed. + +Lemma CReal_abs_def2 : forall x a:CReal, + CReal_abs x <= a -> (x <= a) /\ (- a <= x). +Proof. + split. + - exact (CReal_le_trans _ _ _ (CReal_le_abs _) H). + - rewrite <- (CReal_opp_involutive x). + apply CReal_opp_ge_le_contravar. + rewrite <- CReal_abs_opp in H. + exact (CReal_le_trans _ _ _ (CReal_le_abs _) H). +Qed. + + +(* Min and max *) + +Definition CReal_min (x y : CReal) : CReal + := (x + y - CReal_abs (y - x)) * inject_Q (1#2). + +Definition CReal_max (x y : CReal) : CReal + := (x + y + CReal_abs (y - x)) * inject_Q (1#2). + +Add Parametric Morphism : CReal_min + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_min_morph. +Proof. + intros. unfold CReal_min. + rewrite H, H0. reflexivity. +Qed. + +Add Parametric Morphism : CReal_max + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_max_morph. +Proof. + intros. unfold CReal_max. + rewrite H, H0. reflexivity. +Qed. + +Lemma CReal_double : forall x:CReal, 2 * x == x + x. +Proof. + intro x. rewrite (inject_Q_plus 1 1). ring. +Qed. + +Lemma CReal_max_lub : forall x y z:CReal, + x <= z -> y <= z -> CReal_max x y <= z. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + apply (CReal_plus_le_reg_l (-x-y)). ring_simplify. + apply CReal_abs_le. split. + - unfold CReal_minus. repeat rewrite CReal_opp_plus_distr. + do 2 rewrite CReal_opp_involutive. + rewrite (CReal_plus_comm x), CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l (-x)). + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. + rewrite CReal_mult_comm, CReal_double. rewrite CReal_opp_plus_distr. + apply CReal_plus_le_compat; apply CReal_opp_ge_le_contravar; assumption. + - unfold CReal_minus. + rewrite (CReal_plus_comm y), CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l y). + rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + rewrite CReal_mult_comm, CReal_double. + apply CReal_plus_le_compat; assumption. +Qed. + +Lemma CReal_min_glb : forall x y z:CReal, + z <= x -> z <= y -> z <= CReal_min x y. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + apply (CReal_plus_le_reg_l (CReal_abs(y-x) - (z*2))). ring_simplify. + apply CReal_abs_le. split. + - unfold CReal_minus. repeat rewrite CReal_opp_plus_distr. + rewrite CReal_opp_mult_distr_l, CReal_opp_involutive. + rewrite (CReal_plus_comm (z*2)), (CReal_plus_comm y), CReal_plus_assoc. + apply CReal_plus_le_compat_l, (CReal_plus_le_reg_r y). + rewrite CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r. + rewrite CReal_mult_comm, CReal_double. + apply CReal_plus_le_compat; assumption. + - unfold CReal_minus. + rewrite (CReal_plus_comm y). apply CReal_plus_le_compat. + 2: apply CRealLe_refl. + apply (CReal_plus_le_reg_r (-x)). + rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r. + rewrite CReal_mult_comm, CReal_double. + apply CReal_plus_le_compat; apply CReal_opp_ge_le_contravar; assumption. +Qed. + +Lemma CReal_max_l : forall x y : CReal, x <= CReal_max x y. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l (-y)). + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. + rewrite CReal_abs_minus_sym, CReal_plus_comm. + apply CReal_le_abs. +Qed. + +Lemma CReal_max_r : forall x y : CReal, y <= CReal_max x y. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite (CReal_plus_comm x). + rewrite CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l (-x)). + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. + rewrite CReal_plus_comm. apply CReal_le_abs. +Qed. + +Lemma CReal_min_l : forall x y : CReal, CReal_min x y <= x. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + unfold CReal_minus. + rewrite CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l (CReal_abs (y + - x)+ -x)). ring_simplify. + rewrite CReal_plus_comm. apply CReal_le_abs. +Qed. + +Lemma CReal_min_r : forall x y : CReal, CReal_min x y <= y. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + unfold CReal_minus. rewrite (CReal_plus_comm x). + rewrite CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l (CReal_abs (y + - x)+ -y)). ring_simplify. + fold (y-x). rewrite CReal_abs_minus_sym. + rewrite CReal_plus_comm. apply CReal_le_abs. +Qed. + +Lemma CReal_min_left : forall x y : CReal, + x <= y -> CReal_min x y == x. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_abs_right. ring. + rewrite <- (CReal_plus_opp_r x). apply CReal_plus_le_compat. + exact H. apply CRealLe_refl. +Qed. + +Lemma CReal_min_right : forall x y : CReal, + y <= x -> CReal_min x y == y. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_abs_left. ring. + rewrite <- (CReal_plus_opp_r x). apply CReal_plus_le_compat. + exact H. apply CRealLe_refl. +Qed. + +Lemma CReal_max_left : forall x y : CReal, + y <= x -> CReal_max x y == x. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_abs_left. ring. + rewrite <- (CReal_plus_opp_r x). apply CReal_plus_le_compat. + exact H. apply CRealLe_refl. +Qed. + +Lemma CReal_max_right : forall x y : CReal, + x <= y -> CReal_max x y == y. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_abs_right. ring. + rewrite <- (CReal_plus_opp_r x). apply CReal_plus_le_compat. + exact H. apply CRealLe_refl. +Qed. + +Lemma CReal_min_lt_r : forall x y : CReal, + CReal_min x y < y -> CReal_min x y == x. +Proof. + intros. unfold CReal_min. unfold CReal_min in H. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_abs_right. ring. + apply (CReal_mult_lt_compat_r 2) in H. 2: apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult in H. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in H. 2: reflexivity. + rewrite CReal_mult_1_r in H. + rewrite CReal_mult_comm, CReal_double in H. + intro abs. rewrite CReal_abs_left in H. + unfold CReal_minus in H. + rewrite CReal_opp_involutive, CReal_plus_comm in H. + rewrite CReal_plus_assoc, <- (CReal_plus_assoc (-x)), CReal_plus_opp_l in H. + rewrite CReal_plus_0_l in H. exact (CRealLt_asym _ _ H H). + apply CRealLt_asym, abs. +Qed. + +Lemma posPartAbsMax : forall x : CReal, + CReal_max 0 x == (x + CReal_abs x) * (inject_Q (1#2)). +Proof. + split. + - intro abs. apply (CReal_mult_lt_compat_r 2) in abs. + 2: apply (inject_Q_lt 0 2); reflexivity. + rewrite CReal_mult_assoc, <- (inject_Q_mult) in abs. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in abs. 2: reflexivity. + rewrite CReal_mult_1_r in abs. + apply (CReal_plus_lt_compat_l (-x)) in abs. + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l in abs. + apply CReal_abs_le in abs. exact abs. split. + + rewrite CReal_opp_plus_distr, CReal_opp_involutive. + apply (CReal_le_trans _ (x + 0)). 2: rewrite CReal_plus_0_r; apply CRealLe_refl. + apply CReal_plus_le_compat_l. apply (CReal_le_trans _ (2 * 0)). + rewrite CReal_opp_mult_distr_l, <- (CReal_mult_comm 2). apply CReal_mult_le_compat_l_half. + apply inject_Q_lt. reflexivity. + apply (CReal_plus_le_reg_l (CReal_max 0 x)). rewrite CReal_plus_opp_r, CReal_plus_0_r. + apply CReal_max_l. rewrite CReal_mult_0_r. apply CRealLe_refl. + + apply (CReal_plus_le_reg_l x). + rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + rewrite (inject_Q_plus 1 1), CReal_mult_plus_distr_l, CReal_mult_1_r. + apply CReal_plus_le_compat; apply CReal_max_r. + - apply CReal_max_lub. rewrite <- (CReal_mult_0_l (inject_Q (1#2))). + do 2 rewrite <- (CReal_mult_comm (inject_Q (1#2))). + apply CReal_mult_le_compat_l_half. + apply inject_Q_lt; reflexivity. + rewrite <- (CReal_plus_opp_r x). apply CReal_plus_le_compat_l. + rewrite <- CReal_abs_opp. apply CReal_le_abs. + intros abs. + apply (CReal_mult_lt_compat_r 2) in abs. 2: apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult in abs. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in abs. 2: reflexivity. + rewrite CReal_mult_1_r, (inject_Q_plus 1 1), CReal_mult_plus_distr_l, CReal_mult_1_r in abs. + apply CReal_plus_lt_reg_l in abs. + exact (CReal_le_abs x abs). +Qed. + +Lemma negPartAbsMin : forall x : CReal, + CReal_min 0 x == (x - CReal_abs x) * (inject_Q (1#2)). +Proof. + split. + - intro abs. apply (CReal_mult_lt_compat_r 2) in abs. + 2: apply (inject_Q_lt 0 2); reflexivity. + rewrite CReal_mult_assoc, <- (inject_Q_mult) in abs. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in abs. 2: reflexivity. + rewrite CReal_mult_1_r in abs. + apply (CReal_plus_lt_compat_r (CReal_abs x)) in abs. + unfold CReal_minus in abs. + rewrite CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r in abs. + apply (CReal_plus_lt_compat_l (-(CReal_min 0 x * 2))) in abs. + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l in abs. + apply CReal_abs_lt in abs. destruct abs. + apply (CReal_plus_lt_compat_l (CReal_min 0 x * 2)) in c0. + rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l in c0. + apply (CReal_plus_lt_compat_r x) in c0. + rewrite CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r in c0. + rewrite <- CReal_double, CReal_mult_comm in c0. apply CReal_mult_lt_reg_l in c0. + apply CReal_min_lt_r in c0. + rewrite c0, CReal_mult_0_l, CReal_opp_0, CReal_plus_0_l in c. + exact (CRealLt_asym _ _ c c). apply inject_Q_lt; reflexivity. + - intro abs. + assert ((x - CReal_abs x) * inject_Q (1 # 2) < 0 * inject_Q (1 # 2)). + { rewrite CReal_mult_0_l. + apply (CReal_lt_le_trans _ _ _ abs). apply CReal_min_l. } + apply CReal_mult_lt_reg_r in H. + 2: apply inject_Q_lt; reflexivity. + rewrite <- (CReal_plus_opp_r (CReal_abs x)) in H. + apply CReal_plus_lt_reg_r, CReal_abs_gt in H. + rewrite CReal_min_right, <- CReal_abs_opp, CReal_abs_right in abs. + unfold CReal_minus in abs. + rewrite CReal_opp_involutive, <- CReal_double, CReal_mult_comm in abs. + rewrite <- CReal_mult_assoc, <- inject_Q_mult in abs. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in abs. + rewrite CReal_mult_1_l in abs. exact (CRealLt_asym _ _ abs abs). + reflexivity. rewrite <- CReal_opp_0. + apply CReal_opp_ge_le_contravar, CRealLt_asym, H. + apply CRealLt_asym, H. +Qed. + +Lemma CReal_min_sym : forall (x y : CReal), + CReal_min x y == CReal_min y x. +Proof. + intros. unfold CReal_min. + rewrite CReal_abs_minus_sym. ring. +Qed. + +Lemma CReal_max_sym : forall (x y : CReal), + CReal_max x y == CReal_max y x. +Proof. + intros. unfold CReal_max. + rewrite CReal_abs_minus_sym. ring. +Qed. + +Lemma CReal_min_mult : + forall (p q r:CReal), 0 <= r -> CReal_min (r * p) (r * q) == r * CReal_min p q. +Proof. + intros p q r H. unfold CReal_min. + setoid_replace (r * q - r * p) with (r * (q - p)). + 2: ring. rewrite CReal_abs_mult. + rewrite (CReal_abs_right r). ring. exact H. +Qed. + +Lemma CReal_min_plus : forall (x y z : CReal), + x + CReal_min y z == CReal_min (x + y) (x + z). +Proof. + intros. unfold CReal_min. + setoid_replace (x + z - (x + y)) with (z-y). + 2: ring. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_plus_distr_r. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. ring. +Qed. + +Lemma CReal_max_plus : forall (x y z : CReal), + x + CReal_max y z == CReal_max (x + y) (x + z). +Proof. + intros. unfold CReal_max. + setoid_replace (x + z - (x + y)) with (z-y). + 2: ring. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_plus_distr_r. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. ring. +Qed. + +Lemma CReal_min_lt : forall x y z : CReal, + z < x -> z < y -> z < CReal_min x y. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_lt_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + apply (CReal_plus_lt_reg_l (CReal_abs (y - x) - (z*2))). + ring_simplify. apply Rabs_def1. + - unfold CReal_minus. rewrite <- (CReal_plus_comm y). + apply CReal_plus_lt_compat_l. + apply (CReal_plus_lt_reg_r (-x)). + rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r. + rewrite <- CReal_double, CReal_mult_comm. apply CReal_mult_lt_compat_r. + apply inject_Q_lt; reflexivity. + apply CReal_opp_gt_lt_contravar, H. + - unfold CReal_minus. rewrite CReal_opp_plus_distr, CReal_opp_involutive. + rewrite CReal_plus_comm, (CReal_plus_comm (-z*2)), CReal_plus_assoc. + apply CReal_plus_lt_compat_l. + apply (CReal_plus_lt_reg_r (-y)). + rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r. + rewrite <- CReal_double, CReal_mult_comm. apply CReal_mult_lt_compat_r. + apply inject_Q_lt; reflexivity. + apply CReal_opp_gt_lt_contravar, H0. +Qed. + +Lemma CReal_max_assoc : forall a b c : CReal, + CReal_max a (CReal_max b c) == CReal_max (CReal_max a b) c. +Proof. + split. + - apply CReal_max_lub. + + apply CReal_max_lub. apply CReal_max_l. + apply (CReal_le_trans _ (CReal_max b c)). + apply CReal_max_l. apply CReal_max_r. + + apply (CReal_le_trans _ (CReal_max b c)). + apply CReal_max_r. apply CReal_max_r. + - apply CReal_max_lub. + + apply (CReal_le_trans _ (CReal_max a b)). + apply CReal_max_l. apply CReal_max_l. + + apply CReal_max_lub. + apply (CReal_le_trans _ (CReal_max a b)). + apply CReal_max_r. apply CReal_max_l. apply CReal_max_r. +Qed. + +Lemma CReal_min_max_mult_neg : + forall (p q r:CReal), r <= 0 -> CReal_min (r * p) (r * q) == r * CReal_max p q. +Proof. + intros p q r H. unfold CReal_min, CReal_max. + setoid_replace (r * q - r * p) with (r * (q - p)). + 2: ring. rewrite CReal_abs_mult. + rewrite (CReal_abs_left r). ring. exact H. +Qed. + +Lemma CReal_min_assoc : forall a b c : CReal, + CReal_min a (CReal_min b c) == CReal_min (CReal_min a b) c. +Proof. + split. + - apply CReal_min_glb. + + apply (CReal_le_trans _ (CReal_min a b)). + apply CReal_min_l. apply CReal_min_l. + + apply CReal_min_glb. + apply (CReal_le_trans _ (CReal_min a b)). + apply CReal_min_l. apply CReal_min_r. apply CReal_min_r. + - apply CReal_min_glb. + + apply CReal_min_glb. apply CReal_min_l. + apply (CReal_le_trans _ (CReal_min b c)). + apply CReal_min_r. apply CReal_min_l. + + apply (CReal_le_trans _ (CReal_min b c)). + apply CReal_min_r. apply CReal_min_r. +Qed. + +Lemma CReal_max_lub_lt : forall x y z : CReal, + x < z -> y < z -> CReal_max x y < z. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_lt_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + apply (CReal_plus_lt_reg_l (-x -y)). ring_simplify. + apply Rabs_def1. + - unfold CReal_minus. rewrite (CReal_plus_comm y), CReal_plus_assoc. + apply CReal_plus_lt_compat_l. + apply (CReal_plus_lt_reg_l y). + rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + rewrite <- CReal_double, CReal_mult_comm. apply CReal_mult_lt_compat_r. + apply inject_Q_lt; reflexivity. exact H0. + - unfold CReal_minus. rewrite CReal_opp_plus_distr, CReal_opp_involutive. + rewrite (CReal_plus_comm (-x)), CReal_plus_assoc. + apply CReal_plus_lt_compat_l. + apply (CReal_plus_lt_reg_l x). + rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + rewrite <- CReal_double, CReal_mult_comm. apply CReal_mult_lt_compat_r. + apply inject_Q_lt; reflexivity. + apply H. +Qed. + +Lemma CReal_max_contract : forall x y a : CReal, + CReal_abs (CReal_max x a - CReal_max y a) + <= CReal_abs (x - y). +Proof. + intros. unfold CReal_max. + rewrite (CReal_abs_morph + _ ((x - y + (CReal_abs (a - x) - CReal_abs (a - y))) * inject_Q (1 # 2))). + 2: ring. + rewrite CReal_abs_mult, (CReal_abs_right (inject_Q (1 # 2))). + 2: apply inject_Q_le; discriminate. + apply (CReal_le_trans + _ ((CReal_abs (x - y) * 1 + CReal_abs (x-y) * 1) + * inject_Q (1 # 2))). + apply CReal_mult_le_compat_r. apply inject_Q_le. discriminate. + apply (CReal_le_trans _ (CReal_abs (x - y) + CReal_abs (CReal_abs (a - x) - CReal_abs (a - y)))). + apply CReal_abs_triang. rewrite CReal_mult_1_r. apply CReal_plus_le_compat_l. + rewrite (CReal_abs_minus_sym x y). + rewrite (CReal_abs_morph (y-x) ((a-x)-(a-y))). + apply CReal_abs_triang_inv2. + unfold CReal_minus. rewrite (CReal_plus_comm (a + - x)). + rewrite <- CReal_plus_assoc. apply CReal_plus_morph. 2: reflexivity. + rewrite CReal_plus_comm, CReal_opp_plus_distr, <- CReal_plus_assoc. + rewrite CReal_plus_opp_r, CReal_opp_involutive, CReal_plus_0_l. + reflexivity. + rewrite <- CReal_mult_plus_distr_l, <- inject_Q_plus. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. apply CRealLe_refl. +Qed. + +Lemma CReal_min_contract : forall x y a : CReal, + CReal_abs (CReal_min x a - CReal_min y a) + <= CReal_abs (x - y). +Proof. + intros. unfold CReal_min. + rewrite (CReal_abs_morph + _ ((x - y + (CReal_abs (a - y) - CReal_abs (a - x))) * inject_Q (1 # 2))). + 2: ring. + rewrite CReal_abs_mult, (CReal_abs_right (inject_Q (1 # 2))). + 2: apply inject_Q_le; discriminate. + apply (CReal_le_trans + _ ((CReal_abs (x - y) * 1 + CReal_abs (x-y) * 1) + * inject_Q (1 # 2))). + apply CReal_mult_le_compat_r. apply inject_Q_le. discriminate. + apply (CReal_le_trans _ (CReal_abs (x - y) + CReal_abs (CReal_abs (a - y) - CReal_abs (a - x)))). + apply CReal_abs_triang. rewrite CReal_mult_1_r. apply CReal_plus_le_compat_l. + rewrite (CReal_abs_morph (x-y) ((a-y)-(a-x))). + apply CReal_abs_triang_inv2. + unfold CReal_minus. rewrite (CReal_plus_comm (a + - y)). + rewrite <- CReal_plus_assoc. apply CReal_plus_morph. 2: reflexivity. + rewrite CReal_plus_comm, CReal_opp_plus_distr, <- CReal_plus_assoc. + rewrite CReal_plus_opp_r, CReal_opp_involutive, CReal_plus_0_l. + reflexivity. + rewrite <- CReal_mult_plus_distr_l, <- inject_Q_plus. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. apply CRealLe_refl. +Qed. diff --git a/theories/Reals/ConstructiveCauchyReals.v b/theories/Reals/Cauchy/ConstructiveCauchyReals.v index 62e42a7ef3..167f8d41c9 100644 --- a/theories/Reals/ConstructiveCauchyReals.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyReals.v @@ -275,12 +275,6 @@ Proof. pose proof (Pos2Nat.is_pos n). rewrite abs in H. inversion H. Qed. -(* Alias the quotient order equality *) -Definition CRealEq (x y : CReal) : Prop - := (CRealLt x y -> False) /\ (CRealLt y x -> False). - -Infix "==" := CRealEq : CReal_scope. - (* Alias the large order *) Definition CRealLe (x y : CReal) : Prop := CRealLt y x -> False. @@ -295,6 +289,12 @@ 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. +(* Alias the quotient order equality *) +Definition CRealEq (x y : CReal) : Prop + := (CRealLe y x) /\ (CRealLe x y). + +Infix "==" := CRealEq : CReal_scope. + Lemma CRealLe_not_lt : forall x y : CReal, (forall n:positive, Qle (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n)) (2 # n)) @@ -322,13 +322,16 @@ Proof. setoid_replace (- (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) with (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)). apply H2. assumption. ring. - - intros. split. apply CRealLe_not_lt. intro n. specialize (H n). - rewrite Qabs_Qminus in H. - apply (Qle_trans _ (Qabs (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)))). - apply Qle_Qabs. apply H. - apply CRealLe_not_lt. intro n. specialize (H n). - apply (Qle_trans _ (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n)))). - apply Qle_Qabs. apply H. + - intros. split. + + apply CRealLe_not_lt. intro n. specialize (H n). + rewrite Qabs_Qminus in H. + apply (Qle_trans _ (Qabs (proj1_sig y (Pos.to_nat n) + - proj1_sig x (Pos.to_nat n)))). + apply Qle_Qabs. apply H. + + apply CRealLe_not_lt. intro n. specialize (H n). + apply (Qle_trans _ (Qabs (proj1_sig x (Pos.to_nat n) + - proj1_sig y (Pos.to_nat n)))). + apply Qle_Qabs. apply H. Qed. (* The equality on Cauchy reals is just QSeqEquiv, diff --git a/theories/Reals/ConstructiveCauchyRealsMult.v b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v index 7530a8f1ef..fa24bd988e 100644 --- a/theories/Reals/ConstructiveCauchyRealsMult.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v @@ -15,7 +15,7 @@ Require Import QArith. Require Import Qabs. Require Import Qround. Require Import Logic.ConstructiveEpsilon. -Require Export Reals.ConstructiveCauchyReals. +Require Export ConstructiveCauchyReals. Require CMorphisms. Local Open Scope CReal_scope. @@ -1413,3 +1413,91 @@ Proof. destruct (QCauchySeq_bounded (fun _ : nat => r) Pos.to_nat (ConstCauchy r)). simpl in maj. ring_simplify in maj. discriminate maj. Qed. + +Definition Rup_nat (x : CReal) + : { n : nat & x < inject_Q (Z.of_nat n #1) }. +Proof. + intros. destruct (CRealArchimedean x) as [p maj]. + destruct p. + - exists O. apply maj. + - exists (Pos.to_nat p). rewrite positive_nat_Z. apply maj. + - exists O. apply (CReal_lt_trans _ (inject_Q (Z.neg p # 1))). + apply maj. apply inject_Q_lt. reflexivity. +Qed. + +Lemma CReal_mult_le_0_compat : forall (a b : CReal), + 0 <= a -> 0 <= b -> 0 <= a * b. +Proof. + (* Limit of (a + 1/n)*b when n -> infty. *) + intros. intro abs. + assert (0 < -(a*b)) as epsPos. + { rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar. exact abs. } + destruct (Rup_nat (b * (/ (-(a*b))) (inr epsPos))) + as [n maj]. + destruct n as [|n]. + - apply (CReal_mult_lt_compat_r (-(a*b))) in maj. + rewrite CReal_mult_0_l, CReal_mult_assoc, CReal_inv_l, CReal_mult_1_r in maj. + contradiction. exact epsPos. + - (* n > 0 *) + assert (0 < inject_Q (Z.of_nat (S n) #1)) as nPos. + { apply inject_Q_lt. unfold Qlt, Qnum, Qden. + do 2 rewrite Z.mul_1_r. apply Z2Nat.inj_lt. discriminate. + apply Zle_0_nat. rewrite Nat2Z.id. apply le_n_S, le_0_n. } + assert (b * (/ inject_Q (Z.of_nat (S n) #1)) (inr nPos) < -(a*b)). + { apply (CReal_mult_lt_reg_r (inject_Q (Z.of_nat (S n) #1))). apply nPos. + rewrite CReal_mult_assoc, CReal_inv_l, CReal_mult_1_r. + apply (CReal_mult_lt_compat_r (-(a*b))) in maj. + rewrite CReal_mult_assoc, CReal_inv_l, CReal_mult_1_r in maj. + rewrite CReal_mult_comm. apply maj. apply epsPos. } + pose proof (CReal_mult_le_compat_l_half + (a + (/ inject_Q (Z.of_nat (S n) #1)) (inr nPos)) 0 b). + assert (0 + 0 < a + (/ inject_Q (Z.of_nat (S n) #1)) (inr nPos)). + { apply CReal_plus_le_lt_compat. apply H. apply CReal_inv_0_lt_compat. apply nPos. } + rewrite CReal_plus_0_l in H3. specialize (H2 H3 H0). + clear H3. rewrite CReal_mult_0_r in H2. + apply H2. clear H2. rewrite CReal_mult_plus_distr_r. + apply (CReal_plus_lt_compat_l (a*b)) in H1. + rewrite CReal_plus_opp_r in H1. + rewrite (CReal_mult_comm ((/ inject_Q (Z.of_nat (S n) #1)) (inr nPos))). + apply H1. +Qed. + +Lemma CReal_mult_le_compat_l : forall (r r1 r2:CReal), + 0 <= r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. apply (CReal_plus_le_reg_r (-(r*r1))). + rewrite CReal_plus_opp_r, CReal_opp_mult_distr_r. + rewrite <- CReal_mult_plus_distr_l. + apply CReal_mult_le_0_compat. exact H. + apply (CReal_plus_le_reg_r r1). + rewrite CReal_plus_0_l, CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r. + exact H0. +Qed. + +Lemma CReal_mult_le_compat_r : forall (r r1 r2:CReal), + 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r. +Proof. + intros. apply (CReal_plus_le_reg_r (-(r1*r))). + rewrite CReal_plus_opp_r, CReal_opp_mult_distr_l. + rewrite <- CReal_mult_plus_distr_r. + apply CReal_mult_le_0_compat. 2: exact H. + apply (CReal_plus_le_reg_r r1). ring_simplify. exact H0. +Qed. + +Lemma CReal_mult_le_reg_l : + forall x y z : CReal, + 0 < x -> x * y <= x * z -> y <= z. +Proof. + intros. intro abs. + apply (CReal_mult_lt_compat_l x) in abs. contradiction. + exact H. +Qed. + +Lemma CReal_mult_le_reg_r : + forall x y z : CReal, + 0 < x -> y * x <= z * x -> y <= z. +Proof. + intros. intro abs. + apply (CReal_mult_lt_compat_r x) in abs. contradiction. + exact H. +Qed. diff --git a/theories/Reals/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index 7d743e464e..51fd0dd7f9 100644 --- a/theories/Reals/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -14,52 +14,76 @@ Require Import Qabs. Require Import ConstructiveReals. Require Import ConstructiveCauchyRealsMult. Require Import Logic.ConstructiveEpsilon. +Require Import ConstructiveCauchyAbs. Local Open Scope CReal_scope. -Definition absLe (a b : CReal) : Prop - := -b <= a <= b. +(* We use <= in sort Prop rather than < in sort Set, + it is equivalent for the definition of limits and it + extracts smaller programs. *) +Definition seq_cv (un : nat -> CReal) (l : CReal) : Set + := forall p : positive, + { n : nat | forall i:nat, le n i -> CReal_abs (un i - l) <= inject_Q (1#p) }. -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)))) - -> absLe y x. +Definition Un_cauchy_mod (un : nat -> CReal) : Set + := forall p : positive, + { n : nat | forall i j:nat, le n i -> le n j + -> CReal_abs (un i - un j) <= inject_Q (1#p) }. + +Lemma seq_cv_proper : forall (un : nat -> CReal) (a b : CReal), + seq_cv un a + -> a == b + -> seq_cv un b. Proof. - intros x y n maj. split. - - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. - simpl in maj. unfold Qminus. rewrite Qopp_involutive. - rewrite Qplus_comm. - apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). - apply maj. apply Qplus_le_r. - rewrite <- (Qopp_involutive (yn (Pos.to_nat n))). - apply Qopp_le_compat. rewrite Qabs_opp. apply Qle_Qabs. - - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. - simpl in maj. - apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). - apply maj. apply Qplus_le_r. apply Qopp_le_compat. apply Qle_Qabs. + intros. intro p. specialize (H p) as [n H]. + exists n. intros. rewrite <- H0. apply H, H1. Qed. -(* We use absLe in sort Prop rather than Set, - to extract smaller programs. *) -Definition Un_cv_mod (un : nat -> CReal) (l : CReal) : Set - := forall p : positive, - { n : nat | forall i:nat, le n i -> absLe (un i - l) (inject_Q (1#p)) }. +Instance seq_cv_morph + : forall (un : nat -> CReal), CMorphisms.Proper + (CMorphisms.respectful CRealEq CRelationClasses.iffT) (seq_cv un). +Proof. + split. intros. apply (seq_cv_proper un x). exact H0. exact H. + intros. apply (seq_cv_proper un y). exact H0. symmetry. exact H. +Qed. -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. +Lemma growing_transit : forall un : nat -> CReal, + (forall n:nat, un n <= un (S n)) + -> forall n p : nat, le n p -> un n <= un p. Proof. - intros v u s seq H1 p. specialize (H1 p) as [N H0]. - exists N. intros. split. - rewrite <- seq. apply H0. apply H. - rewrite <- seq. apply H0. apply H. + induction p. + - intros. inversion H0. apply CRealLe_refl. + - intros. apply Nat.le_succ_r in H0. destruct H0. + apply (CReal_le_trans _ (un p)). apply IHp, H0. apply H. + subst n. apply CRealLe_refl. +Qed. + +Lemma growing_infinite : forall un : nat -> nat, + (forall n:nat, lt (un n) (un (S n))) + -> forall n : nat, le n (un n). +Proof. + induction n. + - apply le_0_n. + - specialize (H n). unfold lt in H. + apply (le_trans _ (S (un n))). apply le_n_S, IHn. exact H. +Qed. + +Lemma Un_cv_growing : forall (un : nat -> CReal) (l : CReal), + (forall n:nat, un n <= un (S n)) + -> (forall n:nat, un n <= l) + -> (forall p : positive, { n : nat | l - un n <= inject_Q (1#p) }) + -> seq_cv un l. +Proof. + intros. intro p. + specialize (H1 p) as [n nmaj]. exists n. + intros. rewrite CReal_abs_minus_sym, CReal_abs_right. + apply (CReal_le_trans _ (l - un n)). apply CReal_plus_le_compat_l. + apply CReal_opp_ge_le_contravar. + exact (growing_transit _ H n i H1). exact nmaj. + rewrite <- (CReal_plus_opp_r (un i)). apply CReal_plus_le_compat. + apply H0. apply CRealLe_refl. Qed. -Definition Un_cauchy_mod (un : nat -> CReal) : Set - := forall p : positive, - { n : nat | forall i j:nat, le n i -> le n j - -> absLe (un i - un j) (inject_Q (1#p)) }. (* Sharpen the archimedean property : constructive versions of @@ -142,11 +166,32 @@ Proof. reflexivity. Qed. +Lemma Qabs_Rabs : forall q : Q, + inject_Q (Qabs q) == CReal_abs (inject_Q q). +Proof. + intro q. apply Qabs_case. + - intros. rewrite CReal_abs_right. reflexivity. + apply inject_Q_le, H. + - intros. rewrite CReal_abs_left, opp_inject_Q. reflexivity. + apply inject_Q_le, H. +Qed. + Definition Un_cauchy_Q (xn : nat -> Q) : Set := forall n : positive, { k : nat | forall p q : nat, le k p -> le k q - -> Qle (-(1#n)) (xn p - xn q) - /\ Qle (xn p - xn q) (1#n) }. + -> (Qabs (xn p - xn q) <= 1#n)%Q }. + +Lemma CReal_smaller_interval : forall a b c d : CReal, + a <= c -> c <= b + -> a <= d -> d <= b + -> CReal_abs (d - c) <= b-a. +Proof. + intros. apply CReal_abs_le. split. + - apply (CReal_plus_le_reg_l (b+c)). ring_simplify. + apply CReal_plus_le_compat; assumption. + - apply (CReal_plus_le_reg_l (a+c)). ring_simplify. + apply CReal_plus_le_compat; assumption. +Qed. Lemma Rdiag_cauchy_sequence : forall (xn : nat -> CReal), Un_cauchy_mod xn @@ -154,92 +199,103 @@ Lemma Rdiag_cauchy_sequence : forall (xn : nat -> CReal), Proof. intros xn H p. specialize (H (2 * p)%positive) as [k cv]. exists (max k (2 * Pos.to_nat p)). intros. - specialize (cv p0 q). destruct cv. - apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). - apply Nat.le_max_l. apply H. - apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). - apply Nat.le_max_l. apply H0. - split. + specialize (cv p0 q + (le_trans _ _ _ (Nat.le_max_l _ _) H) + (le_trans _ _ _ (Nat.le_max_l _ _) H0)). + destruct (RQ_limit (xn p0) p0) as [r rmaj]. + destruct (RQ_limit (xn q) q) as [s smaj]. + apply Qabs_Qle_condition. split. - apply le_inject_Q. unfold Qminus. apply (CReal_le_trans _ (xn p0 - (xn q + inject_Q (1 # 2 * p)))). + unfold CReal_minus. rewrite CReal_opp_plus_distr. rewrite <- CReal_plus_assoc. - apply (CReal_plus_le_reg_r (inject_Q (1 # 2 * p))). - rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l. rewrite CReal_plus_0_r. + apply (CReal_plus_le_reg_r (xn q - xn p0 - inject_Q (-(1#p)))). + ring_simplify. unfold CReal_minus. do 2 rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. - setoid_replace (- (1 # p) + (1 # 2 * p))%Q with (- (1 # 2 * p))%Q. - rewrite opp_inject_Q. exact H1. - rewrite Qplus_comm. + setoid_replace (- - (1 # p) + - (1 # 2 * p))%Q with (1 # 2 * p)%Q. + rewrite CReal_abs_minus_sym in cv. + exact (CReal_le_trans _ _ _ (CReal_le_abs _ ) cv). + rewrite Qopp_involutive. setoid_replace (1#p)%Q with (2 # 2 *p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. + rewrite inject_Q_plus. apply CReal_plus_le_compat. apply CRealLt_asym. - destruct (RQ_limit (xn p0) p0); simpl. apply p1. + destruct (RQ_limit (xn p0) p0); simpl. apply rmaj. apply CRealLt_asym. - destruct (RQ_limit (xn q) q); unfold proj1_sig. rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. - apply (CReal_lt_le_trans _ (xn q + inject_Q (1 # Pos.of_nat q))). - apply p1. apply CReal_plus_le_compat_l. apply inject_Q_le. + destruct smaj. apply (CReal_lt_le_trans _ _ _ c0). + apply CReal_plus_le_compat_l. apply inject_Q_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 le_inject_Q. unfold Qminus. apply (CReal_le_trans _ (xn p0 + inject_Q (1 # 2 * p) - xn q)). + rewrite inject_Q_plus. apply CReal_plus_le_compat. apply CRealLt_asym. destruct (RQ_limit (xn p0) p0); unfold proj1_sig. apply (CReal_lt_le_trans _ (xn p0 + inject_Q (1 # Pos.of_nat p0))). - apply p1. apply CReal_plus_le_compat_l. apply inject_Q_le. + apply rmaj. apply CReal_plus_le_compat_l. apply inject_Q_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 Nat2Pos.id. apply H1. intro abs. subst p0. + inversion H1. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H3 in H2. inversion H2. apply CRealLt_asym. rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. - destruct (RQ_limit (xn q) q); simpl. apply p1. + destruct (RQ_limit (xn q) q); simpl. apply smaj. + unfold CReal_minus. rewrite (CReal_plus_comm (xn p0)). rewrite CReal_plus_assoc. apply (CReal_plus_le_reg_l (- inject_Q (1 # 2 * p))). rewrite <- CReal_plus_assoc. rewrite CReal_plus_opp_l. rewrite CReal_plus_0_l. rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. setoid_replace (- (1 # 2 * p) + (1 # p))%Q with (1 # 2 * p)%Q. - exact H2. rewrite Qplus_comm. + exact (CReal_le_trans _ _ _ (CReal_le_abs _) cv). + rewrite Qplus_comm. setoid_replace (1#p)%Q with (2 # 2*p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. Qed. -Lemma doubleLeCovariant : forall a b c d e f : CReal, - a == b -> c == d -> e == f - -> (a <= c <= e) - -> (b <= d <= f). +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)))) + -> CReal_abs y <= x. Proof. - split. rewrite <- H. rewrite <- H0. apply H2. - rewrite <- H0. rewrite <- H1. apply H2. + intros x y n maj. apply CReal_abs_le. split. + - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + simpl in maj. unfold Qminus. rewrite Qopp_involutive. + rewrite Qplus_comm. + apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). + apply maj. apply Qplus_le_r. + rewrite <- (Qopp_involutive (yn (Pos.to_nat n))). + apply Qopp_le_compat. rewrite Qabs_opp. apply Qle_Qabs. + - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + simpl in maj. + apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). + apply maj. apply Qplus_le_r. apply Qopp_le_compat. apply Qle_Qabs. Qed. + (* An element of CReal is a Cauchy sequence of rational numbers, show that it converges to itself in CReal. *) Lemma CReal_cv_self : forall (qn : nat -> Q) (x : CReal) (cvmod : positive -> nat), QSeqEquiv qn (fun n => proj1_sig x n) cvmod - -> Un_cv_mod (fun n => inject_Q (qn n)) x. + -> seq_cv (fun n => inject_Q (qn n)) x. Proof. intros qn x cvmod H p. specialize (H (2*p)%positive). exists (cvmod (2*p)%positive). - intros p0 H0. unfold absLe, CReal_minus. - apply (doubleLeCovariant (-inject_Q (1#p)) _ (inject_Q (qn p0) - x) _ (inject_Q (1#p))). - reflexivity. reflexivity. reflexivity. - apply (CReal_absSmall _ _ (Pos.max (4 * p)%positive (Pos.of_nat (cvmod (2 * p)%positive)))). + intros p0 H0. + 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. @@ -266,22 +322,12 @@ Proof. reflexivity. reflexivity. Qed. -Lemma Un_cv_extens : forall (xn yn : nat -> CReal) (l : CReal), - Un_cv_mod xn l - -> (forall n : nat, xn n == yn n) - -> Un_cv_mod yn l. -Proof. - intros. intro p. destruct (H p) as [n cv]. exists n. - intros. unfold absLe, CReal_minus. - split; rewrite <- (H0 i); apply cv; apply H1. -Qed. - (* Q is dense in Archimedean fields, so all real numbers are limits of rational sequences. The biggest computable such field has all rational limits. *) Lemma R_has_all_rational_limits : forall qn : nat -> Q, Un_cauchy_Q qn - -> { r : CReal & Un_cv_mod (fun n:nat => inject_Q (qn n)) r }. + -> { r : CReal & seq_cv (fun n:nat => inject_Q (qn n)) r }. Proof. (* qn is an element of CReal. Show that inject_Q qn converges to it in CReal. *) @@ -289,8 +335,7 @@ Proof. destruct (standard_modulus qn (fun p => proj1_sig (H (Pos.succ p)))). - intros p n k H0 H1. destruct (H (Pos.succ p)%positive) as [x a]; simpl in H0,H1. specialize (a n k H0 H1). - apply (Qle_lt_trans _ (1#Pos.succ p)). - apply Qabs_Qle_condition. exact a. + apply (Qle_lt_trans _ (1#Pos.succ p) _ a). apply Pos2Z.pos_lt_pos. simpl. apply Pos.lt_succ_diag_r. - exists (exist _ (fun n : nat => qn (increasing_modulus (fun p : positive => proj1_sig (H (Pos.succ p))) n)) H0). @@ -302,24 +347,25 @@ Qed. Lemma Rcauchy_complete : forall (xn : nat -> CReal), Un_cauchy_mod xn - -> { l : CReal & Un_cv_mod xn l }. + -> { l : CReal & seq_cv xn l }. Proof. intros xn cau. destruct (R_has_all_rational_limits (fun n => let (l,_) := RQ_limit (xn n) n in l) (Rdiag_cauchy_sequence xn cau)) as [l cv]. exists l. intro p. specialize (cv (2*p)%positive) as [k cv]. - exists (max k (2 * Pos.to_nat p)). intros p0 H. specialize (cv p0). - destruct cv as [H0 H1]. apply (le_trans _ (max k (2 * Pos.to_nat p))). - apply Nat.le_max_l. apply H. - destruct (RQ_limit (xn p0) p0) as [q maj]; unfold proj1_sig in H0,H1. - split. + exists (max k (2 * Pos.to_nat p)). intros p0 H. + specialize (cv p0 (le_trans _ _ _ (Nat.le_max_l _ _) H)). + destruct (RQ_limit (xn p0) p0) as [q maj]. + apply CReal_abs_le. split. - apply (CReal_le_trans _ (inject_Q q - inject_Q (1 # 2 * p) - l)). + unfold CReal_minus. rewrite (CReal_plus_comm (inject_Q q)). - apply (CReal_plus_le_reg_l (inject_Q (1 # 2 * p))). - ring_simplify. unfold CReal_minus. rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. - setoid_replace ((1 # 2 * p) + - (1 # p))%Q with (-(1#2*p))%Q. - rewrite opp_inject_Q. apply H0. + apply (CReal_plus_le_reg_r (inject_Q (1 # p) + l - inject_Q q)). + ring_simplify. unfold CReal_minus. + rewrite <- (opp_inject_Q (1# 2*p)), <- inject_Q_plus. + setoid_replace ((1 # p) + - (1 # 2* p))%Q with (1#2*p)%Q. + rewrite CReal_abs_minus_sym in cv. + exact (CReal_le_trans _ _ _ (CReal_le_abs _) cv). setoid_replace (1#p)%Q with (2 # 2*p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. + unfold CReal_minus. @@ -335,48 +381,66 @@ Proof. 2: apply H. replace (p~0)%positive with (2*p)%positive. 2: reflexivity. rewrite Pos2Nat.inj_mul. apply Nat.le_max_r. } - rewrite Nat2Pos.id. apply H2. intro abs. subst p0. - inversion H2. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H4 in H3. inversion H3. + rewrite Nat2Pos.id. apply H0. intro abs. subst p0. + inversion H0. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H2 in H1. inversion H1. - apply (CReal_le_trans _ (inject_Q q - l)). + unfold CReal_minus. do 2 rewrite <- (CReal_plus_comm (-l)). apply CReal_plus_le_compat_l. apply CRealLt_asym, maj. + apply (CReal_le_trans _ (inject_Q (1 # 2 * p))). - apply H1. apply inject_Q_le. - rewrite <- Qplus_0_r. + exact (CReal_le_trans _ _ _ (CReal_le_abs _) cv). + apply inject_Q_le. rewrite <- Qplus_0_r. setoid_replace (1#p)%Q with ((1#2*p)+(1#2*p))%Q. apply Qplus_le_r. discriminate. rewrite Qinv_plus_distr. reflexivity. Qed. -Definition CRealImplem : ConstructiveReals. +Lemma CRealLtIsLinear : isLinearOrder CRealLt. Proof. - assert (isLinearOrder CReal CRealLt) as lin. - { repeat split. exact CRealLt_asym. - exact CReal_lt_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 - inject_Q inject_Q_plus inject_Q_mult - inject_Q_one inject_Q_lt lt_inject_Q - CRealQ_dense Rup_pos). - - intros. destruct (Rcauchy_complete xn) as [l cv]. - intro n. destruct (H n). exists x. intros. - specialize (a i j H0 H1) as [a b]. split. 2: exact b. - rewrite <- opp_inject_Q. - setoid_replace (-(1#n))%Q with (-1#n)%Q. exact a. reflexivity. - exists l. intros p. destruct (cv p). - exists x. intros. specialize (a i H0). split. 2: apply a. - unfold orderLe. - intro abs. setoid_replace (-1#p)%Q with (-(1#p))%Q in abs. - rewrite opp_inject_Q in abs. destruct a. contradiction. - reflexivity. + repeat split. exact CRealLt_asym. + exact CReal_lt_trans. + intros. destruct (CRealLt_dec x z y H). + left. exact c. right. exact c. +Qed. + +Lemma CRealAbsLUB : forall x y : CReal, + x <= y /\ (- x) <= y <-> (CReal_abs x) <= y. +Proof. + split. + - intros [H H0]. apply CReal_abs_le. split. 2: exact H. + apply (CReal_plus_le_reg_r (y-x)). ring_simplify. exact H0. + - intros. apply CReal_abs_def2 in H. destruct H. split. + exact H. fold (-x <= y). + apply (CReal_plus_le_reg_r (x-y)). ring_simplify. exact H0. +Qed. + +Lemma CRealComplete : forall xn : nat -> CReal, + (forall p : positive, + {n : nat | + forall i j : nat, + (n <= i)%nat -> (n <= j)%nat -> (CReal_abs (xn i + - xn j)) <= (inject_Q (1 # p))}) -> + {l : CReal & + forall p : positive, + {n : nat | + forall i : nat, (n <= i)%nat -> (CReal_abs (xn i + - l)) <= (inject_Q (1 # p))}}. +Proof. + intros. destruct (Rcauchy_complete xn) as [l cv]. + intro p. destruct (H p) as [n a]. exists n. intros. + exact (a i j H0 H1). + exists l. intros p. destruct (cv p). + exists x. exact c. Defined. + +Definition CRealConstructive : ConstructiveReals + := Build_ConstructiveReals + CReal CRealLt CRealLtIsLinear 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 + inject_Q inject_Q_plus inject_Q_mult + inject_Q_one inject_Q_lt lt_inject_Q + CRealQ_dense Rup_pos CReal_abs CRealAbsLUB CRealComplete. diff --git a/theories/Reals/ConstructiveReals.v b/theories/Reals/ConstructiveReals.v deleted file mode 100644 index d6eee518d3..0000000000 --- a/theories/Reals/ConstructiveReals.v +++ /dev/null @@ -1,835 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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 (see file ConstructiveRealsMorphisms). - 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). - - Any computation about constructive reals, can be worked - in the fastest instance for it; we then transport the results - to all other instances by the isomorphisms. This way of working - is different from the usual interfaces, where we would rather - prove things abstractly, by quantifying universally on the instance. - - The functions of ConstructiveReals do not have a direct impact - on performance, because algorithms will be extracted from instances, - and because fast ConstructiveReals morphisms should be coded - manually. However, since instances are forced to implement - those functions, it is probable that they will also use them - in their algorithms. So those functions hint at what we think - will yield fast and small extracted programs. *) - - -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 orderLe (X : Set) (Xlt : X -> X -> Set) (x y : X) : Prop - := Xlt y x -> False. - -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; - - (* Put this order relation in sort Set rather than Prop, - to allow the definition of fast ConstructiveReals morphisms. - For example, the Cauchy reals do store information in - the proofs of CRlt, which is used in algorithms in sort Set. *) - CRlt : CRcarrier -> CRcarrier -> Set; - CRltLinear : isLinearOrder CRcarrier CRlt; - - (* The propositional truncation of CRlt. It facilitates proofs - when computations are not considered important, for example in - classical reals with extra logical axioms. *) - 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); - - (* The initial field morphism (in characteristic zero). - The abstract definition by iteration of addition is - probably the slowest. Let each instance implement - a faster (and often simpler) version. *) - CR_of_Q : Q -> CRcarrier; - CR_of_Q_plus : forall q r : Q, orderEq _ CRlt (CR_of_Q (q+r)) - (CRplus (CR_of_Q q) (CR_of_Q r)); - CR_of_Q_mult : forall q r : Q, orderEq _ CRlt (CR_of_Q (q*r)) - (CRmult (CR_of_Q q) (CR_of_Q r)); - CR_of_Q_one : orderEq _ CRlt (CR_of_Q 1) CRone; - CR_of_Q_lt : forall q r : Q, - Qlt q r -> CRlt (CR_of_Q q) (CR_of_Q r); - lt_CR_of_Q : forall q r : Q, - CRlt (CR_of_Q q) (CR_of_Q r) -> Qlt q r; - - (* This function is very fast in both the Cauchy and Dedekind - instances, because this rational number q is almost what - the proof of CRlt x y contains. - This function is also the heart of the computation of - constructive real numbers : it approximates x to any - requested precision y. *) - CR_Q_dense : forall x y : CRcarrier, CRlt x y -> - { q : Q & prod (CRlt x (CR_of_Q q)) - (CRlt (CR_of_Q q) y) }; - CR_archimedean : forall x : CRcarrier, - { n : positive & CRlt x (CR_of_Q (Z.pos n # 1)) }; - - CRminus (x y : CRcarrier) : CRcarrier - := CRplus x (CRopp y); - - (* Definitions of convergence and Cauchy-ness. The formulas - with orderLe or CRlt are logically equivalent, the choice of - orderLe in sort Prop is a question of performance. - It is very rare to turn back to the strict order to - define functions in sort Set, so we prefer to discard - those proofs during extraction. And even in those rare cases, - it is easy to divide epsilon by 2 for example. *) - CR_cv (un : nat -> CRcarrier) (l : CRcarrier) : Set - := forall p:positive, - { n : nat | forall i:nat, le n i - -> orderLe _ CRlt (CR_of_Q (-1#p)) (CRminus (un i) l) - /\ orderLe _ CRlt (CRminus (un i) l) (CR_of_Q (1#p)) }; - CR_cauchy (un : nat -> CRcarrier) : Set - := forall p : positive, - { n : nat | forall i j:nat, le n i -> le n j - -> orderLe _ CRlt (CR_of_Q (-1#p)) (CRminus (un i) (un j)) - /\ orderLe _ CRlt (CRminus (un i) (un j)) (CR_of_Q (1#p)) }; - - (* For the Cauchy reals, this algorithm consists in building - a Cauchy sequence of rationals un : nat -> Q that has - the same limit as xn. For each n:nat, un n is a 1/n - rational approximation of a point of xn that has converged - within 1/n. *) - CR_complete : - forall xn : (nat -> CRcarrier), - CR_cauchy xn -> { l : CRcarrier & CR_cv xn l }; - }. - -Lemma CRlt_asym : forall (R : ConstructiveReals) (x y : CRcarrier R), - CRlt R x y -> CRlt R y x -> False. -Proof. - intros. destruct (CRltLinear R), p. - apply (f x y); assumption. -Qed. - -Lemma CRlt_proper - : forall R : ConstructiveReals, - CMorphisms.Proper - (CMorphisms.respectful (orderEq _ (CRlt R)) - (CMorphisms.respectful (orderEq _ (CRlt R)) CRelationClasses.iffT)) (CRlt R). -Proof. - intros R x y H x0 y0 H0. destruct H, H0. - destruct (CRltLinear R). split. - - intro. destruct (s x y x0). assumption. - contradiction. destruct (s y y0 x0). - assumption. assumption. contradiction. - - intro. destruct (s y x y0). assumption. - contradiction. destruct (s x x0 y0). - assumption. assumption. contradiction. -Qed. - -Lemma CRle_refl : forall (R : ConstructiveReals) (x : CRcarrier R), - CRlt R x x -> False. -Proof. - intros. destruct (CRltLinear R), p. - exact (f x x H H). -Qed. - -Lemma CRle_lt_trans : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), - (CRlt R r2 r1 -> False) -> CRlt R r2 r3 -> CRlt R r1 r3. -Proof. - intros. destruct (CRltLinear R). - destruct (s r2 r1 r3 H0). contradiction. apply c. -Qed. - -Lemma CRlt_le_trans : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), - CRlt R r1 r2 -> (CRlt R r3 r2 -> False) -> CRlt R r1 r3. -Proof. - intros. destruct (CRltLinear R). - destruct (s r1 r3 r2 H). apply c. contradiction. -Qed. - -Lemma CRle_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), - orderLe _ (CRlt R) x y -> orderLe _ (CRlt R) y z -> orderLe _ (CRlt R) x z. -Proof. - intros. intro abs. apply H0. - apply (CRlt_le_trans _ _ x); assumption. -Qed. - -Lemma CRlt_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), - CRlt R x y -> CRlt R y z -> CRlt R x z. -Proof. - intros. apply (CRlt_le_trans R _ y _ H). - apply CRlt_asym. exact H0. -Defined. - -Lemma CRlt_trans_flip : forall (R : ConstructiveReals) (x y z : CRcarrier R), - CRlt R y z -> CRlt R x y -> CRlt R x z. -Proof. - intros. apply (CRlt_le_trans R _ y). exact H0. - apply CRlt_asym. exact H. -Defined. - -Lemma CReq_refl : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) x x. -Proof. - split; apply CRle_refl. -Qed. - -Lemma CReq_sym : forall (R : ConstructiveReals) (x y : CRcarrier R), - orderEq _ (CRlt R) x y - -> orderEq _ (CRlt R) y x. -Proof. - intros. destruct H. split; intro abs; contradiction. -Qed. - -Lemma CReq_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), - orderEq _ (CRlt R) x y - -> orderEq _ (CRlt R) y z - -> orderEq _ (CRlt R) x z. -Proof. - intros. destruct H,H0. destruct (CRltLinear R), p. split. - - intro abs. destruct (s _ y _ abs); contradiction. - - intro abs. destruct (s _ y _ abs); contradiction. -Qed. - -Lemma CR_setoid : forall R : ConstructiveReals, - Setoid_Theory (CRcarrier R) (orderEq _ (CRlt R)). -Proof. - split. intro x. apply CReq_refl. - intros x y. apply CReq_sym. - intros x y z. apply CReq_trans. -Qed. - -Lemma CRplus_0_r : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) (CRplus R x (CRzero R)) x. -Proof. - intros. destruct (CRisRing R). - apply (CReq_trans R _ (CRplus R (CRzero R) x)). - apply Radd_comm. apply Radd_0_l. -Qed. - -Lemma CRmult_1_r : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) (CRmult R x (CRone R)) x. -Proof. - intros. destruct (CRisRing R). - apply (CReq_trans R _ (CRmult R (CRone R) x)). - apply Rmul_comm. apply Rmul_1_l. -Qed. - -Lemma CRplus_opp_l : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) (CRplus R (CRopp R x) x) (CRzero R). -Proof. - intros. destruct (CRisRing R). - apply (CReq_trans R _ (CRplus R x (CRopp R x))). - apply Radd_comm. apply Ropp_def. -Qed. - -Lemma CRplus_lt_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R r1 r2 -> CRlt R (CRplus R r1 r) (CRplus R r2 r). -Proof. - intros. destruct (CRisRing R). - apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) - (CRplus R r2 r) (CRplus R r2 r)). - apply CReq_refl. - apply (CRlt_proper R _ _ (CReq_refl _ _) _ (CRplus R r r2)). - apply Radd_comm. apply CRplus_lt_compat_l. exact H. -Qed. - -Lemma CRplus_lt_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRplus R r1 r) (CRplus R r2 r) -> CRlt R r1 r2. -Proof. - intros. destruct (CRisRing R). - apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) - (CRplus R r2 r) (CRplus R r2 r)) in H. - 2: apply CReq_refl. - apply (CRlt_proper R _ _ (CReq_refl _ _) _ (CRplus R r r2)) in H. - apply CRplus_lt_reg_l in H. exact H. - apply Radd_comm. -Qed. - -Lemma CRplus_le_compat_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderLe _ (CRlt R) r1 r2 - -> orderLe _ (CRlt R) (CRplus R r r1) (CRplus R r r2). -Proof. - intros. intros abs. apply CRplus_lt_reg_l in abs. apply H. exact abs. -Qed. - -Lemma CRplus_le_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderLe _ (CRlt R) r1 r2 - -> orderLe _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r). -Proof. - intros. intros abs. apply CRplus_lt_reg_r in abs. apply H. exact abs. -Qed. - -Lemma CRplus_le_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderLe _ (CRlt R) (CRplus R r r1) (CRplus R r r2) - -> orderLe _ (CRlt R) r1 r2. -Proof. - intros. intro abs. apply H. clear H. - apply CRplus_lt_compat_l. exact abs. -Qed. - -Lemma CRplus_le_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderLe _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r) - -> orderLe _ (CRlt R) r1 r2. -Proof. - intros. intro abs. apply H. clear H. - apply CRplus_lt_compat_r. exact abs. -Qed. - -Lemma CRplus_lt_le_compat : - forall (R : ConstructiveReals) (r1 r2 r3 r4 : CRcarrier R), - CRlt R r1 r2 - -> (CRlt R r4 r3 -> False) - -> CRlt R (CRplus R r1 r3) (CRplus R r2 r4). -Proof. - intros. apply (CRlt_le_trans R _ (CRplus R r2 r3)). - apply CRplus_lt_compat_r. exact H. intro abs. - apply CRplus_lt_reg_l in abs. contradiction. -Qed. - -Lemma CRplus_eq_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderEq _ (CRlt R) (CRplus R r r1) (CRplus R r r2) - -> orderEq _ (CRlt R) r1 r2. -Proof. - intros. - destruct (CRisRingExt R). clear Rmul_ext Ropp_ext. - pose proof (Radd_ext - (CRopp R r) (CRopp R r) (CReq_refl _ _) - _ _ H). - destruct (CRisRing R). - apply (CReq_trans _ r1) in H0. - apply (CReq_trans R _ _ _ H0). - apply (CReq_trans R _ (CRplus R (CRplus R (CRopp R r) r) r2)). - apply Radd_assoc. - apply (CReq_trans R _ (CRplus R (CRzero R) r2)). - apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. - apply Radd_0_l. apply CReq_sym. - apply (CReq_trans R _ (CRplus R (CRplus R (CRopp R r) r) r1)). - apply Radd_assoc. - apply (CReq_trans R _ (CRplus R (CRzero R) r1)). - apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. - apply Radd_0_l. -Qed. - -Lemma CRplus_eq_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderEq _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r) - -> orderEq _ (CRlt R) r1 r2. -Proof. - intros. apply (CRplus_eq_reg_l R r). - apply (CReq_trans R _ (CRplus R r1 r)). apply (Radd_comm (CRisRing R)). - apply (CReq_trans R _ (CRplus R r2 r)). - exact H. apply (Radd_comm (CRisRing R)). -Qed. - -Lemma CRopp_involutive : forall (R : ConstructiveReals) (r : CRcarrier R), - orderEq _ (CRlt R) (CRopp R (CRopp R r)) r. -Proof. - intros. apply (CRplus_eq_reg_l R (CRopp R r)). - apply (CReq_trans R _ (CRzero R)). apply CRisRing. - apply CReq_sym, (CReq_trans R _ (CRplus R r (CRopp R r))). - apply CRisRing. apply CRisRing. -Qed. - -Lemma CRopp_gt_lt_contravar - : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), - CRlt R r2 r1 -> CRlt R (CRopp R r1) (CRopp R r2). -Proof. - intros. apply (CRplus_lt_reg_l R r1). - destruct (CRisRing R). - apply (CRle_lt_trans R _ (CRzero R)). apply Ropp_def. - apply (CRplus_lt_compat_l R (CRopp R r2)) in H. - apply (CRle_lt_trans R _ (CRplus R (CRopp R r2) r2)). - apply (CRle_trans R _ (CRplus R r2 (CRopp R r2))). - destruct (Ropp_def r2). exact H0. - destruct (Radd_comm r2 (CRopp R r2)). exact H1. - apply (CRlt_le_trans R _ _ _ H). - destruct (Radd_comm r1 (CRopp R r2)). exact H0. -Qed. - -Lemma CRopp_lt_cancel : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), - CRlt R (CRopp R r2) (CRopp R r1) -> CRlt R r1 r2. -Proof. - intros. apply (CRplus_lt_compat_r R r1) in H. - destruct (CRplus_opp_l R r1) as [_ H1]. - apply (CRlt_le_trans R _ _ _ H) in H1. clear H. - apply (CRplus_lt_compat_l R r2) in H1. - destruct (CRplus_0_r R r2) as [_ H0]. - apply (CRlt_le_trans R _ _ _ H1) in H0. clear H1. - destruct (Radd_assoc (CRisRing R) r2 (CRopp R r2) r1) as [H _]. - apply (CRle_lt_trans R _ _ _ H) in H0. clear H. - apply (CRle_lt_trans R _ (CRplus R (CRzero R) r1)). - apply (Radd_0_l (CRisRing R)). - apply (CRle_lt_trans R _ (CRplus R (CRplus R r2 (CRopp R r2)) r1)). - 2: exact H0. apply CRplus_le_compat_r. - destruct (Ropp_def (CRisRing R) r2). exact H. -Qed. - -Lemma CRopp_plus_distr : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), - orderEq _ (CRlt R) (CRopp R (CRplus R r1 r2)) (CRplus R (CRopp R r1) (CRopp R r2)). -Proof. - intros. destruct (CRisRing R), (CRisRingExt R). - apply (CRplus_eq_reg_l R (CRplus R r1 r2)). - apply (CReq_trans R _ (CRzero R)). apply Ropp_def. - apply (CReq_trans R _ (CRplus R (CRplus R r2 r1) (CRplus R (CRopp R r1) (CRopp R r2)))). - apply (CReq_trans R _ (CRplus R r2 (CRplus R r1 (CRplus R (CRopp R r1) (CRopp R r2))))). - apply (CReq_trans R _ (CRplus R r2 (CRopp R r2))). - apply CReq_sym. apply Ropp_def. apply Radd_ext. - apply CReq_refl. - apply (CReq_trans R _ (CRplus R (CRzero R) (CRopp R r2))). - apply CReq_sym, Radd_0_l. - apply (CReq_trans R _ (CRplus R (CRplus R r1 (CRopp R r1)) (CRopp R r2))). - apply Radd_ext. 2: apply CReq_refl. apply CReq_sym, Ropp_def. - apply CReq_sym, Radd_assoc. apply Radd_assoc. - apply Radd_ext. 2: apply CReq_refl. apply Radd_comm. -Qed. - -Lemma CRmult_plus_distr_l : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), - orderEq _ (CRlt R) (CRmult R r1 (CRplus R r2 r3)) - (CRplus R (CRmult R r1 r2) (CRmult R r1 r3)). -Proof. - intros. destruct (CRisRing R). - apply (CReq_trans R _ (CRmult R (CRplus R r2 r3) r1)). - apply Rmul_comm. - apply (CReq_trans R _ (CRplus R (CRmult R r2 r1) (CRmult R r3 r1))). - apply Rdistr_l. - apply (CReq_trans R _ (CRplus R (CRmult R r1 r2) (CRmult R r3 r1))). - destruct (CRisRingExt R). apply Radd_ext. - apply Rmul_comm. apply CReq_refl. - destruct (CRisRingExt R). apply Radd_ext. - apply CReq_refl. apply Rmul_comm. -Qed. - -(* x == x+x -> x == 0 *) -Lemma CRzero_double : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) x (CRplus R x x) - -> orderEq _ (CRlt R) x (CRzero R). -Proof. - intros. - apply (CRplus_eq_reg_l R x), CReq_sym, (CReq_trans R _ x). - apply CRplus_0_r. exact H. -Qed. - -Lemma CRmult_0_r : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) (CRmult R x (CRzero R)) (CRzero R). -Proof. - intros. apply CRzero_double. - apply (CReq_trans R _ (CRmult R x (CRplus R (CRzero R) (CRzero R)))). - destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. - apply CReq_sym, CRplus_0_r. - destruct (CRisRing R). apply CRmult_plus_distr_l. -Qed. - -Lemma CRopp_mult_distr_r : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), - orderEq _ (CRlt R) (CRopp R (CRmult R r1 r2)) - (CRmult R r1 (CRopp R r2)). -Proof. - intros. apply (CRplus_eq_reg_l R (CRmult R r1 r2)). - destruct (CRisRing R). - apply (CReq_trans R _ (CRzero R)). apply Ropp_def. - apply (CReq_trans R _ (CRmult R r1 (CRplus R r2 (CRopp R r2)))). - 2: apply CRmult_plus_distr_l. - apply (CReq_trans R _ (CRmult R r1 (CRzero R))). - apply CReq_sym, CRmult_0_r. - destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. - apply CReq_sym, Ropp_def. -Qed. - -Lemma CRopp_mult_distr_l : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), - orderEq _ (CRlt R) (CRopp R (CRmult R r1 r2)) - (CRmult R (CRopp R r1) r2). -Proof. - intros. apply (CReq_trans R _ (CRmult R r2 (CRopp R r1))). - apply (CReq_trans R _ (CRopp R (CRmult R r2 r1))). - apply (Ropp_ext (CRisRingExt R)). - apply CReq_sym, (Rmul_comm (CRisRing R)). - apply CRopp_mult_distr_r. - apply CReq_sym, (Rmul_comm (CRisRing R)). -Qed. - -Lemma CRmult_lt_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRzero R) r - -> CRlt R r1 r2 - -> CRlt R (CRmult R r1 r) (CRmult R r2 r). -Proof. - intros. apply (CRplus_lt_reg_r R (CRopp R (CRmult R r1 r))). - apply (CRle_lt_trans R _ (CRzero R)). - apply (Ropp_def (CRisRing R)). - apply (CRlt_le_trans R _ (CRplus R (CRmult R r2 r) (CRmult R (CRopp R r1) r))). - apply (CRlt_le_trans R _ (CRmult R (CRplus R r2 (CRopp R r1)) r)). - apply CRmult_lt_0_compat. 2: exact H. - apply (CRplus_lt_reg_r R r1). - apply (CRle_lt_trans R _ r1). apply (Radd_0_l (CRisRing R)). - apply (CRlt_le_trans R _ r2 _ H0). - apply (CRle_trans R _ (CRplus R r2 (CRplus R (CRopp R r1) r1))). - apply (CRle_trans R _ (CRplus R r2 (CRzero R))). - destruct (CRplus_0_r R r2). exact H1. - apply CRplus_le_compat_l. destruct (CRplus_opp_l R r1). exact H1. - destruct (Radd_assoc (CRisRing R) r2 (CRopp R r1) r1). exact H2. - destruct (CRisRing R). - destruct (Rdistr_l r2 (CRopp R r1) r). exact H2. - apply CRplus_le_compat_l. destruct (CRopp_mult_distr_l R r1 r). - exact H1. -Qed. - -Lemma CRinv_r : forall (R : ConstructiveReals) (r:CRcarrier R) - (rnz : orderAppart _ (CRlt R) r (CRzero R)), - orderEq _ (CRlt R) (CRmult R r (CRinv R r rnz)) (CRone R). -Proof. - intros. apply (CReq_trans R _ (CRmult R (CRinv R r rnz) r)). - apply (CRisRing R). apply CRinv_l. -Qed. - -Lemma CRmult_lt_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRzero R) r - -> CRlt R (CRmult R r1 r) (CRmult R r2 r) - -> CRlt R r1 r2. -Proof. - intros. apply (CRmult_lt_compat_r R (CRinv R r (inr H))) in H0. - 2: apply CRinv_0_lt_compat, H. - apply (CRle_lt_trans R _ (CRmult R (CRmult R r1 r) (CRinv R r (inr H)))). - - clear H0. apply (CRle_trans R _ (CRmult R r1 (CRone R))). - destruct (CRmult_1_r R r1). exact H0. - apply (CRle_trans R _ (CRmult R r1 (CRmult R r (CRinv R r (inr H))))). - destruct (Rmul_ext (CRisRingExt R) r1 r1 (CReq_refl R r1) - (CRmult R r (CRinv R r (inr H))) (CRone R)). - apply CRinv_r. exact H0. - destruct (Rmul_assoc (CRisRing R) r1 r (CRinv R r (inr H))). exact H1. - - apply (CRlt_le_trans R _ (CRmult R (CRmult R r2 r) (CRinv R r (inr H)))). - exact H0. clear H0. - apply (CRle_trans R _ (CRmult R r2 (CRone R))). - 2: destruct (CRmult_1_r R r2); exact H1. - apply (CRle_trans R _ (CRmult R r2 (CRmult R r (CRinv R r (inr H))))). - destruct (Rmul_assoc (CRisRing R) r2 r (CRinv R r (inr H))). exact H0. - destruct (Rmul_ext (CRisRingExt R) r2 r2 (CReq_refl R r2) - (CRmult R r (CRinv R r (inr H))) (CRone R)). - apply CRinv_r. exact H1. -Qed. - -Lemma CRmult_lt_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRzero R) r - -> CRlt R (CRmult R r r1) (CRmult R r r2) - -> CRlt R r1 r2. -Proof. - intros. - destruct (Rmul_comm (CRisRing R) r r1) as [H1 _]. - apply (CRle_lt_trans R _ _ _ H1) in H0. clear H1. - destruct (Rmul_comm (CRisRing R) r r2) as [_ H1]. - apply (CRlt_le_trans R _ _ _ H0) in H1. clear H0. - apply CRmult_lt_reg_r in H1. - exact H1. exact H. -Qed. - -Lemma CRmult_le_compat_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRzero R) r - -> orderLe _ (CRlt R) r1 r2 - -> orderLe _ (CRlt R) (CRmult R r r1) (CRmult R r r2). -Proof. - intros. intro abs. apply CRmult_lt_reg_l in abs. - contradiction. exact H. -Qed. - -Lemma CRmult_le_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRzero R) r - -> orderLe _ (CRlt R) r1 r2 - -> orderLe _ (CRlt R) (CRmult R r1 r) (CRmult R r2 r). -Proof. - intros. intro abs. apply CRmult_lt_reg_r in abs. - contradiction. exact H. -Qed. - -Lemma CRmult_eq_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderAppart _ (CRlt R) (CRzero R) r - -> orderEq _ (CRlt R) (CRmult R r1 r) (CRmult R r2 r) - -> orderEq _ (CRlt R) r1 r2. -Proof. - intros. destruct H0,H. - - split. - + intro abs. apply H0. apply CRmult_lt_compat_r. - exact c. exact abs. - + intro abs. apply H1. apply CRmult_lt_compat_r. - exact c. exact abs. - - split. - + intro abs. apply H1. apply CRopp_lt_cancel. - apply (CRle_lt_trans R _ (CRmult R r1 (CRopp R r))). - apply CRopp_mult_distr_r. - apply (CRlt_le_trans R _ (CRmult R r2 (CRopp R r))). - 2: apply CRopp_mult_distr_r. - apply CRmult_lt_compat_r. 2: exact abs. - apply (CRplus_lt_reg_r R r). apply (CRle_lt_trans R _ r). - apply (Radd_0_l (CRisRing R)). - apply (CRlt_le_trans R _ (CRzero R) _ c). - apply CRplus_opp_l. - + intro abs. apply H0. apply CRopp_lt_cancel. - apply (CRle_lt_trans R _ (CRmult R r2 (CRopp R r))). - apply CRopp_mult_distr_r. - apply (CRlt_le_trans R _ (CRmult R r1 (CRopp R r))). - 2: apply CRopp_mult_distr_r. - apply CRmult_lt_compat_r. 2: exact abs. - apply (CRplus_lt_reg_r R r). apply (CRle_lt_trans R _ r). - apply (Radd_0_l (CRisRing R)). - apply (CRlt_le_trans R _ (CRzero R) _ c). - apply CRplus_opp_l. -Qed. - -Lemma CR_of_Q_proper : forall (R : ConstructiveReals) (q r : Q), - q == r -> orderEq _ (CRlt R) (CR_of_Q R q) (CR_of_Q R r). -Proof. - split. - - intro abs. apply lt_CR_of_Q in abs. rewrite H in abs. - exact (Qlt_not_le r r abs (Qle_refl r)). - - intro abs. apply lt_CR_of_Q in abs. rewrite H in abs. - exact (Qlt_not_le r r abs (Qle_refl r)). -Qed. - -Lemma CR_of_Q_zero : forall (R : ConstructiveReals), - orderEq _ (CRlt R) (CR_of_Q R 0) (CRzero R). -Proof. - intros. apply CRzero_double. - apply (CReq_trans R _ (CR_of_Q R (0+0))). apply CR_of_Q_proper. - reflexivity. apply CR_of_Q_plus. -Qed. - -Lemma CR_of_Q_opp : forall (R : ConstructiveReals) (q : Q), - orderEq _ (CRlt R) (CR_of_Q R (-q)) (CRopp R (CR_of_Q R q)). -Proof. - intros. apply (CRplus_eq_reg_l R (CR_of_Q R q)). - apply (CReq_trans R _ (CRzero R)). - apply (CReq_trans R _ (CR_of_Q R (q-q))). - apply CReq_sym, CR_of_Q_plus. - apply (CReq_trans R _ (CR_of_Q R 0)). - apply CR_of_Q_proper. ring. apply CR_of_Q_zero. - apply CReq_sym. apply (CRisRing R). -Qed. - -Lemma CR_of_Q_le : forall (R : ConstructiveReals) (r q : Q), - Qle r q - -> orderLe _ (CRlt R) (CR_of_Q R r) (CR_of_Q R q). -Proof. - intros. intro abs. apply lt_CR_of_Q in abs. - exact (Qlt_not_le _ _ abs H). -Qed. - -Lemma CR_of_Q_pos : forall (R : ConstructiveReals) (q:Q), - Qlt 0 q -> CRlt R (CRzero R) (CR_of_Q R q). -Proof. - intros. apply (CRle_lt_trans R _ (CR_of_Q R 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. exact H. -Qed. - -Lemma CR_cv_above_rat - : forall (R : ConstructiveReals) (xn : nat -> Q) (x : CRcarrier R) (q : Q), - CR_cv R (fun n : nat => CR_of_Q R (xn n)) x - -> CRlt R (CR_of_Q R q) x - -> { n : nat | forall p:nat, le n p -> Qlt q (xn p) }. -Proof. - intros. - destruct (CR_Q_dense R _ _ H0) as [r [H1 H2]]. - apply lt_CR_of_Q in H1. clear H0. - destruct (Qarchimedean (/(r-q))) as [p pmaj]. - destruct (H p) as [n nmaj]. - exists n. intros k lenk. specialize (nmaj k lenk) as [H3 _]. - apply (lt_CR_of_Q R), (CRlt_le_trans R _ (CRplus R x (CR_of_Q R (-1#p)))). - apply (CRlt_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (-1#p)))). - 2: apply CRplus_lt_compat_r, H2. - apply (CRlt_le_trans R _ (CR_of_Q R (r+(-1#p)))). - - apply CR_of_Q_lt. - apply (Qplus_lt_l _ _ (-(-1#p)-q)). field_simplify. - setoid_replace (-1*(-1#p)) with (1#p). 2: reflexivity. - apply (Qmult_lt_l _ _ (r-q)) in pmaj. - rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. - 2: reflexivity. setoid_replace (-1*q + r) with (r-q). exact pmaj. - ring. intro abs. apply Qlt_minus_iff in H1. - rewrite abs in H1. inversion H1. - apply Qlt_minus_iff in H1. exact H1. - - apply CR_of_Q_plus. - - apply (CRplus_le_reg_r R (CRopp R x)). - apply (CRle_trans R _ (CR_of_Q R (-1#p))). 2: exact H3. clear H3. - apply (CRle_trans R _ (CRplus R (CRopp R x) (CRplus R x (CR_of_Q R (-1 # p))))). - exact (proj1 (Radd_comm (CRisRing R) _ _)). - apply (CRle_trans R _ (CRplus R (CRplus R (CRopp R x) x) (CR_of_Q R (-1 # p)))). - exact (proj2 (Radd_assoc (CRisRing R) _ _ _)). - apply (CRle_trans R _ (CRplus R (CRzero R) (CR_of_Q R (-1 # p)))). - apply CRplus_le_compat_r. exact (proj2 (CRplus_opp_l R _)). - exact (proj2 (Radd_0_l (CRisRing R) _)). -Qed. - -Lemma CR_cv_below_rat - : forall (R : ConstructiveReals) (xn : nat -> Q) (x : CRcarrier R) (q : Q), - CR_cv R (fun n : nat => CR_of_Q R (xn n)) x - -> CRlt R x (CR_of_Q R q) - -> { n : nat | forall p:nat, le n p -> Qlt (xn p) q }. -Proof. - intros. - destruct (CR_Q_dense R _ _ H0) as [r [H1 H2]]. - apply lt_CR_of_Q in H2. clear H0. - destruct (Qarchimedean (/(q-r))) as [p pmaj]. - destruct (H p) as [n nmaj]. - exists n. intros k lenk. specialize (nmaj k lenk) as [_ H4]. - apply (lt_CR_of_Q R), (CRle_lt_trans R _ (CRplus R x (CR_of_Q R (1#p)))). - - apply (CRplus_le_reg_r R (CRopp R x)). - apply (CRle_trans R _ (CR_of_Q R (1#p))). exact H4. clear H4. - apply (CRle_trans R _ (CRplus R (CRopp R x) (CRplus R x (CR_of_Q R (1 # p))))). - 2: exact (proj1 (Radd_comm (CRisRing R) _ _)). - apply (CRle_trans R _ (CRplus R (CRplus R (CRopp R x) x) (CR_of_Q R (1 # p)))). - 2: exact (proj1 (Radd_assoc (CRisRing R) _ _ _)). - apply (CRle_trans R _ (CRplus R (CRzero R) (CR_of_Q R (1 # p)))). - exact (proj1 (Radd_0_l (CRisRing R) _)). - apply CRplus_le_compat_r. exact (proj1 (CRplus_opp_l R _)). - - apply (CRlt_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (1 # p)))). - apply CRplus_lt_compat_r. exact H1. - apply (CRle_lt_trans R _ (CR_of_Q R (r + (1#p)))). - apply CR_of_Q_plus. apply CR_of_Q_lt. - apply (Qmult_lt_l _ _ (q-r)) in pmaj. - rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. - apply (Qplus_lt_l _ _ (-r)). field_simplify. - setoid_replace (-1*r + q) with (q-r). exact pmaj. - ring. reflexivity. intro abs. apply Qlt_minus_iff in H2. - rewrite abs in H2. inversion H2. - apply Qlt_minus_iff in H2. exact H2. -Qed. - -Lemma CR_cv_const : forall (R : ConstructiveReals) (x y : CRcarrier R), - CR_cv R (fun _ => x) y -> orderEq _ (CRlt R) x y. -Proof. - intros. destruct (CRisRing R). split. - - intro abs. - destruct (CR_Q_dense R x y abs) as [q [H0 H1]]. - destruct (CR_Q_dense R _ _ H1) as [r [H2 H3]]. - apply lt_CR_of_Q in H2. - destruct (Qarchimedean (/(r-q))) as [p pmaj]. - destruct (H p) as [n nmaj]. specialize (nmaj n (le_refl n)) as [nmaj _]. - apply nmaj. clear nmaj. - apply (CRlt_trans R _ (CR_of_Q R (q-r))). - apply (CRlt_le_trans R _ (CRplus R (CR_of_Q R q) (CRopp R (CR_of_Q R r)))). - + apply CRplus_lt_le_compat. exact H0. - intro H4. apply CRopp_lt_cancel in H4. exact (CRlt_asym R _ _ H4 H3). - + apply (CRle_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R (-r)))). - apply CRplus_le_compat_l. exact (proj1 (CR_of_Q_opp R r)). - exact (proj1 (CR_of_Q_plus R _ _)). - + apply CR_of_Q_lt. - apply (Qplus_lt_l _ _ (-(-1#p)+r-q)). field_simplify. - setoid_replace (-1*(-1#p)) with (1#p). 2: reflexivity. - apply (Qmult_lt_l _ _ (r-q)) in pmaj. - rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. - 2: reflexivity. setoid_replace (-1*q + r) with (r-q). exact pmaj. - ring. intro H4. apply Qlt_minus_iff in H2. - rewrite H4 in H2. inversion H2. - apply Qlt_minus_iff in H2. exact H2. - - intro abs. - destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. - destruct (CR_Q_dense R _ _ H0) as [r [H2 H3]]. - apply lt_CR_of_Q in H3. - destruct (Qarchimedean (/(q-r))) as [p pmaj]. - destruct (H p) as [n nmaj]. specialize (nmaj n (le_refl n)) as [_ nmaj]. - apply nmaj. clear nmaj. - apply (CRlt_trans R _ (CR_of_Q R (q-r))). - + apply CR_of_Q_lt. - apply (Qmult_lt_l _ _ (q-r)) in pmaj. - rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. - exact pmaj. reflexivity. - intro H4. apply Qlt_minus_iff in H3. - rewrite H4 in H3. inversion H3. - apply Qlt_minus_iff in H3. exact H3. - + apply (CRle_lt_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R (-r)))). - apply CR_of_Q_plus. - apply (CRle_lt_trans R _ (CRplus R (CR_of_Q R q) (CRopp R (CR_of_Q R r)))). - apply CRplus_le_compat_l. exact (proj2 (CR_of_Q_opp R r)). - apply CRplus_lt_le_compat. exact H1. - intro H4. apply CRopp_lt_cancel in H4. - exact (CRlt_asym R _ _ H4 H2). -Qed. diff --git a/theories/Reals/ConstructiveRealsLUB.v b/theories/Reals/ConstructiveRealsLUB.v deleted file mode 100644 index cc18bd910d..0000000000 --- a/theories/Reals/ConstructiveRealsLUB.v +++ /dev/null @@ -1,318 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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 ConstructiveReals. -Require Import ConstructiveCauchyRealsMult. -Require Import ConstructiveRealsMorphisms. -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 (inject_Q (Z.of_nat n # 1)) }. -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_pos x). exists (Pos.to_nat x0). - intros y ey. specialize (H y ey). - apply CRealLt_asym. apply (CReal_le_lt_trans _ x). - exact H. rewrite positive_nat_Z. exact c. -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 (-inject_Q (Z.of_nat m # 1)) }. -Proof. - intros E lpo sig_not_dec H. - apply constructive_indefinite_ground_description_nat. - - intro n. destruct (is_upper_bound_dec E (-inject_Q (Z.of_nat n # 1)) lpo sig_not_dec). - right. intro abs. contradiction. left. exact n0. - - destruct H as [x H]. destruct (Rup_pos (-x)) as [n H0]. - exists (Pos.to_nat n). intro abs. specialize (abs x H). - apply abs. rewrite positive_nat_Z. - apply (CReal_plus_lt_reg_l (inject_Q (Z.pos n # 1)-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 < inject_Q r -> DDupcut upcut r) - /\ (inject_Q 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 *) - 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 [p pmaj] abs. - 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 < inject_Q r -> is_upper_bound E (inject_Q r)) - /\ (inject_Q r < x -> ~is_upper_bound E (inject_Q 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 (inject_Q 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 (CReal_le_lt_trans _ (inject_Q r)). 2: exact abs. - apply inject_Q_le. exact H0. } - assert (upcut (Z.of_nat a # 1)%Q). - { intros x Ex. exact (luba x Ex). } - assert (~upcut (- Z.of_nat b # 1)%Q). - { intros abs. apply glbb. intros x Ex. - specialize (abs x Ex). rewrite <- opp_inject_Q. - 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 (CReal_lt_trans _ (inject_Q 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. - -Definition CRis_upper_bound (R : ConstructiveReals) (E:CRcarrier R -> Prop) (m:CRcarrier R) - := forall x:CRcarrier R, E x -> CRlt R m x -> False. - -Lemma CR_sig_lub : - forall (R : ConstructiveReals) (E:CRcarrier R -> Prop), - (forall x y : CRcarrier R, orderEq _ (CRlt R) x y -> (E x <-> E y)) - -> sig_forall_dec_T - -> sig_not_dec_T - -> (exists x : CRcarrier R, E x) - -> (exists x : CRcarrier R, CRis_upper_bound R E x) - -> { u : CRcarrier R | CRis_upper_bound R E u /\ - forall y:CRcarrier R, CRis_upper_bound R E y -> CRlt R y u -> False }. -Proof. - intros. destruct (sig_lub (fun x:CReal => E (CauchyMorph R x)) X X0) as [u ulub]. - - destruct H0. exists (CauchyMorph_inv R x). - specialize (H (CauchyMorph R (CauchyMorph_inv R x)) x - (CauchyMorph_surject R x)) as [_ H]. - exact (H H0). - - destruct H1. exists (CauchyMorph_inv R x). - intros y Ey. specialize (H1 (CauchyMorph R y) Ey). - intros abs. apply H1. - apply (CauchyMorph_increasing R) in abs. - apply (CRle_lt_trans R _ (CauchyMorph R (CauchyMorph_inv R x))). - 2: exact abs. apply (CauchyMorph_surject R x). - - exists (CauchyMorph R u). destruct ulub. split. - + intros y Ey abs. specialize (H2 (CauchyMorph_inv R y)). - simpl in H2. - specialize (H (CauchyMorph R (CauchyMorph_inv R y)) y - (CauchyMorph_surject R y)) as [_ H]. - specialize (H2 (H Ey)). apply H2. - apply CauchyMorph_inv_increasing in abs. - rewrite CauchyMorph_inject in abs. exact abs. - + intros. apply (H3 (CauchyMorph_inv R y)). - intros z Ez abs. specialize (H4 (CauchyMorph R z)). - apply (H4 Ez). apply (CauchyMorph_increasing R) in abs. - apply (CRle_lt_trans R _ (CauchyMorph R (CauchyMorph_inv R y))). - 2: exact abs. apply (CauchyMorph_surject R y). - apply CauchyMorph_inv_increasing in H5. - rewrite CauchyMorph_inject in H5. exact H5. -Qed. diff --git a/theories/Reals/ConstructiveRealsMorphisms.v b/theories/Reals/ConstructiveRealsMorphisms.v deleted file mode 100644 index 4af95e2980..0000000000 --- a/theories/Reals/ConstructiveRealsMorphisms.v +++ /dev/null @@ -1,1158 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \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) *) -(************************************************************************) -(************************************************************************) - -(** Morphisms used to transport results from any instance of - ConstructiveReals to any other. - Between any two constructive reals structures R1 and R2, - all morphisms R1 -> R2 are extensionally equal. We will - further show that they exist, and so are isomorphisms. - The difference between two morphisms R1 -> R2 is therefore - the speed of computation. - - The canonical isomorphisms we provide here are often very slow, - when a new implementation of constructive reals is added, - it should define its own ad hoc isomorphisms for better speed. - - Apart from the speed, those unique isomorphisms also serve as - sanity checks of the interface ConstructiveReals : - it captures a concept with a strong notion of uniqueness. *) - -Require Import QArith. -Require Import Qabs. -Require Import ConstructiveReals. -Require Import ConstructiveCauchyRealsMult. -Require Import ConstructiveRcomplete. - - -Record ConstructiveRealsMorphism (R1 R2 : ConstructiveReals) : Set := - { - CRmorph : CRcarrier R1 -> CRcarrier R2; - CRmorph_rat : forall q : Q, - orderEq _ (CRlt R2) (CRmorph (CR_of_Q R1 q)) (CR_of_Q R2 q); - CRmorph_increasing : forall x y : CRcarrier R1, - CRlt R1 x y -> CRlt R2 (CRmorph x) (CRmorph y); - }. - - -Lemma CRmorph_increasing_inv - : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - CRlt R2 (CRmorph _ _ f x) (CRmorph _ _ f y) - -> CRlt R1 x y. -Proof. - intros. destruct (CR_Q_dense R2 _ _ H) as [q [H0 H1]]. - destruct (CR_Q_dense R2 _ _ H0) as [r [H2 H3]]. - apply lt_CR_of_Q, (CR_of_Q_lt R1) in H3. - destruct (CRltLinear R1). - destruct (s _ x _ H3). - - exfalso. apply (CRmorph_increasing _ _ f) in c. - destruct (CRmorph_rat _ _ f r) as [H4 _]. - apply (CRle_lt_trans R2 _ _ _ H4) in c. clear H4. - exact (CRlt_asym R2 _ _ c H2). - - clear H2 H3 r. apply (CRlt_trans R1 _ _ _ c). clear c. - destruct (CR_Q_dense R2 _ _ H1) as [t [H2 H3]]. - apply lt_CR_of_Q, (CR_of_Q_lt R1) in H2. - destruct (s _ y _ H2). exact c. - exfalso. apply (CRmorph_increasing _ _ f) in c. - destruct (CRmorph_rat _ _ f t) as [_ H4]. - apply (CRlt_le_trans R2 _ _ _ c) in H4. clear c. - exact (CRlt_asym R2 _ _ H4 H3). -Qed. - -Lemma CRmorph_unique : forall (R1 R2 : ConstructiveReals) - (f g : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1), - orderEq _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ g x). -Proof. - split. - - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. - destruct (CRmorph_rat _ _ f q) as [H1 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - destruct (CRmorph_rat _ _ g q) as [_ H2]. - apply (CRle_lt_trans R2 _ _ _ H2) in H0. clear H2. - apply CRmorph_increasing_inv in H0. - exact (CRlt_asym R1 _ _ H0 H1). - - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. - destruct (CRmorph_rat _ _ f q) as [_ H1]. - apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. - apply CRmorph_increasing_inv in H0. - destruct (CRmorph_rat _ _ g q) as [H2 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H2. clear H. - apply CRmorph_increasing_inv in H2. - exact (CRlt_asym R1 _ _ H0 H2). -Qed. - - -(* The identity is the only endomorphism of constructive reals. - For any ConstructiveReals R1, R2 and any morphisms - f : R1 -> R2 and g : R2 -> R1, - f and g are isomorphisms and are inverses of each other. *) -Lemma Endomorph_id : forall (R : ConstructiveReals) (f : ConstructiveRealsMorphism R R) - (x : CRcarrier R), - orderEq _ (CRlt R) (CRmorph _ _ f x) x. -Proof. - split. - - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. - destruct (CRmorph_rat _ _ f q) as [H _]. - apply (CRlt_le_trans R _ _ _ H0) in H. clear H0. - apply CRmorph_increasing_inv in H. - exact (CRlt_asym R _ _ H1 H). - - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. - destruct (CRmorph_rat _ _ f q) as [_ H]. - apply (CRle_lt_trans R _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - exact (CRlt_asym R _ _ H1 H0). -Qed. - -Lemma CRmorph_proper : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - orderEq _ (CRlt R1) x y - -> orderEq _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). -Proof. - split. - - intro abs. apply CRmorph_increasing_inv in abs. - destruct H. contradiction. - - intro abs. apply CRmorph_increasing_inv in abs. - destruct H. contradiction. -Qed. - -Definition CRmorph_compose (R1 R2 R3 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (g : ConstructiveRealsMorphism R2 R3) - : ConstructiveRealsMorphism R1 R3. -Proof. - apply (Build_ConstructiveRealsMorphism - R1 R3 (fun x:CRcarrier R1 => CRmorph _ _ g (CRmorph _ _ f x))). - - intro q. apply (CReq_trans R3 _ (CRmorph R2 R3 g (CR_of_Q R2 q))). - apply CRmorph_proper. apply CRmorph_rat. apply CRmorph_rat. - - intros. apply CRmorph_increasing. apply CRmorph_increasing. exact H. -Defined. - -Lemma CRmorph_le : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - orderLe _ (CRlt R1) x y - -> orderLe _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). -Proof. - intros. intro abs. apply CRmorph_increasing_inv in abs. contradiction. -Qed. - -Lemma CRmorph_le_inv : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - orderLe _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y) - -> orderLe _ (CRlt R1) x y. -Proof. - intros. intro abs. apply (CRmorph_increasing _ _ f) in abs. contradiction. -Qed. - -Lemma CRmorph_zero : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRzero R1)) (CRzero R2). -Proof. - intros. apply (CReq_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 0))). - apply CRmorph_proper. apply CReq_sym, CR_of_Q_zero. - apply (CReq_trans R2 _ (CR_of_Q R2 0)). - apply CRmorph_rat. apply CR_of_Q_zero. -Qed. - -Lemma CRmorph_one : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRone R1)) (CRone R2). -Proof. - intros. apply (CReq_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 1))). - apply CRmorph_proper. apply CReq_sym, CR_of_Q_one. - apply (CReq_trans R2 _ (CR_of_Q R2 1)). - apply CRmorph_rat. apply CR_of_Q_one. -Qed. - -Lemma CRmorph_opp : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRopp R1 x)) - (CRopp R2 (CRmorph _ _ f x)). -Proof. - split. - - intro abs. - destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. - destruct (CRmorph_rat R1 R2 f q) as [H1 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - apply CRopp_gt_lt_contravar in H0. - destruct (CR_of_Q_opp R2 q) as [H2 _]. - apply (CRlt_le_trans R2 _ _ _ H0) in H2. clear H0. - pose proof (CRopp_involutive R2 (CRmorph R1 R2 f x)) as [H _]. - apply (CRle_lt_trans R2 _ _ _ H) in H2. clear H. - destruct (CRmorph_rat R1 R2 f (-q)) as [H _]. - apply (CRlt_le_trans R2 _ _ _ H2) in H. clear H2. - apply CRmorph_increasing_inv in H. - destruct (CR_of_Q_opp R1 q) as [_ H2]. - apply (CRlt_le_trans R1 _ _ _ H) in H2. clear H. - apply CRopp_gt_lt_contravar in H2. - pose proof (CRopp_involutive R1 (CR_of_Q R1 q)) as [H _]. - apply (CRle_lt_trans R1 _ _ _ H) in H2. clear H. - exact (CRlt_asym R1 _ _ H1 H2). - - intro abs. - destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. - destruct (CRmorph_rat R1 R2 f q) as [_ H1]. - apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. - apply CRmorph_increasing_inv in H0. - apply CRopp_gt_lt_contravar in H. - pose proof (CRopp_involutive R2 (CRmorph R1 R2 f x)) as [_ H1]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - destruct (CR_of_Q_opp R2 q) as [_ H2]. - apply (CRle_lt_trans R2 _ _ _ H2) in H1. clear H2. - destruct (CRmorph_rat R1 R2 f (-q)) as [_ H]. - apply (CRle_lt_trans R2 _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - destruct (CR_of_Q_opp R1 q) as [H2 _]. - apply (CRle_lt_trans R1 _ _ _ H2) in H1. clear H2. - apply CRopp_gt_lt_contravar in H1. - pose proof (CRopp_involutive R1 (CR_of_Q R1 q)) as [_ H]. - apply (CRlt_le_trans R1 _ _ _ H1) in H. clear H1. - exact (CRlt_asym R1 _ _ H0 H). -Qed. - -Lemma CRplus_pos_rat_lt : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), - Qlt 0 q -> CRlt R x (CRplus R x (CR_of_Q R q)). -Proof. - intros. - apply (CRle_lt_trans R _ (CRplus R x (CRzero R))). apply CRplus_0_r. - apply CRplus_lt_compat_l. - apply (CRle_lt_trans R _ (CR_of_Q R 0)). apply CR_of_Q_zero. - apply CR_of_Q_lt. exact H. -Defined. - -Lemma CRplus_neg_rat_lt : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), - Qlt q 0 -> CRlt R (CRplus R x (CR_of_Q R q)) x. -Proof. - intros. - apply (CRlt_le_trans R _ (CRplus R x (CRzero R))). 2: apply CRplus_0_r. - apply CRplus_lt_compat_l. - apply (CRlt_le_trans R _ (CR_of_Q R 0)). - apply CR_of_Q_lt. exact H. apply CR_of_Q_zero. -Qed. - -Lemma CRmorph_plus_rat : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) (q : Q), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRplus R1 x (CR_of_Q R1 q))) - (CRplus R2 (CRmorph _ _ f x) (CR_of_Q R2 q)). -Proof. - split. - - intro abs. - destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. - destruct (CRmorph_rat _ _ f r) as [H1 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - apply (CRlt_asym R1 _ _ H1). clear H1. - apply (CRplus_lt_reg_r R1 (CRopp R1 (CR_of_Q R1 q))). - apply (CRlt_le_trans R1 _ x). - apply (CRle_lt_trans R1 _ (CR_of_Q R1 (r-q))). - apply (CRle_trans R1 _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). - apply CRplus_le_compat_l. destruct (CR_of_Q_opp R1 q). exact H. - destruct (CR_of_Q_plus R1 r (-q)). exact H. - apply (CRmorph_increasing_inv _ _ f). - apply (CRle_lt_trans R2 _ (CR_of_Q R2 (r - q))). - apply CRmorph_rat. - apply (CRplus_lt_reg_r R2 (CR_of_Q R2 q)). - apply (CRle_lt_trans R2 _ (CR_of_Q R2 r)). 2: exact H0. - intro H. - destruct (CR_of_Q_plus R2 (r-q) q) as [H1 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - apply lt_CR_of_Q in H1. ring_simplify in H1. - exact (Qlt_not_le _ _ H1 (Qle_refl _)). - destruct (CRisRing R1). - apply (CRle_trans R1 _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). - apply (CRle_trans R1 _ (CRplus R1 x (CRzero R1))). - destruct (CRplus_0_r R1 x). exact H. - apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H. - destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). - exact H1. - - intro abs. - destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. - destruct (CRmorph_rat _ _ f r) as [_ H1]. - apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. - apply CRmorph_increasing_inv in H0. - apply (CRlt_asym R1 _ _ H0). clear H0. - apply (CRplus_lt_reg_r R1 (CRopp R1 (CR_of_Q R1 q))). - apply (CRle_lt_trans R1 _ x). - destruct (CRisRing R1). - apply (CRle_trans R1 _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). - destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). - exact H0. - apply (CRle_trans R1 _ (CRplus R1 x (CRzero R1))). - apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H1. - destruct (CRplus_0_r R1 x). exact H1. - apply (CRlt_le_trans R1 _ (CR_of_Q R1 (r-q))). - apply (CRmorph_increasing_inv _ _ f). - apply (CRlt_le_trans R2 _ (CR_of_Q R2 (r - q))). - apply (CRplus_lt_reg_r R2 (CR_of_Q R2 q)). - apply (CRlt_le_trans R2 _ _ _ H). - 2: apply CRmorph_rat. - apply (CRle_trans R2 _ (CR_of_Q R2 (r-q+q))). - intro abs. apply lt_CR_of_Q in abs. ring_simplify in abs. - exact (Qlt_not_le _ _ abs (Qle_refl _)). - destruct (CR_of_Q_plus R2 (r-q) q). exact H1. - apply (CRle_trans R1 _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). - destruct (CR_of_Q_plus R1 r (-q)). exact H1. - apply CRplus_le_compat_l. destruct (CR_of_Q_opp R1 q). exact H1. -Qed. - -Lemma CRmorph_plus : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRplus R1 x y)) - (CRplus R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). -Proof. - intros R1 R2 f. - assert (forall (x y : CRcarrier R1), - orderLe _ (CRlt R2) (CRplus R2 (CRmorph R1 R2 f x) (CRmorph R1 R2 f y)) - (CRmorph R1 R2 f (CRplus R1 x y))). - { intros x y abs. destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. - destruct (CRmorph_rat _ _ f r) as [H1 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - apply (CRlt_asym R1 _ _ H1). clear H1. - destruct (CR_Q_dense R2 _ _ H0) as [q [H2 H3]]. - apply lt_CR_of_Q in H2. - assert (Qlt (r-q) 0) as epsNeg. - { apply (Qplus_lt_r _ _ q). ring_simplify. exact H2. } - destruct (CR_Q_dense R1 _ _ (CRplus_neg_rat_lt R1 x (r-q) epsNeg)) - as [s [H4 H5]]. - apply (CRlt_trans R1 _ (CRplus R1 (CR_of_Q R1 s) y)). - 2: apply CRplus_lt_compat_r, H5. - apply (CRmorph_increasing_inv _ _ f). - apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 s) (CRmorph _ _ f y))). - apply (CRmorph_increasing _ _ f) in H4. - destruct (CRmorph_plus_rat _ _ f x (r-q)) as [H _]. - apply (CRle_lt_trans R2 _ _ _ H) in H4. clear H. - destruct (CRmorph_rat _ _ f s) as [_ H1]. - apply (CRlt_le_trans R2 _ _ _ H4) in H1. clear H4. - apply (CRlt_trans R2 _ (CRplus R2 (CRplus R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (r - q))) - (CRmorph R1 R2 f y))). - 2: apply CRplus_lt_compat_r, H1. - apply (CRlt_le_trans R2 _ (CRplus R2 (CRplus R2 (CR_of_Q R2 (r - q)) (CRmorph R1 R2 f x)) - (CRmorph R1 R2 f y))). - apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 (r - q)) - (CRplus R2 (CRmorph R1 R2 f x) (CRmorph R1 R2 f y)))). - apply (CRle_lt_trans R2 _ (CRplus R2 (CR_of_Q R2 (r - q)) (CR_of_Q R2 q))). - 2: apply CRplus_lt_compat_l, H3. - intro abs. - destruct (CR_of_Q_plus R2 (r-q) q) as [_ H4]. - apply (CRle_lt_trans R2 _ _ _ H4) in abs. clear H4. - destruct (CRmorph_rat _ _ f r) as [_ H4]. - apply (CRlt_le_trans R2 _ _ _ abs) in H4. clear abs. - apply lt_CR_of_Q in H4. ring_simplify in H4. - exact (Qlt_not_le _ _ H4 (Qle_refl _)). - destruct (CRisRing R2); apply Radd_assoc. - apply CRplus_le_compat_r. destruct (CRisRing R2). - destruct (Radd_comm (CRmorph R1 R2 f x) (CR_of_Q R2 (r - q))). - exact H. - intro abs. - destruct (CRmorph_plus_rat _ _ f y s) as [H _]. apply H. clear H. - apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 s) (CRmorph R1 R2 f y))). - apply (CRle_lt_trans R2 _ (CRmorph R1 R2 f (CRplus R1 (CR_of_Q R1 s) y))). - apply CRmorph_proper. destruct (CRisRing R1); apply Radd_comm. - exact abs. destruct (CRisRing R2); apply Radd_comm. } - split. - - apply H. - - specialize (H (CRplus R1 x y) (CRopp R1 y)). - intro abs. apply H. clear H. - apply (CRle_lt_trans R2 _ (CRmorph R1 R2 f x)). - apply CRmorph_proper. destruct (CRisRing R1). - apply (CReq_trans R1 _ (CRplus R1 x (CRplus R1 y (CRopp R1 y)))). - apply CReq_sym, Radd_assoc. - apply (CReq_trans R1 _ (CRplus R1 x (CRzero R1))). 2: apply CRplus_0_r. - destruct (CRisRingExt R1). apply Radd_ext. - apply CReq_refl. apply Ropp_def. - apply (CRplus_lt_reg_r R2 (CRmorph R1 R2 f y)). - apply (CRlt_le_trans R2 _ _ _ abs). clear abs. - apply (CRle_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRplus R1 x y)) (CRzero R2))). - destruct (CRplus_0_r R2 (CRmorph R1 R2 f (CRplus R1 x y))). exact H. - apply (CRle_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRplus R1 x y)) - (CRplus R2 (CRmorph R1 R2 f (CRopp R1 y)) (CRmorph R1 R2 f y)))). - apply CRplus_le_compat_l. - apply (CRle_trans R2 _ (CRplus R2 (CRopp R2 (CRmorph R1 R2 f y)) (CRmorph R1 R2 f y))). - destruct (CRplus_opp_l R2 (CRmorph R1 R2 f y)). exact H. - apply CRplus_le_compat_r. destruct (CRmorph_opp _ _ f y). exact H. - destruct (CRisRing R2). - destruct (Radd_assoc (CRmorph R1 R2 f (CRplus R1 x y)) - (CRmorph R1 R2 f (CRopp R1 y)) (CRmorph R1 R2 f y)). - exact H0. -Qed. - -Lemma CRmorph_mult_pos : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) (n : nat), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))) - (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (Z.of_nat n # 1))). -Proof. - induction n. - - simpl. destruct (CRisRingExt R1). - apply (CReq_trans R2 _ (CRzero R2)). - + apply (CReq_trans R2 _ (CRmorph R1 R2 f (CRzero R1))). - 2: apply CRmorph_zero. apply CRmorph_proper. - apply (CReq_trans R1 _ (CRmult R1 x (CRzero R1))). - 2: apply CRmult_0_r. apply Rmul_ext. apply CReq_refl. apply CR_of_Q_zero. - + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRzero R2))). - apply CReq_sym, CRmult_0_r. destruct (CRisRingExt R2). - apply Rmul_ext0. apply CReq_refl. apply CReq_sym, CR_of_Q_zero. - - destruct (CRisRingExt R1), (CRisRingExt R2). - apply (CReq_trans - R2 _ (CRmorph R1 R2 f (CRplus R1 x (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). - apply CRmorph_proper. - apply (CReq_trans R1 _ (CRmult R1 x (CRplus R1 (CRone R1) (CR_of_Q R1 (Z.of_nat n # 1))))). - apply Rmul_ext. apply CReq_refl. - apply (CReq_trans R1 _ (CR_of_Q R1 (1 + (Z.of_nat n # 1)))). - apply CR_of_Q_proper. rewrite Nat2Z.inj_succ. unfold Z.succ. - rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. - apply (CReq_trans R1 _ (CRplus R1 (CR_of_Q R1 1) (CR_of_Q R1 (Z.of_nat n # 1)))). - apply CR_of_Q_plus. apply Radd_ext. apply CR_of_Q_one. apply CReq_refl. - apply (CReq_trans R1 _ (CRplus R1 (CRmult R1 x (CRone R1)) - (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))))). - apply CRmult_plus_distr_l. apply Radd_ext. apply CRmult_1_r. apply CReq_refl. - apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f x) - (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). - apply CRmorph_plus. - apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f x) - (CRmult R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (Z.of_nat n # 1))))). - apply Radd_ext0. apply CReq_refl. exact IHn. - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRplus R2 (CRone R2) (CR_of_Q R2 (Z.of_nat n # 1))))). - apply (CReq_trans R2 _ (CRplus R2 (CRmult R2 (CRmorph R1 R2 f x) (CRone R2)) - (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (Z.of_nat n # 1))))). - apply Radd_ext0. 2: apply CReq_refl. apply CReq_sym, CRmult_1_r. - apply CReq_sym, CRmult_plus_distr_l. - apply Rmul_ext0. apply CReq_refl. - apply (CReq_trans R2 _ (CR_of_Q R2 (1 + (Z.of_nat n # 1)))). - apply (CReq_trans R2 _ (CRplus R2 (CR_of_Q R2 1) (CR_of_Q R2 (Z.of_nat n # 1)))). - apply Radd_ext0. apply CReq_sym, CR_of_Q_one. apply CReq_refl. - apply CReq_sym, CR_of_Q_plus. - apply CR_of_Q_proper. rewrite Nat2Z.inj_succ. unfold Z.succ. - rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. -Qed. - -Lemma NatOfZ : forall n : Z, { p : nat | n = Z.of_nat p \/ n = Z.opp (Z.of_nat p) }. -Proof. - intros [|p|n]. - - exists O. left. reflexivity. - - exists (Pos.to_nat p). left. rewrite positive_nat_Z. reflexivity. - - exists (Pos.to_nat n). right. rewrite positive_nat_Z. reflexivity. -Qed. - -Lemma CRmorph_mult_int : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) (n : Z), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (n # 1)))) - (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (n # 1))). -Proof. - intros. destruct (NatOfZ n) as [p [pos|neg]]. - - subst n. apply CRmorph_mult_pos. - - subst n. - apply (CReq_trans R2 _ (CRopp R2 (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). - + apply (CReq_trans R2 _ (CRmorph R1 R2 f (CRopp R1 (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). - 2: apply CRmorph_opp. apply CRmorph_proper. - apply (CReq_trans R1 _ (CRmult R1 x (CR_of_Q R1 (- (Z.of_nat p # 1))))). - destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. - apply CR_of_Q_proper. reflexivity. - apply (CReq_trans R1 _ (CRmult R1 x (CRopp R1 (CR_of_Q R1 (Z.of_nat p # 1))))). - destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. - apply CR_of_Q_opp. apply CReq_sym, CRopp_mult_distr_r. - + apply (CReq_trans R2 _ (CRopp R2 (CRmult R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (Z.of_nat p # 1))))). - destruct (CRisRingExt R2). apply Ropp_ext. apply CRmorph_mult_pos. - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRopp R2 (CR_of_Q R2 (Z.of_nat p # 1))))). - apply CRopp_mult_distr_r. destruct (CRisRingExt R2). - apply Rmul_ext. apply CReq_refl. - apply (CReq_trans R2 _ (CR_of_Q R2 (- (Z.of_nat p # 1)))). - apply CReq_sym, CR_of_Q_opp. apply CR_of_Q_proper. reflexivity. -Qed. - -Lemma CRmorph_mult_inv : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) (p : positive), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (1 # p)))) - (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (1 # p))). -Proof. - intros. apply (CRmult_eq_reg_r R2 (CR_of_Q R2 (Z.pos p # 1))). - left. apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. - apply (CReq_trans R2 _ (CRmorph _ _ f x)). - - apply (CReq_trans - R2 _ (CRmorph R1 R2 f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (1 # p))) - (CR_of_Q R1 (Z.pos p # 1))))). - apply CReq_sym, CRmorph_mult_int. apply CRmorph_proper. - apply (CReq_trans - R1 _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (1 # p)) - (CR_of_Q R1 (Z.pos p # 1))))). - destruct (CRisRing R1). apply CReq_sym, Rmul_assoc. - apply (CReq_trans R1 _ (CRmult R1 x (CRone R1))). - apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. - apply (CReq_trans R1 _ (CR_of_Q R1 ((1#p) * (Z.pos p # 1)))). - apply CReq_sym, CR_of_Q_mult. - apply (CReq_trans R1 _ (CR_of_Q R1 1)). - apply CR_of_Q_proper. reflexivity. apply CR_of_Q_one. - apply CRmult_1_r. - - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) - (CRmult R2 (CR_of_Q R2 (1 # p)) (CR_of_Q R2 (Z.pos p # 1))))). - 2: apply (Rmul_assoc (CRisRing R2)). - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRone R2))). - apply CReq_sym, CRmult_1_r. - apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. - apply (CReq_trans R2 _ (CR_of_Q R2 1)). - apply CReq_sym, CR_of_Q_one. - apply (CReq_trans R2 _ (CR_of_Q R2 ((1#p)*(Z.pos p # 1)))). - apply CR_of_Q_proper. reflexivity. apply CR_of_Q_mult. -Qed. - -Lemma CRmorph_mult_rat : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) (q : Q), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 q))) - (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 q)). -Proof. - intros. destruct q as [a b]. - apply (CReq_trans R2 _ (CRmult R2 (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (a # 1)))) - (CR_of_Q R2 (1 # b)))). - - apply (CReq_trans - R2 _ (CRmorph R1 R2 f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (a # 1))) - (CR_of_Q R1 (1 # b))))). - 2: apply CRmorph_mult_inv. apply CRmorph_proper. - apply (CReq_trans R1 _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (a # 1)) - (CR_of_Q R1 (1 # b))))). - apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. - apply (CReq_trans R1 _ (CR_of_Q R1 ((a#1)*(1#b)))). - apply CR_of_Q_proper. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. - apply CR_of_Q_mult. - apply (Rmul_assoc (CRisRing R1)). - - apply (CReq_trans R2 _ (CRmult R2 (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (a # 1))) - (CR_of_Q R2 (1 # b)))). - apply (Rmul_ext (CRisRingExt R2)). apply CRmorph_mult_int. - apply CReq_refl. - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) - (CRmult R2 (CR_of_Q R2 (a # 1)) (CR_of_Q R2 (1 # b))))). - apply CReq_sym, (Rmul_assoc (CRisRing R2)). - apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. - apply (CReq_trans R2 _ (CR_of_Q R2 ((a#1)*(1#b)))). - apply CReq_sym, CR_of_Q_mult. - apply CR_of_Q_proper. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. -Qed. - -Lemma CRmorph_mult_pos_pos_le : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - CRlt R1 (CRzero R1) y - -> orderLe _ (CRlt R2) (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) - (CRmorph _ _ f (CRmult R1 x y)). -Proof. - intros. intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. - destruct (CRmorph_rat _ _ f q) as [H3 _]. - apply (CRlt_le_trans R2 _ _ _ H1) in H3. clear H1. - apply CRmorph_increasing_inv in H3. - apply (CRlt_asym R1 _ _ H3). clear H3. - destruct (CR_Q_dense R2 _ _ H2) as [r [H1 H3]]. - apply lt_CR_of_Q in H1. - destruct (CR_archimedean R1 y) as [A Amaj]. - assert (/ ((r - q) * (1 # A)) * (q - r) == - (Z.pos A # 1)) as diveq. - { rewrite Qinv_mult_distr. setoid_replace (q-r) with (-1*(r-q)). - field_simplify. reflexivity. 2: field. - split. intro H4. inversion H4. intro H4. - apply Qlt_minus_iff in H1. rewrite H4 in H1. inversion H1. } - destruct (CR_Q_dense R1 (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A)))) x) - as [s [H4 H5]]. - - apply (CRlt_le_trans R1 _ (CRplus R1 x (CRzero R1))). - 2: apply CRplus_0_r. apply CRplus_lt_compat_l. - apply (CRplus_lt_reg_l R1 (CR_of_Q R1 ((r-q) * (1#A)))). - apply (CRle_lt_trans R1 _ (CRzero R1)). - apply (CRle_trans R1 _ (CR_of_Q R1 ((r-q)*(1#A) + (q-r)*(1#A)))). - destruct (CR_of_Q_plus R1 ((r-q)*(1#A)) ((q-r)*(1#A))). - exact H0. apply (CRle_trans R1 _ (CR_of_Q R1 0)). - 2: destruct (CR_of_Q_zero R1); exact H4. - intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. - inversion H4. - apply (CRlt_le_trans R1 _ (CR_of_Q R1 ((r - q) * (1 # A)))). - 2: apply CRplus_0_r. - apply (CRle_lt_trans R1 _ (CR_of_Q R1 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. - rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. - apply Qlt_minus_iff in H1. exact H1. reflexivity. - - apply (CRmorph_increasing _ _ f) in H4. - destruct (CRmorph_plus _ _ f x (CR_of_Q R1 ((q-r) * (1#A)))) as [H6 _]. - apply (CRle_lt_trans R2 _ _ _ H6) in H4. clear H6. - destruct (CRmorph_rat _ _ f s) as [_ H6]. - apply (CRlt_le_trans R2 _ _ _ H4) in H6. clear H4. - apply (CRmult_lt_compat_r R2 (CRmorph _ _ f y)) in H6. - destruct (Rdistr_l (CRisRing R2) (CRmorph _ _ f x) - (CRmorph R1 R2 f (CR_of_Q R1 ((q-r) * (1#A)))) - (CRmorph _ _ f y)) as [H4 _]. - apply (CRle_lt_trans R2 _ _ _ H4) in H6. clear H4. - apply (CRle_lt_trans R1 _ (CRmult R1 (CR_of_Q R1 s) y)). - 2: apply CRmult_lt_compat_r. 2: exact H. 2: exact H5. - apply (CRmorph_le_inv _ _ f). - apply (CRle_trans R2 _ (CR_of_Q R2 q)). - destruct (CRmorph_rat _ _ f q). exact H4. - apply (CRle_trans R2 _ (CRmult R2 (CR_of_Q R2 s) (CRmorph _ _ f y))). - apply (CRle_trans R2 _ (CRplus R2 (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) - (CR_of_Q R2 (q-r)))). - apply (CRle_trans R2 _ (CRplus R2 (CR_of_Q R2 r) (CR_of_Q R2 (q - r)))). - + apply (CRle_trans R2 _ (CR_of_Q R2 (r + (q-r)))). - intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. - exact (Qlt_not_le q q H4 (Qle_refl q)). - destruct (CR_of_Q_plus R2 r (q-r)). exact H4. - + apply CRplus_le_compat_r. intro H4. - apply (CRlt_asym R2 _ _ H3). exact H4. - + intro H4. apply (CRlt_asym R2 _ _ H4). clear H4. - apply (CRlt_trans_flip R2 _ _ _ H6). clear H6. - apply CRplus_lt_compat_l. - apply (CRlt_le_trans R2 _ (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) (CRmorph R1 R2 f y))). - apply (CRmult_lt_reg_l R2 (CR_of_Q R2 (/((r-q)*(1#A))))). - apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). apply CR_of_Q_zero. - apply CR_of_Q_lt, Qinv_lt_0_compat. - rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. - apply Qlt_minus_iff in H1. exact H1. reflexivity. - apply (CRle_lt_trans R2 _ (CRopp R2 (CR_of_Q R2 (Z.pos A # 1)))). - apply (CRle_trans R2 _ (CR_of_Q R2 (-(Z.pos A # 1)))). - apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) * (q - r)))). - destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) (q - r)). - exact H0. destruct (CR_of_Q_proper R2 (/ ((r - q) * (1 # A)) * (q - r)) - (-(Z.pos A # 1))). - exact diveq. intro H7. apply lt_CR_of_Q in H7. - rewrite diveq in H7. exact (Qlt_not_le _ _ H7 (Qle_refl _)). - destruct (CR_of_Q_opp R2 (Z.pos A # 1)). exact H4. - apply (CRlt_le_trans R2 _ (CRopp R2 (CRmorph _ _ f y))). - apply CRopp_gt_lt_contravar. - apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 (Z.pos A # 1)))). - apply CRmorph_increasing. exact Amaj. - destruct (CRmorph_rat _ _ f (Z.pos A # 1)). exact H4. - apply (CRle_trans R2 _ (CRmult R2 (CRopp R2 (CRone R2)) (CRmorph _ _ f y))). - apply (CRle_trans R2 _ (CRopp R2 (CRmult R2 (CRone R2) (CRmorph R1 R2 f y)))). - destruct (Ropp_ext (CRisRingExt R2) (CRmorph _ _ f y) - (CRmult R2 (CRone R2) (CRmorph R1 R2 f y))). - apply CReq_sym, (Rmul_1_l (CRisRing R2)). exact H4. - destruct (CRopp_mult_distr_l R2 (CRone R2) (CRmorph _ _ f y)). exact H4. - apply (CRle_trans R2 _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((r - q) * (1 # A)))) - (CR_of_Q R2 ((q - r) * (1 # A)))) - (CRmorph R1 R2 f y))). - apply CRmult_le_compat_r. - apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. - apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) - * ((q - r) * (1 # A))))). - apply (CRle_trans R2 _ (CR_of_Q R2 (-1))). - apply (CRle_trans R2 _ (CRopp R2 (CR_of_Q R2 1))). - destruct (Ropp_ext (CRisRingExt R2) (CRone R2) (CR_of_Q R2 1)). - apply CReq_sym, CR_of_Q_one. exact H4. - destruct (CR_of_Q_opp R2 1). exact H0. - destruct (CR_of_Q_proper R2 (-1) (/ ((r - q) * (1 # A)) * ((q - r) * (1 # A)))). - field. split. - intro H4. inversion H4. intro H4. apply Qlt_minus_iff in H1. - rewrite H4 in H1. inversion H1. exact H4. - destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) ((q - r) * (1 # A))). - exact H4. - destruct (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((r - q) * (1 # A)))) - (CR_of_Q R2 ((q - r) * (1 # A))) - (CRmorph R1 R2 f y)). - exact H0. - apply CRmult_le_compat_r. - apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. - destruct (CRmorph_rat _ _ f ((q - r) * (1 # A))). exact H0. - + apply (CRle_trans R2 _ (CRmorph _ _ f (CRmult R1 y (CR_of_Q R1 s)))). - apply (CRle_trans R2 _ (CRmult R2 (CRmorph R1 R2 f y) (CR_of_Q R2 s))). - destruct (Rmul_comm (CRisRing R2) (CRmorph R1 R2 f y) (CR_of_Q R2 s)). - exact H0. - destruct (CRmorph_mult_rat _ _ f y s). exact H0. - destruct (CRmorph_proper _ _ f (CRmult R1 y (CR_of_Q R1 s)) - (CRmult R1 (CR_of_Q R1 s) y)). - apply (Rmul_comm (CRisRing R1)). exact H4. - + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. -Qed. - -Lemma CRmorph_mult_pos_pos : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - CRlt R1 (CRzero R1) y - -> orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x y)) - (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). -Proof. - split. apply CRmorph_mult_pos_pos_le. exact H. - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. - destruct (CRmorph_rat _ _ f q) as [_ H3]. - apply (CRle_lt_trans R2 _ _ _ H3) in H2. clear H3. - apply CRmorph_increasing_inv in H2. - apply (CRlt_asym R1 _ _ H2). clear H2. - destruct (CR_Q_dense R2 _ _ H1) as [r [H2 H3]]. - apply lt_CR_of_Q in H3. - destruct (CR_archimedean R1 y) as [A Amaj]. - destruct (CR_Q_dense R1 x (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A))))) - as [s [H4 H5]]. - - apply (CRle_lt_trans R1 _ (CRplus R1 x (CRzero R1))). - apply CRplus_0_r. apply CRplus_lt_compat_l. - apply (CRle_lt_trans R1 _ (CR_of_Q R1 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. - rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. - apply Qlt_minus_iff in H3. exact H3. reflexivity. - - apply (CRmorph_increasing _ _ f) in H5. - destruct (CRmorph_plus _ _ f x (CR_of_Q R1 ((q-r) * (1#A)))) as [_ H6]. - apply (CRlt_le_trans R2 _ _ _ H5) in H6. clear H5. - destruct (CRmorph_rat _ _ f s) as [H5 _ ]. - apply (CRle_lt_trans R2 _ _ _ H5) in H6. clear H5. - apply (CRmult_lt_compat_r R2 (CRmorph _ _ f y)) in H6. - apply (CRlt_le_trans R1 _ (CRmult R1 (CR_of_Q R1 s) y)). - apply CRmult_lt_compat_r. exact H. exact H4. clear H4. - apply (CRmorph_le_inv _ _ f). - apply (CRle_trans R2 _ (CR_of_Q R2 q)). - 2: destruct (CRmorph_rat _ _ f q); exact H0. - apply (CRle_trans R2 _ (CRmult R2 (CR_of_Q R2 s) (CRmorph R1 R2 f y))). - + apply (CRle_trans R2 _ (CRmorph _ _ f (CRmult R1 y (CR_of_Q R1 s)))). - destruct (CRmorph_proper _ _ f (CRmult R1 (CR_of_Q R1 s) y) - (CRmult R1 y (CR_of_Q R1 s))). - apply (Rmul_comm (CRisRing R1)). exact H4. - apply (CRle_trans R2 _ (CRmult R2 (CRmorph R1 R2 f y) (CR_of_Q R2 s))). - exact (proj2 (CRmorph_mult_rat _ _ f y s)). - destruct (Rmul_comm (CRisRing R2) (CR_of_Q R2 s) (CRmorph R1 R2 f y)). - exact H0. - + intro H5. apply (CRlt_asym R2 _ _ H5). clear H5. - apply (CRlt_trans R2 _ _ _ H6). clear H6. - apply (CRle_lt_trans - R2 _ (CRplus R2 - (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) - (CRmult R2 (CRmorph R1 R2 f (CR_of_Q R1 ((q - r) * (1 # A)))) - (CRmorph R1 R2 f y)))). - apply (Rdistr_l (CRisRing R2)). - apply (CRle_lt_trans - R2 _ (CRplus R2 (CR_of_Q R2 r) - (CRmult R2 (CRmorph R1 R2 f (CR_of_Q R1 ((q - r) * (1 # A)))) - (CRmorph R1 R2 f y)))). - apply CRplus_le_compat_r. intro H5. apply (CRlt_asym R2 _ _ H5 H2). - clear H2. - apply (CRle_lt_trans - R2 _ (CRplus R2 (CR_of_Q R2 r) - (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) - (CRmorph R1 R2 f y)))). - apply CRplus_le_compat_l, CRmult_le_compat_r. - apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. - destruct (CRmorph_rat _ _ f ((q - r) * (1 # A))). exact H2. - apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 r) - (CR_of_Q R2 ((q - r))))). - apply CRplus_lt_compat_l. - * apply (CRmult_lt_reg_l R2 (CR_of_Q R2 (/((q - r) * (1 # A))))). - apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). apply CR_of_Q_zero. - apply CR_of_Q_lt, Qinv_lt_0_compat. - rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. - apply Qlt_minus_iff in H3. exact H3. reflexivity. - apply (CRle_lt_trans R2 _ (CRmorph _ _ f y)). - apply (CRle_trans R2 _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((q - r) * (1 # A)))) - (CR_of_Q R2 ((q - r) * (1 # A)))) - (CRmorph R1 R2 f y))). - exact (proj2 (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((q - r) * (1 # A)))) - (CR_of_Q R2 ((q - r) * (1 # A))) - (CRmorph _ _ f y))). - apply (CRle_trans R2 _ (CRmult R2 (CRone R2) (CRmorph R1 R2 f y))). - apply CRmult_le_compat_r. - apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. - apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * ((q - r) * (1 # A))))). - exact (proj1 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) ((q - r) * (1 # A)))). - apply (CRle_trans R2 _ (CR_of_Q R2 1)). - destruct (CR_of_Q_proper R2 (/ ((q - r) * (1 # A)) * ((q - r) * (1 # A))) 1). - field_simplify. reflexivity. split. - intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. - rewrite H5 in H3. inversion H3. exact H2. - destruct (CR_of_Q_one R2). exact H2. - destruct (Rmul_1_l (CRisRing R2) (CRmorph _ _ f y)). - intro H5. contradiction. - apply (CRlt_le_trans R2 _ (CR_of_Q R2 (Z.pos A # 1))). - apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 (Z.pos A # 1)))). - apply CRmorph_increasing. exact Amaj. - exact (proj2 (CRmorph_rat _ _ f (Z.pos A # 1))). - apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * (q - r)))). - 2: exact (proj2 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) (q - r))). - destruct (CR_of_Q_proper R2 (Z.pos A # 1) (/ ((q - r) * (1 # A)) * (q - r))). - field_simplify. reflexivity. split. - intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. - rewrite H5 in H3. inversion H3. exact H2. - * apply (CRle_trans R2 _ (CR_of_Q R2 (r + (q-r)))). - exact (proj1 (CR_of_Q_plus R2 r (q-r))). - destruct (CR_of_Q_proper R2 (r + (q-r)) q). ring. exact H2. - + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. -Qed. - -Lemma CRmorph_mult : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x y)) - (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). -Proof. - intros. - destruct (CR_archimedean R1 (CRopp R1 y)) as [p pmaj]. - apply (CRplus_eq_reg_r R2 (CRmult R2 (CRmorph _ _ f x) - (CR_of_Q R2 (Z.pos p # 1)))). - apply (CReq_trans R2 _ (CRmorph _ _ f (CRmult R1 x (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). - - apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRmult R1 x y)) - (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). - apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. - apply CReq_sym, CRmorph_mult_int. - apply (CReq_trans R2 _ (CRmorph _ _ f (CRplus R1 (CRmult R1 x y) - (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). - apply CReq_sym, CRmorph_plus. apply CRmorph_proper. - apply CReq_sym, CRmult_plus_distr_l. - - apply (CReq_trans R2 _ (CRmult R2 (CRmorph _ _ f x) - (CRmorph _ _ f (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). - apply CRmorph_mult_pos_pos. - apply (CRplus_lt_compat_l R1 y) in pmaj. - apply (CRle_lt_trans R1 _ (CRplus R1 y (CRopp R1 y))). - 2: exact pmaj. apply (CRisRing R1). - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) - (CRplus R2 (CRmorph R1 R2 f y) (CR_of_Q R2 (Z.pos p # 1))))). - apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. - apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f y) - (CRmorph _ _ f (CR_of_Q R1 (Z.pos p # 1))))). - apply CRmorph_plus. - apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. - apply CRmorph_rat. - apply CRmult_plus_distr_l. -Qed. - -Lemma CRmorph_appart : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1) - (app : orderAppart _ (CRlt R1) x y), - orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). -Proof. - intros. destruct app. - - left. apply CRmorph_increasing. exact c. - - right. apply CRmorph_increasing. exact c. -Defined. - -Lemma CRmorph_appart_zero : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) - (app : orderAppart _ (CRlt R1) x (CRzero R1)), - orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRzero R2). -Proof. - intros. destruct app. - - left. apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_increasing. exact c. - exact (proj2 (CRmorph_zero _ _ f)). - - right. apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - exact (proj1 (CRmorph_zero _ _ f)). - apply CRmorph_increasing. exact c. -Defined. - -Lemma CRmorph_inv : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) - (xnz : orderAppart _ (CRlt R1) x (CRzero R1)) - (fxnz : orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRzero R2)), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRinv R1 x xnz)) - (CRinv R2 (CRmorph _ _ f x) fxnz). -Proof. - intros. apply (CRmult_eq_reg_r R2 (CRmorph _ _ f x)). - destruct fxnz. right. exact c. left. exact c. - apply (CReq_trans R2 _ (CRone R2)). - 2: apply CReq_sym, CRinv_l. - apply (CReq_trans R2 _ (CRmorph _ _ f (CRmult R1 (CRinv R1 x xnz) x))). - apply CReq_sym, CRmorph_mult. - apply (CReq_trans R2 _ (CRmorph _ _ f (CRone R1))). - apply CRmorph_proper. apply CRinv_l. - apply CRmorph_one. -Qed. - -Definition CauchyMorph (R : ConstructiveReals) - : CReal -> CRcarrier R. -Proof. - intros [xn xcau]. - destruct (CR_complete R (fun n:nat => CR_of_Q R (xn n))). - - intros p. exists (Pos.to_nat p). intros. - specialize (xcau p i j H H0). apply Qlt_le_weak in xcau. - rewrite Qabs_Qle_condition in xcau. split. - + unfold CRminus. - apply (CRle_trans R _ (CRplus R (CR_of_Q R (xn i)) (CR_of_Q R (-xn j)))). - apply (CRle_trans R _ (CR_of_Q R (xn i-xn j))). - apply CR_of_Q_le. apply xcau. exact (proj2 (CR_of_Q_plus R _ _)). - apply CRplus_le_compat_l. exact (proj2 (CR_of_Q_opp R (xn j))). - + unfold CRminus. - apply (CRle_trans R _ (CRplus R (CR_of_Q R (xn i)) (CR_of_Q R (-xn j)))). - apply CRplus_le_compat_l. exact (proj1 (CR_of_Q_opp R (xn j))). - apply (CRle_trans R _ (CR_of_Q R (xn i-xn j))). - exact (proj1 (CR_of_Q_plus R _ _)). - apply CR_of_Q_le. apply xcau. - - exact x. -Defined. - -Lemma CauchyMorph_rat : forall (R : ConstructiveReals) (q : Q), - orderEq _ (CRlt R) (CauchyMorph R (inject_Q q)) (CR_of_Q R q). -Proof. - intros. - unfold CauchyMorph; simpl; - destruct (CRltLinear R), p, (CR_complete R (fun _ : nat => CR_of_Q R q)). - apply CR_cv_const in c0. apply CReq_sym. exact c0. -Qed. - -Lemma CauchyMorph_increasing_Ql : forall (R : ConstructiveReals) (x : CReal) (q : Q), - CRealLt x (inject_Q q) -> CRlt R (CauchyMorph R x) (CR_of_Q R q). -Proof. - intros. - unfold CauchyMorph; simpl; - destruct x as [xn xcau], (CRltLinear R), p, (CR_complete R (fun n : nat => CR_of_Q R (xn n))). - destruct (CRealQ_dense _ _ H) as [r [H0 H1]]. - apply lt_inject_Q in H1. - destruct (s _ x _ (CR_of_Q_lt R _ _ H1)). 2: exact c1. exfalso. - clear H1 H q. - (* For an index high enough, xn should be both higher - and lower than r, which is absurd. *) - apply CRealLt_above in H0. - destruct H0 as [p pmaj]. simpl in pmaj. - destruct (CR_cv_above_rat R xn x r c0 c1). - assert (x0 <= Nat.max (Pos.to_nat p) (S x0))%nat. - { apply (le_trans _ (S x0)). apply le_S, le_refl. apply Nat.le_max_r. } - specialize (q (Nat.max (Pos.to_nat p) (S x0)) H). clear H. - specialize (pmaj (Pos.max p (Pos.of_nat (S x0))) (Pos.le_max_l _ _)). - rewrite Pos2Nat.inj_max, Nat2Pos.id in pmaj. 2: discriminate. - apply (Qlt_not_le _ _ q). apply Qlt_le_weak. - apply Qlt_minus_iff. apply (Qlt_trans _ (2#p)). reflexivity. exact pmaj. -Qed. - -Lemma CauchyMorph_increasing_Qr : forall (R : ConstructiveReals) (x : CReal) (q : Q), - CRealLt (inject_Q q) x -> CRlt R (CR_of_Q R q) (CauchyMorph R x). -Proof. - intros. - unfold CauchyMorph; simpl; - destruct x as [xn xcau], (CRltLinear R), p, (CR_complete R (fun n : nat => CR_of_Q R (xn n))). - destruct (CRealQ_dense _ _ H) as [r [H0 H1]]. - apply lt_inject_Q in H0. - destruct (s _ x _ (CR_of_Q_lt R _ _ H0)). exact c1. exfalso. - clear H0 H q. - (* For an index high enough, xn should be both higher - and lower than r, which is absurd. *) - apply CRealLt_above in H1. - destruct H1 as [p pmaj]. simpl in pmaj. - destruct (CR_cv_below_rat R xn x r c0 c1). - assert (x0 <= Nat.max (Pos.to_nat p) (S x0))%nat. - { apply (le_trans _ (S x0)). apply le_S, le_refl. apply Nat.le_max_r. } - specialize (q (Nat.max (Pos.to_nat p) (S x0)) H). clear H. - specialize (pmaj (Pos.max p (Pos.of_nat (S x0))) (Pos.le_max_l _ _)). - rewrite Pos2Nat.inj_max, Nat2Pos.id in pmaj. 2: discriminate. - apply (Qlt_not_le _ _ q). apply Qlt_le_weak. - apply Qlt_minus_iff. apply (Qlt_trans _ (2#p)). reflexivity. exact pmaj. -Qed. - -Lemma CauchyMorph_increasing : forall (R : ConstructiveReals) (x y : CReal), - CRealLt x y -> CRlt R (CauchyMorph R x) (CauchyMorph R y). -Proof. - intros. - destruct (CRealQ_dense _ _ H) as [q [H0 H1]]. - apply (CRlt_trans R _ (CR_of_Q R q)). - apply CauchyMorph_increasing_Ql. exact H0. - apply CauchyMorph_increasing_Qr. exact H1. -Qed. - -Definition CauchyMorphism (R : ConstructiveReals) : ConstructiveRealsMorphism CRealImplem R. -Proof. - apply (Build_ConstructiveRealsMorphism CRealImplem R (CauchyMorph R)). - exact (CauchyMorph_rat R). - exact (CauchyMorph_increasing R). -Defined. - -Lemma RightBound : forall (R : ConstructiveReals) (x : CRcarrier R) (p q r : Q), - CRlt R x (CR_of_Q R q) - -> CRlt R x (CR_of_Q R r) - -> CRlt R (CR_of_Q R q) (CRplus R x (CR_of_Q R p)) - -> CRlt R (CR_of_Q R r) (CRplus R x (CR_of_Q R p)) - -> Qlt (Qabs (q - r)) p. -Proof. - intros. apply Qabs_case. - - intros. apply (Qplus_lt_l _ _ r). ring_simplify. - apply (lt_CR_of_Q R), (CRlt_le_trans R _ _ _ H1). - apply (CRle_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R p))). - intro abs. apply CRplus_lt_reg_r in abs. - exact (CRlt_asym R _ _ abs H0). - destruct (CR_of_Q_plus R r p). exact H4. - - intros. apply (Qplus_lt_l _ _ q). ring_simplify. - apply (lt_CR_of_Q R), (CRlt_le_trans R _ _ _ H2). - apply (CRle_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R p))). - intro abs. apply CRplus_lt_reg_r in abs. - exact (CRlt_asym R _ _ abs H). - destruct (CR_of_Q_plus R q p). exact H4. -Qed. - -Definition CauchyMorph_inv (R : ConstructiveReals) - : CRcarrier R -> CReal. -Proof. - intro x. - exists (fun n:nat => let (q,_) := CR_Q_dense - R x _ (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S n)) (eq_refl _)) - in q). - intros n p q H0 H1. - destruct (CR_Q_dense R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S p)))) - (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S p)) (eq_refl _))) - as [r [H2 H3]]. - destruct (CR_Q_dense R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S q)))) - (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S q)) (eq_refl _))) - as [s [H4 H5]]. - apply (RightBound R x (1#n) r s). exact H2. exact H4. - apply (CRlt_trans R _ _ _ H3), CRplus_lt_compat_l, CR_of_Q_lt. - unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. - apply Pos2Z.pos_lt_pos, Pos2Nat.inj_lt. rewrite Nat2Pos.id. - 2: discriminate. apply le_n_S. exact H0. - apply (CRlt_trans R _ _ _ H5), CRplus_lt_compat_l, CR_of_Q_lt. - unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. - apply Pos2Z.pos_lt_pos, Pos2Nat.inj_lt. rewrite Nat2Pos.id. - 2: discriminate. apply le_n_S. exact H1. -Defined. - -Lemma CauchyMorph_inv_rat : forall (R : ConstructiveReals) (q : Q), - CRealEq (CauchyMorph_inv R (CR_of_Q R q)) (inject_Q q). -Proof. - split. - - intros [n nmaj]. unfold CauchyMorph_inv, proj1_sig, inject_Q in nmaj. - destruct (CR_Q_dense R (CR_of_Q R q) - (CRplus R (CR_of_Q R q) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat n))))) - (CRplus_pos_rat_lt R (CR_of_Q R q) (1 # Pos.of_nat (S (Pos.to_nat n))) - eq_refl)) - as [r [H _]]. - apply lt_CR_of_Q, Qlt_minus_iff in H. - apply (Qlt_not_le _ _ H), (Qplus_le_l _ _ (q-r)). - ring_simplify. apply (Qle_trans _ (2#n)). discriminate. - apply Qlt_le_weak. ring_simplify in nmaj. rewrite Qplus_comm. exact nmaj. - - intros [n nmaj]. unfold CauchyMorph_inv, proj1_sig, inject_Q in nmaj. - destruct (CR_Q_dense R (CR_of_Q R q) - (CRplus R (CR_of_Q R q) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat n))))) - (CRplus_pos_rat_lt R (CR_of_Q R q) (1 # Pos.of_nat (S (Pos.to_nat n))) - eq_refl)) - as [r [_ H0]]. - destruct (CR_of_Q_plus R q (1 # Pos.of_nat (S (Pos.to_nat n)))) as [H1 _]. - apply (CRlt_le_trans R _ _ _ H0) in H1. clear H0. - apply lt_CR_of_Q, (Qplus_lt_l _ _ (-q)) in H1. - ring_simplify in H1. ring_simplify in nmaj. - apply (Qlt_trans _ _ _ nmaj) in H1. clear nmaj. - apply (Qlt_not_le _ _ H1). clear H1. - apply (Qle_trans _ (1#n)). - unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. - apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. - rewrite Nat2Pos.id. 2: discriminate. apply le_S, le_refl. - unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. - 2: discriminate. apply Pos2Z.pos_is_nonneg. -Qed. - -(* The easier side, because CauchyMorph_inv takes a limit from above. *) -Lemma CauchyMorph_inv_increasing_Qr - : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), - CRlt R (CR_of_Q R q) x -> CRealLt (inject_Q q) (CauchyMorph_inv R x). -Proof. - intros. - destruct (CR_Q_dense R _ _ H) as [r [H2 H3]]. - apply lt_CR_of_Q in H2. - destruct (Qarchimedean (/(r-q))) as [p pmaj]. - exists (2*p)%positive. unfold CauchyMorph_inv, inject_Q, proj1_sig. - destruct (CR_Q_dense - R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (2*p)))))) - (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S (Pos.to_nat (2*p)))) eq_refl)) - as [t [H4 H5]]. - setoid_replace (2#2*p) with (1#p). 2: reflexivity. - apply (Qlt_trans _ (r-q)). - apply (Qmult_lt_l _ _ (r-q)) in pmaj. - rewrite Qmult_inv_r in pmaj. - apply Qlt_shift_inv_r in pmaj. 2: reflexivity. exact pmaj. - intro abs. apply Qlt_minus_iff in H2. - rewrite abs in H2. inversion H2. - apply Qlt_minus_iff in H2. exact H2. - apply Qplus_lt_l, (lt_CR_of_Q R), (CRlt_trans R _ x _ H3 H4). -Qed. - -Lemma CauchyMorph_inv_increasing : forall (R : ConstructiveReals) (x y : CRcarrier R), - CRlt R x y -> CRealLt (CauchyMorph_inv R x) (CauchyMorph_inv R y). -Proof. - intros. - destruct (CR_Q_dense R _ _ H) as [q [H0 H1]]. - apply (CReal_lt_trans _ (inject_Q q)). - - clear H1 H y. - destruct (CR_Q_dense R _ _ H0) as [r [H2 H3]]. - apply lt_CR_of_Q in H3. - destruct (Qarchimedean (/(q-r))) as [p pmaj]. - exists (4*p)%positive. unfold CauchyMorph_inv, inject_Q, proj1_sig. - destruct (CR_Q_dense - R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (4*p)))))) - (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S (Pos.to_nat (4*p)))) eq_refl)) - as [t [H4 H5]]. - setoid_replace (2#4*p) with (1#2*p). 2: reflexivity. - assert (1 # 2 * p < (q - r) / 2) as H. - { apply Qlt_shift_div_l. reflexivity. - setoid_replace ((1#2*p)*2) with (1#p). - apply (Qmult_lt_l _ _ (q-r)) in pmaj. - rewrite Qmult_inv_r in pmaj. - apply Qlt_shift_inv_r in pmaj. 2: reflexivity. exact pmaj. - intro abs. apply Qlt_minus_iff in H3. - rewrite abs in H3. inversion H3. - apply Qlt_minus_iff in H3. exact H3. - rewrite Qmult_comm. reflexivity. } - apply (Qlt_trans _ ((q-r)/2)). exact H. - apply (Qplus_lt_l _ _ (t + (r-q)/2)). field_simplify. - setoid_replace (2*t/2) with t. 2: field. - apply (lt_CR_of_Q R). apply (CRlt_trans R _ _ _ H5). - apply (CRlt_trans - R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (4 * p))))))). - apply CRplus_lt_compat_r. exact H2. - apply (CRle_lt_trans - R _ (CR_of_Q R (r + (1 # Pos.of_nat (S (Pos.to_nat (4 * p))))))). - apply CR_of_Q_plus. apply CR_of_Q_lt. - apply (Qlt_le_trans _ (r + (q-r)/2)). - 2: field_simplify; apply Qle_refl. - apply Qplus_lt_r. - apply (Qlt_trans _ (1#2*p)). 2: exact H. - unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. - apply Pos2Z.pos_lt_pos. - rewrite Nat2Pos.inj_succ, Pos2Nat.id. - apply (Pos.lt_trans _ (4*p)). apply Pos2Nat.inj_lt. - do 2 rewrite Pos2Nat.inj_mul. - apply Nat.mul_lt_mono_pos_r. apply Pos2Nat.is_pos. - unfold Pos.to_nat. simpl. auto. - apply Pos.lt_succ_diag_r. - intro abs. pose proof (Pos2Nat.is_pos (4*p)). - rewrite abs in H1. inversion H1. - - apply CauchyMorph_inv_increasing_Qr. exact H1. -Qed. - -Definition CauchyMorphismInv (R : ConstructiveReals) - : ConstructiveRealsMorphism R CRealImplem. -Proof. - apply (Build_ConstructiveRealsMorphism R CRealImplem (CauchyMorph_inv R)). - - apply CauchyMorph_inv_rat. - - apply CauchyMorph_inv_increasing. -Defined. - -Lemma CauchyMorph_surject : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) (CauchyMorph R (CauchyMorph_inv R x)) x. -Proof. - intros. - apply (Endomorph_id - R (CRmorph_compose _ _ _ (CauchyMorphismInv R) (CauchyMorphism R)) x). -Qed. - -Lemma CauchyMorph_inject : forall (R : ConstructiveReals) (x : CReal), - CRealEq (CauchyMorph_inv R (CauchyMorph R x)) x. -Proof. - intros. - apply (Endomorph_id CRealImplem (CRmorph_compose _ _ _ (CauchyMorphism R) (CauchyMorphismInv R)) x). -Qed. - -(* We call this morphism slow to remind that it should only be used - for proofs, not for computations. *) -Definition SlowConstructiveRealsMorphism (R1 R2 : ConstructiveReals) - : ConstructiveRealsMorphism R1 R2 - := CRmorph_compose R1 CRealImplem R2 - (CauchyMorphismInv R1) (CauchyMorphism R2). diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 57912a1196..8c5bc8475b 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -24,7 +24,7 @@ Require Import ClassicalDedekindReals. Require Import ConstructiveCauchyReals. Require Import ConstructiveCauchyRealsMult. Require Import ConstructiveRcomplete. -Require Import ConstructiveRealsLUB. +Require Import ConstructiveLUB. Require Export Rdefinitions. Local Open Scope R_scope. @@ -438,7 +438,7 @@ Proof. as Ebound. { destruct H. exists (Rrepr x). intros y Ey. rewrite <- (Rquot2 y). apply Rrepr_le. apply H. exact Ey. } - destruct (CR_sig_lub CRealImplem + destruct (@CR_sig_lub CRealConstructive Er Erproper sig_forall_dec sig_not_dec Einhab Ebound). exists (Rabst x). split. intros y Ey. apply Rrepr_le. rewrite Rquot2. diff --git a/theories/omega/Omega.v b/theories/omega/Omega.v index 9c2e8a9212..10a5aa47b3 100644 --- a/theories/omega/Omega.v +++ b/theories/omega/Omega.v @@ -19,6 +19,7 @@ Require Export ZArith_base. Require Export OmegaLemmas. Require Export PreOmega. +Require Import Lia. Declare ML Module "omega_plugin". @@ -28,28 +29,28 @@ Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l Require Export Zhints. -Hint Extern 10 (_ = _ :>nat) => abstract omega: zarith. -Hint Extern 10 (_ <= _) => abstract omega: zarith. -Hint Extern 10 (_ < _) => abstract omega: zarith. -Hint Extern 10 (_ >= _) => abstract omega: zarith. -Hint Extern 10 (_ > _) => abstract omega: zarith. - -Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith. -Hint Extern 10 (~ _ <= _) => abstract omega: zarith. -Hint Extern 10 (~ _ < _) => abstract omega: zarith. -Hint Extern 10 (~ _ >= _) => abstract omega: zarith. -Hint Extern 10 (~ _ > _) => abstract omega: zarith. - -Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith. -Hint Extern 10 (_ <= _)%Z => abstract omega: zarith. -Hint Extern 10 (_ < _)%Z => abstract omega: zarith. -Hint Extern 10 (_ >= _)%Z => abstract omega: zarith. -Hint Extern 10 (_ > _)%Z => abstract omega: zarith. - -Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith. - -Hint Extern 10 False => abstract omega: zarith. +Hint Extern 10 (_ = _ :>nat) => abstract lia: zarith. +Hint Extern 10 (_ <= _) => abstract lia: zarith. +Hint Extern 10 (_ < _) => abstract lia: zarith. +Hint Extern 10 (_ >= _) => abstract lia: zarith. +Hint Extern 10 (_ > _) => abstract lia: zarith. + +Hint Extern 10 (_ <> _ :>nat) => abstract lia: zarith. +Hint Extern 10 (~ _ <= _) => abstract lia: zarith. +Hint Extern 10 (~ _ < _) => abstract lia: zarith. +Hint Extern 10 (~ _ >= _) => abstract lia: zarith. +Hint Extern 10 (~ _ > _) => abstract lia: zarith. + +Hint Extern 10 (_ = _ :>Z) => abstract lia: zarith. +Hint Extern 10 (_ <= _)%Z => abstract lia: zarith. +Hint Extern 10 (_ < _)%Z => abstract lia: zarith. +Hint Extern 10 (_ >= _)%Z => abstract lia: zarith. +Hint Extern 10 (_ > _)%Z => abstract lia: zarith. + +Hint Extern 10 (_ <> _ :>Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ <= _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ < _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ >= _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ > _)%Z) => abstract lia: zarith. + +Hint Extern 10 False => abstract lia: zarith. diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 210ac754a1..0f25bc8e12 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -116,6 +116,11 @@ let begin_show () = save_state (); Cdglobals.gallina := false; Cdglobals.light := false let end_show () = restore_state () + let begin_details s = + save_state (); Cdglobals.gallina := false; Cdglobals.light := false; + Output.start_details s + let end_details () = Output.stop_details (); restore_state () + (* Reset the globals *) let reset () = @@ -434,6 +439,8 @@ let begin_hide = "(*" space* "begin" space+ "hide" space* "*)" space* nl let end_hide = "(*" space* "end" space+ "hide" space* "*)" space* nl let begin_show = "(*" space* "begin" space+ "show" space* "*)" space* nl let end_show = "(*" space* "end" space+ "show" space* "*)" space* nl +let begin_details = "(*" space* "begin" space+ "details" space* +let end_details = "(*" space* "end" space+ "details" space* "*)" space* nl (* let begin_verb = "(*" space* "begin" space+ "verb" space* "*)" let end_verb = "(*" space* "end" space+ "verb" space* "*)" @@ -460,6 +467,11 @@ rule coq_bol = parse { begin_show (); coq_bol lexbuf } | space* end_show { end_show (); coq_bol lexbuf } + | space* begin_details + { let s = details_body lexbuf in + Output.end_coq (); begin_details s; Output.start_coq (); coq_bol lexbuf } + | space* end_details + { Output.end_coq (); end_details (); Output.start_coq (); coq_bol lexbuf } | space* (("Local"|"Global") space+)? gallina_kw_to_hide { let s = lexeme lexbuf in if !Cdglobals.light && section_or_end s then @@ -1221,6 +1233,19 @@ and printing_token_body = parse | _ { Buffer.add_string token_buffer (lexeme lexbuf); printing_token_body lexbuf } +and details_body = parse + | "*)" space* nl? | eof + { None } + | ":" space* { details_body_rec lexbuf } + +and details_body_rec = parse + | "*)" space* nl? | eof + { let s = Buffer.contents token_buffer in + Buffer.clear token_buffer; + Some s } + | _ { Buffer.add_string token_buffer (lexeme lexbuf); + details_body_rec lexbuf } + (*s These handle inference rules, parsing the body segments of things enclosed in [[[ ]]] brackets *) and inf_rules indents = parse diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index d2b0078a7c..dd1b65d294 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -42,7 +42,7 @@ let is_keyword = "Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "All"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Assumptions"; "Axioms"; "Universes"; "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; - "Search"; "SearchAbout"; "SearchHead"; "SearchPattern"; "SearchRewrite"; + "Search"; "SearchHead"; "SearchPattern"; "SearchRewrite"; "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context"; "Notation"; "Reserved Notation"; "Tactic Notation"; "Delimit"; "Bind"; "Open"; "Scope"; "Inline"; @@ -469,6 +469,11 @@ module Latex = struct let stop_emph () = printf "}" + let start_details _ = () + + let stop_details () = () + + let start_comment () = printf "\\begin{coqdoccomment}\n" let end_comment () = printf "\\end{coqdoccomment}\n" @@ -740,6 +745,12 @@ module Html = struct let stop_emph () = printf "</i>" + let start_details = function + | Some s -> printf "<details><summary>%s</summary>" s + | _ -> printf "<details>" + + let stop_details () = printf "</details>" + let start_comment () = printf "<span class=\"comment\">(*" let end_comment () = printf "*)</span>" @@ -1053,6 +1064,9 @@ module TeXmacs = struct let start_emph () = printf "<with|font shape|italic|" let stop_emph () = printf ">" + let start_details _ = () + let stop_details () = () + let start_comment () = () let end_comment () = () @@ -1159,6 +1173,9 @@ module Raw = struct let start_emph () = printf "_" let stop_emph () = printf "_" + let start_details _ = () + let stop_details () = () + let start_comment () = printf "(*" let end_comment () = printf "*)" @@ -1272,6 +1289,11 @@ let start_emph = let stop_emph = select Latex.stop_emph Html.stop_emph TeXmacs.stop_emph Raw.stop_emph +let start_details = + select Latex.start_details Html.start_details TeXmacs.start_details Raw.start_details +let stop_details = + select Latex.stop_details Html.stop_details TeXmacs.stop_details Raw.stop_details + let start_latex_math = select Latex.start_latex_math Html.start_latex_math TeXmacs.start_latex_math Raw.start_latex_math let stop_latex_math = diff --git a/tools/coqdoc/output.mli b/tools/coqdoc/output.mli index 485183a4ed..b7a8d4d858 100644 --- a/tools/coqdoc/output.mli +++ b/tools/coqdoc/output.mli @@ -29,6 +29,9 @@ val start_module : unit -> unit val start_doc : unit -> unit val end_doc : unit -> unit +val start_details : string option -> unit +val stop_details : unit -> unit + val start_emph : unit -> unit val stop_emph : unit -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index a63cff3e6f..7d08244d49 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -197,6 +197,7 @@ let init_execution opts custom_init = Global.set_engagement opts.config.logic.impredicative_set; Global.set_indices_matter opts.config.logic.indices_matter; Global.set_VM opts.config.enable_VM; + Flags.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); Global.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); Global.set_allow_sprop opts.config.logic.allow_sprop; if opts.config.logic.cumulative_sprop then Global.make_sprop_cumulative (); diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 955630f40c..076796468f 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -100,7 +100,7 @@ let load_vernac_core ~echo ~check ~interactive ~state file = with | None -> input_cleanup (); - state, ids, Pcoq.Parsable.comment_state in_pa + state, ids, Pcoq.Parsable.comments in_pa | Some ast -> (* Printing of AST for -compile-verbose *) Option.iter (vernac_echo ?loc:ast.CAst.loc) in_echo; diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 5e04959e9a..57d59fc2ef 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -826,12 +826,12 @@ END let () = -let open Extend in let open Tok in -let (++) r s = Next (r, s) in +let (++) r s = Pcoq.Rule.next r s in let rules = [ - Rule ( - Stop ++ Aentry test_dollar_ident ++ Atoken (PKEYWORD "$") ++ Aentry Prim.ident, + Pcoq.( + Production.make + (Rule.stop ++ Symbol.nterm test_dollar_ident ++ Symbol.token (PKEYWORD "$") ++ Symbol.nterm Prim.ident) begin fun id _ _ loc -> let id = Loc.tag ~loc id in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in @@ -839,8 +839,9 @@ let rules = [ end ); - Rule ( - Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, + Pcoq.( + Production.make + (Rule.stop ++ Symbol.nterm test_ampersand_ident ++ Symbol.token (PKEYWORD "&") ++ Symbol.nterm Prim.ident) begin fun id _ _ loc -> let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in @@ -848,9 +849,10 @@ let rules = [ end ); - Rule ( - Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ - Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), + Pcoq.( + Production.make + (Rule.stop ++ Symbol.token (PIDENT (Some "ltac2")) ++ Symbol.token (PKEYWORD ":") ++ + Symbol.token (PKEYWORD "(") ++ Symbol.nterm tac2expr ++ Symbol.token (PKEYWORD ")")) begin fun _ tac _ _ _ loc -> let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) @@ -859,7 +861,7 @@ let rules = [ ] in Hook.set Tac2entries.register_constr_quotations begin fun () -> - Pcoq.grammar_extend Pcoq.Constr.operconstr (Some (Gramlib.Gramext.Level "0"), [(None, None, rules)]) + Pcoq.grammar_extend Pcoq.Constr.operconstr {pos=Some (Gramlib.Gramext.Level "0"); data=[(None, None, rules)]} end } diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 38b05bed6b..72df4d75c8 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -20,7 +20,7 @@ open Proofview.Notations let constr_flags = let open Pretyping in { - use_typeclasses = true; + use_typeclasses = Pretyping.UseTC; solve_unification_constraints = true; fail_evar = true; expand_evars = true; @@ -31,7 +31,7 @@ let constr_flags = let open_constr_no_classes_flags = let open Pretyping in { - use_typeclasses = false; + use_typeclasses = Pretyping.NoUseTC; solve_unification_constraints = true; fail_evar = false; expand_evars = true; @@ -1431,7 +1431,7 @@ let q_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) let add_generic_scope s entry arg = let parse = function | [] -> - let scope = Extend.Aentry entry in + let scope = Pcoq.Symbol.nterm entry in let act x = CAst.make @@ CTacExt (arg, x) in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail s arg @@ -1442,14 +1442,14 @@ open CAst let () = add_scope "keyword" begin function | [SexprStr {loc;v=s}] -> - let scope = Extend.Atoken (Tok.PKEYWORD s) in + let scope = Pcoq.Symbol.token (Tok.PKEYWORD s) in Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) | arg -> scope_fail "keyword" arg end let () = add_scope "terminal" begin function | [SexprStr {loc;v=s}] -> - let scope = Extend.Atoken (CLexer.terminal s) in + let scope = Pcoq.Symbol.token (CLexer.terminal s) in Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) | arg -> scope_fail "terminal" arg end @@ -1457,13 +1457,13 @@ end let () = add_scope "list0" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Alist0 scope in + let scope = Pcoq.Symbol.list0 scope in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | [tok; SexprStr {v=str}] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let sep = Extend.Atoken (CLexer.terminal str) in - let scope = Extend.Alist0sep (scope, sep) in + let sep = Pcoq.Symbol.token (CLexer.terminal str) in + let scope = Pcoq.Symbol.list0sep scope sep false in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "list0" arg @@ -1472,13 +1472,13 @@ end let () = add_scope "list1" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Alist1 scope in + let scope = Pcoq.Symbol.list1 scope in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | [tok; SexprStr {v=str}] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let sep = Extend.Atoken (CLexer.terminal str) in - let scope = Extend.Alist1sep (scope, sep) in + let sep = Pcoq.Symbol.token (CLexer.terminal str) in + let scope = Pcoq.Symbol.list1sep scope sep false in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "list1" arg @@ -1487,7 +1487,7 @@ end let () = add_scope "opt" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Aopt scope in + let scope = Pcoq.Symbol.opt scope in let act opt = match opt with | None -> CAst.make @@ CTacCst (AbsKn (Other Core.c_none)) @@ -1500,7 +1500,7 @@ end let () = add_scope "self" begin function | [] -> - let scope = Extend.Aself in + let scope = Pcoq.Symbol.self in let act tac = tac in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "self" arg @@ -1508,7 +1508,7 @@ end let () = add_scope "next" begin function | [] -> - let scope = Extend.Anext in + let scope = Pcoq.Symbol.next in let act tac = tac in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "next" arg @@ -1517,12 +1517,12 @@ end let () = add_scope "tactic" begin function | [] -> (* Default to level 5 parsing *) - let scope = Extend.Aentryl (tac2expr, "5") in + let scope = Pcoq.Symbol.nterml tac2expr "5" in let act tac = tac in Tac2entries.ScopeRule (scope, act) | [SexprInt {loc;v=n}] as arg -> let () = if n < 0 || n > 6 then scope_fail "tactic" arg in - let scope = Extend.Aentryl (tac2expr, string_of_int n) in + let scope = Pcoq.Symbol.nterml tac2expr (string_of_int n) in let act tac = tac in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "tactic" arg @@ -1543,12 +1543,12 @@ let () = add_scope "constr" (fun arg -> arg in let act e = Tac2quote.of_constr ~delimiters e in - Tac2entries.ScopeRule (Extend.Aentry Pcoq.Constr.constr, act) + Tac2entries.ScopeRule (Pcoq.Symbol.nterm Pcoq.Constr.constr, act) ) let add_expr_scope name entry f = add_scope name begin function - | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) + | [] -> Tac2entries.ScopeRule (Pcoq.Symbol.nterm entry, f) | arg -> scope_fail name arg end @@ -1578,28 +1578,7 @@ let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern (** seq scope, a bit hairy *) -open Extend -exception SelfSymbol - -let rec generalize_symbol : - type a tr s. (s, tr, a) Extend.symbol -> (s, Extend.norec, a) Extend.symbol = function -| Atoken tok -> Atoken tok -| Alist1 e -> Alist1 (generalize_symbol e) -| Alist1sep (e, sep) -> - let e = generalize_symbol e in - let sep = generalize_symbol sep in - Alist1sep (e, sep) -| Alist0 e -> Alist0 (generalize_symbol e) -| Alist0sep (e, sep) -> - let e = generalize_symbol e in - let sep = generalize_symbol sep in - Alist0sep (e, sep) -| Aopt e -> Aopt (generalize_symbol e) -| Aself -> raise SelfSymbol -| Anext -> raise SelfSymbol -| Aentry e -> Aentry e -| Aentryl (e, l) -> Aentryl (e, l) -| Arules r -> Arules r +open Pcoq type _ converter = | CvNil : (Loc.t -> raw_tacexpr) converter @@ -1611,16 +1590,21 @@ let rec apply : type a. a converter -> raw_tacexpr list -> a = function | CvCns (c, Some f) -> fun accu x -> apply c (f x :: accu) type seqrule = -| Seqrule : (Tac2expr.raw_tacexpr, Extend.norec, 'act, Loc.t -> raw_tacexpr) rule * 'act converter -> seqrule +| Seqrule : (Tac2expr.raw_tacexpr, Gramlib.Grammar.norec, 'act, Loc.t -> raw_tacexpr) Rule.t * 'act converter -> seqrule let rec make_seq_rule = function | [] -> - Seqrule (Stop, CvNil) + Seqrule (Pcoq.Rule.stop, CvNil) | tok :: rem -> let Tac2entries.ScopeRule (scope, f) = Tac2entries.parse_scope tok in - let scope = generalize_symbol scope in + let scope = + match Pcoq.generalize_symbol scope with + | None -> + CErrors.user_err (str "Recursive symbols (self / next) are not allowed in local rules") + | Some scope -> scope + in let Seqrule (r, c) = make_seq_rule rem in - let r = NextNoRec (r, scope) in + let r = Pcoq.Rule.next_norec r scope in let f = match tok with | SexprStr _ -> None (* Leave out mere strings *) | _ -> Some f @@ -1629,11 +1613,8 @@ let rec make_seq_rule = function let () = add_scope "seq" begin fun toks -> let scope = - try - let Seqrule (r, c) = make_seq_rule (List.rev toks) in - Arules [Rules (r, apply c [])] - with SelfSymbol -> - CErrors.user_err (str "Recursive symbols (self / next) are not allowed in local rules") + let Seqrule (r, c) = make_seq_rule (List.rev toks) in + Pcoq.(Symbol.rules [Rules.make r (apply c [])]) in Tac2entries.ScopeRule (scope, (fun e -> e)) end diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index e9945794d3..ebc63ddd01 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -558,7 +558,7 @@ type 'a token = | TacNonTerm of Name.t * 'a type scope_rule = -| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule +| ScopeRule : (raw_tacexpr, _, 'a) Pcoq.Symbol.t * ('a -> raw_tacexpr) -> scope_rule type scope_interpretation = sexpr list -> scope_rule @@ -583,7 +583,7 @@ let parse_scope = function CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) | SexprStr {v=str} -> let v_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) in - ScopeRule (Extend.Atoken (Tok.PIDENT (Some str)), (fun _ -> v_unit)) + ScopeRule (Pcoq.Symbol.token (Tok.PIDENT (Some str)), (fun _ -> v_unit)) | tok -> let loc = loc_of_token tok in CErrors.user_err ?loc (str "Invalid parsing token") @@ -611,19 +611,19 @@ type synext = { type krule = | KRule : - (raw_tacexpr, _, 'act, Loc.t -> raw_tacexpr) Extend.rule * + (raw_tacexpr, _, 'act, Loc.t -> raw_tacexpr) Pcoq.Rule.t * ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule let rec get_rule (tok : scope_rule token list) : krule = match tok with -| [] -> KRule (Extend.Stop, fun k loc -> k loc []) +| [] -> KRule (Pcoq.Rule.stop, fun k loc -> k loc []) | TacNonTerm (na, ScopeRule (scope, inj)) :: tok -> let KRule (rule, act) = get_rule tok in - let rule = Extend.Next (rule, scope) in + let rule = Pcoq.Rule.next rule scope in let act k e = act (fun loc acc -> k loc ((na, inj e) :: acc)) in KRule (rule, act) | TacTerm t :: tok -> let KRule (rule, act) = get_rule tok in - let rule = Extend.Next (rule, Extend.Atoken (CLexer.terminal t)) in + let rule = Pcoq.(Rule.next rule (Symbol.token (CLexer.terminal t))) in let act k _ = act k in KRule (rule, act) @@ -637,13 +637,13 @@ let perform_notation syn st = let bnd = List.map map args in CAst.make ~loc @@ CTacLet (false, bnd, syn.synext_exp) in - let rule = Extend.Rule (rule, act mk) in + let rule = Pcoq.Production.make rule (act mk) in let lev = match syn.synext_lev with | None -> None | Some lev -> Some (string_of_int lev) in let rule = (lev, None, [rule]) in - ([Pcoq.ExtendRule (Pltac.tac2expr, (None, [rule]))], st) + ([Pcoq.ExtendRule (Pltac.tac2expr, {Pcoq.pos=None; data=[rule]})], st) let ltac2_notation = Pcoq.create_grammar_command "ltac2-notation" perform_notation diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index fed43a4dd5..edad118dc9 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -36,7 +36,7 @@ val perform_eval : pstate:Proof_global.t option -> raw_tacexpr -> unit (** {5 Notations} *) type scope_rule = -| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule +| ScopeRule : (raw_tacexpr, _, 'a) Pcoq.Symbol.t * ('a -> raw_tacexpr) -> scope_rule type scope_interpretation = sexpr list -> scope_rule diff --git a/user-contrib/Ltac2/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 30ee1a0b4c..9ca38d64df 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -20,7 +20,7 @@ let return = Proofview.tclUNIT let thaw r f = Tac2ffi.app_fun1 f Tac2ffi.unit r () let tactic_infer_flags with_evar = { - Pretyping.use_typeclasses = true; + Pretyping.use_typeclasses = Pretyping.UseTC; Pretyping.solve_unification_constraints = true; Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true; diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 0c9b9c7255..f3ad324aa5 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -113,8 +113,8 @@ let mkFullInd (ind,u) n = else mkIndU (ind,u) let check_bool_is_defined () = - try let _ = Typeops.type_of_global_in_context (Global.env ()) Coqlib.(lib_ref "core.bool.type") in () - with e when CErrors.noncritical e -> raise (UndefinedCst "bool") + if not (Coqlib.has_ref "core.bool.type") + then raise (UndefinedCst "bool") let check_no_indices mib = if Array.exists (fun mip -> mip.mind_nrealargs <> 0) mib.mind_packets then @@ -236,10 +236,11 @@ let build_beq_scheme mode kn = (* Needs Hints, see test suite *) let eq_lbl = Label.make ("eq_" ^ Label.to_string (Constant.label kn)) in let kneq = Constant.change_label kn eq_lbl in - try let _ = Environ.constant_opt_value_in env (kneq, u) in + if Environ.mem_constant kneq env then + let _ = Environ.constant_opt_value_in env (kneq, u) in Term.applist (mkConst kneq,a), Evd.empty_side_effects - with Not_found -> raise (ParameterWithoutEquality (GlobRef.ConstRef kn))) + else raise (ParameterWithoutEquality (GlobRef.ConstRef kn))) | Proj _ -> raise (EqUnknown "projection") | Construct _ -> raise (EqUnknown "constructor") | Case _ -> raise (EqUnknown "match") @@ -373,7 +374,7 @@ so from Ai we can find the correct eq_Ai bl_ai or lb_ai let do_replace_lb mode lb_scheme_key aavoid narg p q = let open EConstr in let avoid = Array.of_list aavoid in - let do_arg sigma hd v offset = + let do_arg env sigma hd v offset = match kind sigma v with | Var s -> let x = narg*offset in @@ -390,7 +391,9 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Parameter (see example "J" in test file SchemeEquality.v) *) let lbl = Label.to_string (Constant.label cst) in let newlbl = if Int.equal offset 1 then ("eq_" ^ lbl) else (lbl ^ "_lb") in - mkConst (Constant.change_label cst (Label.make newlbl)) + let newcst = Constant.change_label cst (Label.make newlbl) in + if Environ.mem_constant newcst env then mkConst newcst + else raise (ConstructorWithNonParametricInductiveType (fst hd)) | _ -> raise (ConstructorWithNonParametricInductiveType (fst hd)) in @@ -419,8 +422,8 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = Proofview.tclEVARMAP >>= fun sigma -> let lb_args = Array.append (Array.append v - (Array.Smart.map (fun x -> do_arg sigma u x 1) v)) - (Array.Smart.map (fun x -> do_arg sigma u x 2) v) + (Array.Smart.map (fun x -> do_arg env sigma u x 1) v)) + (Array.Smart.map (fun x -> do_arg env sigma u x 2) v) in let app = if Array.is_empty lb_args then lb_type_of_p else mkApp (lb_type_of_p,lb_args) in @@ -433,7 +436,7 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let open EConstr in let avoid = Array.of_list aavoid in - let do_arg sigma hd v offset = + let do_arg env sigma hd v offset = match kind sigma v with | Var s -> let x = narg*offset in @@ -450,7 +453,9 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = Parameter (see example "J" in test file SchemeEquality.v) *) let lbl = Label.to_string (Constant.label cst) in let newlbl = if Int.equal offset 1 then ("eq_" ^ lbl) else (lbl ^ "_bl") in - mkConst (Constant.change_label cst (Label.make newlbl)) + let newcst = Constant.change_label cst (Label.make newlbl) in + if Environ.mem_constant newcst env then mkConst newcst + else raise (ConstructorWithNonParametricInductiveType (fst hd)) | _ -> raise (ConstructorWithNonParametricInductiveType (fst hd)) in @@ -487,8 +492,8 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = in let bl_args = Array.append (Array.append v - (Array.Smart.map (fun x -> do_arg sigma u x 1) v)) - (Array.Smart.map (fun x -> do_arg sigma u x 2) v ) + (Array.Smart.map (fun x -> do_arg env sigma u x 1) v)) + (Array.Smart.map (fun x -> do_arg env sigma u x 2) v ) in let app = if Array.is_empty bl_args then bl_t1 else mkApp (bl_t1,bl_args) @@ -837,8 +842,8 @@ let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind (* Decidable equality *) let check_not_is_defined () = - try ignore (Coqlib.lib_ref "core.not.type") - with Not_found -> raise (UndefinedCst "not") + if not (Coqlib.has_ref "core.not.type") + then raise (UndefinedCst "not") (* {n=m}+{n<>m} part *) let compute_dec_goal ind lnamesparrec nparrec = diff --git a/vernac/classes.ml b/vernac/classes.ml index dafd1cc5e4..3d38713e09 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -304,22 +304,19 @@ let id_of_class cl = mip.(0).Declarations.mind_typename | _ -> assert false -let instance_hook info global imps ?hook cst = - Impargs.maybe_declare_manual_implicits false cst imps; +let instance_hook info global ?hook cst = let info = intern_info info in let env = Global.env () in let sigma = Evd.from_env env in declare_instance env sigma (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant info global imps ?hook name udecl poly sigma term termtype = +let declare_instance_constant info global impargs ?hook name udecl poly sigma term termtype = let kind = Decls.(IsDefinition Instance) in - let sigma, entry = DeclareDef.prepare_definition - ~allow_evars:false ~poly sigma ~udecl ~types:(Some termtype) ~body:term in - let kn = Declare.declare_constant ~name ~kind (Declare.DefinitionEntry entry) in - Declare.definition_message name; - DeclareUniv.declare_univ_binders (GlobRef.ConstRef kn) (Evd.universe_binders sigma); - instance_hook info global imps ?hook (GlobRef.ConstRef kn) + let scope = DeclareDef.Global Declare.ImportDefaultBehavior in + let kn = DeclareDef.declare_definition ~name ~kind ~scope ~impargs + ~opaque:false ~poly sigma ~udecl ~types:(Some termtype) ~body:term in + instance_hook info global ?hook kn let do_declare_instance sigma ~global ~poly k u ctx ctx' pri udecl impargs subst name = let subst = List.fold_left2 @@ -328,30 +325,31 @@ let do_declare_instance sigma ~global ~poly k u ctx ctx' pri udecl impargs subst in let (_, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let sigma, entry = DeclareDef.prepare_parameter ~allow_evars:false ~poly sigma ~udecl ~types:termtype in + let sigma, entry = DeclareDef.prepare_parameter ~poly sigma ~udecl ~types:termtype in let cst = Declare.declare_constant ~name ~kind:Decls.(IsAssumption Logical) (Declare.ParameterEntry entry) in DeclareUniv.declare_univ_binders (GlobRef.ConstRef cst) (Evd.universe_binders sigma); - instance_hook pri global impargs (GlobRef.ConstRef cst) + let cst = (GlobRef.ConstRef cst) in + Impargs.maybe_declare_manual_implicits false cst impargs; + instance_hook pri global cst -let declare_instance_program env sigma ~global ~poly name pri imps udecl term termtype = +let declare_instance_program env sigma ~global ~poly name pri impargs udecl term termtype = let hook { DeclareDef.Hook.S.scope; dref; _ } = let cst = match dref with GlobRef.ConstRef kn -> kn | _ -> assert false in - Impargs.declare_manual_implicits false dref imps; let pri = intern_info pri in let env = Global.env () in let sigma = Evd.from_env env in declare_instance env sigma (Some pri) (not global) (GlobRef.ConstRef cst) in - let obls, _, term, typ = Obligations.eterm_obligations env name sigma 0 term termtype in + let obls, _, term, typ = RetrieveObl.retrieve_obligations env name sigma 0 term termtype in let hook = DeclareDef.Hook.make hook in let uctx = Evd.evar_universe_context sigma in let scope, kind = DeclareDef.Global Declare.ImportDefaultBehavior, Decls.Instance in let _ : DeclareObl.progress = - Obligations.add_definition ~name ~term ~udecl ~scope ~poly ~kind ~hook typ ~uctx obls + Obligations.add_definition ~name ~term ~udecl ~scope ~poly ~kind ~hook ~impargs ~uctx typ obls in () -let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids term termtype = +let declare_instance_open sigma ?hook ~tac ~global ~poly id pri impargs udecl ids term termtype = (* spiwack: it is hard to reorder the actions to do the pretyping after the proof has opened. As a consequence, we use the low-level primitives to code @@ -359,12 +357,12 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids t let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in let kind = Decls.(IsDefinition Instance) in - let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global imps ?hook dref)) in + let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global ?hook dref)) in let info = Lemmas.Info.make ~hook ~kind () in (* XXX: We need to normalize the type, otherwise Admitted / Qed will fails! This is due to a bug in proof_global :( *) let termtype = Evarutil.nf_evar sigma termtype in - let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info sigma termtype in + let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info ~impargs sigma termtype in (* spiwack: I don't know what to do with the status here. *) let lemma = match term with @@ -516,7 +514,8 @@ let interp_instance_context ~program_mode env ctx ~generalize pl tclass = else tclass in let sigma, (impls, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma ctx in - let sigma, (c', imps') = interp_type_evars_impls ~program_mode ~impls env' sigma tclass in + let flags = Pretyping.{ all_no_fail_flags with program_mode } in + let sigma, (c', imps') = interp_type_evars_impls ~flags ~impls env' sigma tclass in let imps = imps @ imps' in let ctx', c = decompose_prod_assum sigma c' in let ctx'' = ctx' @ ctx in diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index dc9c8e2d3c..1e2e2e53e2 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -70,7 +70,8 @@ let declare_axiom is_coe ~poly ~local ~kind typ (univs, pl) imps nl {CAst.v=name (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 + let flags = { Pretyping.all_no_fail_flags with program_mode } in + let sigma, (ty, impls) = interp_type_evars_impls ~flags env sigma ~impls c in sigma, (ty, impls) (* When monomorphic the universe constraints and universe names are @@ -203,8 +204,12 @@ let context_insection sigma ~poly ctx = else Monomorphic_entry Univ.ContextSet.empty in let entry = Declare.definition_entry ~univs ~types:t b in - let _ : GlobRef.t = DeclareDef.declare_definition ~name ~scope:DeclareDef.Discharge - ~kind:Decls.(IsDefinition Definition) ~ubind:UnivNames.empty_binders ~impargs:[] entry + (* XXX Fixme: Use DeclareDef.prepare_definition *) + let uctx = Evd.evar_universe_context sigma in + let kind = Decls.(IsDefinition Definition) in + let _ : GlobRef.t = + DeclareDef.declare_entry ~name ~scope:DeclareDef.Discharge + ~kind ~impargs:[] ~uctx entry in () in diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index ba2c1ac115..66d5a4f7f5 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -12,7 +12,6 @@ open Pp open Util open Redexpr open Constrintern -open Pretyping (* Commands of the interface: Constant definitions *) @@ -40,15 +39,56 @@ let check_imps ~impsty ~impsbody = | [], [] -> () in aux impsty impsbody +let protect_pattern_in_binder bl c ctypopt = + (* We turn "Definition d binders := body : typ" into *) + (* "Definition d := fun binders => body:type" *) + (* This is a hack while waiting for LocalPattern in regular environments *) + if List.exists (function Constrexpr.CLocalPattern _ -> true | _ -> false) bl + then + let t = match ctypopt with + | None -> CAst.make ?loc:c.CAst.loc (Constrexpr.CHole (None,Namegen.IntroAnonymous,None)) + | Some t -> t in + let loc = Loc.merge_opt c.CAst.loc t.CAst.loc in + let c = CAst.make ?loc @@ Constrexpr.CCast (c, Glob_term.CastConv t) in + let loc = match List.hd bl with + | Constrexpr.CLocalAssum (a::_,_,_) | Constrexpr.CLocalDef (a,_,_) -> a.CAst.loc + | Constrexpr.CLocalPattern {CAst.loc} -> loc + | Constrexpr.CLocalAssum ([],_,_) -> assert false in + let apply_under_binders f env evd c = + let rec aux env evd c = + let open Constr in + let open EConstr in + let open Context.Rel.Declaration in + match kind evd c with + | Lambda (x,t,c) -> + let evd,c = aux (push_rel (LocalAssum (x,t)) env) evd c in + evd, mkLambda (x,t,c) + | LetIn (x,b,t,c) -> + let evd,c = aux (push_rel (LocalDef (x,b,t)) env) evd c in + evd, mkLetIn (x,t,b,c) + | Case (ci,p,a,bl) -> + let evd,bl = Array.fold_left_map (aux env) evd bl in + evd, mkCase (ci,p,a,bl) + | Cast (c,_,_) -> f env evd c (* we remove the cast we had set *) + (* This last case may happen when reaching the proof of an + impossible case, as when pattern-matching on a vector of length 1 *) + | _ -> (evd,c) in + aux env evd c in + ([], Constrexpr_ops.mkLambdaCN ?loc:(Loc.merge_opt loc c.CAst.loc) bl c, None, apply_under_binders) + else + (bl, c, ctypopt, fun f env evd c -> f env evd c) + let interp_definition ~program_mode pl bl ~poly red_option c ctypopt = + let flags = Pretyping.{ all_no_fail_flags with program_mode } in let env = Global.env() in (* Explicitly bound universes and constraints *) let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in + let (bl, c, ctypopt, apply_under_binders) = protect_pattern_in_binder bl c ctypopt in (* Build the parameters *) let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars ~program_mode env evd bl in (* Build the type *) let evd, tyopt = Option.fold_left_map - (interp_type_evars_impls ~program_mode ~impls env_bl) + (interp_type_evars_impls ~flags ~impls env_bl) evd ctypopt in (* Build the body, and merge implicits from parameters and from type/body *) @@ -63,46 +103,31 @@ let interp_definition ~program_mode pl bl ~poly red_option c ctypopt = evd, c, imps1@impsty, Some ty in (* Do the reduction *) - let evd, c = red_constant_body red_option env_bl evd c in + let evd, c = apply_under_binders (red_constant_body red_option) env_bl evd c in (* Declare the definition *) let c = EConstr.it_mkLambda_or_LetIn c ctx in let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in + (c, tyopt), evd, udecl, imps - let evd, ce = DeclareDef.prepare_definition ~allow_evars:program_mode - ~opaque:false ~poly evd ~udecl ~types:tyopt ~body:c in - - (ce, evd, udecl, imps) - -let check_definition ~program_mode (ce, evd, _, imps) = - let env = Global.env () in - check_evars_are_solved ~program_mode env evd; - ce +let do_definition ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = + let program_mode = false in + let (body, types), evd, udecl, impargs = + interp_definition ~program_mode udecl bl ~poly red_option c ctypopt + in + let kind = Decls.IsDefinition kind in + let _ : Names.GlobRef.t = + DeclareDef.declare_definition ~name ~scope ~kind ?hook ~impargs + ~opaque:false ~poly evd ~udecl ~types ~body + in () -let do_definition ~program_mode ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = - let (ce, evd, udecl, impargs as def) = +let do_definition_program ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = + let program_mode = true in + let (body, types), evd, udecl, impargs = interp_definition ~program_mode udecl bl ~poly red_option c ctypopt in - if program_mode then - let env = Global.env () in - let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in - assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); - assert(Univ.ContextSet.is_empty ctx); - Obligations.check_evars env evd; - let c = EConstr.of_constr c in - let typ = match ce.Declare.proof_entry_type with - | Some t -> EConstr.of_constr t - | None -> Retyping.get_type_of env evd c - in - let obls, _, c, cty = - Obligations.eterm_obligations env name evd 0 c typ - in - let uctx = Evd.evar_universe_context evd in - ignore(Obligations.add_definition - ~name ~term:c cty ~uctx ~udecl ~impargs ~scope ~poly ~kind ?hook obls) - else - let ce = check_definition ~program_mode def in - let uctx = Evd.evar_universe_context evd in - let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - let kind = Decls.IsDefinition kind in - ignore(DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ~ubind:(Evd.universe_binders evd) ce ~impargs) + let term, ty, uctx, obls = DeclareDef.prepare_obligation ~name ~poly ~body ~types ~udecl evd in + let _ : DeclareObl.progress = + Obligations.add_definition + ~name ~term ty ~uctx ~udecl ~impargs ~scope ~poly ~kind ?hook obls + in () diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 6c6da8952e..337da22018 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -15,8 +15,7 @@ open Constrexpr (** {6 Definitions/Let} *) val do_definition - : program_mode:bool - -> ?hook:DeclareDef.Hook.t + : ?hook:DeclareDef.Hook.t -> name:Id.t -> scope:DeclareDef.locality -> poly:bool @@ -28,18 +27,15 @@ val do_definition -> constr_expr option -> unit -(************************************************************************) -(** Internal API *) -(************************************************************************) - -(** Not used anywhere. *) -val interp_definition - : program_mode:bool +val do_definition_program + : ?hook:DeclareDef.Hook.t + -> name:Id.t + -> scope:DeclareDef.locality + -> poly:bool + -> kind:Decls.definition_object_kind -> universe_decl_expr option -> local_binder_expr list - -> poly:bool -> red_expr option -> constr_expr -> constr_expr option - -> Evd.side_effects Declare.proof_entry * - Evd.evar_map * UState.universe_decl * Impargs.manual_implicits + -> unit diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 6580495295..e4fa212a23 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -107,7 +107,8 @@ let interp_fix_context ~program_mode ~cofix env sigma fix = sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) let interp_fix_ccl ~program_mode sigma impls (env,_) fix = - let sigma, (c, impl) = interp_type_evars_impls ~program_mode ~impls env sigma fix.Vernacexpr.rtype in + let flags = Pretyping.{ all_no_fail_flags with program_mode } in + let sigma, (c, impl) = interp_type_evars_impls ~flags ~impls env sigma fix.Vernacexpr.rtype in let r = Retyping.relevance_of_type env sigma c in sigma, (c, r, impl) @@ -140,8 +141,8 @@ let compute_possible_guardness_evidences (ctx,_,recindex) = fixpoints ?) *) List.interval 0 (Context.Rel.nhyps ctx - 1) -type recursive_preentry = - Id.t list * Sorts.relevance list * Constr.t option list * Constr.types list +type ('constr, 'types) recursive_preentry = + Id.t list * Sorts.relevance list * 'constr option list * 'types list (* Wellfounded definition *) @@ -230,7 +231,11 @@ let ground_fixpoint env evd (fixnames,fixrs,fixdefs,fixtypes) = let fixtypes = List.map EConstr.(to_constr evd) fixtypes in Evd.evar_universe_context evd, (fixnames,fixrs,fixdefs,fixtypes) -let interp_fixpoint ~cofix l = +(* XXX: Unify with interp_recursive *) +let interp_fixpoint ~cofix l : + ( (Constr.t, Constr.types) recursive_preentry * + UState.universe_decl * UState.t * + (EConstr.rel_context * Impargs.manual_implicits * int option) list) = let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l in check_recursive true env evd fix; let uctx,fix = ground_fixpoint env evd fix in @@ -243,8 +248,10 @@ let build_recthms ~indexes fixnames fixtypes fiximps = in let thms = List.map3 (fun name typ (ctx,impargs,_) -> - { DeclareDef.Recthm.name; typ - ; args = List.map Context.Rel.Declaration.get_name ctx; impargs}) + { DeclareDef.Recthm.name + ; typ + ; args = List.map Context.Rel.Declaration.get_name ctx + ; impargs}) fixnames fixtypes fiximps in fix_kind, cofix, thms diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 2ad6c03bae..a19b96f0f3 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Constr open Vernacexpr (** {6 Fixpoints and cofixpoints} *) @@ -40,6 +39,9 @@ val adjust_rec_order -> Constrexpr.recursion_order_expr option -> lident option +(** names / relevance / defs / types *) +type ('constr, 'types) recursive_preentry = Id.t list * Sorts.relevance list * 'constr option list * 'types list + (** Exported for Program *) val interp_recursive : (* Misc arguments *) @@ -49,18 +51,17 @@ val interp_recursive : (* env / signature / univs / evar_map *) (Environ.env * EConstr.named_context * UState.universe_decl * Evd.evar_map) * (* names / defs / types *) - (Id.t list * Sorts.relevance list * EConstr.constr option list * EConstr.types list) * + (EConstr.t, EConstr.types) recursive_preentry * (* ctx per mutual def / implicits / struct annotations *) (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Exported for Funind *) -type recursive_preentry = Id.t list * Sorts.relevance list * constr option list * types list - val interp_fixpoint : cofix:bool -> lident option fix_expr_gen list - -> recursive_preentry * UState.universe_decl * UState.t * + -> (Constr.t, Constr.types) recursive_preentry * + UState.universe_decl * UState.t * (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Very private function, do not use *) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 1f1700b4d6..cc9b840bed 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -20,7 +20,6 @@ open Nameops open Constrexpr open Constrexpr_ops open Constrintern -open Reductionops open Type_errors open Pretyping open Context.Rel.Declaration @@ -51,20 +50,6 @@ let should_auto_template = if b then warn_auto_template id; b -let rec complete_conclusion a cs = CAst.map_with_loc (fun ?loc -> function - | CProdN (bl,c) -> CProdN (bl,complete_conclusion a cs c) - | CLetIn (na,b,t,c) -> CLetIn (na,b,t,complete_conclusion a cs c) - | CHole (k, _, _) -> - let (has_no_args,name,params) = a in - if not has_no_args then - user_err ?loc - (strbrk"Cannot infer the non constant arguments of the conclusion of " - ++ Id.print cs ++ str "."); - let args = List.map (fun id -> CAst.(make ?loc @@ CRef(qualid_of_ident ?loc id,None))) params in - CAppExpl ((None,qualid_of_ident ?loc name,None),List.rev args) - | c -> c - ) - let push_types env idl rl tl = List.fold_left3 (fun env id r t -> EConstr.push_rel (LocalAssum (make_annot (Name id) r,t)) env) env idl rl tl @@ -93,10 +78,6 @@ let check_all_names_different indl = | [] -> () | _ -> raise (InductiveError (SameNamesOverlap l)) -let mk_mltype_data sigma env assums arity indname = - let is_ml_type = is_sort env sigma arity in - (is_ml_type,indname,assums) - (** Make the arity conclusion flexible to avoid generating an upper bound universe now, only if the universe does not appear anywhere else. This is really a hack to stay compatible with the semantics of template polymorphic @@ -145,16 +126,50 @@ let pretype_ind_arity env sigma (loc, c, impls, pseudo_poly) = in sigma, (t, Retyping.relevance_of_sort s, concl, impls) -let interp_cstrs env sigma impls mldata arity ind = +(* ind_rel is the Rel for this inductive in the context without params. + n is how many arguments there are in the constructor. *) +let model_conclusion env sigma ind_rel params n arity_indices = + let model_head = EConstr.mkRel (n + Context.Rel.length params + ind_rel) in + let model_params = Context.Rel.to_extended_vect EConstr.mkRel n params in + let sigma,model_indices = + List.fold_right + (fun (_,t) (sigma, subst) -> + let t = EConstr.Vars.substl subst (EConstr.Vars.liftn n (List.length subst + 1) (EConstr.Vars.liftn 1 (List.length params + List.length subst + 1) t)) in + let sigma, c = Evarutil.new_evar env sigma t in + sigma, c::subst) + arity_indices (sigma, []) in + sigma, EConstr.mkApp (EConstr.mkApp (model_head, model_params), Array.of_list (List.rev model_indices)) + +let interp_cstrs env (sigma, ind_rel) impls params ind arity = let cnames,ctyps = List.split ind.ind_lc in - (* Complete conclusions of constructor types if given in ML-style syntax *) - let ctyps' = List.map2 (complete_conclusion mldata) cnames ctyps in + let arity_indices, cstr_sort = Reductionops.splay_arity env sigma arity in (* Interpret the constructor types *) - let sigma, (ctyps'', cimpls) = + let interp_cstr sigma ctyp = + let flags = + Pretyping.{ all_no_fail_flags with + use_typeclasses = UseTCForConv; + solve_unification_constraints = false } + in + let sigma, (ctyp, cimpl) = interp_type_evars_impls ~flags env sigma ~impls ctyp in + let ctx, concl = Reductionops.splay_prod_assum env sigma ctyp in + let concl_env = EConstr.push_rel_context ctx env in + let sigma_with_model_evars, model = + model_conclusion concl_env sigma ind_rel params (Context.Rel.length ctx) arity_indices + in + (* unify the expected with the provided conclusion *) + let sigma = + try Evarconv.unify concl_env sigma_with_model_evars Reduction.CONV concl model + with Evarconv.UnableToUnify (sigma,e) -> + user_err (Himsg.explain_pretype_error concl_env sigma + (Pretype_errors.CannotUnify (concl, model, (Some e)))) + in + sigma, (ctyp, cimpl) + in + let sigma, (ctyps, cimpls) = on_snd List.split @@ - List.fold_left_map (fun sigma l -> - interp_type_evars_impls ~program_mode:false env sigma ~impls l) sigma ctyps' in - sigma, (cnames, ctyps'', cimpls) + List.fold_left_map interp_cstr sigma ctyps + in + (sigma, pred ind_rel), (cnames, ctyps, cimpls) let sign_level env evd sign = fst (List.fold_right @@ -427,6 +442,30 @@ let interp_params env udecl uparamsl paramsl = sigma, env_params, (ctx_params, env_uparams, ctx_uparams, List.map (RelDecl.get_name %> Name.get_id) assums, userimpls, useruimpls, impls, udecl) +(* When a hole remains for a param, pretend the param is uniform and + do the unification. + [env_ar_par] is [uparams; inds; params] + *) +let maybe_unify_params_in env_ar_par sigma ~ninds ~nparams c = + let is_ind sigma k c = match EConstr.kind sigma c with + | Constr.Rel n -> + (* env is [uparams; inds; params; k other things] *) + n > k + nparams && n <= k + nparams + ninds + | _ -> false + in + let rec aux (env,k as envk) sigma c = match EConstr.kind sigma c with + | Constr.App (h,args) when is_ind sigma k h -> + Array.fold_left_i (fun i sigma arg -> + if i >= nparams || not (EConstr.isEvar sigma arg) then sigma + else Evarconv.unify_delay env sigma arg (EConstr.mkRel (k+nparams-i))) + sigma args + | _ -> Termops.fold_constr_with_full_binders + sigma + (fun d (env,k) -> EConstr.push_rel d env, k+1) + aux envk sigma c + in + aux (env_ar_par,0) sigma c + let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) notations ~cumulative ~poly ~private_ind finite = check_all_names_different indl; List.iter check_param paramsl; @@ -464,20 +503,31 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not (* Compute interpretation metadatas *) let indimpls = List.map (fun impls -> userimpls @ impls) indimpls in - let impls = compute_internalization_env env_uparams sigma ~impls (Inductive (params,true)) indnames fullarities indimpls in - let ntn_impls = compute_internalization_env env_uparams sigma (Inductive (params,true)) indnames fullarities indimpls in - let mldatas = List.map2 (mk_mltype_data sigma env_params params) arities indnames in + let impls = compute_internalization_env env_uparams sigma ~impls Inductive indnames fullarities indimpls in + let ntn_impls = compute_internalization_env env_uparams sigma Inductive indnames fullarities indimpls in - let sigma, constructors = + let ninds = List.length indl in + let (sigma, _), constructors = Metasyntax.with_syntax_protection (fun () -> - (* Temporary declaration of notations and scopes *) - List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; - (* Interpret the constructor types *) - List.fold_left3_map (fun sigma -> interp_cstrs env_ar_params sigma impls) sigma mldatas arities indl) - () in + (* Temporary declaration of notations and scopes *) + List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; + (* Interpret the constructor types *) + List.fold_left2_map + (fun (sigma, ind_rel) -> interp_cstrs env_ar_params (sigma, ind_rel) impls ctx_params) + (sigma, ninds) indl arities) + () + in - (* generalize over the uniform parameters *) let nparams = Context.Rel.length ctx_params in + let sigma = + List.fold_left (fun sigma (_,ctyps,_) -> + List.fold_left (fun sigma ctyp -> + maybe_unify_params_in env_ar_params sigma ~ninds ~nparams ctyp) + sigma ctyps) + sigma constructors + in + + (* generalize over the uniform parameters *) let nuparams = Context.Rel.length ctx_uparams in let uargs = Context.Rel.to_extended_vect EConstr.mkRel 0 ctx_uparams in let uparam_subst = diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 2b9da1d4e5..984581152a 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -88,3 +88,9 @@ val template_polymorphism_candidate polymorphic. It should have at least one universe in its monomorphic universe context that can be made parametric in its conclusion sort, if one is given. *) + +val maybe_unify_params_in : Environ.env -> Evd.evar_map -> ninds:int -> nparams:int + -> EConstr.t -> Evd.evar_map +(** [nparams] is the number of parameters which aren't treated as + uniform, ie the length of params (including letins) where the env + is [uniform params, inductives, params]. *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3bac0419ef..80e7e6ab96 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -195,12 +195,12 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let lift_lets = lift_rel_context 1 letbinders in let sigma, intern_body = let ctx = LocalAssum (make_annot (Name recname) Sorts.Relevant, get_type curry_fun) :: binders_rel in - let (r, l, impls, scopes) = + let (r, impls, scopes) = Constrintern.compute_internalization_data env sigma Constrintern.Recursive full_arity impls in let newimpls = Id.Map.singleton recname - (r, l, impls @ [Some (ExplByName (Id.of_string "recproof"), Impargs.Manual, (true, false))], + (r, impls @ [Some (ExplByName (Id.of_string "recproof"), Impargs.Manual, (true, false))], scopes @ [None]) in interp_casted_constr_evars ~program_mode:true (push_rel_context ctx env) sigma ~impls:newimpls body (lift 1 top_arity) @@ -254,9 +254,9 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = in (* XXX: Capturing sigma here... bad bad *) let hook = DeclareDef.Hook.make (hook sigma) in - Obligations.check_evars env sigma; + RetrieveObl.check_evars env sigma; let evars, _, evars_def, evars_typ = - Obligations.eterm_obligations env recname sigma 0 def typ + RetrieveObl.retrieve_obligations env recname sigma 0 def typ in let uctx = Evd.evar_universe_context sigma in ignore(Obligations.add_definition ~name:recname ~term:evars_def ~udecl @@ -281,15 +281,15 @@ let do_program_recursive ~scope ~poly fixkind fixl = let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in (* Solve remaining evars *) let evd = nf_evar_map_undefined evd in - let collect_evars id def typ imps = + let collect_evars name def typ impargs = (* Generalize by the recursive prototypes *) let def = nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) in let typ = nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) in let evm = collect_evars_of_term evd def typ in let evars, _, def, typ = - Obligations.eterm_obligations env id evm + RetrieveObl.retrieve_obligations env name evm (List.length rec_sign) def typ in - (id, def, typ, imps, evars) + ({ DeclareDef.Recthm.name; typ; impargs; args = [] }, def, evars) in let (fixnames,fixrs,fixdefs,fixtypes) = fix in let fiximps = List.map pi2 info in diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index fc53abdcea..1607771598 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -9,7 +9,6 @@ (************************************************************************) open Declare -open Impargs type locality = Discharge | Global of Declare.import_status @@ -34,41 +33,39 @@ module Hook = struct let make hook = CEphemeron.create hook - let call ?hook ?fix_exn x = - try Option.iter (fun hook -> CEphemeron.get hook x) hook - with e when CErrors.noncritical e -> - let e = Exninfo.capture e in - let e = Option.cata (fun fix -> fix e) e fix_exn in - Exninfo.iraise e + let call ?hook x = Option.iter (fun hook -> CEphemeron.get hook x) hook + end (* Locality stuff *) -let declare_definition ~name ~scope ~kind ?hook_data ~ubind ~impargs ce = - let fix_exn = Declare.Internal.get_fix_exn ce in - let should_suggest = ce.Declare.proof_entry_opaque && - Option.is_empty ce.Declare.proof_entry_secctx in +let declare_entry ~name ~scope ~kind ?hook ?(obls=[]) ~impargs ~uctx entry = + let should_suggest = entry.Declare.proof_entry_opaque && + Option.is_empty entry.Declare.proof_entry_secctx in + let ubind = UState.universe_binders uctx in let dref = match scope with | Discharge -> - let () = declare_variable ~name ~kind (SectionLocalDef ce) in + let () = declare_variable ~name ~kind (SectionLocalDef entry) in if should_suggest then Proof_using.suggest_variable (Global.env ()) name; Names.GlobRef.VarRef name | Global local -> - let kn = declare_constant ~name ~local ~kind (DefinitionEntry ce) in + let kn = declare_constant ~name ~local ~kind (DefinitionEntry entry) in let gr = Names.GlobRef.ConstRef kn in if should_suggest then Proof_using.suggest_constant (Global.env ()) kn; let () = DeclareUniv.declare_univ_binders gr ubind in gr in - let () = maybe_declare_manual_implicits false dref impargs in + let () = Impargs.maybe_declare_manual_implicits false dref impargs in let () = definition_message name in - begin - match hook_data with - | None -> () - | Some (hook, uctx, obls) -> - Hook.call ~fix_exn ~hook { Hook.S.uctx; obls; scope; dref } - end; + Option.iter (fun hook -> Hook.call ~hook { Hook.S.uctx; obls; scope; dref }) hook; dref +let declare_entry ~name ~scope ~kind ?hook ?obls ~impargs ~uctx entry = + try declare_entry ~name ~scope ~kind ?hook ?obls ~impargs ~uctx entry + with exn -> + let exn = Exninfo.capture exn in + let fix_exn = Declare.Internal.get_fix_exn entry in + Exninfo.iraise (fix_exn exn) + let mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes = match possible_indexes with | Some possible_indexes -> @@ -98,22 +95,21 @@ end let declare_mutually_recursive ~opaque ~scope ~kind ~poly ~uctx ~udecl ~ntns ~rec_declaration ~possible_indexes ?(restrict_ucontext=true) fixitems = let vars, fixdecls, indexes = mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes in - let ubind, univs = + let uctx, univs = (* XXX: Obligations don't do this, this seems like a bug? *) if restrict_ucontext then - let evd = Evd.from_ctx uctx in - let evd = Evd.restrict_universe_context evd vars in - let univs = Evd.check_univ_decl ~poly evd udecl in - Evd.universe_binders evd, univs + let uctx = UState.restrict uctx vars in + let univs = UState.check_univ_decl ~poly uctx udecl in + uctx, univs else let univs = UState.univ_entry ~poly uctx in - UnivNames.empty_binders, univs + uctx, univs in let csts = CList.map2 (fun Recthm.{ name; typ; impargs } body -> - let ce = Declare.definition_entry ~opaque ~types:typ ~univs body in - declare_definition ~name ~scope ~kind ~ubind ~impargs ce) + let entry = Declare.definition_entry ~opaque ~types:typ ~univs body in + declare_entry ~name ~scope ~kind ~impargs ~uctx entry) fixitems fixdecls in let isfix = Option.is_empty possible_indexes in @@ -127,7 +123,7 @@ let warn_let_as_axiom = Pp.(fun id -> strbrk "Let definition" ++ spc () ++ Names.Id.print id ++ spc () ++ strbrk "declared as an axiom.") -let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = +let declare_assumption ~name ~scope ~hook ~impargs ~uctx pe = let local = match scope with | Discharge -> warn_let_as_axiom name; Declare.ImportNeedQualified | Global local -> local @@ -139,26 +135,58 @@ let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = let () = Impargs.maybe_declare_manual_implicits false dref impargs in let () = Declare.assumption_message name in let () = DeclareUniv.declare_univ_binders dref (UState.universe_binders uctx) in - let () = Hook.(call ?fix_exn ?hook { S.uctx; obls = []; scope; dref}) in + let () = Hook.(call ?hook { S.uctx; obls = []; scope; dref}) in dref +let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = + try declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + with exn -> + let exn = Exninfo.capture exn in + let exn = Option.cata (fun fix -> fix exn) exn fix_exn in + Exninfo.iraise exn + (* Preparing proof entries *) -let check_definition_evars ~allow_evars sigma = +let prepare_definition ?opaque ?inline ?fix_exn ~poly ~udecl ~types ~body sigma = let env = Global.env () in - if not allow_evars then Pretyping.check_evars_are_solved ~program_mode:false env sigma + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:true + sigma (fun nf -> nf body, Option.map nf types) + in + let univs = Evd.check_univ_decl ~poly sigma udecl in + let entry = definition_entry ?fix_exn ?opaque ?inline ?types ~univs body in + let uctx = Evd.evar_universe_context sigma in + entry, uctx + +let declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ?hook + ?obls ~poly ?inline ~types ~body ?fix_exn sigma = + let entry, uctx = prepare_definition ?fix_exn ~opaque ~poly ~udecl ~types ~body ?inline sigma in + declare_entry ~name ~scope ~kind ~impargs ?obls ?hook ~uctx entry -let prepare_definition ~allow_evars ?opaque ?inline ~poly ~udecl ~types ~body sigma = - check_definition_evars ~allow_evars sigma; - let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:(not allow_evars) +let prepare_obligation ?opaque ?inline ~name ~poly ~udecl ~types ~body sigma = + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:false sigma (fun nf -> nf body, Option.map nf types) in let univs = Evd.check_univ_decl ~poly sigma udecl in - sigma, definition_entry ?opaque ?inline ?types ~univs body + let ce = definition_entry ?opaque ?inline ?types ~univs body in + let env = Global.env () in + let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in + assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); + assert(Univ.ContextSet.is_empty ctx); + RetrieveObl.check_evars env sigma; + let c = EConstr.of_constr c in + let typ = match ce.Declare.proof_entry_type with + | Some t -> EConstr.of_constr t + | None -> Retyping.get_type_of env sigma c + in + let obls, _, c, cty = RetrieveObl.retrieve_obligations env name sigma 0 c typ in + let uctx = Evd.evar_universe_context sigma in + c, cty, uctx, obls -let prepare_parameter ~allow_evars ~poly ~udecl ~types sigma = - check_definition_evars ~allow_evars sigma; - let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:(not allow_evars) +let prepare_parameter ~poly ~udecl ~types sigma = + let env = Global.env () in + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:true sigma (fun nf -> nf types) in let univs = Evd.check_univ_decl ~poly sigma udecl in diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 1d7fd3a3bf..3bc1e25f19 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -36,19 +36,44 @@ module Hook : sig end val make : (S.t -> unit) -> t - val call : ?hook:t -> ?fix_exn:Future.fix_exn -> S.t -> unit + val call : ?hook:t -> S.t -> unit end -val declare_definition +(** Declare an interactively-defined constant *) +val declare_entry : name:Id.t -> scope:locality -> kind:Decls.logical_kind - -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) - -> ubind:UnivNames.universe_binders + -> ?hook:Hook.t + -> ?obls:(Id.t * Constr.t) list -> impargs:Impargs.manual_implicits + -> uctx:UState.t -> Evd.side_effects Declare.proof_entry -> GlobRef.t +(** Declares a non-interactive constant; [body] and [types] will be + normalized w.r.t. the passed [evar_map] [sigma]. Universes should + be handled properly, including minimization and restriction. Note + that [sigma] is checked for unresolved evars, thus you should be + careful not to submit open terms or evar maps with stale, + unresolved existentials *) +val declare_definition + : name:Id.t + -> scope:locality + -> kind:Decls.logical_kind + -> opaque:bool + -> impargs:Impargs.manual_implicits + -> udecl:UState.universe_decl + -> ?hook:Hook.t + -> ?obls:(Id.t * Constr.t) list + -> poly:bool + -> ?inline:bool + -> types:EConstr.t option + -> body:EConstr.t + -> ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) + -> Evd.evar_map + -> GlobRef.t + val declare_assumption : ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) -> name:Id.t @@ -88,20 +113,19 @@ val declare_mutually_recursive -> Recthm.t list -> Names.GlobRef.t list -val prepare_definition - : allow_evars:bool - -> ?opaque:bool +val prepare_obligation + : ?opaque:bool -> ?inline:bool + -> name:Id.t -> poly:bool -> udecl:UState.universe_decl -> types:EConstr.t option -> body:EConstr.t -> Evd.evar_map - -> Evd.evar_map * Evd.side_effects Declare.proof_entry + -> Constr.constr * Constr.types * UState.t * RetrieveObl.obligation_info val prepare_parameter - : allow_evars:bool - -> poly:bool + : poly:bool -> udecl:UState.universe_decl -> types:EConstr.types -> Evd.evar_map diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index 98a9e4b9c9..bba3687256 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -362,34 +362,21 @@ let get_fix_exn, stm_get_fix_exn = Hook.make () let declare_definition prg = let varsubst = obligation_substitution true prg in - let body, typ = subst_prog varsubst prg in - let nf = - UnivSubst.nf_evars_and_universes_opt_subst - (fun x -> None) - (UState.subst prg.prg_ctx) - in - let opaque = prg.prg_opaque in + let sigma = Evd.from_ctx prg.prg_ctx in + let body, types = subst_prog varsubst prg in + let body, types = EConstr.(of_constr body, Some (of_constr types)) in + (* All these should be grouped into a struct a some point *) + let opaque, poly, udecl, hook = prg.prg_opaque, prg.prg_poly, prg.prg_univdecl, prg.prg_hook in + let name, scope, kind, impargs = prg.prg_name, prg.prg_scope, Decls.(IsDefinition prg.prg_kind), prg.prg_implicits in let fix_exn = Hook.get get_fix_exn () in - let typ = nf typ in - let body = nf body in - let obls = List.map (fun (id, (_, c)) -> (id, nf c)) varsubst in - let uvars = - Univ.LSet.union - (Vars.universes_of_constr typ) - (Vars.universes_of_constr body) - in - let uctx = UState.restrict prg.prg_ctx uvars in - let univs = - UState.check_univ_decl ~poly:prg.prg_poly uctx prg.prg_univdecl - in - let ce = Declare.definition_entry ~fix_exn ~opaque ~types:typ ~univs body in + let obls = List.map (fun (id, (_, c)) -> (id, c)) varsubst in + (* XXX: This is doing normalization twice *) let () = progmap_remove prg in - let ubind = UState.universe_binders uctx in - let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in - DeclareDef.declare_definition - ~name:prg.prg_name ~scope:prg.prg_scope ~ubind - ~kind:Decls.(IsDefinition prg.prg_kind) ce - ~impargs:prg.prg_implicits ?hook_data + let kn = + DeclareDef.declare_definition ~name ~scope ~kind ~impargs ?hook ~obls + ~fix_exn ~opaque ~poly ~udecl ~types ~body sigma + in + kn let rec lam_index n t acc = match Constr.kind t with @@ -464,9 +451,8 @@ let declare_mutual_definition l = ~restrict_ucontext:false fixitems in (* Only for the first constant *) - let fix_exn = Hook.get get_fix_exn () in let dref = List.hd kns in - DeclareDef.Hook.(call ?hook:first.prg_hook ~fix_exn { S.uctx = first.prg_ctx; obls; scope; dref }); + DeclareDef.Hook.(call ?hook:first.prg_hook { S.uctx = first.prg_ctx; obls; scope; dref }); List.iter progmap_remove l; dref @@ -529,10 +515,6 @@ let obligation_terminator entries uctx { name; num; auto } = Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); (* Declare the obligation ourselves and drop the hook *) let prg = CEphemeron.get (ProgMap.find name !from_prg) in - (* Ensure universes are substituted properly in body and type *) - let body = EConstr.to_constr sigma (EConstr.of_constr body) in - let ty = Option.map (fun x -> EConstr.to_constr sigma (EConstr.of_constr x)) ty in - let ctx = Evd.evar_universe_context sigma in let { obls; remaining=rem } = prg.prg_obligations in let obl = obls.(num) in let status = @@ -545,24 +527,24 @@ let obligation_terminator entries uctx { name; num; auto } = | (_, status), false -> status in let obl = { obl with obl_status = false, status } in - let ctx = - if prg.prg_poly then ctx - else UState.union prg.prg_ctx ctx + let uctx = + if prg.prg_poly then uctx + else UState.union prg.prg_ctx uctx in - let uctx = UState.univ_entry ~poly:prg.prg_poly ctx in - let (defined, obl) = declare_obligation prg obl body ty uctx in + let univs = UState.univ_entry ~poly:prg.prg_poly uctx in + let (defined, obl) = declare_obligation prg obl body ty univs in let prg_ctx = if prg.prg_poly then (* Polymorphic *) (* We merge the new universes and constraints of the polymorphic obligation with the existing ones *) - UState.union prg.prg_ctx ctx + UState.union prg.prg_ctx uctx else (* The first obligation, if defined, declares the univs of the constant, each subsequent obligation declares its own additional universes and constraints if any *) if defined then UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) - else ctx + else uctx in update_program_decl_on_defined prg obls num obl ~uctx:prg_ctx rem ~auto | _ -> diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index 5dae389a62..fdc8b1ba4c 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -325,51 +325,48 @@ let is_binder_level custom (custom',from) e = match e with | _ -> false let make_sep_rules = function - | [tk] -> Atoken tk + | [tk] -> + Pcoq.Symbol.token tk | tkl -> - let rec mkrule : 'a Tok.p list -> 'a rules = function - | [] -> Rules (Stop, fun _ -> (* dropped anyway: *) "") - | tkn :: rem -> - let Rules (r, f) = mkrule rem in - let r = NextNoRec (r, Atoken tkn) in - Rules (r, fun _ -> f) - in - let r = mkrule (List.rev tkl) in - Arules [r] + let r = Pcoq.mk_rule (List.rev tkl) in + Pcoq.Symbol.rules [r] type ('s, 'a) mayrec_symbol = -| MayRecNo : ('s, norec, 'a) symbol -> ('s, 'a) mayrec_symbol -| MayRecMay : ('s, mayrec, 'a) symbol -> ('s, 'a) mayrec_symbol +| MayRecNo : ('s, Gramlib.Grammar.norec, 'a) Symbol.t -> ('s, 'a) mayrec_symbol +| MayRecMay : ('s, Gramlib.Grammar.mayrec, 'a) Symbol.t -> ('s, 'a) mayrec_symbol let symbol_of_target : type s. _ -> _ -> _ -> _ -> s target -> (s, s) mayrec_symbol = fun custom p assoc from forpat -> - if is_binder_level custom from p then (* Prevent self *) MayRecNo (Aentryl (target_entry custom forpat, "200")) - else if is_self custom from p then MayRecMay Aself + if is_binder_level custom from p + then + (* Prevent self *) + MayRecNo (Pcoq.Symbol.nterml (target_entry custom forpat) "200") + else if is_self custom from p then MayRecMay Pcoq.Symbol.self else let g = target_entry custom forpat in let lev = adjust_level custom assoc from p in begin match lev with - | DefaultLevel -> MayRecNo (Aentry g) - | NextLevel -> MayRecMay Anext - | NumLevel lev -> MayRecNo (Aentryl (g, string_of_int lev)) + | DefaultLevel -> MayRecNo (Pcoq.Symbol.nterm g) + | NextLevel -> MayRecMay Pcoq.Symbol.next + | NumLevel lev -> MayRecNo (Pcoq.Symbol.nterml g (string_of_int lev)) end let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) mayrec_symbol = fun assoc from typ -> match typ with | TTConstr (s, p, forpat) -> symbol_of_target s p assoc from forpat | TTConstrList (s, typ', [], forpat) -> begin match symbol_of_target s typ' assoc from forpat with - | MayRecNo s -> MayRecNo (Alist1 s) - | MayRecMay s -> MayRecMay (Alist1 s) end + | MayRecNo s -> MayRecNo (Pcoq.Symbol.list1 s) + | MayRecMay s -> MayRecMay (Pcoq.Symbol.list1 s) end | TTConstrList (s, typ', tkl, forpat) -> begin match symbol_of_target s typ' assoc from forpat with - | MayRecNo s -> MayRecNo (Alist1sep (s, make_sep_rules tkl)) - | MayRecMay s -> MayRecMay (Alist1sep (s, make_sep_rules tkl)) end -| TTPattern p -> MayRecNo (Aentryl (Constr.pattern, string_of_int p)) -| TTClosedBinderList [] -> MayRecNo (Alist1 (Aentry Constr.binder)) -| TTClosedBinderList tkl -> MayRecNo (Alist1sep (Aentry Constr.binder, make_sep_rules tkl)) -| TTName -> MayRecNo (Aentry Prim.name) -| TTOpenBinderList -> MayRecNo (Aentry Constr.open_binders) -| TTBigint -> MayRecNo (Aentry Prim.bignat) -| TTReference -> MayRecNo (Aentry Constr.global) + | MayRecNo s -> MayRecNo (Pcoq.Symbol.list1sep s (make_sep_rules tkl) false) + | MayRecMay s -> MayRecMay (Pcoq.Symbol.list1sep s (make_sep_rules tkl) false) end +| TTPattern p -> MayRecNo (Pcoq.Symbol.nterml Constr.pattern (string_of_int p)) +| TTClosedBinderList [] -> MayRecNo (Pcoq.Symbol.list1 (Pcoq.Symbol.nterm Constr.binder)) +| TTClosedBinderList tkl -> MayRecNo (Pcoq.Symbol.list1sep (Pcoq.Symbol.nterm Constr.binder) (make_sep_rules tkl) false) +| TTName -> MayRecNo (Pcoq.Symbol.nterm Prim.name) +| TTOpenBinderList -> MayRecNo (Pcoq.Symbol.nterm Constr.open_binders) +| TTBigint -> MayRecNo (Pcoq.Symbol.nterm Prim.bignat) +| TTReference -> MayRecNo (Pcoq.Symbol.nterm Constr.global) let interp_entry forpat e = match e with | ETProdName -> TTAny TTName @@ -461,22 +458,22 @@ let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> s env -> ty_eval rem f { env with constrs; constrlists; } type ('s, 'a, 'r) mayrec_rule = -| MayRecRNo : ('s, Extend.norec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule -| MayRecRMay : ('s, Extend.mayrec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule +| MayRecRNo : ('s, Gramlib.Grammar.norec, 'a, 'r) Rule.t -> ('s, 'a, 'r) mayrec_rule +| MayRecRMay : ('s, Gramlib.Grammar.mayrec, 'a, 'r) Rule.t -> ('s, 'a, 'r) mayrec_rule let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) mayrec_rule = function -| TyStop -> MayRecRNo Stop +| TyStop -> MayRecRNo Rule.stop | TyMark (_, _, _, r) -> ty_erase r | TyNext (rem, TyTerm tok) -> begin match ty_erase rem with - | MayRecRNo rem -> MayRecRMay (Next (rem, Atoken tok)) - | MayRecRMay rem -> MayRecRMay (Next (rem, Atoken tok)) end + | MayRecRNo rem -> MayRecRMay (Rule.next rem (Symbol.token tok)) + | MayRecRMay rem -> MayRecRMay (Rule.next rem (Symbol.token tok)) end | TyNext (rem, TyNonTerm (_, _, s, _)) -> begin match ty_erase rem, s with - | MayRecRNo rem, MayRecNo s -> MayRecRMay (Next (rem, s)) - | MayRecRNo rem, MayRecMay s -> MayRecRMay (Next (rem, s)) - | MayRecRMay rem, MayRecNo s -> MayRecRMay (Next (rem, s)) - | MayRecRMay rem, MayRecMay s -> MayRecRMay (Next (rem, s)) end + | MayRecRNo rem, MayRecNo s -> MayRecRMay (Rule.next rem s) + | MayRecRNo rem, MayRecMay s -> MayRecRMay (Rule.next rem s) + | MayRecRMay rem, MayRecNo s -> MayRecRMay (Rule.next rem s) + | MayRecRMay rem, MayRecMay s -> MayRecRMay (Rule.next rem s) end type ('self, 'r) any_ty_rule = | AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule @@ -504,7 +501,7 @@ let target_to_bool : type r. r target -> bool = function | ForPattern -> true let prepare_empty_levels forpat (where,(pos,p4assoc,name,reinit)) = - let empty = (pos, [(name, p4assoc, [])]) in + let empty = { pos; data = [(name, p4assoc, [])] } in match reinit with | None -> ExtendRule (target_entry where forpat, empty) @@ -522,7 +519,13 @@ let rec pure_sublevels' assoc from forpat level = function let rem = pure_sublevels' assoc from forpat level rem in let push where p rem = match symbol_of_target where p assoc from forpat with - | MayRecNo (Aentryl (_,i)) when different_levels (fst from,level) (where,i) -> (where,int_of_string i) :: rem + | MayRecNo sym -> + (match Pcoq.level_of_nonterm sym with + | None -> rem + | Some i -> + if different_levels (fst from,level) (where,i) then + (where,int_of_string i) :: rem + else rem) | _ -> rem in (match e with | ETProdPattern i -> push InConstrEntry (NumLevel i,InternalProd) rem @@ -553,14 +556,15 @@ let extend_constr state forpat ng = let act = ty_eval r (make_act forpat ng.notgram_notation) empty in let rule = let r = match ty_erase r with - | MayRecRNo symbs -> Rule (symbs, act) - | MayRecRMay symbs -> Rule (symbs, act) in + | MayRecRNo symbs -> Pcoq.Production.make symbs act + | MayRecRMay symbs -> Pcoq.Production.make symbs act + in name, p4assoc, [r] in let r = match reinit with | None -> - ExtendRule (entry, (pos, [rule])) + ExtendRule (entry, { pos; data = [rule]}) | Some reinit -> - ExtendRuleReinit (entry, reinit, (pos, [rule])) + ExtendRuleReinit (entry, reinit, { pos; data = [rule]}) in (accu @ empty_rules @ [r], state) in diff --git a/vernac/egramml.ml b/vernac/egramml.ml index 793aad6b24..bda1401bc9 100644 --- a/vernac/egramml.ml +++ b/vernac/egramml.ml @@ -19,14 +19,14 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - ('a raw_abstract_argument_type * ('s, _, 'a) symbol) Loc.located -> 's grammar_prod_item + ('a raw_abstract_argument_type * ('s, _, 'a) Symbol.t) Loc.located -> 's grammar_prod_item type 'a ty_arg = ('a -> raw_generic_argument) type ('self, 'tr, _, 'r) ty_rule = -| TyStop : ('self, Extend.norec, 'r, 'r) ty_rule -| TyNext : ('self, _, 'a, 'r) ty_rule * ('self, _, 'b) Extend.symbol * 'b ty_arg option -> - ('self, Extend.mayrec, 'b -> 'a, 'r) ty_rule +| TyStop : ('self, Gramlib.Grammar.norec, 'r, 'r) ty_rule +| TyNext : ('self, _, 'a, 'r) ty_rule * ('self, _, 'b) Symbol.t * 'b ty_arg option -> + ('self, Gramlib.Grammar.mayrec, 'b -> 'a, 'r) ty_rule type ('self, 'r) any_ty_rule = | AnyTyRule : ('self, _, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule @@ -35,7 +35,7 @@ let rec ty_rule_of_gram = function | [] -> AnyTyRule TyStop | GramTerminal s :: rem -> let AnyTyRule rem = ty_rule_of_gram rem in - let tok = Atoken (CLexer.terminal s) in + let tok = Pcoq.Symbol.token (CLexer.terminal s) in let r = TyNext (rem, tok, None) in AnyTyRule r | GramNonTerminal (_, (t, tok)) :: rem -> @@ -44,9 +44,9 @@ let rec ty_rule_of_gram = function let r = TyNext (rem, tok, inj) in AnyTyRule r -let rec ty_erase : type s tr a r. (s, tr, a, r) ty_rule -> (s, tr, a, r) Extend.rule = function -| TyStop -> Extend.Stop -| TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) +let rec ty_erase : type s tr a r. (s, tr, a, r) ty_rule -> (s, tr, a, r) Pcoq.Rule.t = function +| TyStop -> Pcoq.Rule.stop +| TyNext (rem, tok, _) -> Pcoq.Rule.next (ty_erase rem) tok type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r @@ -62,7 +62,7 @@ let make_rule f prod = let symb = ty_erase ty_rule in let f loc l = f loc (List.rev l) in let act = ty_eval ty_rule f in - Extend.Rule (symb, act) + Pcoq.Production.make symb act let rec proj_symbol : type a b c. (a, b, c) ty_user_symbol -> (a, b, c) genarg_type = function | TUentry a -> ExtraArg a @@ -90,4 +90,4 @@ let extend_vernac_command_grammar s nt gl = vernac_exts := (s,gl) :: !vernac_exts; let mkact loc l = VernacExtend (s, l) in let rules = [make_rule mkact gl] in - grammar_extend nt (None, [None, None, rules]) + grammar_extend nt { pos=None; data=[None, None, rules]} diff --git a/vernac/egramml.mli b/vernac/egramml.mli index 7f6656b079..15f415ca3b 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -18,7 +18,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : ('a Genarg.raw_abstract_argument_type * - ('s, _, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item + ('s, _, 'a) Pcoq.Symbol.t) Loc.located -> 's grammar_prod_item val extend_vernac_command_grammar : extend_name -> vernac_expr Pcoq.Entry.t option -> @@ -32,4 +32,4 @@ val proj_symbol : ('a, 'b, 'c) Extend.ty_user_symbol -> ('a, 'b, 'c) Genarg.gena val make_rule : (Loc.t -> Genarg.raw_generic_argument list -> 'a) -> - 'a grammar_prod_item list -> 'a Extend.production_rule + 'a grammar_prod_item list -> 'a Pcoq.Production.t diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index dd75693c5b..a1cdc718d7 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -348,25 +348,11 @@ GRAMMAR EXTEND Gram (* Simple definitions *) def_body: [ [ bl = binders; ":="; red = reduce; c = lconstr -> - { if List.exists (function CLocalPattern _ -> true | _ -> false) bl - then - (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = mkLambdaCN ~loc bl c in - DefineBody ([], red, c, None) - else - (match c with - | { CAst.v = CCast(c, CastConv t) } -> DefineBody (bl, red, c, Some t) - | _ -> DefineBody (bl, red, c, None)) } + { match c.CAst.v with + | CCast(c, Glob_term.CastConv t) -> DefineBody (bl, red, c, Some t) + | _ -> DefineBody (bl, red, c, None) } | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> - { let ((bl, c), tyo) = - if List.exists (function CLocalPattern _ -> true | _ -> false) bl - then - (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = CAst.make ~loc @@ CCast (c, CastConv t) in - (([],mkLambdaCN ~loc bl c), None) - else ((bl, c), Some t) - in - DefineBody (bl, red, c, tyo) } + { DefineBody (bl, red, c, Some t) } | bl = binders; ":"; t = lconstr -> { ProveBody (bl, t) } ] ] ; @@ -983,13 +969,6 @@ GRAMMAR EXTEND Gram { fun g -> VernacSearch (SearchRewrite c,g, l) } | IDENT "Search"; s = searchabout_query; l = searchabout_queries; "." -> { let (sl,m) = l in fun g -> VernacSearch (Search (s::sl),g, m) } - (* compatibility: SearchAbout *) - | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries; "." -> - { fun g -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl),g, m) } - (* compatibility: SearchAbout with "[ ... ]" *) - | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]"; - l = in_or_out_modules; "." -> - { fun g -> VernacSearch (SearchAbout sl,g, l) } ] ] ; printable: diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index e08d2ce117..7f7340bb34 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -27,15 +27,12 @@ module Proof_ending = struct | Regular | End_obligation of DeclareObl.obligation_qed_info | End_derive of { f : Id.t; name : Id.t } - | End_equations of { hook : Constant.t list -> Evd.evar_map -> unit - ; i : Id.t - ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list - ; wits : EConstr.t list ref - (* wits are actually computed by the proof - engine by side-effect after creating the - proof! This is due to the start_dependent_proof API *) - ; sigma : Evd.evar_map - } + | End_equations of + { hook : Constant.t list -> Evd.evar_map -> unit + ; i : Id.t + ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list + ; sigma : Evd.evar_map + } end @@ -43,22 +40,21 @@ module Info = struct type t = { hook : DeclareDef.Hook.t option - ; compute_guard : lemma_possible_guards - ; impargs : Impargs.manual_implicits ; proof_ending : Proof_ending.t CEphemeron.key (* This could be improved and the CEphemeron removed *) - ; other_thms : DeclareDef.Recthm.t list ; scope : DeclareDef.locality ; kind : Decls.logical_kind + (* thms and compute guard are specific only to start_lemma_with_initialization + regular terminator *) + ; thms : DeclareDef.Recthm.t list + ; compute_guard : lemma_possible_guards } let make ?hook ?(proof_ending=Proof_ending.Regular) ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.(IsProof Lemma)) () = { hook ; compute_guard = [] - ; impargs = [] ; proof_ending = CEphemeron.create proof_ending - ; other_thms = [] + ; thms = [] ; scope ; kind } @@ -100,18 +96,30 @@ let initialize_named_context_for_proof () = let d = if Decls.variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val +let add_first_thm ~info ~name ~typ ~impargs = + let thms = + { DeclareDef.Recthm.name + ; impargs + ; typ = EConstr.Unsafe.to_constr typ + ; args = [] } :: info.Info.thms + in + { info with Info.thms } + (* Starting a goal *) let start_lemma ~name ~poly ?(udecl=UState.default_univ_decl) - ?(info=Info.make ()) - sigma c = + ?(info=Info.make ()) ?(impargs=[]) sigma c = (* We remove the bodies of variables in the named context marked "opaque", this is a hack tho, see #10446 *) let sign = initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in let proof = Proof_global.start_proof sigma ~name ~udecl ~poly goals in - { proof ; info } + let info = add_first_thm ~info ~name ~typ:c ~impargs in + { proof; info } +(* Note that proofs opened by start_dependent lemma cannot be closed + by the regular terminators, thus we don't need to update the [thms] + field. We will capture this invariant by typing in the future *) let start_dependent_lemma ~name ~poly ?(udecl=UState.default_univ_decl) ?(info=Info.make ()) telescope = @@ -153,17 +161,18 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua intro_tac (List.hd thms), [] in match thms with | [] -> CErrors.anomaly (Pp.str "No proof to start.") - | { DeclareDef.Recthm.name; typ; impargs; _}::other_thms -> + | { DeclareDef.Recthm.name; typ; impargs; _} :: thms -> let info = Info.{ hook - ; impargs ; compute_guard - ; other_thms ; proof_ending = CEphemeron.create Proof_ending.Regular + ; thms ; scope ; kind } in - let lemma = start_lemma ~name ~poly ~udecl ~info sigma (EConstr.of_constr typ) in + (* start_lemma has the responsibility to add (name, impargs, typ) + to thms, once Info.t is more refined this won't be necessary *) + let lemma = start_lemma ~name ~impargs ~poly ~udecl ~info sigma (EConstr.of_constr typ) in pf_map (Proof_global.map_proof (fun p -> pi1 @@ Proof.run_tactic Global.(env ()) init_tac p)) lemma @@ -179,39 +188,19 @@ module MutualEntry : sig val declare_variable : info:Info.t -> uctx:UState.t - (* Only for the first constant, introduced by compat *) - -> ubind:UnivNames.universe_binders - -> name:Id.t -> Entries.parameter_entry -> Names.GlobRef.t list val declare_mutdef (* Common to all recthms *) : info:Info.t - -> ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) -> uctx:UState.t - -> ?hook_data:DeclareDef.Hook.t * UState.t * (Names.Id.t * Constr.t) list - (* Only for the first constant, introduced by compat *) - -> ubind:UnivNames.universe_binders - -> name:Id.t -> Evd.side_effects Declare.proof_entry -> Names.GlobRef.t list end = struct - (* Body with the fix *) - type et = - | NoBody of Entries.parameter_entry - | Single of Evd.side_effects Declare.proof_entry - | Mutual of Evd.side_effects Declare.proof_entry - - type t = - { entry : et - ; info : Info.t - } - - (* XXX: Refactor this with the code in - [ComFixpoint.declare_fixpoint_generic] *) + (* XXX: Refactor this with the code in [DeclareDef.declare_mutdef] *) let guess_decreasing env possible_indexes ((body, ctx), eff) = let open Constr in match Constr.kind body with @@ -221,74 +210,55 @@ end = struct (mkFix ((indexes,0),fixdecls), ctx), eff | _ -> (body, ctx), eff - let adjust_guardness_conditions ~info const = - let entry = match info.Info.compute_guard with - | [] -> - (* Not a recursive statement *) - Single const - | possible_indexes -> - (* Try all combinations... not optimal *) - let env = Global.env() in - let pe = Declare.Internal.map_entry_body const - ~f:(guess_decreasing env possible_indexes) - in - Mutual pe - in { entry; info } - - let rec select_body i t = + let select_body i t = let open Constr in match Constr.kind t with | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) | CoFix (0,decls) -> mkCoFix (i,decls) - | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, select_body i t2) - | Lambda(na,ty,t) -> mkLambda(na,ty, select_body i t) - | App (t, args) -> mkApp (select_body i t, args) | _ -> CErrors.anomaly Pp.(str "Not a proof by induction: " ++ Termops.Internal.debug_print_constr (EConstr.of_constr t) ++ str ".") - let declare_mutdef ?fix_exn ~uctx ?hook_data ~ubind ~name ?typ ~impargs ~info mutpe i = - let { Info.hook; compute_guard; scope; kind; _ } = info in - match mutpe with - | NoBody pe -> - DeclareDef.declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe - | Single pe -> - (* We'd like to do [assert (i = 0)] here, however this codepath - is used when declaring mutual cofixpoints *) - DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ~ubind ~impargs pe - | Mutual pe -> - (* if typ = None , we don't touch the type; used in the base case *) - let pe = - match typ with - | None -> pe - | Some typ -> - Declare.Internal.map_entry_type pe ~f:(fun _ -> Some typ) - in - let pe = Declare.Internal.map_entry_body pe - ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) in - DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ~ubind ~impargs pe - - let declare_mutdef ?fix_exn ~uctx ?hook_data ~ubind ~name { entry; info } = - (* At some point make this a single iteration *) - (* At some point make this a single iteration *) - (* impargs here are special too, fixed in upcoming PRs *) - let impargs = info.Info.impargs in - let r = declare_mutdef ?fix_exn ~info ~ubind ?hook_data ~uctx ~name ~impargs entry 0 in - (* Before we used to do this, check if that's right *) - let ubind = UnivNames.empty_binders in - let rs = - List.map_i ( - fun i { DeclareDef.Recthm.name; typ; impargs } -> - declare_mutdef ?fix_exn ~name ~info ~ubind ?hook_data ~uctx ~typ ~impargs entry i) 1 info.Info.other_thms - in r :: rs - - let declare_variable ~info ~uctx ~ubind ~name pe = - declare_mutdef ~uctx ~ubind ~name { entry = NoBody pe; info } - - let declare_mutdef ~info ?fix_exn ~uctx ?hook_data ~ubind ~name const = - let mutpe = adjust_guardness_conditions ~info const in - declare_mutdef ?fix_exn ~uctx ?hook_data ~ubind ~name mutpe + let declare_mutdef ~uctx ~info pe i DeclareDef.Recthm.{ name; impargs; typ; _} = + let { Info.hook; scope; kind; compute_guard; _ } = info in + (* if i = 0 , we don't touch the type; this is for compat + but not clear it is the right thing to do. + *) + let pe, ubind = + if i > 0 && not (CList.is_empty compute_guard) + then Declare.Internal.map_entry_type pe ~f:(fun _ -> Some typ), UnivNames.empty_binders + else pe, UState.universe_binders uctx + in + (* We when compute_guard was [] in the previous step we should not + substitute the body *) + let pe = match compute_guard with + | [] -> pe + | _ -> + Declare.Internal.map_entry_body pe + ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) + in + DeclareDef.declare_entry ~name ~scope ~kind ?hook ~impargs ~uctx pe + + let declare_mutdef ~info ~uctx const = + let pe = match info.Info.compute_guard with + | [] -> + (* Not a recursive statement *) + const + | possible_indexes -> + (* Try all combinations... not optimal *) + let env = Global.env() in + Declare.Internal.map_entry_body const + ~f:(guess_decreasing env possible_indexes) + in + List.map_i (declare_mutdef ~info ~uctx pe) 0 info.Info.thms + + let declare_variable ~info ~uctx pe = + let { Info.scope; hook } = info in + List.map_i ( + fun i { DeclareDef.Recthm.name; typ; impargs } -> + DeclareDef.declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + ) 0 info.Info.thms end @@ -316,14 +286,13 @@ let compute_proof_using_for_admitted proof typ pproofs = Some (Environ.really_needed env (Id.Set.union ids_typ ids_def)) | _ -> None -let finish_admitted ~name ~info ~uctx pe = - let ubind = UnivNames.empty_binders in - let _r : Names.GlobRef.t list = MutualEntry.declare_variable ~info ~uctx ~ubind ~name pe in +let finish_admitted ~info ~uctx pe = + let _r : Names.GlobRef.t list = MutualEntry.declare_variable ~info ~uctx pe in () let save_lemma_admitted ~(lemma : t) : unit = let udecl = Proof_global.get_universe_decl lemma.proof in - let Proof.{ name; poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in + let Proof.{ poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in let typ = match Proofview.initial_goals entry with | [typ] -> snd typ | _ -> CErrors.anomaly ~label:"Lemmas.save_lemma_admitted" (Pp.str "more than one statement.") @@ -332,48 +301,26 @@ let save_lemma_admitted ~(lemma : t) : unit = let proof = Proof_global.get_proof lemma.proof in let pproofs = Proof.partial_proof proof in let sec_vars = compute_proof_using_for_admitted lemma.proof typ pproofs in - let universes = Proof_global.get_initial_euctx lemma.proof in - let ctx = UState.check_univ_decl ~poly universes udecl in - finish_admitted ~name ~info:lemma.info ~uctx:universes (sec_vars, (typ, ctx), None) + let uctx = Proof_global.get_initial_euctx lemma.proof in + let univs = UState.check_univ_decl ~poly uctx udecl in + finish_admitted ~info:lemma.info ~uctx (sec_vars, (typ, univs), None) (************************************************************************) (* Saving a lemma-like constant *) (************************************************************************) -let default_thm_id = Id.of_string "Unnamed_thm" - -let check_anonymity id save_ident = - if not (String.equal (Nameops.atompart_of_id id) (Id.to_string (default_thm_id))) then - CErrors.user_err Pp.(str "This command can only be used for unnamed theorem.") - -let finish_proved idopt po info = +let finish_proved po info = let open Proof_global in - let { Info.hook } = info in match po with - | { name; entries=[const]; uctx; udecl } -> - let name = match idopt with - | None -> name - | Some { CAst.v = save_id } -> check_anonymity name save_id; save_id in - let fix_exn = Declare.Internal.get_fix_exn const in - let () = try - let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - let ubind = UState.universe_binders uctx in - let _r : Names.GlobRef.t list = - MutualEntry.declare_mutdef ~info ~fix_exn ~uctx ?hook_data ~ubind ~name const - in () - with e when CErrors.noncritical e -> - let e = Exninfo.capture e in - Exninfo.iraise (fix_exn e) - in () + | { entries=[const]; uctx } -> + let _r : Names.GlobRef.t list = MutualEntry.declare_mutdef ~info ~uctx const in + () | _ -> CErrors.anomaly ~label:"finish_proved" Pp.(str "close_proof returned more than one proof term") -let finish_derived ~f ~name ~idopt ~entries = +let finish_derived ~f ~name ~entries = (* [f] and [name] correspond to the proof of [f] and of [suchthat], respectively. *) - if Option.has_some idopt then - CErrors.user_err Pp.(str "Cannot save a proof of Derive with an explicit name."); - let f_def, lemma_def = match entries with | [_;f_def;lemma_def] -> @@ -406,11 +353,11 @@ let finish_derived ~f ~name ~idopt ~entries = let _ : Names.Constant.t = Declare.declare_constant ~name ~kind:Decls.(IsProof Proposition) lemma_def in () -let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = +let finish_proved_equations ~kind ~hook i proof_obj types sigma0 = let obls = ref 1 in let sigma, recobls = - CList.fold_left2_map (fun sigma (wit, (evar_env, ev, evi, local_context, type_)) entry -> + CList.fold_left2_map (fun sigma (_evar_env, ev, _evi, local_context, _type) entry -> let id = match Evd.evar_ident ev sigma0 with | Some id -> id @@ -421,34 +368,51 @@ let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = let sigma, app = Evarutil.new_global sigma (GlobRef.ConstRef cst) in let sigma = Evd.define ev (EConstr.applist (app, List.map EConstr.of_constr args)) sigma in sigma, cst) sigma0 - (CList.combine (List.rev !wits) types) proof_obj.Proof_global.entries + types proof_obj.Proof_global.entries in hook recobls sigma -let finalize_proof idopt proof_obj proof_info = +let finalize_proof proof_obj proof_info = let open Proof_global in let open Proof_ending in match CEphemeron.default proof_info.Info.proof_ending Regular with | Regular -> - finish_proved idopt proof_obj proof_info + finish_proved proof_obj proof_info | End_obligation oinfo -> DeclareObl.obligation_terminator proof_obj.entries proof_obj.uctx oinfo | End_derive { f ; name } -> - finish_derived ~f ~name ~idopt ~entries:proof_obj.entries - | End_equations { hook; i; types; wits; sigma } -> - finish_proved_equations idopt proof_info.Info.kind proof_obj hook i types wits sigma + finish_derived ~f ~name ~entries:proof_obj.entries + | End_equations { hook; i; types; sigma } -> + finish_proved_equations ~kind:proof_info.Info.kind ~hook i proof_obj types sigma + +let err_save_forbidden_in_place_of_qed () = + CErrors.user_err (Pp.str "Cannot use Save with more than one constant or in this proof mode") + +let process_idopt_for_save ~idopt info = + match idopt with + | None -> info + | Some { CAst.v = save_name } -> + (* Save foo was used; we override the info in the first theorem *) + let thms = + match info.Info.thms, CEphemeron.default info.Info.proof_ending Proof_ending.Regular with + | [ { DeclareDef.Recthm.name; _} as decl ], Proof_ending.Regular -> + [ { decl with DeclareDef.Recthm.name = save_name } ] + | _ -> + err_save_forbidden_in_place_of_qed () + in { info with Info.thms } let save_lemma_proved ~lemma ~opaque ~idopt = (* Env and sigma are just used for error printing in save_remaining_recthms *) - let proof_obj = Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) lemma.proof in - finalize_proof idopt proof_obj lemma.info + let proof_obj = Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false lemma.proof in + let proof_info = process_idopt_for_save ~idopt lemma.info in + finalize_proof proof_obj proof_info (***********************************************************************) (* Special case to close a lemma without forcing a proof *) (***********************************************************************) let save_lemma_admitted_delayed ~proof ~info = let open Proof_global in - let { name; entries; uctx; udecl } = proof in + let { entries; uctx } = proof in if List.length entries <> 1 then CErrors.user_err Pp.(str "Admitted does not support multiple statements"); let { Declare.proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in @@ -460,6 +424,14 @@ let save_lemma_admitted_delayed ~proof ~info = | Some typ -> typ in let ctx = UState.univ_entry ~poly uctx in let sec_vars = if get_keep_admitted_vars () then proof_entry_secctx else None in - finish_admitted ~name ~uctx ~info (sec_vars, (typ, ctx), None) - -let save_lemma_proved_delayed ~proof ~info ~idopt = finalize_proof idopt proof info + finish_admitted ~uctx ~info (sec_vars, (typ, ctx), None) + +let save_lemma_proved_delayed ~proof ~info ~idopt = + (* vio2vo calls this but with invalid info, we have to workaround + that to add the name to the info structure *) + if CList.is_empty info.Info.thms then + let info = add_first_thm ~info ~name:proof.Proof_global.name ~typ:EConstr.mkSet ~impargs:[] in + finalize_proof proof info + else + let info = process_idopt_for_save ~idopt info in + finalize_proof proof info diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 6a1f8c09f3..8a23daa85f 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -35,12 +35,12 @@ module Proof_ending : sig | Regular | End_obligation of DeclareObl.obligation_qed_info | End_derive of { f : Id.t; name : Id.t } - | End_equations of { hook : Constant.t list -> Evd.evar_map -> unit - ; i : Id.t - ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list - ; wits : EConstr.t list ref - ; sigma : Evd.evar_map - } + | End_equations of + { hook : Constant.t list -> Evd.evar_map -> unit + ; i : Id.t + ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list + ; sigma : Evd.evar_map + } end @@ -68,6 +68,7 @@ val start_lemma -> poly:bool -> ?udecl:UState.universe_decl -> ?info:Info.t + -> ?impargs:Impargs.manual_implicits -> Evd.evar_map -> EConstr.types -> t @@ -95,8 +96,6 @@ val start_lemma_with_initialization -> int list option -> t -val default_thm_id : Names.Id.t - (** {4 Saving proofs} *) val save_lemma_admitted : lemma:t -> unit diff --git a/vernac/library.ml b/vernac/library.ml index 85645b92d4..1b0bd4c0f7 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -103,17 +103,13 @@ type library_summary = { libsum_digests : Safe_typing.vodigest; } -module LibraryOrdered = DirPath -module LibraryMap = Map.Make(LibraryOrdered) -module LibraryFilenameMap = Map.Make(LibraryOrdered) - (* This is a map from names to loaded libraries *) -let libraries_table : library_summary LibraryMap.t ref = - Summary.ref LibraryMap.empty ~name:"LIBRARY" +let libraries_table : library_summary DPmap.t ref = + Summary.ref DPmap.empty ~name:"LIBRARY" (* This is the map of loaded libraries filename *) (* (not synchronized so as not to be caught in the states on disk) *) -let libraries_filename_table = ref LibraryFilenameMap.empty +let libraries_filename_table = ref DPmap.empty (* These are the _ordered_ sets of loaded, imported and exported libraries *) let libraries_loaded_list = Summary.ref [] ~name:"LIBRARY-LOAD" @@ -121,7 +117,7 @@ let libraries_loaded_list = Summary.ref [] ~name:"LIBRARY-LOAD" (* various requests to the tables *) let find_library dir = - LibraryMap.find dir !libraries_table + DPmap.find dir !libraries_table let try_find_library dir = try find_library dir @@ -133,16 +129,16 @@ let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) (* from a previous play of the session *) libraries_filename_table := - LibraryFilenameMap.add dir f !libraries_filename_table + DPmap.add dir f !libraries_filename_table let library_full_filename dir = - try LibraryFilenameMap.find dir !libraries_filename_table + try DPmap.find dir !libraries_filename_table with Not_found -> "<unavailable filename>" let overwrite_library_filenames f = let f = if Filename.is_relative f then Filename.concat (Sys.getcwd ()) f else f in - LibraryMap.iter (fun dir _ -> register_library_filename dir f) + DPmap.iter (fun dir _ -> register_library_filename dir f) !libraries_table let library_is_loaded dir = @@ -159,15 +155,16 @@ let register_loaded_library m = let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in let f = prefix ^ "cmo" in let f = Dynlink.adapt_filename f in - if Coq_config.native_compiler then - Nativelib.link_library (Global.env()) ~prefix ~dirname ~basename:f + Nativelib.link_library (Global.env()) ~prefix ~dirname ~basename:f in let rec aux = function - | [] -> link (); [libname] + | [] -> + let () = if Flags.get_native_compiler () then link () in + [libname] | m'::_ as l when DirPath.equal m' libname -> l | m'::l' -> m' :: aux l' in libraries_loaded_list := aux !libraries_loaded_list; - libraries_table := LibraryMap.add libname m !libraries_table + libraries_table := DPmap.add libname m !libraries_table let loaded_libraries () = !libraries_loaded_list @@ -187,13 +184,13 @@ type 'a table_status = | Fetched of 'a array let opaque_tables = - ref (LibraryMap.empty : (Opaqueproof.opaque_proofterm table_status) LibraryMap.t) + ref (DPmap.empty : (Opaqueproof.opaque_proofterm table_status) DPmap.t) let add_opaque_table dp st = - opaque_tables := LibraryMap.add dp st !opaque_tables + opaque_tables := DPmap.add dp st !opaque_tables let access_table what tables dp i = - let t = match LibraryMap.find dp !tables with + let t = match DPmap.find dp !tables with | Fetched t -> t | ToFetch f -> let dir_path = Names.DirPath.to_string dp in @@ -206,7 +203,7 @@ let access_table what tables dp i = str ") is inaccessible or corrupted,\ncannot load some " ++ str what ++ str " in it.\n") in - tables := LibraryMap.add dp (Fetched t) !tables; + tables := DPmap.add dp (Fetched t) !tables; t in assert (i < Array.length t); t.(i) @@ -261,14 +258,12 @@ let intern_from_file f = | Some (_,false) -> mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty -module DPMap = Map.Make(DirPath) - let rec intern_library ~lib_resolver (needed, contents) (dir, f) from = (* Look if in the current logical environment *) try (find_library dir).libsum_digests, (needed, contents) with Not_found -> (* Look if already listed and consequently its dependencies too *) - try (DPMap.find dir contents).library_digests, (needed, contents) + try (DPmap.find dir contents).library_digests, (needed, contents) with Not_found -> Feedback.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* [dir] is an absolute name which matches [f] which must be in loadpath *) @@ -286,7 +281,7 @@ and intern_library_deps ~lib_resolver libs dir m from = let needed, contents = Array.fold_left (intern_mandatory_library ~lib_resolver dir from) libs m.library_deps in - (dir :: needed, DPMap.add dir m contents ) + (dir :: needed, DPmap.add dir m contents ) and intern_mandatory_library ~lib_resolver caller from libs (dir,d) = let digest, libs = intern_library ~lib_resolver libs (dir, None) (Some from) in @@ -372,8 +367,8 @@ let warn_require_in_module = strbrk "and optionally Import it inside another one.") let require_library_from_dirpath ~lib_resolver modrefl export = - let needed, contents = List.fold_left (rec_intern_library ~lib_resolver) ([], DPMap.empty) modrefl in - let needed = List.rev_map (fun dir -> DPMap.find dir contents) needed in + let needed, contents = List.fold_left (rec_intern_library ~lib_resolver) ([], DPmap.empty) modrefl in + let needed = List.rev_map (fun dir -> DPmap.find dir contents) needed in let modrefl = List.map fst modrefl in if Lib.is_module_or_modtype () then begin @@ -500,14 +495,11 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = let save_library_raw f sum lib univs proofs = save_library_base f sum lib (Some univs) None proofs -module StringOrd = struct type t = string let compare = String.compare end -module StringSet = Set.Make(StringOrd) - let get_used_load_paths () = - StringSet.elements - (List.fold_left (fun acc m -> StringSet.add + String.Set.elements + (List.fold_left (fun acc m -> String.Set.add (Filename.dirname (library_full_filename m)) acc) - StringSet.empty !libraries_loaded_list) + String.Set.empty !libraries_loaded_list) let _ = Nativelib.get_load_paths := get_used_load_paths diff --git a/vernac/obligations.ml b/vernac/obligations.ml index a29ba44907..435085793c 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -10,252 +10,16 @@ open Printf -(** - - Get types of existentials ; - - Flatten dependency tree (prefix order) ; - - Replace existentials by de Bruijn indices in term, applied to the right arguments ; - - Apply term prefixed by quantification on "existentials". -*) - -open Constr open Names open Pp open CErrors open Util -module NamedDecl = Context.Named.Declaration - (* For the records fields, opens should go away one these types are private *) open DeclareObl open DeclareObl.Obligation open DeclareObl.ProgramDecl -let succfix (depth, fixrels) = - (succ depth, List.map succ fixrels) - -let check_evars env evm = - Evar.Map.iter - (fun key evi -> - if Evd.is_obligation_evar evm key then () - else - let (loc,k) = Evd.evar_source key evm in - Pretype_errors.error_unsolvable_implicit ?loc env evm key None) - (Evd.undefined_map evm) - -type oblinfo = - { ev_name: int * Id.t; - ev_hyps: EConstr.named_context; - ev_status: bool * Evar_kinds.obligation_definition_status; - ev_chop: int option; - ev_src: Evar_kinds.t Loc.located; - ev_typ: types; - ev_tac: unit Proofview.tactic option; - ev_deps: Int.Set.t } - -(** Substitute evar references in t using de Bruijn indices, - where n binders were passed through. *) - -let subst_evar_constr evm evs n idf t = - let seen = ref Int.Set.empty in - let transparent = ref Id.Set.empty in - let evar_info id = List.assoc_f Evar.equal id evs in - let rec substrec (depth, fixrels) c = match EConstr.kind evm c with - | Evar (k, args) -> - let { ev_name = (id, idstr) ; - ev_hyps = hyps ; ev_chop = chop } = - try evar_info k - with Not_found -> - anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found.") - in - seen := Int.Set.add id !seen; - (* Evar arguments are created in inverse order, - and we must not apply to defined ones (i.e. LetIn's) - *) - let args = - let n = match chop with None -> 0 | Some c -> c in - let (l, r) = List.chop n (List.rev (Array.to_list args)) in - List.rev r - in - let args = - let rec aux hyps args acc = - let open Context.Named.Declaration in - match hyps, args with - (LocalAssum _ :: tlh), (c :: tla) -> - aux tlh tla ((substrec (depth, fixrels) c) :: acc) - | (LocalDef _ :: tlh), (_ :: tla) -> - aux tlh tla acc - | [], [] -> acc - | _, _ -> acc (*failwith "subst_evars: invalid argument"*) - in aux hyps args [] - in - if List.exists - (fun x -> match EConstr.kind evm x with - | Rel n -> Int.List.mem n fixrels - | _ -> false) args - then - transparent := Id.Set.add idstr !transparent; - EConstr.mkApp (idf idstr, Array.of_list args) - | Fix _ -> - EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c - | _ -> EConstr.map_with_binders evm succfix substrec (depth, fixrels) c - in - let t' = substrec (0, []) t in - EConstr.to_constr evm t', !seen, !transparent - - -(** Substitute variable references in t using de Bruijn indices, - where n binders were passed through. *) -let subst_vars acc n t = - let var_index id = Util.List.index Id.equal id acc in - let rec substrec depth c = match Constr.kind c with - | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) - | _ -> Constr.map_with_binders succ substrec depth c - in - substrec 0 t - -(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) - to a product : forall H1 : t1, ..., forall Hn : tn, concl. - Changes evars and hypothesis references to variable references. -*) -let etype_of_evar evm evs hyps concl = - let open Context.Named.Declaration in - let rec aux acc n = function - decl :: tl -> - let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar (NamedDecl.get_type decl) in - let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (NamedDecl.get_id decl :: acc) (succ n) tl in - let s' = Int.Set.union s s' in - let trans' = Id.Set.union trans trans' in - (match decl with - | LocalDef (id,c,_) -> - let c', s'', trans'' = subst_evar_constr evm evs n EConstr.mkVar c in - let c' = subst_vars acc 0 c' in - Term.mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, - Int.Set.union s'' s', - Id.Set.union trans'' trans' - | LocalAssum (id,_) -> - Term.mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') - | [] -> - let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar concl in - subst_vars acc 0 t', s, trans - in aux [] 0 (List.rev hyps) - -let trunc_named_context n ctx = - let len = List.length ctx in - List.firstn (len - n) ctx - -let rec chop_product n t = - let pop t = Vars.lift (-1) t in - if Int.equal n 0 then Some t - else - match Constr.kind t with - | Prod (_, _, b) -> if Vars.noccurn 1 b then chop_product (pred n) (pop b) else None - | _ -> None - -let evar_dependencies evm oev = - let one_step deps = - Evar.Set.fold (fun ev s -> - let evi = Evd.find evm ev in - let deps' = Evd.evars_of_filtered_evar_info evm evi in - if Evar.Set.mem oev deps' then - invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ Pp.string_of_ppcmds @@ Evar.print oev) - else Evar.Set.union deps' s) - deps deps - in - let rec aux deps = - let deps' = one_step deps in - if Evar.Set.equal deps deps' then deps - else aux deps' - in aux (Evar.Set.singleton oev) - -let move_after (id, ev, deps as obl) l = - let rec aux restdeps = function - | (id', _, _) as obl' :: tl -> - let restdeps' = Evar.Set.remove id' restdeps in - if Evar.Set.is_empty restdeps' then - obl' :: obl :: tl - else obl' :: aux restdeps' tl - | [] -> [obl] - in aux (Evar.Set.remove id deps) l - -let sort_dependencies evl = - let rec aux l found list = - match l with - | (id, ev, deps) as obl :: tl -> - let found' = Evar.Set.union found (Evar.Set.singleton id) in - if Evar.Set.subset deps found' then - aux tl found' (obl :: list) - else aux (move_after obl tl) found list - | [] -> List.rev list - in aux evl Evar.Set.empty [] - -let eterm_obligations env name evm fs ?status t ty = - (* 'Serialize' the evars *) - let nc = Environ.named_context env in - let nc_len = Context.Named.length nc in - let evm = Evarutil.nf_evar_map_undefined evm in - let evl = Evarutil.non_instantiated evm in - let evl = Evar.Map.bindings evl in - let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in - let sevl = sort_dependencies evl in - let evl = List.map (fun (id, ev, _) -> id, ev) sevl in - let evn = - let i = ref (-1) in - List.rev_map (fun (id, ev) -> incr i; - (id, (!i, Id.of_string - (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))), - ev)) evl - in - let evts = - (* Remove existential variables in types and build the corresponding products *) - List.fold_right - (fun (id, (n, nstr), ev) l -> - let hyps = Evd.evar_filtered_context ev in - let hyps = trunc_named_context nc_len hyps in - let evtyp, deps, transp = etype_of_evar evm l hyps ev.Evd.evar_concl in - let evtyp, hyps, chop = - match chop_product fs evtyp with - | Some t -> t, trunc_named_context fs hyps, fs - | None -> evtyp, hyps, 0 - in - let loc, k = Evd.evar_source id evm in - let status = match k with - | Evar_kinds.QuestionMark { Evar_kinds.qm_obligation=o } -> o - | _ -> match status with - | Some o -> o - | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ())) - in - let force_status, status, chop = match status with - | Evar_kinds.Define true as stat -> - if not (Int.equal chop fs) then true, Evar_kinds.Define false, None - else false, stat, Some chop - | s -> false, s, None - in - let info = { ev_name = (n, nstr); - ev_hyps = hyps; ev_status = force_status, status; ev_chop = chop; - ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None } - in (id, info) :: l) - evn [] - in - let t', _, transparent = (* Substitute evar refs in the term by variables *) - subst_evar_constr evm evts 0 EConstr.mkVar t - in - let ty, _, _ = subst_evar_constr evm evts 0 EConstr.mkVar ty in - let evars = - List.map (fun (ev, info) -> - let { ev_name = (_, name); ev_status = force_status, status; - ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info - in - let force_status, status = match status with - | Evar_kinds.Define true when Id.Set.mem name transparent -> - true, Evar_kinds.Define false - | _ -> force_status, status - in name, typ, src, (force_status, status), deps, tac) evts - in - let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in - let evmap f c = pi1 (subst_evar_constr evm evts 0 f c) in - Array.of_list (List.rev evars), (evnames, evmap), t', ty - let pperror cmd = CErrors.user_err ~hdr:"Program" cmd let error s = pperror (str s) @@ -270,11 +34,6 @@ let explain_no_obligations = function Some ident -> str "No obligations for program " ++ Id.print ident | None -> str "No obligations remaining" -type obligation_info = - (Names.Id.t * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) - * Int.Set.t * unit Proofview.tactic option) array - let assumption_message = Declare.assumption_message let default_tactic = ref (Proofview.tclUNIT ()) @@ -571,12 +330,12 @@ let add_definition ~name ?term t ~uctx ?(udecl=UState.default_univ_decl) let add_mutual_definitions l ~uctx ?(udecl=UState.default_univ_decl) ?tactic ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?(reduce=reduce) ?hook ?(opaque = false) notations fixkind = - let deps = List.map (fun (n, b, t, imps, obls) -> n) l in + let deps = List.map (fun ({ DeclareDef.Recthm.name; _ }, _, _) -> name) l in List.iter - (fun (n, b, t, impargs, obls) -> - let prg = ProgramDecl.make ~opaque n ~udecl (Some b) t ~uctx deps (Some fixkind) + (fun ({ DeclareDef.Recthm.name; typ; impargs; _ }, b, obls) -> + let prg = ProgramDecl.make ~opaque name ~udecl (Some b) typ ~uctx deps (Some fixkind) notations obls ~impargs ~poly ~scope ~kind reduce ?hook - in progmap_add n (CEphemeron.create prg)) l; + in progmap_add name (CEphemeron.create prg)) l; let _defined = List.fold_left (fun finished x -> if finished then finished diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 101958072a..f42d199e18 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -8,51 +8,73 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Environ open Constr -open Evd -open Names - -val check_evars : env -> evar_map -> unit - -val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t -val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar_info * Evar.Set.t) list - -(* ident, type, location, (opaque or transparent, expand or define), dependencies, tactic to solve it *) -type obligation_info = - (Id.t * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array - -(* env, id, evars, number of function prototypes to try to clear from - evars contexts, object and type *) -val eterm_obligations - : env - -> Id.t - -> evar_map - -> int - -> ?status:Evar_kinds.obligation_definition_status - -> EConstr.constr - -> EConstr.types - -> obligation_info * - - (* Existential key, obl. name, type as product, location of the - original evar, associated tactic, status and dependencies as - indexes into the array *) - ((Evar.t * Id.t) list * ((Id.t -> EConstr.constr) -> EConstr.constr -> constr)) * - - (* Translations from existential identifiers to obligation - identifiers and for terms with existentials to closed terms, - given a translation from obligation identifiers to constrs, - new term, new type *) - constr * types + +(** Coq's Program mode support. This mode extends declarations of + constants and fixpoints with [Program Definition] and [Program + Fixpoint] to support incremental construction of terms using + delayed proofs, called "obligations" + + The mode also provides facilities for managing and auto-solving + sets of obligations. + + The basic code flow of programs/obligations is as follows: + + - [add_definition] / [add_mutual_definitions] are called from the + respective [Program] vernacular command interpretation; at this + point the only extra work we do is to prepare the new definition + [d] using [RetrieveObl], which consists in turning unsolved evars + into obligations. [d] is not sent to the kernel yet, as it is not + complete and cannot be typchecked, but saved in a special + data-structure. Auto-solving of obligations is tried at this stage + (see below) + + - [next_obligation] will retrieve the next obligation + ([RetrieveObl] sorts them by topological order) and will try to + solve it. When all obligations are solved, the original constant + [d] is grounded and sent to the kernel for addition to the global + environment. Auto-solving of obligations is also triggered on + obligation completion. + +{2} Solving of obligations: Solved obligations are stored as regular + global declarations in the global environment, usually with name + [constant_obligation_number] where [constant] is the original + [constant] and [number] is the corresponding (internal) number. + + Solving an obligation can trigger a bit of a complex cascaded + callback path; closing an obligation can indeed allow all other + obligations to be closed, which in turn may trigged the declaration + of the original constant. Care must be taken, as this can modify + [Global.env] in arbitrarily ways. Current code takes some care to + refresh the [env] in the proper boundaries, but the invariants + remain delicate. + +{2} Saving of obligations: as open obligations use the regular proof + mode, a `Qed` will call `Lemmas.save_lemma` first. For this reason + obligations code is split in two: this file, [Obligations], taking + care of the top-level vernac commands, and [DeclareObl], which is + called by `Lemmas` to close an obligation proof and eventually to + declare the top-level [Program]ed constant. + + There is little obligations-specific code in [DeclareObl], so + eventually that file should be integrated in the regular [Declare] + path, as it gains better support for "dependent_proofs". + + *) val default_tactic : unit Proofview.tactic ref -val add_definition - : name:Names.Id.t - -> ?term:constr -> types +(** Start a [Program Definition c] proof. [uctx] [udecl] [impargs] + [kind] [scope] [poly] etc... come from the interpretation of the + vernacular; `obligation_info` was generated by [RetrieveObl] It + will return whether all the obligations were solved; if so, it will + also register [c] with the kernel. *) +val add_definition : + name:Names.Id.t + -> ?term:constr + -> types -> uctx:UState.t - -> ?udecl:UState.universe_decl (* Universe binders and constraints *) + -> ?udecl:UState.universe_decl (** Universe binders and constraints *) -> ?impargs:Impargs.manual_implicits -> poly:bool -> ?scope:DeclareDef.locality @@ -61,52 +83,56 @@ val add_definition -> ?reduce:(constr -> constr) -> ?hook:DeclareDef.Hook.t -> ?opaque:bool - -> obligation_info + -> RetrieveObl.obligation_info -> DeclareObl.progress -val add_mutual_definitions - (* XXX: unify with MutualEntry *) - : (Names.Id.t * constr * types * Impargs.manual_implicits * obligation_info) list +(* XXX: unify with MutualEntry *) + +(** Start a [Program Fixpoint] declaration, similar to the above, + except it takes a list now. *) +val add_mutual_definitions : + (DeclareDef.Recthm.t * Constr.t * RetrieveObl.obligation_info) list -> uctx:UState.t - -> ?udecl:UState.universe_decl - (** Universe binders and constraints *) + -> ?udecl:UState.universe_decl (** Universe binders and constraints *) -> ?tactic:unit Proofview.tactic -> poly:bool -> ?scope:DeclareDef.locality -> ?kind:Decls.definition_object_kind -> ?reduce:(constr -> constr) - -> ?hook:DeclareDef.Hook.t -> ?opaque:bool + -> ?hook:DeclareDef.Hook.t + -> ?opaque:bool -> Vernacexpr.decl_notation list - -> DeclareObl.fixpoint_kind -> unit + -> DeclareObl.fixpoint_kind + -> unit -val obligation - : int * Names.Id.t option * Constrexpr.constr_expr option +(** Implementation of the [Obligation] command *) +val obligation : + int * Names.Id.t option * Constrexpr.constr_expr option -> Genarg.glob_generic_argument option -> Lemmas.t -val next_obligation - : Names.Id.t option - -> Genarg.glob_generic_argument option - -> Lemmas.t +(** Implementation of the [Next Obligation] command *) +val next_obligation : + Names.Id.t option -> Genarg.glob_generic_argument option -> Lemmas.t -val solve_obligations : Names.Id.t option -> unit Proofview.tactic option - -> DeclareObl.progress -(* Number of remaining obligations to be solved for this program *) +(** Implementation of the [Solve Obligation] command *) +val solve_obligations : + Names.Id.t option -> unit Proofview.tactic option -> DeclareObl.progress val solve_all_obligations : unit Proofview.tactic option -> unit -val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit +(** Number of remaining obligations to be solved for this program *) +val try_solve_obligation : + int -> Names.Id.t option -> unit Proofview.tactic option -> unit -val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit +val try_solve_obligations : + Names.Id.t option -> unit Proofview.tactic option -> unit val show_obligations : ?msg:bool -> Names.Id.t option -> unit - val show_term : Names.Id.t option -> Pp.t - val admit_obligations : Names.Id.t option -> unit exception NoObligations of Names.Id.t option val explain_no_obligations : Names.Id.t option -> Pp.t - val check_program_libraries : unit -> unit diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index a3de88d4dc..054b60853f 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -142,7 +142,7 @@ open Pputils | SearchOutside [] -> mt() | SearchOutside l -> spc() ++ keyword "outside" ++ spc() ++ prlist_with_sep sep pr_module l - let pr_search_about (b,c) = + let pr_search (b,c) = (if b then str "-" else mt()) ++ match c with | SearchSubPattern p -> @@ -158,10 +158,8 @@ open Pputils | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b - | SearchAbout sl -> - keyword "SearchAbout" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b | Search sl -> - keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b + keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search sl ++ pr_in_out_modules b let pr_option_ref_value = function | QualidRefValue id -> pr_qualid id diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index 08625b41a6..f4cb1adfe8 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -51,14 +51,13 @@ module Vernac_ = let noedit_mode = gec_vernac "noedit_command" let () = - let open Extend in let act_vernac v loc = Some v in let act_eoi _ loc = None in let rule = [ - Rule (Next (Stop, Atoken Tok.PEOI), act_eoi); - Rule (Next (Stop, Aentry vernac_control), act_vernac); + Pcoq.(Production.make (Rule.next Rule.stop (Symbol.token Tok.PEOI)) act_eoi); + Pcoq.(Production.make (Rule.next Rule.stop (Symbol.nterm vernac_control)) act_vernac); ] in - Pcoq.grammar_extend main_entry (None, [None, None, rule]) + Pcoq.(grammar_extend main_entry {pos=None; data=[None, None, rule]}) let select_tactic_entry spec = match spec with diff --git a/vernac/record.ml b/vernac/record.ml index d974ead942..b9d450044b 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -59,26 +59,37 @@ let () = optread = (fun () -> !typeclasses_unique); optwrite = (fun b -> typeclasses_unique := b); } -let interp_fields_evars env sigma impls_env nots l = - List.fold_left2 - (fun (env, sigma, uimpls, params, impls) no ({CAst.loc;v=i}, b, t) -> - let sigma, (t', impl) = interp_type_evars_impls ~program_mode:false env sigma ~impls t in - let r = Retyping.relevance_of_type env sigma t' in - let sigma, b' = - Option.cata (fun x -> on_snd (fun x -> Some (fst x)) @@ - interp_casted_constr_evars_impls ~program_mode:false env sigma ~impls x t') (sigma,None) b in - let impls = - match i with - | Anonymous -> impls - | Name id -> Id.Map.add id (compute_internalization_data env sigma Constrintern.Method t' impl) impls - in - let d = match b' with - | None -> LocalAssum (make_annot i r,t') - | Some b' -> LocalDef (make_annot i r,b',t') +let interp_fields_evars env sigma ~ninds ~nparams impls_env nots l = + let _, sigma, impls, newfs, _ = + List.fold_left2 + (fun (env, sigma, uimpls, params, impls) no ({CAst.loc;v=i}, b, t) -> + let sigma, (t', impl) = interp_type_evars_impls env sigma ~impls t in + let r = Retyping.relevance_of_type env sigma t' in + let sigma, b' = + Option.cata (fun x -> on_snd (fun x -> Some (fst x)) @@ + interp_casted_constr_evars_impls ~program_mode:false env sigma ~impls x t') (sigma,None) b in + let impls = + match i with + | Anonymous -> impls + | Name id -> Id.Map.add id (compute_internalization_data env sigma Constrintern.Method t' impl) impls + in + let d = match b' with + | None -> LocalAssum (make_annot i r,t') + | Some b' -> LocalDef (make_annot i r,b',t') + in + List.iter (Metasyntax.set_notation_for_interpretation env impls) no; + (EConstr.push_rel d env, sigma, impl :: uimpls, d::params, impls)) + (env, sigma, [], [], impls_env) nots l + in + let _, sigma = Context.Rel.fold_outside ~init:(env,sigma) (fun f (env,sigma) -> + let sigma = RelDecl.fold_constr (fun c sigma -> + ComInductive.maybe_unify_params_in env sigma ~ninds ~nparams c) + f sigma in - List.iter (Metasyntax.set_notation_for_interpretation env impls) no; - (EConstr.push_rel d env, sigma, impl :: uimpls, d::params, impls)) - (env, sigma, [], [], impls_env) nots l + EConstr.push_rel f env, sigma) + newfs + in + sigma, (impls, newfs) let compute_constructor_level evars env l = List.fold_right (fun d (env, univ) -> @@ -103,7 +114,7 @@ let check_anonymous_type ind = | { CAst.v = CSort (Glob_term.UAnonymous {rigid=true}) } -> true | _ -> false -let typecheck_params_and_fields finite def poly pl ps records = +let typecheck_params_and_fields def poly pl ps records = let env0 = Global.env () in (* Special case elaboration for template-polymorphic inductives, lower bound on introduced universes is Prop so that we do not miss @@ -157,17 +168,15 @@ let typecheck_params_and_fields finite def poly pl ps records = let fold accu (id, _, _, _) arity r = EConstr.push_rel (LocalAssum (make_annot (Name id) r,arity)) accu in let env_ar = EConstr.push_rel_context newps (List.fold_left3 fold env0 records arities relevances) in - let assums = List.filter is_local_assum newps in let impls_env = - let params = List.map (RelDecl.get_name %> Name.get_id) assums in - let ty = Inductive (params, (finite != Declarations.BiFinite)) in let ids = List.map (fun (id, _, _, _) -> id) records in let imps = List.map (fun _ -> imps) arities in - compute_internalization_env env0 sigma ~impls:impls_env ty ids arities imps + compute_internalization_env env0 sigma ~impls:impls_env Inductive ids arities imps in + let ninds = List.length arities in + let nparams = List.length newps in let fold sigma (_, _, nots, fs) arity = - let _, sigma, impls, newfs, _ = interp_fields_evars env_ar sigma impls_env nots (binders_of_decls fs) in - (sigma, (impls, newfs)) + interp_fields_evars env_ar sigma ~ninds ~nparams impls_env nots (binders_of_decls fs) in let (sigma, data) = List.fold_left2_map fold sigma records arities in let sigma = @@ -702,7 +711,7 @@ let definition_structure udecl kind ~template ~cumulative ~poly finite records = let ps, data = extract_record_data records in let ubinders, univs, auto_template, params, implpars, data = States.with_state_protection (fun () -> - typecheck_params_and_fields finite (kind = Class true) poly udecl ps data) () in + typecheck_params_and_fields (kind = Class true) poly udecl ps data) () in let template = template, auto_template in match kind with | Class def -> diff --git a/vernac/retrieveObl.ml b/vernac/retrieveObl.ml new file mode 100644 index 0000000000..c529972b8d --- /dev/null +++ b/vernac/retrieveObl.ml @@ -0,0 +1,296 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +(** + - Get types of existentials ; + - Flatten dependency tree (prefix order) ; + - Replace existentials by de Bruijn indices in term, applied to the right arguments ; + - Apply term prefixed by quantification on "existentials". +*) + +let check_evars env evm = + Evar.Map.iter + (fun key evi -> + if Evd.is_obligation_evar evm key then () + else + let loc, k = Evd.evar_source key evm in + Pretype_errors.error_unsolvable_implicit ?loc env evm key None) + (Evd.undefined_map evm) + +type obligation_info = + ( Names.Id.t + * Constr.types + * Evar_kinds.t Loc.located + * (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t + * unit Proofview.tactic option ) + array + +type oblinfo = + { ev_name : int * Id.t + ; ev_hyps : EConstr.named_context + ; ev_status : bool * Evar_kinds.obligation_definition_status + ; ev_chop : int option + ; ev_src : Evar_kinds.t Loc.located + ; ev_typ : Constr.types + ; ev_tac : unit Proofview.tactic option + ; ev_deps : Int.Set.t } + +(** Substitute evar references in t using de Bruijn indices, + where n binders were passed through. *) + +let succfix (depth, fixrels) = (succ depth, List.map succ fixrels) + +let subst_evar_constr evm evs n idf t = + let seen = ref Int.Set.empty in + let transparent = ref Id.Set.empty in + let evar_info id = CList.assoc_f Evar.equal id evs in + let rec substrec (depth, fixrels) c = + match EConstr.kind evm c with + | Constr.Evar (k, args) -> + let {ev_name = id, idstr; ev_hyps = hyps; ev_chop = chop} = + try evar_info k + with Not_found -> + CErrors.anomaly ~label:"eterm" + Pp.( + str "existential variable " + ++ int (Evar.repr k) + ++ str " not found.") + in + seen := Int.Set.add id !seen; + (* Evar arguments are created in inverse order, + and we must not apply to defined ones (i.e. LetIn's) + *) + let args = + let n = match chop with None -> 0 | Some c -> c in + let l, r = CList.chop n (List.rev (Array.to_list args)) in + List.rev r + in + let args = + let rec aux hyps args acc = + let open Context.Named.Declaration in + match (hyps, args) with + | LocalAssum _ :: tlh, c :: tla -> + aux tlh tla (substrec (depth, fixrels) c :: acc) + | LocalDef _ :: tlh, _ :: tla -> aux tlh tla acc + | [], [] -> acc + | _, _ -> acc + (*failwith "subst_evars: invalid argument"*) + in + aux hyps args [] + in + if + List.exists + (fun x -> + match EConstr.kind evm x with + | Constr.Rel n -> Int.List.mem n fixrels + | _ -> false) + args + then transparent := Id.Set.add idstr !transparent; + EConstr.mkApp (idf idstr, Array.of_list args) + | Constr.Fix _ -> + EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c + | _ -> EConstr.map_with_binders evm succfix substrec (depth, fixrels) c + in + let t' = substrec (0, []) t in + (EConstr.to_constr evm t', !seen, !transparent) + +(** Substitute variable references in t using de Bruijn indices, + where n binders were passed through. *) +let subst_vars acc n t = + let var_index id = Util.List.index Id.equal id acc in + let rec substrec depth c = + match Constr.kind c with + | Constr.Var v -> ( + try Constr.mkRel (depth + var_index v) with Not_found -> c ) + | _ -> Constr.map_with_binders succ substrec depth c + in + substrec 0 t + +(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) + to a product : forall H1 : t1, ..., forall Hn : tn, concl. + Changes evars and hypothesis references to variable references. +*) +let etype_of_evar evm evs hyps concl = + let open Context.Named.Declaration in + let rec aux acc n = function + | decl :: tl -> ( + let t', s, trans = + subst_evar_constr evm evs n EConstr.mkVar + (Context.Named.Declaration.get_type decl) + in + let t'' = subst_vars acc 0 t' in + let rest, s', trans' = + aux (Context.Named.Declaration.get_id decl :: acc) (succ n) tl + in + let s' = Int.Set.union s s' in + let trans' = Id.Set.union trans trans' in + match decl with + | LocalDef (id, c, _) -> + let c', s'', trans'' = subst_evar_constr evm evs n EConstr.mkVar c in + let c' = subst_vars acc 0 c' in + ( Term.mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest + , Int.Set.union s'' s' + , Id.Set.union trans'' trans' ) + | LocalAssum (id, _) -> + (Term.mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') ) + | [] -> + let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar concl in + (subst_vars acc 0 t', s, trans) + in + aux [] 0 (List.rev hyps) + +let trunc_named_context n ctx = + let len = List.length ctx in + CList.firstn (len - n) ctx + +let rec chop_product n t = + let pop t = Vars.lift (-1) t in + if Int.equal n 0 then Some t + else + match Constr.kind t with + | Constr.Prod (_, _, b) -> + if Vars.noccurn 1 b then chop_product (pred n) (pop b) else None + | _ -> None + +let evar_dependencies evm oev = + let one_step deps = + Evar.Set.fold + (fun ev s -> + let evi = Evd.find evm ev in + let deps' = Evd.evars_of_filtered_evar_info evm evi in + if Evar.Set.mem oev deps' then + invalid_arg + ( "Ill-formed evar map: cycle detected for evar " + ^ Pp.string_of_ppcmds @@ Evar.print oev ) + else Evar.Set.union deps' s) + deps deps + in + let rec aux deps = + let deps' = one_step deps in + if Evar.Set.equal deps deps' then deps else aux deps' + in + aux (Evar.Set.singleton oev) + +let move_after ((id, ev, deps) as obl) l = + let rec aux restdeps = function + | ((id', _, _) as obl') :: tl -> + let restdeps' = Evar.Set.remove id' restdeps in + if Evar.Set.is_empty restdeps' then obl' :: obl :: tl + else obl' :: aux restdeps' tl + | [] -> [obl] + in + aux (Evar.Set.remove id deps) l + +let sort_dependencies evl = + let rec aux l found list = + match l with + | ((id, ev, deps) as obl) :: tl -> + let found' = Evar.Set.union found (Evar.Set.singleton id) in + if Evar.Set.subset deps found' then aux tl found' (obl :: list) + else aux (move_after obl tl) found list + | [] -> List.rev list + in + aux evl Evar.Set.empty [] + +let retrieve_obligations env name evm fs ?status t ty = + (* 'Serialize' the evars *) + let nc = Environ.named_context env in + let nc_len = Context.Named.length nc in + let evm = Evarutil.nf_evar_map_undefined evm in + let evl = Evarutil.non_instantiated evm in + let evl = Evar.Map.bindings evl in + let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in + let sevl = sort_dependencies evl in + let evl = List.map (fun (id, ev, _) -> (id, ev)) sevl in + let evn = + let i = ref (-1) in + List.rev_map + (fun (id, ev) -> + incr i; + ( id + , ( !i + , Id.of_string + (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i)) ) + , ev )) + evl + in + let evts = + (* Remove existential variables in types and build the corresponding products *) + List.fold_right + (fun (id, (n, nstr), ev) l -> + let hyps = Evd.evar_filtered_context ev in + let hyps = trunc_named_context nc_len hyps in + let evtyp, deps, transp = etype_of_evar evm l hyps ev.Evd.evar_concl in + let evtyp, hyps, chop = + match chop_product fs evtyp with + | Some t -> (t, trunc_named_context fs hyps, fs) + | None -> (evtyp, hyps, 0) + in + let loc, k = Evd.evar_source id evm in + let status = + match k with + | Evar_kinds.QuestionMark {Evar_kinds.qm_obligation = o} -> o + | _ -> ( + match status with + | Some o -> o + | None -> + Evar_kinds.Define (not (Program.get_proofs_transparency ())) ) + in + let force_status, status, chop = + match status with + | Evar_kinds.Define true as stat -> + if not (Int.equal chop fs) then (true, Evar_kinds.Define false, None) + else (false, stat, Some chop) + | s -> (false, s, None) + in + let info = + { ev_name = (n, nstr) + ; ev_hyps = hyps + ; ev_status = (force_status, status) + ; ev_chop = chop + ; ev_src = (loc, k) + ; ev_typ = evtyp + ; ev_deps = deps + ; ev_tac = None } + in + (id, info) :: l) + evn [] + in + let t', _, transparent = + (* Substitute evar refs in the term by variables *) + subst_evar_constr evm evts 0 EConstr.mkVar t + in + let ty, _, _ = subst_evar_constr evm evts 0 EConstr.mkVar ty in + let evars = + List.map + (fun (ev, info) -> + let { ev_name = _, name + ; ev_status = force_status, status + ; ev_src = src + ; ev_typ = typ + ; ev_deps = deps + ; ev_tac = tac } = + info + in + let force_status, status = + match status with + | Evar_kinds.Define true when Id.Set.mem name transparent -> + (true, Evar_kinds.Define false) + | _ -> (force_status, status) + in + (name, typ, src, (force_status, status), deps, tac)) + evts + in + let evnames = List.map (fun (ev, info) -> (ev, snd info.ev_name)) evts in + let evmap f c = Util.pi1 (subst_evar_constr evm evts 0 f c) in + (Array.of_list (List.rev evars), (evnames, evmap), t', ty) diff --git a/vernac/retrieveObl.mli b/vernac/retrieveObl.mli new file mode 100644 index 0000000000..c9c45bd889 --- /dev/null +++ b/vernac/retrieveObl.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val check_evars : Environ.env -> Evd.evar_map -> unit + +type obligation_info = + ( Names.Id.t + * Constr.types + * Evar_kinds.t Loc.located + * (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t + * unit Proofview.tactic option ) + array +(** ident, type, location of the original evar, (opaque or + transparent, expand or define), dependencies as indexes into the + array, tactic to solve it *) + +val retrieve_obligations : + Environ.env + -> Names.Id.t + -> Evd.evar_map + -> int + -> ?status:Evar_kinds.obligation_definition_status + -> EConstr.t + -> EConstr.types + -> obligation_info + * ( (Evar.t * Names.Id.t) list + * ((Names.Id.t -> EConstr.t) -> EConstr.t -> Constr.t) ) + * Constr.t + * Constr.t +(** [retrieve_obligations env id sigma fs ?status body type] returns + [obls, (evnames, evmap), nbody, ntype] a list of obligations built + from evars in [body, type]. + + [fs] is the number of function prototypes to try to clear from + evars contexts. [evnames, evmap) is the list of names / + substitution functions used to program with holes. This is not used + in Coq, but in the equations plugin; [evnames] is actually + redundant with the information contained in [obls] *) diff --git a/vernac/search.ml b/vernac/search.ml index ceff8acc79..68a30b4231 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -23,8 +23,8 @@ module NamedDecl = Context.Named.Declaration type filter_function = GlobRef.t -> env -> constr -> bool type display_function = GlobRef.t -> env -> constr -> unit -(* This option restricts the output of [SearchPattern ...], -[SearchAbout ...], etc. to the names of the symbols matching the +(* This option restricts the output of [SearchPattern ...], etc. +to the names of the symbols matching the query, separated by a newline. This type of output is useful for editors (like emacs), to generate a list of completion candidates without having to parse through the types of all symbols. *) @@ -226,7 +226,7 @@ let module_filter (mods, outside) ref env typ = let name_of_reference ref = Id.to_string (Nametab.basename_of_global ref) -let search_about_filter query gr env typ = match query with +let search_filter query gr env typ = match query with | GlobSearchSubPattern pat -> Constr_matching.is_matching_appsubterm ~closed:false env (Evd.from_env env) pat (EConstr.of_constr typ) | GlobSearchString s -> @@ -283,14 +283,14 @@ let search_by_head ?pstate gopt pat mods pr_search = in generic_search ?pstate gopt iter -(** SearchAbout *) +(** Search *) -let search_about ?pstate gopt items mods pr_search = +let search ?pstate gopt items mods pr_search = let filter ref env typ = let eqb b1 b2 = if b1 then b2 else not b2 in module_filter mods ref env typ && List.for_all - (fun (b,i) -> eqb b (search_about_filter i ref env typ)) items && + (fun (b,i) -> eqb b (search_filter i ref env typ)) items && blacklist_filter ref env typ in let iter ref env typ = diff --git a/vernac/search.mli b/vernac/search.mli index 11dd0c6794..6dbbff3a8c 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -30,8 +30,7 @@ val blacklist_filter : filter_function val module_filter : DirPath.t list * bool -> filter_function (** Check whether a reference pertains or not to a set of modules *) -val search_about_filter : glob_search_about_item -> filter_function -(** Check whether a reference matches a SearchAbout query. *) +val search_filter : glob_search_about_item -> filter_function (** {6 Specialized search functions} @@ -45,7 +44,7 @@ val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> D -> display_function -> unit val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_about : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list +val search : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 6e398d87ca..5a2bdb43d4 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -14,6 +14,7 @@ Proof_using Egramcoq Metasyntax DeclareUniv +RetrieveObl DeclareDef DeclareObl Canonical diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 8641c67d9f..2e509921c1 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -486,11 +486,14 @@ let program_inference_hook env sigma ev = let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = let env0 = Global.env () in + let flags = Pretyping.{ all_no_fail_flags with program_mode } in let decl = fst (List.hd thms) in let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env0 (snd decl) in let evd, thms = List.fold_left_map (fun evd ((id, _), (bl, t)) -> - let evd, (impls, ((env, ctx), imps)) = Constrintern.interp_context_evars ~program_mode env0 evd bl in - let evd, (t', imps') = Constrintern.interp_type_evars_impls ~program_mode ~impls env evd t in + let evd, (impls, ((env, ctx), imps)) = + Constrintern.interp_context_evars ~program_mode env0 evd bl + in + let evd, (t', imps') = Constrintern.interp_type_evars_impls ~flags ~impls env evd t in let flags = Pretyping.{ all_and_fail_flags with program_mode } in let inference_hook = if program_mode then Some program_inference_hook else None in let evd = Pretyping.solve_remaining_evars ?hook:inference_hook flags env evd in @@ -527,8 +530,10 @@ let vernac_definition_hook ~canonical_instance ~local ~poly = let open Decls in Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure dref))) | _ -> None +let default_thm_id = Id.of_string "Unnamed_thm" + let fresh_name_for_anonymous_theorem () = - Namegen.next_global_ident_away Lemmas.default_thm_id Id.Set.empty + Namegen.next_global_ident_away default_thm_id Id.Set.empty let vernac_definition_name lid local = let lid = @@ -565,7 +570,9 @@ let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt let env = Global.env () in let sigma = Evd.from_env env in Some (snd (Hook.get f_interp_redexp env sigma r)) in - ComDefinition.do_definition ~program_mode ~name:name.v + let do_definition = + ComDefinition.(if program_mode then do_definition_program else do_definition) in + do_definition ~name:name.v ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook (* NB: pstate argument to use combinators easily *) @@ -1773,10 +1780,6 @@ let () = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let warn_deprecated_search_about = - CWarnings.create ~name:"deprecated-search-about" ~category:"deprecated" - (fun () -> strbrk "The SearchAbout command is deprecated. Please use Search instead.") - let vernac_search ~pstate ~atts s gopt r = let gopt = query_command_selector gopt in let r = interp_search_restriction r in @@ -1809,12 +1812,8 @@ let vernac_search ~pstate ~atts s gopt r = (Search.search_rewrite ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchHead c -> (Search.search_by_head ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search - | SearchAbout sl -> - warn_deprecated_search_about (); - (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> - Search.prioritize_search) pr_search | Search sl -> - (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> + (Search.search ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> Search.prioritize_search) pr_search); Feedback.msg_notice (str "(use \"About\" for full details on implicit arguments)") diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index b7c6d3c490..d6e7a3947a 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -69,7 +69,6 @@ type searchable = | SearchPattern of constr_pattern_expr | SearchRewrite of constr_pattern_expr | SearchHead of constr_pattern_expr - | SearchAbout of (bool * search_about_item) list | Search of (bool * search_about_item) list type locatable = diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 0e8202da9f..1920c276af 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -166,15 +166,15 @@ let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args -> vernac_c | Some Refl -> untype_command ty (f v) args end -let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, Extend.norec, a) Extend.symbol = +let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, Gramlib.Grammar.norec, a) Pcoq.Symbol.t = let open Extend in function -| TUlist1 l -> Alist1 (untype_user_symbol l) -| TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s)) -| TUlist0 l -> Alist0 (untype_user_symbol l) -| TUlist0sep (l, s) -> Alist0sep (untype_user_symbol l, Atoken (CLexer.terminal s)) -| TUopt o -> Aopt (untype_user_symbol o) -| TUentry a -> Aentry (Pcoq.genarg_grammar (Genarg.ExtraArg a)) -| TUentryl (a, i) -> Aentryl (Pcoq.genarg_grammar (Genarg.ExtraArg a), string_of_int i) + | TUlist1 l -> Pcoq.Symbol.list1 (untype_user_symbol l) + | TUlist1sep (l, s) -> Pcoq.Symbol.list1sep (untype_user_symbol l) (Pcoq.Symbol.token (CLexer.terminal s)) false + | TUlist0 l -> Pcoq.Symbol.list0 (untype_user_symbol l) + | TUlist0sep (l, s) -> Pcoq.Symbol.list0sep (untype_user_symbol l) (Pcoq.Symbol.token (CLexer.terminal s)) false + | TUopt o -> Pcoq.Symbol.opt (untype_user_symbol o) + | TUentry a -> Pcoq.Symbol.nterm (Pcoq.genarg_grammar (Genarg.ExtraArg a)) + | TUentryl (a, i) -> Pcoq.Symbol.nterml (Pcoq.genarg_grammar (Genarg.ExtraArg a)) (string_of_int i) let rec untype_grammar : type r s. (r, s) ty_sig -> 'a Egramml.grammar_prod_item list = function | TyNil -> [] @@ -229,7 +229,7 @@ let vernac_extend ~command ?classifier ?entry ext = type 'a argument_rule = | Arg_alias of 'a Pcoq.Entry.t -| Arg_rules of 'a Extend.production_rule list +| Arg_rules of 'a Pcoq.Production.t list type 'a vernac_argument = { arg_printer : Environ.env -> Evd.evar_map -> 'a -> Pp.t; @@ -244,7 +244,7 @@ let vernac_argument_extend ~name arg = e | Arg_rules rules -> let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in - let () = Pcoq.grammar_extend e (None, [(None, None, rules)]) in + let () = Pcoq.grammar_extend e {Pcoq.pos=None; data=[(None, None, rules)]} in e in let pr = arg.arg_printer in diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 90c00415d4..0d0ebc1086 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -111,7 +111,7 @@ type 'a argument_rule = | Arg_alias of 'a Pcoq.Entry.t (** This is used because CAMLP5 parser can be dumb about rule factorization, which sometimes requires two entries to be the same. *) -| Arg_rules of 'a Extend.production_rule list +| Arg_rules of 'a Pcoq.Production.t list (** There is a discrepancy here as we use directly extension rules and thus entries instead of ty_user_symbol and thus arguments as roots. *) diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 6846826bfa..a4e9c8e1ab 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -164,14 +164,15 @@ module Proof_global = struct type closed_proof = Proof_global.proof_object * Lemmas.Info.t - let return_proof ?allow_partial () = cc (return_proof ?allow_partial) + let return_proof () = cc return_proof + let return_partial_proof () = cc return_partial_proof - let close_future_proof ~opaque ~feedback_id pf = - cc_lemma (fun pt -> pf_fold (fun st -> close_future_proof ~opaque ~feedback_id st pf) pt, + let close_future_proof ~feedback_id pf = + cc_lemma (fun pt -> pf_fold (fun st -> close_future_proof ~feedback_id st pf) pt, Internal.get_info pt) - let close_proof ~opaque ~keep_body_ucst_separate f = - cc_lemma (fun pt -> pf_fold ((close_proof ~opaque ~keep_body_ucst_separate f)) pt, + let close_proof ~opaque ~keep_body_ucst_separate = + cc_lemma (fun pt -> pf_fold ((close_proof ~opaque ~keep_body_ucst_separate)) pt, Internal.get_info pt) let discard_all () = s_lemmas := None diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index 7607f8373a..9c4de7720c 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -65,16 +65,16 @@ module Proof_global : sig val with_current_proof : (unit Proofview.tactic -> Proof.t -> Proof.t * 'a) -> 'a - val return_proof : ?allow_partial:bool -> unit -> Proof_global.closed_proof_output + val return_proof : unit -> Proof_global.closed_proof_output + val return_partial_proof : unit -> Proof_global.closed_proof_output type closed_proof = Proof_global.proof_object * Lemmas.Info.t val close_future_proof : - opaque:Proof_global.opacity_flag -> feedback_id:Stateid.t -> Proof_global.closed_proof_output Future.computation -> closed_proof - val close_proof : opaque:Proof_global.opacity_flag -> keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof + val close_proof : opaque:Proof_global.opacity_flag -> keep_body_ucst_separate:bool -> closed_proof val discard_all : unit -> unit val update_global_env : unit -> unit |