diff options
100 files changed, 7582 insertions, 3994 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 39c801197b..f2e0c362b4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -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 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/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/configure.ml b/configure.ml index 55d71f6c2e..ee2e50ef86 100644 --- a/configure.ml +++ b/configure.ml @@ -923,7 +923,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/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/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/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/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..cada680895 --- /dev/null +++ b/doc/sphinx/using/tools/coqdoc.rst @@ -0,0 +1,463 @@ +.. _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``. 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..fba4856241 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -5,26 +5,47 @@ (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 + (bash "for f in fullGrammar orderedGrammar; do cp ${f} ${f}.old; done") + (chdir %{project_root} (run doc_grammar -check-cmds %{input})) + (bash "for f in fullGrammar orderedGrammar; do cp ${f} ${f}.new; done") + (bash "for f in fullGrammar orderedGrammar; do cp ${f}.old ${f}; done") + (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/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/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/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/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/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/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/reductionops.ml b/pretyping/reductionops.ml index 1e4b537117..8822cc2338 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) = @@ -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/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/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_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/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/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/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/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/output.ml b/tools/coqdoc/output.ml index d2b0078a7c..862715753d 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"; 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..2ed854c9f7 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -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/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 a6bbc2377e..a1cdc718d7 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -969,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/library.ml b/vernac/library.ml index 85645b92d4..7c629b08e7 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 = @@ -167,7 +163,7 @@ let register_loaded_library m = | 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 +183,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 +202,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 +257,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 +280,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 +366,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 +494,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/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/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/vernacentries.ml b/vernac/vernacentries.ml index 8641c67d9f..963b5f2084 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1773,10 +1773,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 +1805,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. *) |