diff options
97 files changed, 2125 insertions, 3272 deletions
diff --git a/checker/check.mllib b/checker/check.mllib index d47a93c70d..a16a871dc3 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -1,5 +1,6 @@ Analyze +CheckFlags CheckInductive Mod_checking CheckTypes diff --git a/checker/checkFlags.ml b/checker/checkFlags.ml new file mode 100644 index 0000000000..1f5e76bd83 --- /dev/null +++ b/checker/checkFlags.ml @@ -0,0 +1,23 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +open Declarations + +let set_local_flags flags env = + let flags = + { (Environ.typing_flags env) with + check_guarded = flags.check_guarded; + check_positive = flags.check_positive; + check_universes = flags.check_universes; + conv_oracle = flags.conv_oracle; + cumulative_sprop = flags.cumulative_sprop; + } + in + Environ.set_typing_flags flags env diff --git a/checker/checkFlags.mli b/checker/checkFlags.mli new file mode 100644 index 0000000000..2e41e656f1 --- /dev/null +++ b/checker/checkFlags.mli @@ -0,0 +1,12 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +val set_local_flags : Declarations.typing_flags -> Environ.env -> Environ.env +(** Set flags except for those ignored by the checker (eg vm_compute). *) diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index a1d5aedb01..c370a77ea0 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -164,16 +164,7 @@ let check_inductive env mind mb = mind_private; mind_typing_flags; } = (* Locally set typing flags for further typechecking *) - let mb_flags = mb.mind_typing_flags in - let env = Environ.set_typing_flags - {env.env_typing_flags with - check_guarded = mb_flags.check_guarded; - check_positive = mb_flags.check_positive; - check_universes = mb_flags.check_universes; - conv_oracle = mb_flags.conv_oracle; - } - env - in + let env = CheckFlags.set_local_flags mb.mind_typing_flags env in Indtypes.check_inductive env ~sec_univs:None mind entry in let check = check mind in diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 44b7089fd0..8fd81d43be 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -17,14 +17,7 @@ let set_indirect_accessor f = indirect_accessor := f let check_constant_declaration env kn cb = Flags.if_verbose Feedback.msg_notice (str " checking cst:" ++ Constant.print kn); - let cb_flags = cb.const_typing_flags in - let env = Environ.set_typing_flags - {env.env_typing_flags with - check_guarded = cb_flags.check_guarded; - check_universes = cb_flags.check_universes; - conv_oracle = cb_flags.conv_oracle;} - env - in + let env = CheckFlags.set_local_flags cb.const_typing_flags env in let poly, env = match cb.const_universes with | Monomorphic ctx -> diff --git a/checker/values.ml b/checker/values.ml index b9efce6948..9bd381e4a9 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -241,7 +241,10 @@ let v_cst_def = [|[|Opt Int|]; [|v_cstr_subst|]; [|v_opaque|]; [|v_primitive|]|] let v_typing_flags = - v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool|] + v_tuple "typing_flags" + [|v_bool; v_bool; v_bool; + v_oracle; v_bool; v_bool; + v_bool; v_bool; v_bool|] let v_univs = v_sum "universes" 0 [|[|v_context_set|]; [|v_abs_context|]|] diff --git a/dev/base_include b/dev/base_include index 96a867475d..45e79147c1 100644 --- a/dev/base_include +++ b/dev/base_include @@ -129,7 +129,7 @@ open Elim open Equality open Hipattern open Inv -open Leminv +open Ltac_plugin.Leminv open Tacticals open Tactics open Eqschemes diff --git a/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh b/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh new file mode 100644 index 0000000000..6bee3c7bb6 --- /dev/null +++ b/dev/ci/user-overlays/12023-herbelin-master+fixing-empty-Ltac-v-file.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "12023" ] || [ "$CI_BRANCH" = "master+fixing-empty-Ltac-v-file" ]; then + + fiat_crypto_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + fiat_crypto_CI_GITURL=https://github.com/herbelin/fiat-crypto + + mtac2_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + mtac2_CI_GITURL=https://github.com/herbelin/Mtac2 + + metacoq_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + metacoq_CI_GITURL=https://github.com/herbelin/template-coq + + unimath_CI_REF=master+pr12023-atomic-tactic-now-qualified-in-ltac-file + unimath_CI_GITURL=https://github.com/herbelin/UniMath + +fi diff --git a/doc/changelog/04-tactics/12023-master+fixing-empty-Ltac-v-file.rst b/doc/changelog/04-tactics/12023-master+fixing-empty-Ltac-v-file.rst new file mode 100644 index 0000000000..f10208e9b2 --- /dev/null +++ b/doc/changelog/04-tactics/12023-master+fixing-empty-Ltac-v-file.rst @@ -0,0 +1,6 @@ +- **Changed:** + Tactics with qualified name of the form ``Coq.Init.Notations`` are + now qualified with prefix ``Coq.Init.Ltac``; users of the -noinit + option should now import Coq.Init.Ltac if they want to use Ltac + (`#12023 <https://github.com/coq/coq/pull/12023>`_, + by Hugo Herbelin; minor source of incompatibilities). diff --git a/doc/changelog/07-commands-and-options/12034-cumul-sprop.rst b/doc/changelog/07-commands-and-options/12034-cumul-sprop.rst new file mode 100644 index 0000000000..ad7cf44482 --- /dev/null +++ b/doc/changelog/07-commands-and-options/12034-cumul-sprop.rst @@ -0,0 +1,5 @@ +- **Changed:** + Added :flag:`Cumulative StrictProp` to control cumulativity of + |SProp| and deprecated now redundant command line + ``--cumulative-sprop`` (`#12034 + <https://github.com/coq/coq/pull/12034>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/10-standard-library/12031-ollibs-cpermutation.rst b/doc/changelog/10-standard-library/12031-ollibs-cpermutation.rst new file mode 100644 index 0000000000..95b4cce2f7 --- /dev/null +++ b/doc/changelog/10-standard-library/12031-ollibs-cpermutation.rst @@ -0,0 +1,4 @@ +- **Added:** + Definition and properties of cyclic permutations / circular shifts: ``CPermutation`` + (`#12031 <https://github.com/coq/coq/pull/12031>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12119-issue12119.rst b/doc/changelog/10-standard-library/12119-issue12119.rst new file mode 100644 index 0000000000..42672b1465 --- /dev/null +++ b/doc/changelog/10-standard-library/12119-issue12119.rst @@ -0,0 +1,5 @@ +- **Changed:** + new lemma ``NoDup_incl_NoDup`` in ``List.v`` + to remove useless hypothesis `NoDup l'` in ``Sorting.Permutation.NoDup_Permutation_bis`` + (`#12119 <https://github.com/coq/coq/pull/12119>`_, + by Olivier Laurent). diff --git a/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css b/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css deleted file mode 100644 index d23ea8f362..0000000000 --- a/doc/common/styles/html/coqremote/sites/all/themes/coq/coqdoc.css +++ /dev/null @@ -1,329 +0,0 @@ -body { padding: 0px 0px; - margin: 0px 0px; - background-color: white } - -#page { display: block; - padding: 0px; - margin: 0px; - padding-bottom: 10px; } - -#header { display: block; - position: relative; - padding: 0; - margin: 0; - vertical-align: middle; - border-bottom-style: solid; - border-width: thin } - -#header h1 { padding: 0; - margin: 0;} - - -/* Contents */ - -#main{ display: block; - padding: 10px; - font-family: sans-serif; - font-size: 100%; - line-height: 100% } - -#main h1 { line-height: 95% } /* allow for multi-line headers */ - -#main a.idref:visited {color : #416DFF; text-decoration : none; } -#main a.idref:link {color : #416DFF; text-decoration : none; } -#main a.idref:hover {text-decoration : none; } -#main a.idref:active {text-decoration : none; } - -#main a.modref:visited {color : #416DFF; text-decoration : none; } -#main a.modref:link {color : #416DFF; text-decoration : none; } -#main a.modref:hover {text-decoration : none; } -#main a.modref:active {text-decoration : none; } - -#main .keyword { color : #cf1d1d } -#main { color: black } - -.section { background-color: rgb(60%,60%,100%); - padding-top: 13px; - padding-bottom: 13px; - padding-left: 3px; - margin-top: 5px; - margin-bottom: 5px; - font-size : 175% } - -h2.section { background-color: rgb(80%,80%,100%); - padding-left: 3px; - padding-top: 12px; - padding-bottom: 10px; - font-size : 130% } - -h3.section { background-color: rgb(90%,90%,100%); - padding-left: 3px; - padding-top: 7px; - padding-bottom: 7px; - font-size : 115% } - -h4.section { -/* - background-color: rgb(80%,80%,80%); - max-width: 20em; - padding-left: 5px; - padding-top: 5px; - padding-bottom: 5px; -*/ - background-color: white; - padding-left: 0px; - padding-top: 0px; - padding-bottom: 0px; - font-size : 100%; - font-weight : bold; - text-decoration : underline; - } - -#main .doc { margin: 0px; - font-family: sans-serif; - font-size: 100%; - line-height: 125%; - max-width: 40em; - color: black; - padding: 10px; - background-color: #90bdff} - -.inlinecode { - display: inline; -/* font-size: 125%; */ - color: #666666; - font-family: monospace } - -.doc .inlinecode { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.doc .inlinecode .id { - color: rgb(30%,30%,70%); -} - -.inlinecodenm { - display: inline; - color: #444444; -} - -.doc .code { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.comment { - display: inline; - font-family: monospace; - color: rgb(50%,50%,80%); -} - -.code { - display: block; -/* padding-left: 15px; */ - font-size: 110%; - font-family: monospace; - } - -table.infrule { - border: 0px; - margin-left: 50px; - margin-top: 10px; - margin-bottom: 10px; -} - -td.infrule { - font-family: monospace; - text-align: center; -/* color: rgb(35%,35%,70%); */ - padding: 0px; - line-height: 100%; -} - -tr.infrulemiddle hr { - margin: 1px 0 1px 0; -} - -.infrulenamecol { - color: rgb(60%,60%,60%); - font-size: 80%; - padding-left: 1em; - padding-bottom: 0.1em -} - -/* Pied de page */ - -#footer { font-size: 65%; - font-family: sans-serif; } - -/* Identifiers: <span class="id" title="...">) */ - -.id { display: inline; } - -.id[title="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[title="var"] { - color: rgb(40%,0%,40%); -} - -.id[title="variable"] { - color: rgb(40%,0%,40%); -} - -.id[title="definition"] { - color: rgb(0%,40%,0%); -} - -.id[title="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[title="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[title="instance"] { - color: rgb(0%,40%,0%); -} - -.id[title="projection"] { - color: rgb(0%,40%,0%); -} - -.id[title="method"] { - color: rgb(0%,40%,0%); -} - -.id[title="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[title="record"] { - color: rgb(0%,0%,80%); -} - -.id[title="class"] { - color: rgb(0%,0%,80%); -} - -.id[title="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -/* Deprecated rules using the 'type' attribute of <span> (not xhtml valid) */ - -.id[type="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[type="var"] { - color: rgb(40%,0%,40%); -} - -.id[type="variable"] { - color: rgb(40%,0%,40%); -} - -.id[type="definition"] { - color: rgb(0%,40%,0%); -} - -.id[type="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[type="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[type="instance"] { - color: rgb(0%,40%,0%); -} - -.id[type="projection"] { - color: rgb(0%,40%,0%); -} - -.id[type="method"] { - color: rgb(0%,40%,0%); -} - -.id[type="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[type="record"] { - color: rgb(0%,0%,80%); -} - -.id[type="class"] { - color: rgb(0%,0%,80%); -} - -.id[type="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -.inlinecode .id { - color: rgb(0%,0%,0%); -} - - -/* TOC */ - -#toc h2 { - padding: 10px; - background-color: rgb(60%,60%,100%); -} - -#toc li { - padding-bottom: 8px; -} - -/* Index */ - -#index { - margin: 0; - padding: 0; - width: 100%; -} - -#index #frontispiece { - margin: 1em auto; - padding: 1em; - width: 60%; -} - -.booktitle { font-size : 140% } -.authors { font-size : 90%; - line-height: 115%; } -.moreauthors { font-size : 60% } - -#index #entrance { - text-align: center; -} - -#index #entrance .spacer { - margin: 0 30px 0 30px; -} - -#index #footer { - position: absolute; - bottom: 0; -} - -.paragraph { - height: 0.75em; -} - -ul.doclist { - margin-top: 0em; - margin-bottom: 0em; -} diff --git a/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css b/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css deleted file mode 100644 index 32c0b33166..0000000000 --- a/doc/common/styles/html/coqremote/sites/all/themes/coq/style.css +++ /dev/null @@ -1,801 +0,0 @@ -body -{ - background: white; - color:#444; - font:normal normal normal small/1.5em "Lucida Grande", Verdana, sans-serif; - margin:0; - padding:0; -} - -h2 -{ - font-size:150%; - font-weight:normal; - margin:20px 0 0; -} - -h3 -{ - font-size:130%; - font-weight:normal; -} - -a:link,a:visited -{ - color:#660403; - font-weight:normal; - text-decoration:none; -} - -a:hover -{ - color: red; - text-decoration:none; -} - -#container -{ - margin: 0; - padding: 0; - } - - /*----------header, logo and site name styles----------*/ - #headertop - { - display: block; - /* position:absolute; */ - min-width: 700px; - top: 0; - width: 100%; - height:30px; - z-index: 1; - background: transparent url('images/header_top.png') repeat-x; - } - - #header - { - min-width: 700px; - width: 100%; height:70px; - position: relative; - left: 0; top: 0; - background: transparent url('images/header_bot.png') repeat-x; - } - - #logo - { - float:left; - z-index: 2; - position: absolute; - top: -15px; - left: 0px; - } - - #logo img - { - border:0; - float:left; - } - - #logoWrapper - { - line-height:4em; - } - - #siteName - { - position: relative; - top: 10px; left: 80px; - color:#fff; - float:left; - font-size:350%; - } - - #siteName a - { - color:#fff; - text-decoration:none; - } - - #siteName a:hover - { - color:#ddd; - text-decoration:none; - } - - #siteSlogan - { - color:#eee; - float:left; - font-size:170%; - margin:50px 0 0 10px; - text-transform:lowercase; - white-space:nowrap; - } - - /*----------nav styles -- primary links in header----------*/ - - #nav -{ - position:absolute; right:0; - margin: 0; - padding: 5px; - } - -#nav ul - { - list-style:none outside none; - list-style-image:none; - margin:0; - padding:0; - } - - #nav li - { - display: inline; - margin: 0; padding: 4px; - } - - #nav li a - { - border:medium none; - color:#ccc; - font-weight:normal; - padding-left:10px; - padding-right:10px; - text-decoration:none; - } - - #nav li a:hover - { - background:#7B0505 none repeat; - border:medium none; - border-left:1px solid #ddd; - border-right:1px solid #ddd; - color:#fff; - padding: 6px 9px 5px 9px; - } - - -/************** FOOTER *******************/ - - -#footer -{ - background:transparent url('images/footer.png') repeat-x; - width:100%; - clear:both; - font-size:85%; - text-align:center; - /* position:fixed; */ - margin: 0; - padding: 0; -} - - -#nav-footer -{ - display: inline; - color:#444; - margin: 0; - padding: 0; - text-align:right; - } - -#nav-footer ul - { - list-style:none outside none; - list-style-image:none; - margin:0; - padding:0px; padding-right: 5px; - } - -#nav-footer li -{ - display:inline; padding: 4px; -} - - #nav-footer li a - { - border:medium none; - color:#ccc; - font-size: 11px; - font-weight:normal; - padding-left: 10px; - padding-right: 10px; - text-decoration:none; - } - - #nav-footer li a:hover - { - background:#7B0505 none repeat; - border:medium none; - border-left:1px solid #ddd; - border-right:1px solid #ddd; - color:#fff; - margin:0; - padding: 3px 9px 0px 9px; - } - - - /*----------main content----------*/ - #content - { - display: block; - position: static; - -/* min-width: 640px; */ - max-width: 800px; - - margin-left:40px; - margin-right:300px; - padding: 2ex 2ex; - - z-index:1; - } - -.content { - display: block; - position: relative; - - margin: 0; - padding: 0; -} - - /*----------sidebar styles----------*/ - #sidebarWrapper - { - /* background:transparent url('images/sidebar_bottom.jpg') no-repeat scroll left bottom;*/ - display:block; - position:fixed; - /* avant : top: 100px; right:0px*/ - top: 15px; /* 180 */ - right:0px; - left: auto; - - margin-right: 0px; - - /* avant - width: 12%; - min-width:80px; */ - - /* width: 18%; */ - /* min-*/ - width:270px; - - z-index:0; - overflow:hidden; - -/* ajout precedent:*/ -/* min-height:320px; - padding:10px; - background-image:url('http://www.lix.polytechnique.fr/Labo/Denis.Cousineau/data/coq/rttr340bis.png'); - background-repeat : repeat-x ;*/ - -/* last ajout */ - /* min-height:510px; */ /* 360 */ - padding-left:0px; - padding-right:0px; - padding-top:105px; /* 40 */ - padding-bottom:/*105px*/115px; - /* background:transparent url('http://www.lix.polytechnique.fr/Labo/Denis.Cousineau/data/coq/trig6b.png') no-repeat scroll left top; */ - background:transparent url('images/sidebarbot.png') no-repeat scroll right bottom; - - } - -#sidebar { - padding-left: 40px; - padding-top: 105px; - overflow: visible; - background:transparent url('images/sidebartop.png') no-repeat scroll right top; -} - -#sidebar .title -{ - /* avant :border-bottom:1px solid #eee;*/ - /* avant : color:#660403;*/ - color:#2D0102; - font-size:120%; - font-weight:bold; - line-height:19px; - margin:10px 0; -} - -/*----------page styles----------*/ -.pageTitle -{ - color:#2D0102; - font-size:220%; - margin:10px 0 20px; -} - -.mission -{ - background-color:#efefef; - border:solid 1px #ccc; - margin:0 0 10px 0; - padding:10px; -} - -.messages -{ - color:#C80000; - font-size:110%; - margin:10px 0; -} - -/*----------node styles----------*/ -.nodeTitle -{ - background: url('images/nodeTitle.gif') no-repeat 0 100%; - color:#9a0000; - font-size: 100%; - margin:0; -} - -.nodeTitle a -{ - color:#660403; - text-decoration:none; -} - -.nodeTitle a:hover -{ - color:#d00000; - text-decoration:none; -} - -.node -{ - margin:0 0 20px; -} - -.content p -{ - margin:10px 0; -} - -.submitted -{ - color:#a3a3a3; - font-size:70%; -} - -.nodeLinks -{ - font-size:95%; - margin:0; - padding:0; -} - -.taxonomy -{ - background:url('icons/tag_red.png') no-repeat 0 7px; - font-size:80%; - padding:0 0 5px 16px; -} - -/*----------comment styles----------*/ -.commentTitle -{ - Border-bottom:1px solid #ddd; - color:#9a0000; - font-size:130%; - margin:20px 0 0; -} - -.commentTitle a -{ - color:#660403; - text-decoration:none; -} - -.commentTitle a:hover -{ - color:#d00000; - text-decoration:none; -} - -.commentLinks -{ - background:#f7f7f7; - border:1px solid #e1e1e1; - color:#444; - font-size:95%; - margin:20px 0 30px; - padding:4px 0 4px 4px; -} - - -/*----------img styles----------*/ -img -{ - padding:3px; -} - -/*----------icons for links----------*/ -.comment_comments a -{ - background:url('icons/comment.png') no-repeat 0 2px; - padding-bottom:5px; - padding-left:20px; -} - -.node_read_more a -{ - background:url('icons/page_white_go.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} - -.comment_add a,.comment_reply a -{ - background:url('icons/comment_add.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} -.comment_delete a -{ - background:url('icons/comment_delete.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} - -.comment_edit a -{ - background:url('icons/comment_edit.png') no-repeat; - padding-bottom:5px; - padding-left:20px; -} - -/*----------TinyMCE editor----------*/ -body.mceContentBody -{ - background:#fff; - color:#000; - font-size:12px; -} - -body.mceContentBody a:link -{ - color:#ff0000; -} - -/*----------table styles----------*/ -table -{ - margin:1em 0; - width:100%; -} - -thead th -{ - border-bottom:2px solid #AAA; - color:#494949; - font-weight:bold; -} - -td,th -{ - padding:.3em 0 .5em; -} - -tr.even,tr.odd,tbody th -{ - border:solid #D5D6D7; - border-width:1px 0; -} - -tr.even -{ - background:#fff; -} - -td.region,td.module,td.container -{ - background:#D5D6D7; - border-bottom:1px solid #AAA; - border-top:1.5em solid #fff; - color:#455067; - font-weight:bold; -} - -tr:first-child td.region,tr:first-child td.module,tr:first-child td.container -{ - border-top-width:0; -} - -td.menu-disabled,td.menu-disabled a -{ - background-color:#D5C2C2; - color:#000; -} - -/*----------other styles----------*/ - -.block -{ - margin:5px 0 20px; -} - -.thumbnail,.preview -{ - border:1px solid #ccc; -} - -.lstlisting { - display: block; - font-family: monospace; - white-space: pre; - margin: 1em 0; -} -.center { - text-align: center; -} -.centered { - display: block-inline; -} - -/*----------download table------------*/ - -table.downloadtable -{ - width:90%; - margin-left:auto; - margin-right:auto; -} - -table.downloadtable td.downloadheader -{ -padding: 2px 1em; -font-weight: bold; -font-size: 120%; -color: white; -background: transparent url('images/header_bot.png') repeat-x; -/*background-color: #660403; */ -border: solid 2px white; -border-left: none; -} - -table.downloadtable td.downloadcategory -{ -padding: 2px 1em; -background-color: #dfbfbe; -text-indent: 0; -} - -table.downloadtable td.downloadsize -{ -text-indent: 0; -white-space: nowrap; -height: 52px; -} - -table.downloadtable td -{ -padding: 2px 1em; -background-color: #dfbfbe; -border-right: solid white 2px; -} - - -table.downloadtable td.downloadtopline -{ -border-top: solid white 2px; -} - -table.downloadtable td.downloadtoprightline -{ -border-top: solid 2px white; -border-right: solid 2px white; -} - -table.downloadtable td.downloadbottomline -{ -border-bottom: solid 2px white; -border-right: solid 2px white; -} - -table.downloadtable td.downloadbottomrightline -{ -border-bottom: solid 2px white; -border-right: solid 2px white; -} - -table.downloadtable td.downloadrightline -{ -border-right: solid 2px white; -} - -table.downloadtable td.downloadback -{ -background-color: #efe4e4; -} - -table.downloadtable td.downloadbottomback -{ -border-bottom: solid 2px white; -background-color: #efe4e4; -} - - -/*********** Normal text style ************/ - -p { - text-indent:3em; -} - -ul { - margin: 0px; - margin-left:4em; - padding: 0px; - list-style-type:square; -} - -li -{ - text-indent: 0px; - margin: 0px; - padding: 0px; -} - -tt { font-size: 1em; } - -pre { font-size: 1em; } - -/*********** Framework ***********/ -.framework -{ - display: block; - position:relative; - border:solid 1px #660033; - margin: 8ex 1em; /* 8ex 8ex 1em 1em; */ - padding: 0; -} - -.frameworkcontent -{ - position:relative; - left:0px; - - - margin: 0; - padding: .5ex 2em; - - text-indent: 2em; - text-align: justify; -} - - -.frameworklabel -{ - display: inline; - position:relative; - top:-1.3ex; - - margin-left:2ex; - padding-top:.4ex; - padding-bottom:.4ex; - padding-right:1ex; - padding-left:1ex; - - border: none; - background: white; - color: black; - - font-weight: bold; - font-size:115%; -} - -.frameworklinks { - display:block; - position:relative; - top:1.4ex; - - margin-right:2ex; - - text-align:right; - font-size:100% - } - -.frameworklinks ul -{ - display: inline; - padding: 0px 1ex; - - border: none; - background: white; -} - - -.frameworklinks li - { - display:inline; - padding: 1ex 0px; - } - - .frameworklinks li a -{ - border:medium none; - - margin: 0px 1ex; - padding-left:2px; - padding-right:3px; - - font-weight:normal; - text-decoration:none; - - color: #660003; -} - - .frameworklinks li a:hover - { - color: red; - - border: none; - } - -/* General flat lists */ -.flatlist li {display: inline} - -/* For sections in bycat.html */ -.bycatsection dt { - text-indent: 3em -} - -.bycatsection dt a -{ - font-weight: bold; - color:#444; -} - -/* footnote is used in the new contribution form */ -.footnote { - text-indent: 0pt; - font-size: 80%; - color: silver; - text-align: justify -} - -/****************** CoqIDE Screenshots *****************/ - - -.SCpager { - position:relative; - top:5px; - width:630px; - background: transparent url('images/header_bot.png') repeat-x; - padding:4px; -} - -.SCpagercontent { - width:390px; - position:relative; - margin-left:auto; - margin-right:auto; -} - -.SCthumb { - height:45px; - margin-left:2px; - margin-right:2px; -} - -.SCthumbselected { - height:55px; - margin-left:2px; - margin-right:2px; -} - -.SCcontent { - position:relative; - top:5px; - width:638px; - background-color: #dfbfbe; -} - -.SCscreenshot { - position:relative; - height:400px; - width:auto; - margin:15px auto 15px 19px; -} diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 9acdd18b89..b2d3687780 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -240,3 +240,10 @@ so correctly converts ``x`` and ``y``. the kernel when it is passed a term with incorrect relevance marks. To avoid conversion issues as in ``late_mark`` you may wish to use it to find when your tactics are producing incorrect marks. + +.. flag:: Cumulative StrictProp + :name: Cumulative StrictProp + + Set this flag (it is off by default) to make the kernel accept + cumulativity between |SProp| and other universes. This makes + typechecking incomplete. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 31fb1b7382..ff2b742220 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -481,10 +481,12 @@ Changes in 8.11+beta1 .. _811Reals: - **Added:** - Module `Reals.ConstructiveCauchyReals` defines constructive real numbers + Module `Reals.Cauchy.ConstructiveCauchyReals` defines constructive real numbers by Cauchy sequences of rational numbers (`#10445 <https://github.com/coq/coq/pull/10445>`_, by Vincent Semeria, with the help and review of Guillaume Melquiond and Bas Spitters). + This module is not meant to be imported directly, please import + `Reals.Abstract.ConstructiveReals` instead. - **Added:** New module `Reals.ClassicalDedekindReals` defines Dedekind real numbers as boolean-valued functions along with 3 logical axioms: diff --git a/doc/sphinx/coqdoc.css b/doc/sphinx/coqdoc.css deleted file mode 100644 index a325a33842..0000000000 --- a/doc/sphinx/coqdoc.css +++ /dev/null @@ -1,338 +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) */ -/************************************************************************/ -body { padding: 0px 0px; - margin: 0px 0px; - background-color: white } - -#page { display: block; - padding: 0px; - margin: 0px; - padding-bottom: 10px; } - -#header { display: block; - position: relative; - padding: 0; - margin: 0; - vertical-align: middle; - border-bottom-style: solid; - border-width: thin } - -#header h1 { padding: 0; - margin: 0;} - - -/* Contents */ - -#main{ display: block; - padding: 10px; - font-family: sans-serif; - font-size: 100%; - line-height: 100% } - -#main h1 { line-height: 95% } /* allow for multi-line headers */ - -#main a.idref:visited {color : #416DFF; text-decoration : none; } -#main a.idref:link {color : #416DFF; text-decoration : none; } -#main a.idref:hover {text-decoration : none; } -#main a.idref:active {text-decoration : none; } - -#main a.modref:visited {color : #416DFF; text-decoration : none; } -#main a.modref:link {color : #416DFF; text-decoration : none; } -#main a.modref:hover {text-decoration : none; } -#main a.modref:active {text-decoration : none; } - -#main .keyword { color : #cf1d1d } -#main { color: black } - -.section { background-color: rgb(60%,60%,100%); - padding-top: 13px; - padding-bottom: 13px; - padding-left: 3px; - margin-top: 5px; - margin-bottom: 5px; - font-size : 175% } - -h2.section { background-color: rgb(80%,80%,100%); - padding-left: 3px; - padding-top: 12px; - padding-bottom: 10px; - font-size : 130% } - -h3.section { background-color: rgb(90%,90%,100%); - padding-left: 3px; - padding-top: 7px; - padding-bottom: 7px; - font-size : 115% } - -h4.section { -/* - background-color: rgb(80%,80%,80%); - max-width: 20em; - padding-left: 5px; - padding-top: 5px; - padding-bottom: 5px; -*/ - background-color: white; - padding-left: 0px; - padding-top: 0px; - padding-bottom: 0px; - font-size : 100%; - font-weight : bold; - text-decoration : underline; - } - -#main .doc { margin: 0px; - font-family: sans-serif; - font-size: 100%; - line-height: 125%; - max-width: 40em; - color: black; - padding: 10px; - background-color: #90bdff } - -.inlinecode { - display: inline; -/* font-size: 125%; */ - color: #666666; - font-family: monospace } - -.doc .inlinecode { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.doc .inlinecode .id { - color: rgb(30%,30%,70%); -} - -.inlinecodenm { - display: inline; - color: #444444; -} - -.doc .code { - display: inline; - font-size: 120%; - color: rgb(30%,30%,70%); - font-family: monospace } - -.comment { - display: inline; - font-family: monospace; - color: rgb(50%,50%,80%); -} - -.code { - display: block; -/* padding-left: 15px; */ - font-size: 110%; - font-family: monospace; - } - -table.infrule { - border: 0px; - margin-left: 50px; - margin-top: 10px; - margin-bottom: 10px; -} - -td.infrule { - font-family: monospace; - text-align: center; -/* color: rgb(35%,35%,70%); */ - padding: 0px; - line-height: 100%; -} - -tr.infrulemiddle hr { - margin: 1px 0 1px 0; -} - -.infrulenamecol { - color: rgb(60%,60%,60%); - font-size: 80%; - padding-left: 1em; - padding-bottom: 0.1em -} - -/* Pied de page */ - -#footer { font-size: 65%; - font-family: sans-serif; } - -/* Identifiers: <span class="id" title="...">) */ - -.id { display: inline; } - -.id[title="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[title="var"] { - color: rgb(40%,0%,40%); -} - -.id[title="variable"] { - color: rgb(40%,0%,40%); -} - -.id[title="definition"] { - color: rgb(0%,40%,0%); -} - -.id[title="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[title="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[title="instance"] { - color: rgb(0%,40%,0%); -} - -.id[title="projection"] { - color: rgb(0%,40%,0%); -} - -.id[title="method"] { - color: rgb(0%,40%,0%); -} - -.id[title="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[title="record"] { - color: rgb(0%,0%,80%); -} - -.id[title="class"] { - color: rgb(0%,0%,80%); -} - -.id[title="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -/* Deprecated rules using the 'type' attribute of <span> (not xhtml valid) */ - -.id[type="constructor"] { - color: rgb(60%,0%,0%); -} - -.id[type="var"] { - color: rgb(40%,0%,40%); -} - -.id[type="variable"] { - color: rgb(40%,0%,40%); -} - -.id[type="definition"] { - color: rgb(0%,40%,0%); -} - -.id[type="abbreviation"] { - color: rgb(0%,40%,0%); -} - -.id[type="lemma"] { - color: rgb(0%,40%,0%); -} - -.id[type="instance"] { - color: rgb(0%,40%,0%); -} - -.id[type="projection"] { - color: rgb(0%,40%,0%); -} - -.id[type="method"] { - color: rgb(0%,40%,0%); -} - -.id[type="inductive"] { - color: rgb(0%,0%,80%); -} - -.id[type="record"] { - color: rgb(0%,0%,80%); -} - -.id[type="class"] { - color: rgb(0%,0%,80%); -} - -.id[type="keyword"] { - color : #cf1d1d; -/* color: black; */ -} - -.inlinecode .id { - color: rgb(0%,0%,0%); -} - - -/* TOC */ - -#toc h2 { - padding: 10px; - background-color: rgb(60%,60%,100%); -} - -#toc li { - padding-bottom: 8px; -} - -/* Index */ - -#index { - margin: 0; - padding: 0; - width: 100%; -} - -#index #frontispiece { - margin: 1em auto; - padding: 1em; - width: 60%; -} - -.booktitle { font-size : 140% } -.authors { font-size : 90%; - line-height: 115%; } -.moreauthors { font-size : 60% } - -#index #entrance { - text-align: center; -} - -#index #entrance .spacer { - margin: 0 30px 0 30px; -} - -#index #footer { - position: absolute; - bottom: 0; -} - -.paragraph { - height: 0.75em; -} - -ul.doclist { - margin-top: 0em; - margin-bottom: 0em; -} diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 7da453b7af..9dcfea4fe7 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -2076,7 +2076,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) Now we are in a contradictory context and the proof can be solved. - .. coqtop:: all + .. coqtop:: all abort inversion H. @@ -2104,68 +2104,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) See also the larger example of :tacn:`dependent induction` and an explanation of the underlying technique. -.. tacn:: function induction (@qualid {+ @term}) - :name: function induction - - The tactic functional induction performs case analysis and induction - following the definition of a function. It makes use of a principle - generated by ``Function`` (see :ref:`advanced-recursive-functions`) or - ``Functional Scheme`` (see :ref:`functional-scheme`). - Note that this tactic is only available after a ``Require Import FunInd``. - -.. example:: - - .. coqtop:: reset all - - Require Import FunInd. - Functional Scheme minus_ind := Induction for minus Sort Prop. - Check minus_ind. - Lemma le_minus (n m:nat) : n - m <= n. - functional induction (minus n m) using minus_ind; simpl; auto. - Qed. - -.. note:: - :n:`(@qualid {+ @term})` must be a correct full application - of :n:`@qualid`. In particular, the rules for implicit arguments are the - same as usual. For example use :n:`@qualid` if you want to write implicit - arguments explicitly. - -.. note:: - Parentheses around :n:`@qualid {+ @term}` are not mandatory and can be skipped. - -.. note:: - :n:`functional induction (f x1 x2 x3)` is actually a wrapper for - :n:`induction x1, x2, x3, (f x1 x2 x3) using @qualid` followed by a cleaning - phase, where :n:`@qualid` is the induction principle registered for :g:`f` - (by the ``Function`` (see :ref:`advanced-recursive-functions`) or - ``Functional Scheme`` (see :ref:`functional-scheme`) - command) corresponding to the sort of the goal. Therefore - ``functional induction`` may fail if the induction scheme :n:`@qualid` is not - defined. See also :ref:`advanced-recursive-functions` for the function - terms accepted by ``Function``. - -.. note:: - There is a difference between obtaining an induction scheme - for a function by using :g:`Function` (see :ref:`advanced-recursive-functions`) - and by using :g:`Functional Scheme` after a normal definition using - :g:`Fixpoint` or :g:`Definition`. See :ref:`advanced-recursive-functions` - for details. - -.. seealso:: :ref:`advanced-recursive-functions`, :ref:`functional-scheme` and :tacn:`inversion` - -.. exn:: Cannot find induction information on @qualid. - :undocumented: - -.. exn:: Not the right number of induction arguments. - :undocumented: - -.. tacv:: functional induction (@qualid {+ @term}) as @simple_intropattern using @term with @bindings_list - - Similarly to :tacn:`induction` and :tacn:`elim`, this allows giving - explicitly the name of the introduced variables, the induction principle, and - the values of dependent premises of the elimination scheme, including - *predicates* for mutual induction when :n:`@qualid` is part of a mutually - recursive definition. +.. seealso:: :tacn:`functional induction` .. tacn:: discriminate @term :name: discriminate @@ -2672,6 +2611,8 @@ and an explanation of the underlying technique. assumption. Qed. +.. seealso:: :tacn:`functional inversion` + .. tacn:: fix @ident @num :name: fix @@ -4604,42 +4545,6 @@ symbol :g:`=`. Analogous to :tacn:`dependent rewrite ->` but uses the equality from right to left. -Inversion ---------- - -.. tacn:: functional inversion @ident - :name: functional inversion - - :tacn:`functional inversion` is a tactic that performs inversion on hypothesis - :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or :n:`@term = @qualid - {+ @term}` where :n:`@qualid` must have been defined using Function (see - :ref:`advanced-recursive-functions`). Note that this tactic is only - available after a ``Require Import FunInd``. - - .. exn:: Hypothesis @ident must contain at least one Function. - :undocumented: - - .. exn:: Cannot find inversion information for hypothesis @ident. - - This error may be raised when some inversion lemma failed to be generated by - Function. - - - .. tacv:: functional inversion @num - - This does the same thing as :n:`intros until @num` followed by - :n:`functional inversion @ident` where :token:`ident` is the - identifier for the last introduced hypothesis. - - .. tacv:: functional inversion @ident @qualid - functional inversion @num @qualid - - If the hypothesis :token:`ident` (or :token:`num`) has a type of the form - :n:`@qualid__1 {+ @term__i } = @qualid__2 {+ @term__j }` where - :n:`@qualid__1` and :n:`@qualid__2` are valid candidates to - functional inversion, this variant allows choosing which :token:`qualid` - is inverted. - Classical tactics ----------------- diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index a0d1080314..60fdbf0a9d 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1096,6 +1096,8 @@ Controlling Typing Flags Print the status of the three typing flags: guard checking, positivity checking and universe checking. +See also :flag:`Cumulative StrictProp` in the |SProp| chapter. + .. example:: .. coqtop:: all reset diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index 34197c4fcf..e05be7c2c2 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -190,146 +190,7 @@ Combined Scheme Check tree_forest_mutrect. -.. _functional-scheme: - -Generation of induction principles with ``Functional`` ``Scheme`` ------------------------------------------------------------------ - - -.. cmd:: Functional Scheme @ident__0 := Induction for @ident' Sort @sort {* with @ident__i := Induction for @ident__i' Sort @sort} - - This command is a high-level experimental tool for - generating automatically induction principles corresponding to - (possibly mutually recursive) functions. First, it must be made - available via ``Require Import FunInd``. - Each :n:`@ident__i` is a different mutually defined function - name (the names must be in the same order as when they were defined). This - command generates the induction principle for each :n:`@ident__i`, following - the recursive structure and case analyses of the corresponding function - :n:`@ident__i'`. - -.. warning:: - - There is a difference between induction schemes generated by the command - :cmd:`Functional Scheme` and these generated by the :cmd:`Function`. Indeed, - :cmd:`Function` generally produces smaller principles that are closer to how - a user would implement them. See :ref:`advanced-recursive-functions` for details. - -.. example:: - - Induction scheme for div2. - - We define the function div2 as follows: - - .. coqtop:: all - - Require Import FunInd. - Require Import Arith. - - Fixpoint div2 (n:nat) : nat := - match n with - | O => 0 - | S O => 0 - | S (S n') => S (div2 n') - end. - - The definition of a principle of induction corresponding to the - recursive structure of `div2` is defined by the command: - - .. coqtop:: all - - Functional Scheme div2_ind := Induction for div2 Sort Prop. - - You may now look at the type of div2_ind: - - .. coqtop:: all - - Check div2_ind. - - We can now prove the following lemma using this principle: - - .. coqtop:: all - - Lemma div2_le' : forall n:nat, div2 n <= n. - intro n. - pattern n, (div2 n). - apply div2_ind; intros. - auto with arith. - auto with arith. - simpl; auto with arith. - Qed. - - We can use directly the functional induction (:tacn:`function induction`) tactic instead - of the pattern/apply trick: - - .. coqtop:: all - - Reset div2_le'. - - Lemma div2_le : forall n:nat, div2 n <= n. - intro n. - functional induction (div2 n). - auto with arith. - auto with arith. - auto with arith. - Qed. - -.. example:: - - Induction scheme for tree_size. - - We define trees by the following mutual inductive type: - - .. original LaTeX had "Variable" instead of "Axiom", which generates an ugly warning - - .. coqtop:: reset all - - Axiom A : Set. - - Inductive tree : Set := - node : A -> forest -> tree - with forest : Set := - | empty : forest - | cons : tree -> forest -> forest. - - We define the function tree_size that computes the size of a tree or a - forest. Note that we use ``Function`` which generally produces better - principles. - - .. coqtop:: all - - Require Import FunInd. - - Function tree_size (t:tree) : nat := - match t with - | node A f => S (forest_size f) - end - with forest_size (f:forest) : nat := - match f with - | empty => 0 - | cons t f' => (tree_size t + forest_size f') - end. - - Notice that the induction principles ``tree_size_ind`` and ``forest_size_ind`` - generated by ``Function`` are not mutual. - - .. coqtop:: all - - Check tree_size_ind. - - Mutual induction principles following the recursive structure of ``tree_size`` - and ``forest_size`` can be generated by the following command: - - .. coqtop:: all - - Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop - with forest_size_ind2 := Induction for forest_size Sort Prop. - - You may now look at the type of `tree_size_ind2`: - - .. coqtop:: all - - Check tree_size_ind2. +.. seealso:: :ref:`functional-scheme` .. _derive-inversion: diff --git a/doc/sphinx/using/libraries/funind.rst b/doc/sphinx/using/libraries/funind.rst index ed00f3d455..40f9eedcf0 100644 --- a/doc/sphinx/using/libraries/funind.rst +++ b/doc/sphinx/using/libraries/funind.rst @@ -13,7 +13,7 @@ The following command is available when the ``FunInd`` library has been loaded v This command is a generalization of :cmd:`Fixpoint`. It is a wrapper for several ways of defining a function *and* other useful related objects, namely: an induction principle that reflects the recursive - structure of the function (see :tacn:`function induction`) and its fixpoint equality. + structure of the function (see :tacn:`functional induction`) and its fixpoint equality. This defines a function similar to those defined by :cmd:`Fixpoint`. As in :cmd:`Fixpoint`, the decreasing argument must be given (unless the function is not recursive), but it might not @@ -27,7 +27,7 @@ The following command is available when the ``FunInd`` library has been loaded v to structurally recursive functions (i.e. when :n:`@fixannot` is a :n:`struct` clause). - See :tacn:`function induction` and :cmd:`Functional Scheme` for how to use + See :tacn:`functional induction` and :cmd:`Functional Scheme` for how to use the induction principle to reason easily about the function. The form of the :n:`@fixannot` clause determines which definition mechanism :cmd:`Function` uses. @@ -166,4 +166,235 @@ terminating functions. :tacn:`functional inversion` will not be available for the function. -.. seealso:: :ref:`functional-scheme` and :tacn:`function induction` +Tactics +------- + +.. tacn:: functional induction (@qualid {+ @term}) + :name: functional induction + + The tactic functional induction performs case analysis and induction + following the definition of a function. It makes use of a principle + generated by :cmd:`Function` or :cmd:`Functional Scheme`. + Note that this tactic is only available after a ``Require Import FunInd``. + + .. example:: + + .. coqtop:: reset all + + Require Import FunInd. + Functional Scheme minus_ind := Induction for minus Sort Prop. + Check minus_ind. + Lemma le_minus (n m:nat) : n - m <= n. + functional induction (minus n m) using minus_ind; simpl; auto. + Qed. + + .. note:: + :n:`(@qualid {+ @term})` must be a correct full application + of :n:`@qualid`. In particular, the rules for implicit arguments are the + same as usual. For example use :n:`@qualid` if you want to write implicit + arguments explicitly. + + .. note:: + Parentheses around :n:`@qualid {+ @term}` are not mandatory and can be skipped. + + .. note:: + :n:`functional induction (f x1 x2 x3)` is actually a wrapper for + :n:`induction x1, x2, x3, (f x1 x2 x3) using @qualid` followed by a cleaning + phase, where :n:`@qualid` is the induction principle registered for :g:`f` + (by the :cmd:`Function` or :cmd:`Functional Scheme` command) + corresponding to the sort of the goal. Therefore + :tacn:`functional induction` may fail if the induction scheme :n:`@qualid` is not + defined. + + .. note:: + There is a difference between obtaining an induction scheme + for a function by using :cmd:`Function` + and by using :cmd:`Functional Scheme` after a normal definition using + :cmd:`Fixpoint` or :cmd:`Definition`. + + .. exn:: Cannot find induction information on @qualid. + :undocumented: + + .. exn:: Not the right number of induction arguments. + :undocumented: + + .. tacv:: functional induction (@qualid {+ @term}) as @simple_intropattern using @term with @bindings_list + + Similarly to :tacn:`induction` and :tacn:`elim`, this allows giving + explicitly the name of the introduced variables, the induction principle, and + the values of dependent premises of the elimination scheme, including + *predicates* for mutual induction when :n:`@qualid` is part of a mutually + recursive definition. + +.. tacn:: functional inversion @ident + :name: functional inversion + + :tacn:`functional inversion` is a tactic that performs inversion on hypothesis + :n:`@ident` of the form :n:`@qualid {+ @term} = @term` or :n:`@term = @qualid + {+ @term}` where :n:`@qualid` must have been defined using :cmd:`Function`. + Note that this tactic is only available after a ``Require Import FunInd``. + + .. exn:: Hypothesis @ident must contain at least one Function. + :undocumented: + + .. exn:: Cannot find inversion information for hypothesis @ident. + + This error may be raised when some inversion lemma failed to be generated by + Function. + + + .. tacv:: functional inversion @num + + This does the same thing as :n:`intros until @num` followed by + :n:`functional inversion @ident` where :token:`ident` is the + identifier for the last introduced hypothesis. + + .. tacv:: functional inversion @ident @qualid + functional inversion @num @qualid + + If the hypothesis :token:`ident` (or :token:`num`) has a type of the form + :n:`@qualid__1 {+ @term__i } = @qualid__2 {+ @term__j }` where + :n:`@qualid__1` and :n:`@qualid__2` are valid candidates to + functional inversion, this variant allows choosing which :token:`qualid` + is inverted. + +.. _functional-scheme: + +Generation of induction principles with ``Functional`` ``Scheme`` +----------------------------------------------------------------- + + +.. cmd:: Functional Scheme @ident__0 := Induction for @ident' Sort @sort {* with @ident__i := Induction for @ident__i' Sort @sort} + + This command is a high-level experimental tool for + generating automatically induction principles corresponding to + (possibly mutually recursive) functions. First, it must be made + available via ``Require Import FunInd``. + Each :n:`@ident__i` is a different mutually defined function + name (the names must be in the same order as when they were defined). This + command generates the induction principle for each :n:`@ident__i`, following + the recursive structure and case analyses of the corresponding function + :n:`@ident__i'`. + +.. warning:: + + There is a difference between induction schemes generated by the command + :cmd:`Functional Scheme` and these generated by the :cmd:`Function`. Indeed, + :cmd:`Function` generally produces smaller principles that are closer to how + a user would implement them. See :ref:`advanced-recursive-functions` for details. + +.. example:: + + Induction scheme for div2. + + We define the function div2 as follows: + + .. coqtop:: all + + Require Import FunInd. + Require Import Arith. + + Fixpoint div2 (n:nat) : nat := + match n with + | O => 0 + | S O => 0 + | S (S n') => S (div2 n') + end. + + The definition of a principle of induction corresponding to the + recursive structure of `div2` is defined by the command: + + .. coqtop:: all + + Functional Scheme div2_ind := Induction for div2 Sort Prop. + + You may now look at the type of div2_ind: + + .. coqtop:: all + + Check div2_ind. + + We can now prove the following lemma using this principle: + + .. coqtop:: all + + Lemma div2_le' : forall n:nat, div2 n <= n. + intro n. + pattern n, (div2 n). + apply div2_ind; intros. + auto with arith. + auto with arith. + simpl; auto with arith. + Qed. + + We can use directly the functional induction (:tacn:`functional induction`) tactic instead + of the pattern/apply trick: + + .. coqtop:: all + + Reset div2_le'. + + Lemma div2_le : forall n:nat, div2 n <= n. + intro n. + functional induction (div2 n). + auto with arith. + auto with arith. + auto with arith. + Qed. + +.. example:: + + Induction scheme for tree_size. + + We define trees by the following mutual inductive type: + + .. original LaTeX had "Variable" instead of "Axiom", which generates an ugly warning + + .. coqtop:: reset all + + Axiom A : Set. + + Inductive tree : Set := + node : A -> forest -> tree + with forest : Set := + | empty : forest + | cons : tree -> forest -> forest. + + We define the function tree_size that computes the size of a tree or a + forest. Note that we use ``Function`` which generally produces better + principles. + + .. coqtop:: all + + Require Import FunInd. + + Function tree_size (t:tree) : nat := + match t with + | node A f => S (forest_size f) + end + with forest_size (f:forest) : nat := + match f with + | empty => 0 + | cons t f' => (tree_size t + forest_size f') + end. + + Notice that the induction principles ``tree_size_ind`` and ``forest_size_ind`` + generated by ``Function`` are not mutual. + + .. coqtop:: all + + Check tree_size_ind. + + Mutual induction principles following the recursive structure of ``tree_size`` + and ``forest_size`` can be generated by the following command: + + .. coqtop:: all + + Functional Scheme tree_size_ind2 := Induction for tree_size Sort Prop + with forest_size_ind2 := Induction for forest_size Sort Prop. + + You may now look at the type of `tree_size_ind2`: + + .. coqtop:: all + + Check tree_size_ind2. diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 7fa621c11c..b2c9c936c9 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -13,6 +13,7 @@ through the <tt>Require Import</tt> command.</p> The core library (automatically loaded when starting Coq) </dt> <dd> + theories/Init/Ltac.v theories/Init/Notations.v theories/Init/Datatypes.v theories/Init/Logic.v @@ -444,6 +445,7 @@ through the <tt>Require Import</tt> command.</p> theories/Sorting/PermutSetoid.v theories/Sorting/Mergesort.v theories/Sorting/Sorted.v + theories/Sorting/CPermutation.v </dd> <dt> <b>Wellfounded</b>: diff --git a/engine/uState.ml b/engine/uState.ml index ff85f09efa..abd5f2828f 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -39,7 +39,7 @@ type t = uctx_weak_constraints : UPairSet.t } -let initial_sprop_cumulative = UGraph.make_sprop_cumulative UGraph.initial_universes +let initial_sprop_cumulative = UGraph.set_cumulative_sprop true UGraph.initial_universes let empty = { uctx_names = UNameMap.empty, LMap.empty; @@ -57,11 +57,11 @@ let elaboration_sprop_cumul = ~key:["Elaboration";"StrictProp";"Cumulativity"] ~value:true let make ~lbound u = - let u = if elaboration_sprop_cumul () then UGraph.make_sprop_cumulative u else u in - { empty with - uctx_universes = u; - uctx_universes_lbound = lbound; - uctx_initial_universes = u} + let u = UGraph.set_cumulative_sprop (elaboration_sprop_cumul ()) u in + { empty with + uctx_universes = u; + uctx_universes_lbound = lbound; + uctx_initial_universes = u} let is_empty ctx = ContextSet.is_empty ctx.uctx_local && @@ -547,10 +547,11 @@ let emit_side_effects eff u = merge_seff u uctx let update_sigma_env uctx env = - let univs = UGraph.make_sprop_cumulative (Environ.universes env) in + let univs = UGraph.set_cumulative_sprop (elaboration_sprop_cumul()) (Environ.universes env) in let eunivs = - { uctx with uctx_initial_universes = univs; - uctx_universes = univs } + { uctx with + uctx_initial_universes = univs; + uctx_universes = univs } in merge_seff eunivs eunivs.uctx_local diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 244cd2865d..11d4120d7c 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -92,6 +92,8 @@ type typing_flags = { indices_matter: bool; (** The universe of an inductive type must be above that of its indices. *) + cumulative_sprop : bool; + (** SProp <= Type *) } (* some contraints are in constant_constraints, some other may be in diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 20dc21900c..b347152c16 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -26,6 +26,7 @@ let safe_flags oracle = { enable_VM = true; enable_native_compiler = true; indices_matter = true; + cumulative_sprop = false; } (** {6 Arities } *) diff --git a/kernel/environ.ml b/kernel/environ.ml index de8692ff21..cf01711fe7 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -431,7 +431,7 @@ let push_subgraph (levels,csts) env = in map_universes add_subgraph env -let set_engagement c env = (* Unsafe *) +let set_engagement c env = { env with env_stratification = { env.env_stratification with env_engagement = c } } @@ -445,6 +445,7 @@ let same_flags { share_reduction; enable_VM; enable_native_compiler; + cumulative_sprop; } alt = check_guarded == alt.check_guarded && check_positive == alt.check_positive && @@ -453,14 +454,18 @@ let same_flags { indices_matter == alt.indices_matter && share_reduction == alt.share_reduction && enable_VM == alt.enable_VM && - enable_native_compiler == alt.enable_native_compiler + enable_native_compiler == alt.enable_native_compiler && + cumulative_sprop == alt.cumulative_sprop [@warning "+9"] -let set_typing_flags c env = (* Unsafe *) +let set_cumulative_sprop b = map_universes (UGraph.set_cumulative_sprop b) + +let set_typing_flags c env = if same_flags env.env_typing_flags c then env - else { env with env_typing_flags = c } + else set_cumulative_sprop c.cumulative_sprop { env with env_typing_flags = c } -let make_sprop_cumulative = map_universes UGraph.make_sprop_cumulative +let set_cumulative_sprop b env = + set_typing_flags {env.env_typing_flags with cumulative_sprop=b} env let set_allow_sprop b env = { env with env_stratification = diff --git a/kernel/environ.mli b/kernel/environ.mli index 25ecdfd852..4195f112ca 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -310,7 +310,7 @@ val push_subgraph : Univ.ContextSet.t -> env -> env val set_engagement : engagement -> env -> env val set_typing_flags : typing_flags -> env -> env -val make_sprop_cumulative : env -> env +val set_cumulative_sprop : bool -> env -> env val set_allow_sprop : bool -> env -> env val sprop_allowed : env -> bool diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 58b516dfdd..9fabb441d1 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -243,8 +243,6 @@ let set_native_compiler b senv = let flags = Environ.typing_flags senv.env in set_typing_flags { flags with enable_native_compiler = b } senv -let make_sprop_cumulative senv = { senv with env = Environ.make_sprop_cumulative senv.env } - let set_allow_sprop b senv = { senv with env = Environ.set_allow_sprop b senv.env } (** Check that the engagement [c] expected by a library matches diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index b42746a882..f5bd27ca12 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -135,7 +135,6 @@ val set_check_positive : bool -> safe_transformer0 val set_check_universes : bool -> safe_transformer0 val set_VM : bool -> safe_transformer0 val set_native_compiler : bool -> safe_transformer0 -val make_sprop_cumulative : safe_transformer0 val set_allow_sprop : bool -> safe_transformer0 val check_engagement : Environ.env -> Declarations.set_predicativity -> unit diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 449cd0f0f9..5f5f0ef8cd 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -37,7 +37,7 @@ let g_map f g = if g.graph == g' then g else {g with graph=g'} -let make_sprop_cumulative g = {g with sprop_cumulative=true} +let set_cumulative_sprop b g = {g with sprop_cumulative=b} let check_smaller_expr g (u,n) (v,m) = let diff = n - m in diff --git a/kernel/uGraph.mli b/kernel/uGraph.mli index 8a8c09e911..8d9afb0990 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -13,8 +13,8 @@ open Univ (** {6 Graphs of universes. } *) type t -val make_sprop_cumulative : t -> t -(** Don't use this in the kernel, it makes the system incomplete. *) +val set_cumulative_sprop : bool -> t -> t +(** Makes the system incomplete. *) type 'a check_function = t -> 'a -> 'a -> bool diff --git a/library/global.ml b/library/global.ml index abc04a5e14..5c847fda96 100644 --- a/library/global.ml +++ b/library/global.ml @@ -99,7 +99,9 @@ let set_check_guarded c = globalize0 (Safe_typing.set_check_guarded c) let set_check_positive c = globalize0 (Safe_typing.set_check_positive c) let set_check_universes c = globalize0 (Safe_typing.set_check_universes c) let typing_flags () = Environ.typing_flags (env ()) -let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative +let set_cumulative_sprop b = + set_typing_flags {(typing_flags()) with Declarations.cumulative_sprop = b} +let is_cumulative_sprop () = (typing_flags()).Declarations.cumulative_sprop let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants cd = globalize (Safe_typing.export_private_constants cd) diff --git a/library/global.mli b/library/global.mli index e7133a1034..2acd7e2a67 100644 --- a/library/global.mli +++ b/library/global.mli @@ -36,7 +36,8 @@ val set_check_guarded : bool -> unit val set_check_positive : bool -> unit val set_check_universes : bool -> unit val typing_flags : unit -> Declarations.typing_flags -val make_sprop_cumulative : unit -> unit +val set_cumulative_sprop : bool -> unit +val is_cumulative_sprop : unit -> bool val set_allow_sprop : bool -> unit val sprop_allowed : unit -> bool diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 7754fe401e..0bad3cbe5b 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -312,7 +312,7 @@ let add_rewrite_hint ~poly bases ort t lcsr = if poly then ctx else (* This is a global universe context that shouldn't be refreshed at every use of the hint, declare it globally. *) - (Declare.declare_universe_context ~poly:false ctx; + (DeclareUctx.declare_universe_context ~poly:false ctx; Univ.ContextSet.empty) in CAst.make ?loc:(Constrexpr_ops.constr_loc ce) ((c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t) in diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index e713ab13b2..5baa23b3e9 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -342,7 +342,7 @@ GRAMMAR EXTEND Gram hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - { Hints.HintsExtern (n,c, in_tac tac) } ] ] + { ComHints.HintsExtern (n,c, in_tac tac) } ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> diff --git a/tactics/leminv.ml b/plugins/ltac/leminv.ml index 5a8ec404ee..5a8ec404ee 100644 --- a/tactics/leminv.ml +++ b/plugins/ltac/leminv.ml diff --git a/tactics/leminv.mli b/plugins/ltac/leminv.mli index 5a5de7b58f..5a5de7b58f 100644 --- a/tactics/leminv.mli +++ b/plugins/ltac/leminv.mli diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index e83eab20dc..f31361279c 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -9,6 +9,7 @@ Tactic_debug Tacintern Profile_ltac Tactic_matching +Leminv Tacinterp Tacentries Evar_tactics diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 0646af3552..633cdbd735 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -150,7 +150,7 @@ let decl_constant na univs c = let open Constr in let vars = CVars.universes_of_constr c in let univs = UState.restrict_universe_context ~lbound:(Global.universes_lbound ()) univs vars in - let () = Declare.declare_universe_context ~poly:false univs in + let () = DeclareUctx.declare_universe_context ~poly:false univs in let types = (Typeops.infer (Global.env ()) c).uj_type in let univs = Monomorphic_entry Univ.ContextSet.empty in mkConst(declare_constant ~name:(Id.of_string na) diff --git a/printing/printer.ml b/printing/printer.ml index 81c0a36f53..c2f73715f0 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -989,4 +989,5 @@ let print_and_diff oldp newp = let pr_typing_flags flags = str "check_guarded: " ++ bool flags.check_guarded ++ fnl () ++ str "check_positive: " ++ bool flags.check_positive ++ fnl () - ++ str "check_universes: " ++ bool flags.check_universes + ++ str "check_universes: " ++ bool flags.check_universes ++ fnl () + ++ str "cumulative sprop: " ++ bool flags.cumulative_sprop diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 0e78a03f45..6b575d0807 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -40,6 +40,9 @@ let name_op_to_name ~name_op ~name suffix = | Some s -> s | None -> Nameops.add_suffix name suffix +let declare_abstract = ref (fun ~name ~poly ~kind ~sign ~secsign ~opaque ~solve_tac sigma concl -> + CErrors.anomaly (Pp.str "Abstract declaration hook not registered")) + let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let open Tacticals.New in let open Tacmach.New in @@ -77,7 +80,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let concl = it_mkNamedProd_or_LetIn concl sign in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) Tactics.intro) tac) in let effs, sigma, lem, args, safe = - Declare.declare_abstract ~name ~poly ~sign ~secsign ~kind ~opaque ~solve_tac sigma concl in + !declare_abstract ~name ~poly ~sign ~secsign ~kind ~opaque ~solve_tac sigma concl in let solve = Proofview.tclEFFECTS effs <*> tacK lem args diff --git a/tactics/abstract.mli b/tactics/abstract.mli index 5c936ff9d6..a138a457b3 100644 --- a/tactics/abstract.mli +++ b/tactics/abstract.mli @@ -20,3 +20,15 @@ val cache_term_by_tactic_then -> unit Proofview.tactic val tclABSTRACT : ?opaque:bool -> Id.t option -> unit Proofview.tactic -> unit Proofview.tactic + +val declare_abstract : + ( name:Names.Id.t + -> poly:bool + -> kind:Decls.logical_kind + -> sign:EConstr.named_context + -> secsign:Environ.named_context_val + -> opaque:bool + -> solve_tac:unit Proofview.tactic + -> Evd.evar_map + -> EConstr.t + -> Evd.side_effects * Evd.evar_map * EConstr.t * EConstr.t list * bool) ref diff --git a/tactics/declareUctx.ml b/tactics/declareUctx.ml new file mode 100644 index 0000000000..3f67ff20a4 --- /dev/null +++ b/tactics/declareUctx.ml @@ -0,0 +1,34 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** Monomorphic universes need to survive sections. *) + +let name_instance inst = + let map lvl = match Univ.Level.name lvl with + | None -> (* Having Prop/Set/Var as section universes makes no sense *) + assert false + | Some na -> + try + let qid = Nametab.shortest_qualid_of_universe na in + Names.Name (Libnames.qualid_basename qid) + with Not_found -> + (* Best-effort naming from the string representation of the level. + See univNames.ml for a similar hack. *) + Names.Name (Names.Id.of_string_soft (Univ.Level.to_string lvl)) + in + Array.map map (Univ.Instance.to_array inst) + +let declare_universe_context ~poly ctx = + if poly then + let uctx = Univ.ContextSet.to_context ctx in + let nas = name_instance (Univ.UContext.instance uctx) in + Global.push_section_context (nas, uctx) + else + Global.push_context_set ~strict:true ctx diff --git a/tactics/declareUctx.mli b/tactics/declareUctx.mli new file mode 100644 index 0000000000..7ecfab04f2 --- /dev/null +++ b/tactics/declareUctx.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit diff --git a/tactics/hints.ml b/tactics/hints.ml index ffb0e030db..5fb519cc4f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -23,7 +23,6 @@ open Globnames open Libobject open Namegen open Libnames -open Smartlocate open Termops open Inductiveops open Typeclasses @@ -100,8 +99,6 @@ let empty_hint_info = (* The Type of Constructions Autotactic Hints *) (************************************************************************) -type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen - type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) @@ -164,10 +161,6 @@ type full_hint = hint with_metadata type hint_entry = GlobRef.t option * raw_hint hint_ast with_uid with_metadata -type reference_or_constr = - | HintsReference of qualid - | HintsConstr of Constrexpr.constr_expr - type hint_mode = | ModeInput (* No evars *) | ModeNoHeadEvar (* No evar at the head *) @@ -178,16 +171,6 @@ type 'a hints_transparency_target = | HintsConstants | HintsReferences of 'a list -type hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list - | HintsResolveIFF of bool * qualid list * int option - | HintsImmediate of reference_or_constr list - | HintsUnfold of qualid list - | HintsTransparency of qualid hints_transparency_target * bool - | HintsMode of qualid * hint_mode list - | HintsConstructors of qualid list - | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument - type import_level = HintLax | HintWarn | HintStrict let warn_hint_to_string = function @@ -895,7 +878,7 @@ let fresh_global_or_constr env sigma poly cr = else begin if isgr then warn_polymorphic_hint (pr_hint_term env sigma ctx cr); - Declare.declare_universe_context ~poly:false ctx; + DeclareUctx.declare_universe_context ~poly:false ctx; (c, Univ.ContextSet.empty) end @@ -1310,114 +1293,6 @@ let prepare_hint check env init (sigma,c) = let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in (c', diff) -let project_hint ~poly pri l2r r = - let open EConstr in - let open Coqlib in - let gr = Smartlocate.global_with_alias r in - let env = Global.env() in - let sigma = Evd.from_env env in - let sigma, c = Evd.fresh_global env sigma gr in - let t = Retyping.get_type_of env sigma c in - let t = - Tacred.reduce_to_quantified_ref env sigma (lib_ref "core.iff.type") t in - let sign,ccl = decompose_prod_assum sigma t in - let (a,b) = match snd (decompose_app sigma ccl) with - | [a;b] -> (a,b) - | _ -> assert false in - let p = - if l2r then lib_ref "core.iff.proj1" else lib_ref "core.iff.proj2" in - let sigma, p = Evd.fresh_global env sigma p in - let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in - let c = it_mkLambda_or_LetIn - (mkApp (p,[|mkArrow a Sorts.Relevant (lift 1 b);mkArrow b Sorts.Relevant (lift 1 a);c|])) sign in - let name = - Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) - in - let ctx = Evd.univ_entry ~poly sigma in - let c = EConstr.to_constr sigma c in - let cb = Declare.(DefinitionEntry (definition_entry ~univs:ctx ~opaque:false c)) in - let c = Declare.declare_constant - ~local:Declare.ImportDefaultBehavior - ~name ~kind:Decls.(IsDefinition Definition) cb - in - let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in - (info,false,true,PathAny, IsGlobRef (GlobRef.ConstRef c)) - -let warn_deprecated_hint_constr = - CWarnings.create ~name:"deprecated-hint-constr" ~category:"deprecated" - (fun () -> - Pp.strbrk - "Declaring arbitrary terms as hints is deprecated; declare a global reference instead" - ) - -let interp_hints ~poly = - fun h -> - let env = Global.env () in - let sigma = Evd.from_env env in - let f poly c = - let evd,c = Constrintern.interp_open_constr env sigma c in - let env = Global.env () in - let sigma = Evd.from_env env in - let (c, diff) = prepare_hint true env sigma (evd,c) in - if poly then IsConstr (c, diff) - else - let () = Declare.declare_universe_context ~poly:false diff in - IsConstr (c, Univ.ContextSet.empty) - in - let fref r = - let gr = global_with_alias r in - Dumpglob.add_glob ?loc:r.CAst.loc gr; - gr in - let fr r = evaluable_of_global_reference env (fref r) in - let fi c = - match c with - | HintsReference c -> - let gr = global_with_alias c in - (PathHints [gr], poly, IsGlobRef gr) - | HintsConstr c -> - let () = warn_deprecated_hint_constr () in - (PathAny, poly, f poly c) - in - let fp = Constrintern.intern_constr_pattern env sigma in - let fres (info, b, r) = - let path, poly, gr = fi r in - let info = { info with hint_pattern = Option.map fp info.hint_pattern } in - (info, poly, b, path, gr) - in - let ft = function - | HintsVariables -> HintsVariables - | HintsConstants -> HintsConstants - | HintsReferences lhints -> HintsReferences (List.map fr lhints) - in - let fp = Constrintern.intern_constr_pattern (Global.env()) in - match h with - | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) - | HintsResolveIFF (l2r, lc, n) -> - HintsResolveEntry (List.map (project_hint ~poly n l2r) lc) - | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) - | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) - | HintsTransparency (t, b) -> HintsTransparencyEntry (ft t, b) - | HintsMode (r, l) -> HintsModeEntry (fref r, l) - | HintsConstructors lqid -> - let constr_hints_of_ind qid = - let ind = global_inductive_with_alias qid in - let mib,_ = Global.lookup_inductive ind in - Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" (string_of_qualid qid) "ind"; - List.init (nconstructors env ind) - (fun i -> let c = (ind,i+1) in - let gr = GlobRef.ConstructRef c in - empty_hint_info, - (Declareops.inductive_is_polymorphic mib), true, - PathHints [gr], IsGlobRef gr) - in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) - | HintsExtern (pri, patcom, tacexp) -> - let pat = Option.map (fp sigma) patcom in - let l = match pat with None -> [] | Some (l, _) -> l in - let ltacvars = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in - let env = Genintern.({ (empty_glob_sign env) with ltacvars }) in - let _, tacexp = Genintern.generic_intern env tacexp in - HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) - let add_hints ~locality dbnames h = let local, superglobal = match locality with | Goptions.OptDefault | Goptions.OptGlobal -> false, true @@ -1562,8 +1437,7 @@ let pr_hint_term env sigma cl = (* print all hints that apply to the concl of the current goal *) let pr_applicable_hint pf = let env = Global.env () in - let pts = Declare.Proof.get_proof pf in - let Proof.{goals;sigma} = Proof.data pts in + let Proof.{goals;sigma} = Proof.data pf in match goals with | [] -> CErrors.user_err Pp.(str "No focused goal.") | g::_ -> diff --git a/tactics/hints.mli b/tactics/hints.mli index eed0e37fac..f5fd3348e4 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -32,8 +32,6 @@ val empty_hint_info : 'a Typeclasses.hint_info_gen (** Pre-created hint databases *) -type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen - type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) @@ -78,10 +76,6 @@ type search_entry type hint_entry -type reference_or_constr = - | HintsReference of Libnames.qualid - | HintsConstr of Constrexpr.constr_expr - type hint_mode = | ModeInput (* No evars *) | ModeNoHeadEvar (* No evar at the head *) @@ -92,16 +86,6 @@ type 'a hints_transparency_target = | HintsConstants | HintsReferences of 'a list -type hints_expr = - | HintsResolve of (hint_info_expr * bool * reference_or_constr) list - | HintsResolveIFF of bool * Libnames.qualid list * int option - | HintsImmediate of reference_or_constr list - | HintsUnfold of Libnames.qualid list - | HintsTransparency of Libnames.qualid hints_transparency_target * bool - | HintsMode of Libnames.qualid * hint_mode list - | HintsConstructors of Libnames.qualid list - | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument - type 'a hints_path_gen = | PathAtom of 'a hints_path_atom_gen | PathStar of 'a hints_path_gen @@ -217,8 +201,6 @@ val current_db_names : unit -> String.Set.t val current_pure_db : unit -> hint_db list -val interp_hints : poly:bool -> hints_expr -> hints_entry - val add_hints : locality:Goptions.option_locality -> hint_db_name list -> hints_entry -> unit val prepare_hint : bool (* Check no remaining evars *) -> @@ -306,7 +288,7 @@ val wrap_hint_warning_fun : env -> evar_map -> (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t -val pr_applicable_hint : Declare.Proof.t -> Pp.t +val pr_applicable_hint : Proof.t -> Pp.t val pr_hint_ref : env -> evar_map -> GlobRef.t -> Pp.t val pr_hint_db_by_name : env -> evar_map -> hint_db_name -> Pp.t val pr_hint_db_env : env -> evar_map -> Hint_db.t -> Pp.t diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 8336fae02f..e422366ed6 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -86,15 +86,15 @@ let compute_name internal id = Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name else id +let declare_definition_scheme = ref (fun ~internal ~univs ~role ~name c -> + CErrors.anomaly (Pp.str "scheme declaration not registered")) + let define internal role id c poly univs = let id = compute_name internal id in let ctx = UState.minimize univs in let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in let univs = UState.univ_entry ~poly ctx in - let entry = Declare.pure_definition_entry ~univs c in - let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id entry in - let () = if internal then () else Declare.definition_message id in - kn, eff + !declare_definition_scheme ~internal ~univs ~role ~name:id c let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = let (c, ctx), eff = f mode ind in diff --git a/tactics/ind_tables.mli b/tactics/ind_tables.mli index dad2036c64..736de2af37 100644 --- a/tactics/ind_tables.mli +++ b/tactics/ind_tables.mli @@ -59,3 +59,11 @@ val check_scheme : 'a scheme_kind -> inductive -> bool val lookup_scheme : 'a scheme_kind -> inductive -> Constant.t val pr_scheme_kind : 'a scheme_kind -> Pp.t + +val declare_definition_scheme : + (internal : bool + -> univs:Entries.universes_entry + -> role:Evd.side_effect_role + -> name:Id.t + -> Constr.t + -> Constant.t * Evd.side_effects) ref diff --git a/tactics/tactics.mllib b/tactics/tactics.mllib index 537d111f23..36d61feed1 100644 --- a/tactics/tactics.mllib +++ b/tactics/tactics.mllib @@ -1,5 +1,4 @@ DeclareScheme -Declare Dnet Dn Btermdn @@ -18,7 +17,7 @@ Elim Equality Contradiction Inv -Leminv +DeclareUctx Hints Auto Eauto diff --git a/test-suite/bugs/closed/HoTT_coq_107.v b/test-suite/bugs/closed/HoTT_coq_107.v index fa4072a8f6..91f5c423a5 100644 --- a/test-suite/bugs/closed/HoTT_coq_107.v +++ b/test-suite/bugs/closed/HoTT_coq_107.v @@ -2,6 +2,7 @@ (* File reduced by coq-bug-finder from 4897 lines to 2605 lines, then from 2297 lines to 236 lines, then from 239 lines to 137 lines, then from 118 lines to 67 lines, then from 520 lines to 76 lines. *) (** Note: The bug here is the same as the #113, that is, HoTT_coq_113.v *) Require Import Coq.Init.Logic. +Require Import Coq.Init.Ltac. Global Set Universe Polymorphism. Global Set Asymmetric Patterns. Set Implicit Arguments. diff --git a/test-suite/bugs/closed/bug_3881.v b/test-suite/bugs/closed/bug_3881.v index d7e097e326..50e9de60e5 100644 --- a/test-suite/bugs/closed/bug_3881.v +++ b/test-suite/bugs/closed/bug_3881.v @@ -4,6 +4,7 @@ coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (90ed6636dea41486ddf2cc0daead83f9f0788163) *) Generalizable All Variables. Require Import Coq.Init.Notations. +Require Import Coq.Init.Ltac. Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Notation "A -> B" := (forall (_ : A), B) : type_scope. Axiom admit : forall {T}, T. diff --git a/test-suite/bugs/closed/bug_4527.v b/test-suite/bugs/closed/bug_4527.v index dfb07520f1..cf802eb89b 100644 --- a/test-suite/bugs/closed/bug_4527.v +++ b/test-suite/bugs/closed/bug_4527.v @@ -5,7 +5,7 @@ then from 269 lines to 255 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) -Declare ML Module "ltac_plugin". +Require Import Coq.Init.Ltac. Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/bug_4533.v b/test-suite/bugs/closed/bug_4533.v index d2f9fb9099..2d628f414d 100644 --- a/test-suite/bugs/closed/bug_4533.v +++ b/test-suite/bugs/closed/bug_4533.v @@ -5,7 +5,7 @@ then from 285 lines to 271 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) -Declare ML Module "ltac_plugin". +Require Import Coq.Init.Ltac. Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/bug_4544.v b/test-suite/bugs/closed/bug_4544.v index e9e9c552f6..213c91bfa0 100644 --- a/test-suite/bugs/closed/bug_4544.v +++ b/test-suite/bugs/closed/bug_4544.v @@ -2,7 +2,7 @@ (* File reduced by coq-bug-finder from original input, then from 2553 lines to 1932 lines, then from 1946 lines to 1932 lines, then from 2467 lines to 1002 lines, then from 1016 lines to 1002 lines *) (* coqc version 8.5 (January 2016) compiled on Jan 23 2016 16:15:22 with OCaml 4.01.0 coqtop version 8.5 (January 2016) *) -Declare ML Module "ltac_plugin". +Require Import Coq.Init.Ltac. Inductive False := . Axiom proof_admitted : False. Tactic Notation "admit" := case proof_admitted. diff --git a/test-suite/bugs/closed/bug_6661.v b/test-suite/bugs/closed/bug_6661.v index 28a9ffc7bd..0f4ae2b4c5 100644 --- a/test-suite/bugs/closed/bug_6661.v +++ b/test-suite/bugs/closed/bug_6661.v @@ -7,6 +7,7 @@ Require Export Coq.Init.Notations. +Require Export Coq.Init.Ltac. Notation "'∏' x .. y , P" := (forall x, .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity) : type_scope. Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..) diff --git a/theories/Init/Byte.v b/theories/Init/Byte.v index 33eabb20d9..7449b52d76 100644 --- a/theories/Init/Byte.v +++ b/theories/Init/Byte.v @@ -10,6 +10,7 @@ (** * Bytes *) +Require Import Coq.Init.Ltac. Require Import Coq.Init.Datatypes. Require Import Coq.Init.Logic. Require Import Coq.Init.Specif. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 50d4314a6b..0f2717beef 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -11,6 +11,7 @@ Set Implicit Arguments. Require Import Notations. +Require Import Ltac. Require Import Logic. (********************************************************************) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index ae48febc49..8f9f68a292 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -11,6 +11,7 @@ Set Implicit Arguments. Require Export Notations. +Require Import Ltac. Notation "A -> B" := (forall (_ : A), B) : type_scope. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index d07fe68715..3d9937ae89 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -13,6 +13,7 @@ Set Implicit Arguments. +Require Import Ltac. Require Import Datatypes. Require Export Logic. diff --git a/theories/Init/Ltac.v b/theories/Init/Ltac.v new file mode 100644 index 0000000000..ac5a69a38a --- /dev/null +++ b/theories/Init/Ltac.v @@ -0,0 +1,13 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +Declare ML Module "ltac_plugin". + +Export Set Default Proof Mode "Classic". diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v index a5e4178b93..da540cb099 100644 --- a/theories/Init/Notations.v +++ b/theories/Init/Notations.v @@ -129,9 +129,3 @@ Bind Scope type_scope with Sortclass. Open Scope core_scope. Open Scope function_scope. Open Scope type_scope. - -(** ML Tactic Notations *) - -Declare ML Module "ltac_plugin". - -Global Set Default Proof Mode "Classic". diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 394fa879c4..02903643d4 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -26,6 +26,7 @@ *) Require Import Notations. +Require Import Ltac. Require Import Datatypes. Require Import Logic. Require Coq.Init.Nat. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 71ba3e645d..6a81517d7e 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -18,10 +18,11 @@ Require Coq.Init.Decimal. Require Coq.Init.Nat. Require Export Peano. Require Export Coq.Init.Wf. +Require Export Coq.Init.Ltac. Require Export Coq.Init.Tactics. Require Export Coq.Init.Tauto. (* Some initially available plugins. See also: - - ltac_plugin (in Notations) + - ltac_plugin (in Ltac) - tauto_plugin (in Tauto). *) Declare ML Module "cc_plugin". diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 59ee252d35..4ff007570e 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -14,6 +14,7 @@ Set Implicit Arguments. Set Reversible Pattern Implicit. Require Import Notations. +Require Import Ltac. Require Import Datatypes. Require Import Logic. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index a4347bbe62..b13206db94 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -9,6 +9,7 @@ (************************************************************************) Require Import Notations. +Require Import Ltac. Require Import Logic. Require Import Specif. diff --git a/theories/Init/Tauto.v b/theories/Init/Tauto.v index 87b7a9a3be..2fc6f3cfa6 100644 --- a/theories/Init/Tauto.v +++ b/theories/Init/Tauto.v @@ -1,4 +1,17 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** * The tauto and intuition tactics *) + Require Import Notations. +Require Import Ltac. Require Import Datatypes. Require Import Logic. diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index 06afd9bac0..a305626eb3 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -16,6 +16,7 @@ Set Implicit Arguments. Require Import Notations. +Require Import Ltac. Require Import Logic. Require Import Datatypes. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index f050f11170..5d5f74db44 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -2559,6 +2559,33 @@ Section ReDun. * now apply incl_Add_inv with a l'. Qed. + Lemma NoDup_incl_NoDup (l l' : list A) : NoDup l -> + length l' <= length l -> incl l l' -> NoDup l'. + Proof. + revert l'; induction l; simpl; intros l' Hnd Hlen Hincl. + - now destruct l'; inversion Hlen. + - assert (In a l') as Ha by now apply Hincl; left. + apply in_split in Ha as [l1' [l2' ->]]. + inversion_clear Hnd as [|? ? Hnin Hnd']. + apply (NoDup_Add (Add_app a l1' l2')); split. + + apply IHl; auto. + * rewrite app_length. + rewrite app_length in Hlen; simpl in Hlen; rewrite Nat.add_succ_r in Hlen. + now apply Nat.succ_le_mono. + * apply incl_Add_inv with (u:= l1' ++ l2') in Hincl; auto. + apply Add_app. + + intros Hnin'. + assert (incl (a :: l) (l1' ++ l2')) as Hincl''. + { apply incl_tran with (l1' ++ a :: l2'); auto. + intros x Hin. + apply in_app_or in Hin as [Hin|[->|Hin]]; intuition. } + apply NoDup_incl_length in Hincl''; [ | now constructor ]. + apply (Nat.nle_succ_diag_l (length l1' + length l2')). + rewrite_all app_length. + simpl in Hlen; rewrite Nat.add_succ_r in Hlen. + now transitivity (S (length l)). + Qed. + End ReDun. (** NoDup and map *) diff --git a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v index 7e51b575ba..ce263e1d21 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v @@ -31,9 +31,9 @@ Local Open Scope CReal_scope. 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. +Lemma CauchyAbsStable : forall xn : positive -> Q, + QCauchySeq xn id + -> QCauchySeq (fun n => Qabs (xn n)) id. Proof. intros xn cau n p q H H0. specialize (cau n p q H H0). @@ -53,23 +53,22 @@ Definition CReal_abs (x : CReal) : CReal 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 + (proj1_sig x 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]. + setoid_replace ((-1 # n) + - xn n)%Q + with (- ((1 # n) + xn n))%Q in H. + destruct (Qarchimedean (2 / (-((1#n) + xn 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 _ _)). + specialize (cau n n (Pos.max k n) + (Pos.le_refl _) (Pos.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. + apply (Qmult_lt_l _ _ (-((1 # n) + xn n))) in kmaj. rewrite Qmult_div_r in kmaj. apply (Qmult_lt_r _ _ (1 # k)) in kmaj. rewrite <- Qmult_assoc in kmaj. @@ -77,13 +76,13 @@ Proof. 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)))). + apply (Qplus_lt_l _ _ ((1#n) + xn (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))))). + apply (Qle_lt_trans _ (Qabs (xn n - xn (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. + setoid_replace (- (xn n - xn (Pos.max k n)))%Q + with (xn (Pos.max k n) + -1 * xn 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. @@ -92,10 +91,10 @@ Proof. Qed. Lemma CReal_nonneg : forall (x : CReal) (n : positive), - 0 <= x -> (-1#n <= proj1_sig x (Pos.to_nat n))%Q. + 0 <= x -> (-1#n <= proj1_sig x n)%Q. Proof. intros. destruct x as [xn cau]; unfold proj1_sig. - destruct (Qlt_le_dec (xn (Pos.to_nat n)) (-1#n)). + destruct (Qlt_le_dec (xn n) (-1#n)). 2: exact q. exfalso. apply H. clear H. apply (CReal_neg_nth _ n). exact q. Qed. @@ -107,13 +106,13 @@ Proof. 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). + destruct (Qlt_le_dec (xn 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. + setoid_replace ((-2 # 2) * xn n)%Q with (- xn n)%Q. exact H. ring. - rewrite Qabs_pos. unfold Qminus. rewrite Qplus_opp_r. discriminate. exact q. Qed. @@ -121,7 +120,7 @@ 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 (Qle_not_lt _ _ (Qle_Qabs (xn n))). apply Qlt_minus_iff. apply (Qlt_trans _ (2#n)). reflexivity. exact nmaj. Qed. @@ -129,7 +128,7 @@ 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 (Qle_not_lt _ _ (Qabs_nonneg (xn n))). apply Qlt_minus_iff. apply (Qlt_trans _ (2#n)). reflexivity. exact nmaj. Qed. @@ -153,7 +152,7 @@ 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). + destruct (Qlt_le_dec (xn 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. @@ -189,7 +188,7 @@ 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). + destruct (Qlt_le_dec (an 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. @@ -250,14 +249,14 @@ 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. + assert (xn n < 0)%Q. + { destruct (Qlt_le_dec (xn 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 (Qplus_lt_l _ _ ((1#n) - xn n)). apply (Qmult_lt_l _ _ 2). reflexivity. ring_simplify. setoid_replace (2 * (1 # n))%Q with (2 # n)%Q. 2: reflexivity. rewrite <- Qplus_assoc. @@ -274,7 +273,7 @@ Proof. 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). + destruct (Qlt_le_dec (xn (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. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyReals.v b/theories/Reals/Cauchy/ConstructiveCauchyReals.v index 167f8d41c9..8ca65c30c8 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyReals.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyReals.v @@ -33,20 +33,26 @@ Require CMorphisms. The double quantification on p q is needed to avoid forall un, QSeqEquiv un (fun _ => un O) (fun q => O) which says nothing about the limit of un. + + We define sequences as positive -> Q instead of nat -> Q, + so that we can compute arguments like 2^n fast. + + WARNING: this module is not meant to be imported directly, + please import `Reals.Abstract.ConstructiveReals` instead. *) -Definition QSeqEquiv (un vn : nat -> Q) (cvmod : positive -> nat) +Definition QSeqEquiv (un vn : positive -> Q) (cvmod : positive -> positive) : Prop - := forall (k : positive) (p q : nat), - le (cvmod k) p - -> le (cvmod k) q + := forall (k : positive) (p q : positive), + Pos.le (cvmod k) p + -> Pos.le (cvmod k) q -> Qlt (Qabs (un p - vn q)) (1 # k). (* A Cauchy sequence is a sequence equivalent to itself. If sequences are equivalent, they are both Cauchy and have the same limit. *) -Definition QCauchySeq (un : nat -> Q) (cvmod : positive -> nat) : Prop +Definition QCauchySeq (un : positive -> Q) (cvmod : positive -> positive) : Prop := QSeqEquiv un un cvmod. -Lemma QSeqEquiv_sym : forall (un vn : nat -> Q) (cvmod : positive -> nat), +Lemma QSeqEquiv_sym : forall (un vn : positive -> Q) (cvmod : positive -> positive), QSeqEquiv un vn cvmod -> QSeqEquiv vn un cvmod. Proof. @@ -59,11 +65,12 @@ Proof. intros. unfold Qeq. simpl. destruct a; reflexivity. Qed. -Lemma QSeqEquiv_trans : forall (un vn wn : nat -> Q) - (cvmod cvmodw : positive -> nat), +Lemma QSeqEquiv_trans : forall (un vn wn : positive -> Q) + (cvmod cvmodw : positive -> positive), QSeqEquiv un vn cvmod -> QSeqEquiv vn wn cvmodw - -> QSeqEquiv un wn (fun q => max (cvmod (2 * q)%positive) (cvmodw (2 * q)%positive)). + -> QSeqEquiv un wn (fun q => Pos.max (cvmod (2 * q)%positive) + (cvmodw (2 * q)%positive)). Proof. intros. intros k p q H1 H2. setoid_replace (un p - wn q) with (un p - vn p + (vn p - wn q)). @@ -71,38 +78,42 @@ Proof. _ (Qabs (un p - vn p) + Qabs (vn p - wn q))). apply Qabs_triangle. apply (Qlt_le_trans _ ((1 # (2*k)) + (1 # (2*k)))). apply Qplus_lt_le_compat. - - assert ((cvmod (2 * k)%positive <= p)%nat). - { apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). - apply Nat.le_max_l. assumption. } + - assert ((cvmod (2 * k)%positive <= p)%positive). + { apply (Pos.le_trans _ (Pos.max (cvmod (2 * k)%positive) + (cvmodw (2 * k)%positive))). + apply Pos.le_max_l. assumption. } apply H. assumption. assumption. - apply Qle_lteq. left. apply H0. - apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). - apply Nat.le_max_r. assumption. - apply (le_trans _ (max (cvmod (2 * k)%positive) (cvmodw (2 * k)%positive))). - apply Nat.le_max_r. assumption. + apply (Pos.le_trans _ (Pos.max (cvmod (2 * k)%positive) + (cvmodw (2 * k)%positive))). + apply Pos.le_max_r. assumption. + apply (Pos.le_trans _ (Pos.max (cvmod (2 * k)%positive) + (cvmodw (2 * k)%positive))). + apply Pos.le_max_r. assumption. - rewrite (factorDenom _ _ 2). ring_simplify. apply Qle_refl. - ring. Qed. -Definition QSeqEquivEx (un vn : nat -> Q) : Prop - := exists (cvmod : positive -> nat), QSeqEquiv un vn cvmod. +Definition QSeqEquivEx (un vn : positive -> Q) : Prop + := exists (cvmod : positive -> positive), QSeqEquiv un vn cvmod. -Lemma QSeqEquivEx_sym : forall (un vn : nat -> Q), QSeqEquivEx un vn -> QSeqEquivEx vn un. +Lemma QSeqEquivEx_sym : forall (un vn : positive -> Q), + QSeqEquivEx un vn -> QSeqEquivEx vn un. Proof. intros. destruct H. exists x. apply QSeqEquiv_sym. apply H. Qed. -Lemma QSeqEquivEx_trans : forall un vn wn : nat -> Q, +Lemma QSeqEquivEx_trans : forall un vn wn : positive -> Q, QSeqEquivEx un vn -> QSeqEquivEx vn wn -> QSeqEquivEx un wn. Proof. intros. destruct H,H0. - exists (fun q => max (x (2 * q)%positive) (x0 (2 * q)%positive)). + exists (fun q => Pos.max (x (2 * q)%positive) (x0 (2 * q)%positive)). apply (QSeqEquiv_trans un vn wn); assumption. Qed. -Lemma QSeqEquiv_cau_r : forall (un vn : nat -> Q) (cvmod : positive -> nat), +Lemma QSeqEquiv_cau_r : forall (un vn : positive -> Q) (cvmod : positive -> positive), QSeqEquiv un vn cvmod -> QCauchySeq vn (fun k => cvmod (2 * k)%positive). Proof. @@ -118,82 +129,15 @@ Proof. apply Qabs_triangle. apply (Qlt_le_trans _ ((1 # (2 * k)) + (1 # (2 * k)))). apply Qplus_lt_le_compat. - + rewrite Qabs_Qminus. apply H. apply le_refl. assumption. - + apply Qle_lteq. left. apply H. apply le_refl. assumption. + + rewrite Qabs_Qminus. apply H. apply Pos.le_refl. assumption. + + apply Qle_lteq. left. apply H. apply Pos.le_refl. assumption. + rewrite (factorDenom _ _ 2). ring_simplify. apply Qle_refl. - ring. Qed. -Fixpoint increasing_modulus (modulus : positive -> nat) (n : nat) - := match n with - | O => modulus xH - | S p => max (modulus (Pos.of_nat n)) (increasing_modulus modulus p) - end. - -Lemma increasing_modulus_inc : forall (modulus : positive -> nat) (n p : nat), - le (increasing_modulus modulus n) - (increasing_modulus modulus (p + n)). -Proof. - induction p. - - apply le_refl. - - apply (le_trans _ (increasing_modulus modulus (p + n))). - apply IHp. simpl. destruct (plus p n). apply Nat.le_max_r. apply Nat.le_max_r. -Qed. - -Lemma increasing_modulus_max : forall (modulus : positive -> nat) (p n : nat), - le n p -> le (modulus (Pos.of_nat n)) - (increasing_modulus modulus p). -Proof. - induction p. - - intros. inversion H. subst n. apply le_refl. - - intros. simpl. destruct p. simpl. - + destruct n. apply Nat.le_max_l. apply le_S_n in H. - inversion H. apply Nat.le_max_l. - + apply Nat.le_succ_r in H. destruct H. - apply (le_trans _ (increasing_modulus modulus (S p))). - 2: apply Nat.le_max_r. apply IHp. apply H. - subst n. apply (le_trans _ (modulus (Pos.succ (Pos.of_nat (S p))))). - apply le_refl. apply Nat.le_max_l. -Qed. - -(* Choice of a standard element in each QSeqEquiv class. *) -Lemma standard_modulus : forall (un : nat -> Q) (cvmod : positive -> nat), - QCauchySeq un cvmod - -> (QCauchySeq (fun n => un (increasing_modulus cvmod n)) Pos.to_nat - /\ QSeqEquiv un (fun n => un (increasing_modulus cvmod n)) - (fun p => max (cvmod p) (Pos.to_nat p))). -Proof. - intros. split. - - intros k p q H0 H1. apply H. - + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). - apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). - rewrite Pos2Nat.id. apply le_refl. - destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. - destruct (Nat.le_exists_sub (Pos.to_nat k) p H0) as [i [H2 H3]]. subst p. - apply increasing_modulus_inc. - + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). - apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). - rewrite Pos2Nat.id. apply le_refl. - destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. - destruct (Nat.le_exists_sub (Pos.to_nat k) q H1) as [i [H2 H3]]. subst q. - apply increasing_modulus_inc. - - intros k p q H0 H1. apply H. - + apply (le_trans _ (Init.Nat.max (cvmod k) (Pos.to_nat k))). - apply Nat.le_max_l. assumption. - + apply (le_trans _ (increasing_modulus cvmod (Pos.to_nat k))). - apply (le_trans _ (cvmod (Pos.of_nat (Pos.to_nat k)))). - rewrite Pos2Nat.id. apply le_refl. - destruct (Pos.to_nat k). apply le_refl. apply Nat.le_max_l. - assert (le (Pos.to_nat k) q). - { apply (le_trans _ (Init.Nat.max (cvmod k) (Pos.to_nat k))). - apply Nat.le_max_r. assumption. } - destruct (Nat.le_exists_sub (Pos.to_nat k) q H2) as [i [H3 H4]]. subst q. - apply increasing_modulus_inc. -Qed. - (* A Cauchy real is a Cauchy sequence with the standard modulus *) Definition CReal : Set - := { x : (nat -> Q) | QCauchySeq x Pos.to_nat }. + := { x : (positive -> Q) | QCauchySeq x id }. Declare Scope CReal_scope. @@ -208,12 +152,10 @@ Local Open Scope CReal_scope. (* So QSeqEquiv is the equivalence relation of this constructive pre-order *) Definition CRealLt (x y : CReal) : Set - := { n : positive | Qlt (2 # n) - (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)) }. + := { n : positive | Qlt (2 # n) (proj1_sig y n - proj1_sig x n) }. Definition CRealLtProp (x y : CReal) : Prop - := exists n : positive, Qlt (2 # n) - (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)). + := exists n : positive, Qlt (2 # n) (proj1_sig y n - proj1_sig x n). Definition CRealGt (x y : CReal) := CRealLt y x. Definition CReal_appart (x y : CReal) := sum (CRealLt x y) (CRealLt y x). @@ -226,23 +168,23 @@ Infix "#" := CReal_appart : CReal_scope. Lemma CRealLtEpsilon : forall x y : CReal, CRealLtProp x y -> x < y. Proof. - intros. - assert (exists n : nat, n <> O - /\ Qlt (2 # Pos.of_nat n) (proj1_sig y n - proj1_sig x n)). - { destruct H as [n maj]. exists (Pos.to_nat n). split. - intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. - inversion abs. rewrite Pos2Nat.id. apply maj. } + intros. unfold CRealLtProp in H. + (* Convert to nat to use indefinite description. *) + assert (exists n : nat, lt O n /\ Qlt (2 # Pos.of_nat n) + (proj1_sig y (Pos.of_nat n) - proj1_sig x (Pos.of_nat n))). + { destruct H as [n maj]. exists (Pos.to_nat n). split. apply Pos2Nat.is_pos. + rewrite Pos2Nat.id. exact maj. } + clear H. apply constructive_indefinite_ground_description_nat in H0. - destruct H0 as [n maj]. exists (Pos.of_nat n). - rewrite Nat2Pos.id. apply maj. apply maj. + destruct H0 as [n maj]. exists (Pos.of_nat n). exact (proj2 maj). intro n. destruct n. right. - intros [abs _]. exact (abs (eq_refl O)). + intros [abs _]. inversion abs. destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) - (proj1_sig y (S n) - proj1_sig x (S n))). - left. split. discriminate. apply q. + (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n)))). + left. split. apply le_n_S, le_0_n. apply q. right. intros [_ abs]. apply (Qlt_not_le (2 # Pos.of_nat (S n)) - (proj1_sig y (S n) - proj1_sig x (S n))); assumption. + (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n)))); assumption. Qed. Lemma CRealLtForget : forall x y : CReal, @@ -254,18 +196,18 @@ Qed. (* CRealLt is decided by the LPO in Type, which is a non-constructive oracle. *) Lemma CRealLt_lpo_dec : forall x y : CReal, - (forall (P : nat -> Prop), (forall n, {P n} + {~P n}) + (forall (P : nat -> Prop), (forall n:nat, {P n} + {~P n}) -> {n | ~P n} + {forall n, P n}) -> CRealLt x y + (CRealLt x y -> False). Proof. intros x y lpo. - destruct (lpo (fun n:nat => Qle (proj1_sig y (S n) - proj1_sig x (S n)) + destruct (lpo (fun n:nat => Qle (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n))) (2 # Pos.of_nat (S n)))). - intro n. destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) - (proj1_sig y (S n) - proj1_sig x (S n))). + (proj1_sig y (Pos.of_nat (S n)) - proj1_sig x (Pos.of_nat (S n)))). right. apply Qlt_not_le. exact q. left. exact q. - left. destruct s as [n nmaj]. exists (Pos.of_nat (S n)). - rewrite Nat2Pos.id. apply Qnot_le_lt. exact nmaj. discriminate. + apply Qnot_le_lt. exact nmaj. - right. intro abs. destruct abs as [n majn]. specialize (q (pred (Pos.to_nat n))). replace (S (pred (Pos.to_nat n))) with (Pos.to_nat n) in q. @@ -296,41 +238,37 @@ Definition CRealEq (x y : CReal) : Prop 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)) + (forall n:positive, Qle (proj1_sig x n - proj1_sig y n) (2 # n)) <-> x <= y. Proof. intros. split. - intros. intro H0. destruct H0 as [n H0]. specialize (H n). apply (Qle_not_lt (2 # n) (2 # n)). apply Qle_refl. - apply (Qlt_le_trans _ (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))). + apply (Qlt_le_trans _ (proj1_sig x n - proj1_sig y n)). assumption. assumption. - intros. - destruct (Qlt_le_dec (2 # n) (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))). + destruct (Qlt_le_dec (2 # n) (proj1_sig x n - proj1_sig y n)). exfalso. apply H. exists n. assumption. assumption. Qed. Lemma CRealEq_diff : forall (x y : CReal), CRealEq x y - <-> forall n:positive, Qle (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) - (2 # n). + <-> forall n:positive, Qle (Qabs (proj1_sig x n - proj1_sig y n)) (2 # n). Proof. intros. split. - intros. destruct H. apply Qabs_case. intro. pose proof (CRealLe_not_lt x y) as [_ H2]. apply H2. assumption. intro. pose proof (CRealLe_not_lt y x) as [_ H2]. - setoid_replace (- (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) - with (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)). + setoid_replace (- (proj1_sig x n - proj1_sig y n)) + with (proj1_sig y n - proj1_sig x 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_trans _ (Qabs (proj1_sig y n - proj1_sig x 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_trans _ (Qabs (proj1_sig x n - proj1_sig y n))). apply Qle_Qabs. apply H. Qed. @@ -339,111 +277,106 @@ Qed. Lemma CRealEq_modindep : forall (x y : CReal), QSeqEquivEx (proj1_sig x) (proj1_sig y) <-> forall n:positive, - Qle (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) (2 # n). + Qle (Qabs (proj1_sig x n - proj1_sig y n)) (2 # n). Proof. assert (forall x y: CReal, QSeqEquivEx (proj1_sig x) (proj1_sig y) -> x <= y ). { intros [xn limx] [yn limy] [cvmod H] [n abs]. simpl in abs, H. - pose (xn (Pos.to_nat n) - yn (Pos.to_nat n) - (2#n)) as eps. + pose (xn n - yn n - (2#n)) as eps. destruct (Qarchimedean (/eps)) as [k maj]. - remember (max (cvmod k) (Pos.to_nat n)) as p. - assert (le (cvmod k) p). - { rewrite Heqp. apply Nat.le_max_l. } - assert (Pos.to_nat n <= p)%nat. - { rewrite Heqp. apply Nat.le_max_r. } + remember (Pos.max (cvmod k) n) as p. + assert (Pos.le (cvmod k) p). + { rewrite Heqp. apply Pos.le_max_l. } + assert (n <= p)%positive. + { rewrite Heqp. apply Pos.le_max_r. } specialize (H k p p H0 H0). setoid_replace (Z.pos k #1)%Q with (/ (1#k)) in maj. 2: reflexivity. apply Qinv_lt_contravar in maj. 2: reflexivity. unfold eps in maj. clear abs. (* less precise majoration *) apply (Qplus_lt_r _ _ (2#n)) in maj. ring_simplify in maj. apply (Qlt_not_le _ _ maj). clear maj. - setoid_replace (xn (Pos.to_nat n) + -1 * yn (Pos.to_nat n)) - with (xn (Pos.to_nat n) - xn p + (xn p - yn p + (yn p - yn (Pos.to_nat n)))). + setoid_replace (xn n + -1 * yn n) + with (xn n - xn p + (xn p - yn p + (yn p - yn n))). 2: ring. setoid_replace (2 # n)%Q with ((1 # n) + (1#n)). rewrite <- Qplus_assoc. apply Qplus_le_compat. apply (Qle_trans _ _ _ (Qle_Qabs _)). - apply Qlt_le_weak. apply limx. apply le_refl. assumption. + apply Qlt_le_weak. apply limx. apply Pos.le_refl. assumption. rewrite (Qplus_comm (1#n)). apply Qplus_le_compat. apply (Qle_trans _ _ _ (Qle_Qabs _)). apply Qlt_le_weak. exact H. apply (Qle_trans _ _ _ (Qle_Qabs _)). apply Qlt_le_weak. apply limy. - assumption. apply le_refl. ring_simplify. reflexivity. + assumption. apply Pos.le_refl. ring_simplify. reflexivity. unfold eps. unfold Qminus. rewrite <- Qlt_minus_iff. exact abs. } split. - rewrite <- CRealEq_diff. intros. split. apply H, QSeqEquivEx_sym. exact H0. apply H. exact H0. - clear H. intros. destruct x as [xn limx], y as [yn limy]. - exists (fun q => Pos.to_nat (2 * (3 * q))). intros k p q H0 H1. + exists (fun q:positive => 2 * (3 * q))%positive. intros k p q H0 H1. unfold proj1_sig. specialize (H (2 * (3 * k))%positive). - assert ((Pos.to_nat (3 * k) <= Pos.to_nat (2 * (3 * k)))%nat). - { generalize (3 * k)%positive. intros. rewrite Pos2Nat.inj_mul. - rewrite <- (mult_1_l (Pos.to_nat p0)). apply Nat.mul_le_mono_nonneg. - auto. unfold Pos.to_nat. simpl. auto. - apply (le_trans 0 1). auto. apply Pos2Nat.is_pos. rewrite mult_1_l. - apply le_refl. } + assert (3 * k <= 2 * (3 * k))%positive. + { generalize (3 * k)%positive. intros. apply (Pos.le_trans _ (1 * p0)). + apply Pos.le_refl. rewrite <- Pos.mul_le_mono_r. discriminate. } setoid_replace (xn p - yn q) - with (xn p - xn (Pos.to_nat (2 * (3 * k))) - + (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k))) - + (yn (Pos.to_nat (2 * (3 * k))) - yn q))). + with (xn p - xn (2 * (3 * k))%positive + + (xn (2 * (3 * k))%positive - yn (2 * (3 * k))%positive + + (yn (2 * (3 * k))%positive - yn q))). + 2: ring. setoid_replace (1 # k)%Q with ((1 # 3 * k) + ((1 # 3 * k) + (1 # 3 * k))). apply (Qle_lt_trans - _ (Qabs (xn p - xn (Pos.to_nat (2 * (3 * k)))) - + (Qabs (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k))) - + (yn (Pos.to_nat (2 * (3 * k))) - yn q))))). + _ (Qabs (xn p - xn (2 * (3 * k))%positive) + + (Qabs (xn (2 * (3 * k))%positive - yn (2 * (3 * k))%positive + + (yn (2 * (3 * k))%positive - yn q))))). apply Qabs_triangle. apply Qplus_lt_le_compat. - apply limx. apply (le_trans _ (Pos.to_nat (2 * (3 * k)))). assumption. assumption. + apply limx. apply (Pos.le_trans _ (2 * (3 * k))). assumption. assumption. assumption. apply (Qle_trans - _ (Qabs (xn (Pos.to_nat (2 * (3 * k))) - yn (Pos.to_nat (2 * (3 * k)))) - + Qabs (yn (Pos.to_nat (2 * (3 * k))) - yn q))). + _ (Qabs (xn (2 * (3 * k))%positive - yn (2 * (3 * k))%positive) + + Qabs (yn (2 * (3 * k))%positive - yn q))). apply Qabs_triangle. apply Qplus_le_compat. setoid_replace (1 # 3 * k)%Q with (2 # 2 * (3 * k))%Q. apply H. - rewrite (factorDenom _ _ 3). rewrite (factorDenom _ _ 2). rewrite (factorDenom _ _ 3). + rewrite (factorDenom _ _ 3). + rewrite (factorDenom _ _ 2). rewrite (factorDenom _ _ 3). rewrite Qmult_assoc. rewrite (Qmult_comm (1#2)). rewrite <- Qmult_assoc. apply Qmult_comp. reflexivity. unfold Qeq. reflexivity. apply Qle_lteq. left. apply limy. assumption. - apply (le_trans _ (Pos.to_nat (2 * (3 * k)))). assumption. assumption. - rewrite (factorDenom _ _ 3). ring_simplify. reflexivity. field. + apply (Pos.le_trans _ (2 * (3 * k))). assumption. assumption. + rewrite (factorDenom _ _ 3). ring_simplify. reflexivity. Qed. (* Extend separation to all indices above *) Lemma CRealLt_aboveSig : forall (x y : CReal) (n : positive), (Qlt (2 # n) - (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n))) - -> let (k, _) := Qarchimedean (/(proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n) - (2#n))) + (proj1_sig y n - proj1_sig x n)) + -> let (k, _) := Qarchimedean (/(proj1_sig y n - proj1_sig x n - (2#n))) in forall p:positive, Pos.le (Pos.max n (2*k)) p -> Qlt (2 # (Pos.max n (2*k))) - (proj1_sig y (Pos.to_nat p) - proj1_sig x (Pos.to_nat p)). + (proj1_sig y p - proj1_sig x p). Proof. intros [xn limx] [yn limy] n maj. unfold proj1_sig; unfold proj1_sig in maj. - pose (yn (Pos.to_nat n) - xn (Pos.to_nat n)) as dn. - destruct (Qarchimedean (/(yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2#n)))) as [k kmaj]. - assert (0 < yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2 # n))%Q as H0. + pose (yn n - xn n) as dn. + destruct (Qarchimedean (/(yn n - xn n - (2#n)))) as [k kmaj]. + assert (0 < yn n - xn n - (2 # n))%Q as H0. { rewrite <- (Qplus_opp_r (2#n)). apply Qplus_lt_l. assumption. } - intros. - remember (yn (Pos.to_nat p) - xn (Pos.to_nat p)) as dp. - + intros. remember (yn p - xn p) as dp. rewrite <- (Qplus_0_r dp). rewrite <- (Qplus_opp_r dn). rewrite (Qplus_comm dn). rewrite Qplus_assoc. assert (Qlt (Qabs (dp - dn)) (2#n)). { rewrite Heqdp. unfold dn. - setoid_replace (yn (Pos.to_nat p) - xn (Pos.to_nat p) - (yn (Pos.to_nat n) - xn (Pos.to_nat n))) - with (yn (Pos.to_nat p) - yn (Pos.to_nat n) - + (xn (Pos.to_nat n) - xn (Pos.to_nat p))). - apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat p) - yn (Pos.to_nat n)) - + Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat p)))). + setoid_replace (yn p - xn p - (yn n - xn n)) + with (yn p - yn n + (xn n - xn p)). + apply (Qle_lt_trans _ (Qabs (yn p - yn n) + Qabs (xn n - xn p))). apply Qabs_triangle. setoid_replace (2#n)%Q with ((1#n) + (1#n))%Q. apply Qplus_lt_le_compat. apply limy. - apply Pos2Nat.inj_le. apply (Pos.le_trans _ (Pos.max n (2 * k))). + apply (Pos.le_trans _ (Pos.max n (2 * k))). apply Pos.le_max_l. assumption. - apply le_refl. apply Qlt_le_weak. apply limx. apply le_refl. - apply Pos2Nat.inj_le. apply (Pos.le_trans _ (Pos.max n (2 * k))). + apply Pos.le_refl. apply Qlt_le_weak. apply limx. apply Pos.le_refl. + apply (Pos.le_trans _ (Pos.max n (2 * k))). apply Pos.le_max_l. assumption. - rewrite Qinv_plus_distr. reflexivity. field. } + rewrite Qinv_plus_distr. reflexivity. ring. } apply (Qle_lt_trans _ (-(2#n) + dn)). rewrite Qplus_comm. unfold dn. apply Qlt_le_weak. apply (Qle_lt_trans _ (2 # (2 * k))). apply Pos.le_max_r. @@ -463,12 +396,11 @@ Qed. Lemma CRealLt_above : forall (x y : CReal), CRealLt x y -> { k : positive | forall p:positive, - Pos.le k p -> Qlt (2 # k) (proj1_sig y (Pos.to_nat p) - - proj1_sig x (Pos.to_nat p)) }. + Pos.le k p -> Qlt (2 # k) (proj1_sig y p - proj1_sig x p) }. Proof. intros x y [n maj]. pose proof (CRealLt_aboveSig x y n maj). - destruct (Qarchimedean (/ (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n) - (2 # n)))) + destruct (Qarchimedean (/ (proj1_sig y n - proj1_sig x n - (2 # n)))) as [k kmaj]. exists (Pos.max n (2*k)). apply H. Qed. @@ -476,28 +408,26 @@ Qed. (* The CRealLt index separates the Cauchy sequences *) Lemma CRealLt_above_same : forall (x y : CReal) (n : positive), Qlt (2 # n) - (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)) - -> forall p:positive, Pos.le n p - -> Qlt (proj1_sig x (Pos.to_nat p)) (proj1_sig y (Pos.to_nat p)). + (proj1_sig y n - proj1_sig x n) + -> forall p:positive, Pos.le n p -> Qlt (proj1_sig x p) (proj1_sig y p). Proof. intros [xn limx] [yn limy] n inf p H. simpl. simpl in inf. - apply (Qplus_lt_l _ _ (- xn (Pos.to_nat n))). - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat p) + - xn (Pos.to_nat n)))). + apply (Qplus_lt_l _ _ (- xn n)). + apply (Qle_lt_trans _ (Qabs (xn p + - xn n))). apply Qle_Qabs. apply (Qlt_trans _ (1#n)). - apply limx. apply Pos2Nat.inj_le. assumption. apply le_refl. - rewrite <- (Qplus_0_r (yn (Pos.to_nat p))). - rewrite <- (Qplus_opp_r (yn (Pos.to_nat n))). - rewrite (Qplus_comm (yn (Pos.to_nat n))). rewrite Qplus_assoc. + apply limx. exact H. apply Pos.le_refl. + rewrite <- (Qplus_0_r (yn p)). + rewrite <- (Qplus_opp_r (yn n)). + rewrite (Qplus_comm (yn n)). rewrite Qplus_assoc. rewrite <- Qplus_assoc. setoid_replace (1#n)%Q with (-(1#n) + (2#n))%Q. apply Qplus_lt_le_compat. apply (Qplus_lt_l _ _ (1#n)). rewrite Qplus_opp_r. - apply (Qplus_lt_r _ _ (yn (Pos.to_nat n) + - yn (Pos.to_nat p))). + apply (Qplus_lt_r _ _ (yn n + - yn p)). ring_simplify. - setoid_replace (yn (Pos.to_nat n) + (-1 # 1) * yn (Pos.to_nat p)) - with (yn (Pos.to_nat n) - yn (Pos.to_nat p)). - apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat n) - yn (Pos.to_nat p)))). - apply Qle_Qabs. apply limy. apply le_refl. apply Pos2Nat.inj_le. assumption. + setoid_replace (yn n + (-1 # 1) * yn p) with (yn n - yn p). + apply (Qle_lt_trans _ (Qabs (yn n - yn p))). + apply Qle_Qabs. apply limy. apply Pos.le_refl. assumption. field. apply Qle_lteq. left. assumption. rewrite Qplus_comm. rewrite Qinv_minus_distr. reflexivity. @@ -508,10 +438,10 @@ Proof. intros x y H [n q]. apply CRealLt_above in H. destruct H as [p H]. pose proof (CRealLt_above_same y x n q). - apply (Qlt_not_le (proj1_sig y (Pos.to_nat (Pos.max n p))) - (proj1_sig x (Pos.to_nat (Pos.max n p)))). + apply (Qlt_not_le (proj1_sig y (Pos.max n p)) + (proj1_sig x (Pos.max n p))). apply H0. apply Pos.le_max_l. - apply Qlt_le_weak. apply (Qplus_lt_l _ _ (-proj1_sig x (Pos.to_nat (Pos.max n p)))). + apply Qlt_le_weak. apply (Qplus_lt_l _ _ (-proj1_sig x (Pos.max n p))). rewrite Qplus_opp_r. apply (Qlt_trans _ (2#p)). unfold Qlt. simpl. unfold Z.lt. auto. apply H. apply Pos.le_max_r. Qed. @@ -542,31 +472,24 @@ Lemma CRealLt_dec : forall x y z : CReal, Proof. intros [xn limx] [yn limy] [zn limz] [n inf]. unfold proj1_sig in inf. - remember (yn (Pos.to_nat n) - xn (Pos.to_nat n) - (2 # n)) as eps. + remember (yn n - xn n - (2 # n)) as eps. assert (Qlt 0 eps) as epsPos. { subst eps. unfold Qminus. apply (Qlt_minus_iff (2#n)). assumption. } - assert (forall n p, Pos.to_nat n <= Pos.to_nat (Pos.max n p))%nat. - { intros. apply Pos2Nat.inj_le. unfold Pos.max. unfold Pos.le. - destruct (n0 ?= p)%positive eqn:des. - rewrite des. discriminate. rewrite des. discriminate. - unfold Pos.compare. rewrite Pos.compare_cont_refl. discriminate. } destruct (Qarchimedean (/eps)) as [k kmaj]. - destruct (Qlt_le_dec ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2#1)) - (zn (Pos.to_nat (Pos.max n (4 * k))))) + destruct (Qlt_le_dec ((yn n + xn n) / (2#1)) + (zn (Pos.max n (4 * k)))) as [decMiddle|decMiddle]. - left. exists (Pos.max n (4 * k)). unfold proj1_sig. unfold Qminus. - rewrite <- (Qplus_0_r (zn (Pos.to_nat (Pos.max n (4 * k))))). - rewrite <- (Qplus_opp_r (xn (Pos.to_nat n))). - rewrite (Qplus_comm (xn (Pos.to_nat n))). rewrite Qplus_assoc. + rewrite <- (Qplus_0_r (zn (Pos.max n (4 * k)))). + rewrite <- (Qplus_opp_r (xn n)). + rewrite (Qplus_comm (xn n)). rewrite Qplus_assoc. rewrite <- Qplus_assoc. rewrite <- Qplus_0_r. rewrite <- (Qplus_opp_r (1#n)). rewrite Qplus_assoc. apply Qplus_lt_le_compat. - + apply (Qplus_lt_l _ _ (- xn (Pos.to_nat n))) in decMiddle. - apply (Qlt_trans _ ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1) - + - xn (Pos.to_nat n))). - setoid_replace ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1) - - xn (Pos.to_nat n)) - with ((yn (Pos.to_nat n) - xn (Pos.to_nat n)) / (2 # 1)). + + apply (Qplus_lt_l _ _ (- xn n)) in decMiddle. + apply (Qlt_trans _ ((yn n + xn n) / (2 # 1) + - xn n)). + setoid_replace ((yn n + xn n) / (2 # 1) - xn n) + with ((yn n - xn n) / (2 # 1)). apply Qlt_shift_div_l. unfold Qlt. simpl. unfold Z.lt. auto. rewrite Qmult_plus_distr_l. setoid_replace ((1 # n) * (2 # 1))%Q with (2#n)%Q. @@ -580,31 +503,30 @@ Proof. apply Qinv_lt_contravar. reflexivity. apply epsPos. apply kmaj. unfold Qeq. simpl. rewrite Pos.mul_1_r. reflexivity. field. assumption. - + setoid_replace (xn (Pos.to_nat n) + - xn (Pos.to_nat (Pos.max n (4 * k)))) - with (-(xn (Pos.to_nat (Pos.max n (4 * k))) - xn (Pos.to_nat n))). + + setoid_replace (xn n + - xn (Pos.max n (4 * k))) + with (-(xn (Pos.max n (4 * k)) - xn n)). apply Qopp_le_compat. - apply (Qle_trans _ (Qabs (xn (Pos.to_nat (Pos.max n (4 * k))) - xn (Pos.to_nat n)))). - apply Qle_Qabs. apply Qle_lteq. left. apply limx. apply H. - apply le_refl. field. + apply (Qle_trans _ (Qabs (xn (Pos.max n (4 * k)) - xn n))). + apply Qle_Qabs. apply Qle_lteq. left. apply limx. apply Pos.le_max_l. + apply Pos.le_refl. ring. - right. exists (Pos.max n (4 * k)). unfold proj1_sig. unfold Qminus. - rewrite <- (Qplus_0_r (yn (Pos.to_nat (Pos.max n (4 * k))))). - rewrite <- (Qplus_opp_r (yn (Pos.to_nat n))). - rewrite (Qplus_comm (yn (Pos.to_nat n))). rewrite Qplus_assoc. + rewrite <- (Qplus_0_r (yn (Pos.max n (4 * k)))). + rewrite <- (Qplus_opp_r (yn n)). + rewrite (Qplus_comm (yn n)). rewrite Qplus_assoc. rewrite <- Qplus_assoc. rewrite <- Qplus_0_l. rewrite <- (Qplus_opp_r (1#n)). rewrite (Qplus_comm (1#n)). rewrite <- Qplus_assoc. apply Qplus_lt_le_compat. - + apply (Qplus_lt_r _ _ (yn (Pos.to_nat n) - yn (Pos.to_nat (Pos.max n (4 * k))) + (1#n))) + + apply (Qplus_lt_r _ _ (yn n - yn (Pos.max n (4 * k)) + (1#n))) ; ring_simplify. - setoid_replace (-1 * yn (Pos.to_nat (Pos.max n (4 * k)))) - with (- yn (Pos.to_nat (Pos.max n (4 * k)))). 2: ring. - apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat n) - - yn (Pos.to_nat (Pos.max n (4 * k)))))). - apply Qle_Qabs. apply limy. apply le_refl. apply H. + setoid_replace (-1 * yn (Pos.max n (4 * k))) + with (- yn (Pos.max n (4 * k))). 2: ring. + apply (Qle_lt_trans _ (Qabs (yn n - yn (Pos.max n (4 * k))))). + apply Qle_Qabs. apply limy. apply Pos.le_refl. apply Pos.le_max_l. + apply Qopp_le_compat in decMiddle. - apply (Qplus_le_r _ _ (yn (Pos.to_nat n))) in decMiddle. - apply (Qle_trans _ (yn (Pos.to_nat n) + - ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1)))). - setoid_replace (yn (Pos.to_nat n) + - ((yn (Pos.to_nat n) + xn (Pos.to_nat n)) / (2 # 1))) - with ((yn (Pos.to_nat n) - xn (Pos.to_nat n)) / (2 # 1)). + apply (Qplus_le_r _ _ (yn n)) in decMiddle. + apply (Qle_trans _ (yn n + - ((yn n + xn n) / (2 # 1)))). + setoid_replace (yn n + - ((yn n + xn n) / (2 # 1))) + with ((yn n - xn n) / (2 # 1)). apply Qle_shift_div_l. unfold Qlt. simpl. unfold Z.lt. auto. rewrite Qmult_plus_distr_l. setoid_replace ((1 # n) * (2 # 1))%Q with (2#n)%Q. @@ -766,7 +688,7 @@ Qed. (* Injection of Q into CReal *) Lemma ConstCauchy : forall q : Q, - QCauchySeq (fun _ => q) Pos.to_nat. + QCauchySeq (fun _ => q) id. Proof. intros. intros k p r H H0. unfold Qminus. rewrite Qplus_opp_r. unfold Qlt. simpl. @@ -811,64 +733,64 @@ Qed. by a factor 2. *) Lemma CRealLtQ : forall (x : CReal) (q : Q), CRealLt x (inject_Q q) - -> forall p:positive, Qlt (proj1_sig x (Pos.to_nat p)) (q + (1#p)). + -> forall p:positive, Qlt (proj1_sig x p) (q + (1#p)). Proof. intros [xn cau] q maj p. simpl. - destruct (Qlt_le_dec (xn (Pos.to_nat p)) (q + (1 # p))). assumption. + destruct (Qlt_le_dec (xn p) (q + (1 # p))). assumption. exfalso. apply CRealLt_above in maj. destruct maj as [k maj]; simpl in maj. specialize (maj (Pos.max k p) (Pos.le_max_l _ _)). - specialize (cau p (Pos.to_nat p) (Pos.to_nat (Pos.max k p)) (le_refl _)). - pose proof (Qplus_lt_le_compat (2#k) (q - xn (Pos.to_nat (Pos.max k p))) - (q + (1 # p)) (xn (Pos.to_nat p)) maj q0). + specialize (cau p p (Pos.max k p) (Pos.le_refl _)). + pose proof (Qplus_lt_le_compat (2#k) (q - xn (Pos.max k p)) + (q + (1 # p)) (xn p) maj q0). rewrite Qplus_comm in H. unfold Qminus in H. rewrite <- Qplus_assoc in H. rewrite <- Qplus_assoc in H. apply Qplus_lt_r in H. - rewrite <- (Qplus_lt_r _ _ (xn (Pos.to_nat p))) in maj. + rewrite <- (Qplus_lt_r _ _ (xn p)) in maj. apply (Qlt_not_le (1#p) ((1 # p) + (2 # k))). rewrite <- (Qplus_0_r (1#p)). rewrite <- Qplus_assoc. apply Qplus_lt_r. reflexivity. apply Qlt_le_weak. - apply (Qlt_trans _ (- xn (Pos.to_nat (Pos.max k p)) + xn (Pos.to_nat p)) _ H). + apply (Qlt_trans _ (- xn (Pos.max k p) + xn p) _ H). rewrite Qplus_comm. - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat p) - xn (Pos.to_nat (Pos.max k p))))). - apply Qle_Qabs. apply cau. apply Pos2Nat.inj_le. apply Pos.le_max_r. + apply (Qle_lt_trans _ (Qabs (xn p - xn (Pos.max k p)))). + apply Qle_Qabs. apply cau. apply Pos.le_max_r. Qed. Lemma CRealLtQopp : forall (x : CReal) (q : Q), CRealLt (inject_Q q) x - -> forall p:positive, Qlt (q - (1#p)) (proj1_sig x (Pos.to_nat p)). + -> forall p:positive, Qlt (q - (1#p)) (proj1_sig x p). Proof. intros [xn cau] q maj p. simpl. - destruct (Qlt_le_dec (q - (1 # p)) (xn (Pos.to_nat p))). assumption. + destruct (Qlt_le_dec (q - (1 # p)) (xn p)). assumption. exfalso. apply CRealLt_above in maj. destruct maj as [k maj]; simpl in maj. specialize (maj (Pos.max k p) (Pos.le_max_l _ _)). - specialize (cau p (Pos.to_nat (Pos.max k p)) (Pos.to_nat p)). - pose proof (Qplus_lt_le_compat (2#k) (xn (Pos.to_nat (Pos.max k p)) - q) - (xn (Pos.to_nat p)) (q - (1 # p)) maj q0). + specialize (cau p (Pos.max k p) p). + pose proof (Qplus_lt_le_compat (2#k) (xn (Pos.max k p) - q) + (xn p) (q - (1 # p)) maj q0). unfold Qminus in H. rewrite <- Qplus_assoc in H. rewrite (Qplus_assoc (-q)) in H. rewrite (Qplus_comm (-q)) in H. rewrite Qplus_opp_r in H. rewrite Qplus_0_l in H. apply (Qplus_lt_l _ _ (1#p)) in H. - rewrite <- (Qplus_assoc (xn (Pos.to_nat (Pos.max k p)))) in H. + rewrite <- (Qplus_assoc (xn (Pos.max k p))) in H. rewrite (Qplus_comm (-(1#p))) in H. rewrite Qplus_opp_r in H. rewrite Qplus_0_r in H. rewrite Qplus_comm in H. - rewrite Qplus_assoc in H. apply (Qplus_lt_l _ _ (- xn (Pos.to_nat p))) in H. + rewrite Qplus_assoc in H. apply (Qplus_lt_l _ _ (- xn p)) in H. rewrite <- Qplus_assoc in H. rewrite Qplus_opp_r in H. rewrite Qplus_0_r in H. apply (Qlt_not_le (1#p) ((1 # p) + (2 # k))). rewrite <- (Qplus_0_r (1#p)). rewrite <- Qplus_assoc. apply Qplus_lt_r. reflexivity. apply Qlt_le_weak. - apply (Qlt_trans _ (xn (Pos.to_nat (Pos.max k p)) - xn (Pos.to_nat p)) _ H). - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max k p)) - xn (Pos.to_nat p)))). - apply Qle_Qabs. apply cau. apply Pos2Nat.inj_le. - apply Pos.le_max_r. apply le_refl. + apply (Qlt_trans _ (xn (Pos.max k p) - xn p) _ H). + apply (Qle_lt_trans _ (Qabs (xn (Pos.max k p) - xn p))). + apply Qle_Qabs. apply cau. + apply Pos.le_max_r. apply Pos.le_refl. Qed. Lemma inject_Q_compare : forall (x : CReal) (p : positive), - x <= inject_Q (proj1_sig x (Pos.to_nat p) + (1#p)). + x <= inject_Q (proj1_sig x p + (1#p)). Proof. intros. intros [n nmaj]. destruct x as [xn xcau]; simpl in nmaj. @@ -876,18 +798,17 @@ Proof. ring_simplify in nmaj. destruct (Pos.max_dec p n). - apply Pos.max_l_iff in e. - apply Pos2Nat.inj_le in e. - specialize (xcau n (Pos.to_nat n) (Pos.to_nat p) (le_refl _) e). - apply (Qlt_le_trans _ _ (Qabs (xn (Pos.to_nat n) + -1 * xn (Pos.to_nat p)))) in nmaj. + specialize (xcau n n p (Pos.le_refl _) e). + apply (Qlt_le_trans _ _ (Qabs (xn n + -1 * xn p))) in nmaj. 2: apply Qle_Qabs. apply (Qlt_trans _ _ _ nmaj) in xcau. apply (Qplus_lt_l _ _ (-(1#n)-(1#p))) in xcau. ring_simplify in xcau. setoid_replace ((2 # n) + -1 * (1 # n)) with (1#n)%Q in xcau. discriminate xcau. setoid_replace (-1 * (1 # n)) with (-1#n)%Q. 2: reflexivity. rewrite Qinv_plus_distr. reflexivity. - - apply Pos.max_r_iff, Pos2Nat.inj_le in e. - specialize (xcau p (Pos.to_nat n) (Pos.to_nat p) e (le_refl _)). - apply (Qlt_le_trans _ _ (Qabs (xn (Pos.to_nat n) + -1 * xn (Pos.to_nat p)))) in nmaj. + - apply Pos.max_r_iff in e. + specialize (xcau p n p e (Pos.le_refl _)). + apply (Qlt_le_trans _ _ (Qabs (xn n + -1 * xn p))) in nmaj. 2: apply Qle_Qabs. apply (Qlt_trans _ _ _ nmaj) in xcau. apply (Qplus_lt_l _ _ (-(1#p))) in xcau. ring_simplify in xcau. discriminate. @@ -921,12 +842,12 @@ Qed. (* Algebraic operations *) Lemma CReal_plus_cauchy - : forall (xn yn zn : nat -> Q) (cvmod : positive -> nat), + : forall (xn yn zn : positive -> Q) (cvmod : positive -> positive), QSeqEquiv xn yn cvmod - -> QCauchySeq zn Pos.to_nat - -> QSeqEquiv (fun n:nat => xn n + zn n) (fun n:nat => yn n + zn n) - (fun p => max (cvmod (2 * p)%positive) - (Pos.to_nat (2 * p)%positive)). + -> QCauchySeq zn id + -> QSeqEquiv (fun n:positive => xn n + zn n) (fun n:positive => yn n + zn n) + (fun p => Pos.max (cvmod (2 * p)%positive) + (2 * p)%positive). Proof. intros. intros p n k H1 H2. setoid_replace (xn n + zn n - (yn k + zn k)) @@ -936,70 +857,67 @@ Proof. apply Qabs_triangle. setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. apply Qplus_lt_le_compat. - - apply H. apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). - apply Nat.le_max_l. apply H1. - apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). - apply Nat.le_max_l. apply H2. + - apply H. apply (Pos.le_trans _ (Pos.max (cvmod (2 * p)%positive) (2 * p))). + apply Pos.le_max_l. apply H1. + apply (Pos.le_trans _ (Pos.max (cvmod (2 * p)%positive) (2 * p))). + apply Pos.le_max_l. apply H2. - apply Qle_lteq. left. apply H0. - apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). - apply Nat.le_max_r. apply H1. - apply (le_trans _ (Init.Nat.max (cvmod (2 * p)%positive) (Pos.to_nat (2 * p)))). - apply Nat.le_max_r. apply H2. + apply (Pos.le_trans _ (Pos.max (cvmod (2 * p)%positive) (2 * p))). + apply Pos.le_max_r. apply H1. + apply (Pos.le_trans _ (Pos.max (cvmod (2 * p)%positive) (2 * p))). + apply Pos.le_max_r. apply H2. - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. Qed. Definition CReal_plus (x y : CReal) : CReal. Proof. destruct x as [xn limx], y as [yn limy]. - pose proof (CReal_plus_cauchy xn xn yn Pos.to_nat limx limy). - exists (fun n : nat => xn (2 * n)%nat + yn (2 * n)%nat). + pose proof (CReal_plus_cauchy xn xn yn id limx limy). + exists (fun n : positive => xn (2 * n)%positive + yn (2 * n)%positive). intros p k n H0 H1. apply H. - - rewrite max_l. rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. apply le_0_n. apply le_refl. - apply le_0_n. apply H0. apply le_refl. - - rewrite Pos2Nat.inj_mul. rewrite max_l. - apply Nat.mul_le_mono_nonneg. apply le_0_n. apply le_refl. - apply le_0_n. apply H1. apply le_refl. + - rewrite Pos.max_l. unfold id. rewrite <- Pos.mul_le_mono_l. + exact H0. apply Pos.le_refl. + - rewrite Pos.max_l. unfold id. + apply Pos.mul_le_mono_l. exact H1. apply Pos.le_refl. Defined. Infix "+" := CReal_plus : CReal_scope. -Lemma CReal_plus_nth : forall (x y : CReal) (n : nat), - proj1_sig (x + y) n = Qplus (proj1_sig x (2*n)%nat) (proj1_sig y (2*n)%nat). +Lemma CReal_plus_nth : forall (x y : CReal) (n : positive), + proj1_sig (x + y) n = Qplus (proj1_sig x (2*n)%positive) + (proj1_sig y (2*n)%positive). Proof. intros. destruct x,y; reflexivity. Qed. Lemma CReal_plus_unfold : forall (x y : CReal), QSeqEquiv (proj1_sig (CReal_plus x y)) - (fun n : nat => proj1_sig x n + proj1_sig y n)%Q - (fun p => Pos.to_nat (2 * p)). + (fun n : positive => proj1_sig x n + proj1_sig y n)%Q + (fun p => 2 * p)%positive. Proof. intros [xn limx] [yn limy]. unfold CReal_plus; simpl. intros p n k H H0. - setoid_replace (xn (2 * n)%nat + yn (2 * n)%nat - (xn k + yn k))%Q - with (xn (2 * n)%nat - xn k + (yn (2 * n)%nat - yn k))%Q. + setoid_replace (xn (2 * n)%positive + yn (2 * n)%positive - (xn k + yn k))%Q + with (xn (2 * n)%positive - xn k + (yn (2 * n)%positive - yn k))%Q. 2: field. - apply (Qle_lt_trans _ (Qabs (xn (2 * n)%nat - xn k) + Qabs (yn (2 * n)%nat - yn k))). + apply (Qle_lt_trans _ (Qabs (xn (2 * n)%positive - xn k) + Qabs (yn (2 * n)%positive - yn k))). apply Qabs_triangle. setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. apply Qplus_lt_le_compat. - - apply limx. apply (le_trans _ n). apply H. - rewrite <- (mult_1_l n). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. simpl. auto. - apply le_0_n. apply le_refl. apply H0. - - apply Qlt_le_weak. apply limy. apply (le_trans _ n). apply H. - rewrite <- (mult_1_l n). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. simpl. auto. - apply le_0_n. apply le_refl. apply H0. + - apply limx. apply (Pos.le_trans _ n). apply H. + apply (Pos.le_trans _ (1 * n)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. exact H0. + - apply Qlt_le_weak. apply limy. apply (Pos.le_trans _ n). apply H. + apply (Pos.le_trans _ (1 * n)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. exact H0. - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. Qed. Definition CReal_opp (x : CReal) : CReal. Proof. destruct x as [xn limx]. - exists (fun n : nat => - xn n). + exists (fun n : positive => - xn n). intros k p q H H0. unfold Qminus. rewrite Qopp_involutive. rewrite Qplus_comm. apply limx; assumption. Defined. @@ -1011,10 +929,10 @@ Definition CReal_minus (x y : CReal) : CReal Infix "-" := CReal_minus : CReal_scope. -Lemma belowMultiple : forall n p : nat, lt 0 p -> le n (p * n). +Lemma belowMultiple : forall n p : positive, Pos.le n (p * n). Proof. - intros. rewrite <- (mult_1_l n). apply Nat.mul_le_mono_nonneg. - auto. assumption. apply le_0_n. rewrite mult_1_l. apply le_refl. + intros. apply (Pos.le_trans _ (1*n)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. destruct p; discriminate. Qed. Lemma CReal_plus_assoc : forall (x y z : CReal), @@ -1024,20 +942,20 @@ Proof. intros. apply CRealEq_diff. intro n. destruct x as [xn limx], y as [yn limy], z as [zn limz]. unfold CReal_plus; unfold proj1_sig. - setoid_replace (xn (2 * (2 * Pos.to_nat n))%nat + yn (2 * (2 * Pos.to_nat n))%nat - + zn (2 * Pos.to_nat n)%nat - - (xn (2 * Pos.to_nat n)%nat + (yn (2 * (2 * Pos.to_nat n))%nat - + zn (2 * (2 * Pos.to_nat n))%nat)))%Q - with (xn (2 * (2 * Pos.to_nat n))%nat - xn (2 * Pos.to_nat n)%nat - + (zn (2 * Pos.to_nat n)%nat - zn (2 * (2 * Pos.to_nat n))%nat))%Q. - apply (Qle_trans _ (Qabs (xn (2 * (2 * Pos.to_nat n))%nat - xn (2 * Pos.to_nat n)%nat) - + Qabs (zn (2 * Pos.to_nat n)%nat - zn (2 * (2 * Pos.to_nat n))%nat))). + setoid_replace (xn (2 * (2 * n))%positive + yn (2 * (2 * n))%positive + + zn (2 * n)%positive + - (xn (2 * n)%positive + (yn (2 * (2 * n))%positive + + zn (2 * (2 * n))%positive)))%Q + with (xn (2 * (2 * n))%positive - xn (2 * n)%positive + + (zn (2 * n)%positive - zn (2 * (2 * n))%positive))%Q. + apply (Qle_trans _ (Qabs (xn (2 * (2 * n))%positive - xn (2 * n)%positive) + + Qabs (zn (2 * n)%positive - zn (2 * (2 * n))%positive))). apply Qabs_triangle. rewrite <- (Qinv_plus_distr 1 1 n). apply Qplus_le_compat. - apply Qle_lteq. left. apply limx. rewrite mult_assoc. - apply belowMultiple. simpl. auto. apply belowMultiple. auto. - apply Qle_lteq. left. apply limz. apply belowMultiple. auto. - rewrite mult_assoc. apply belowMultiple. simpl. auto. field. + apply Qle_lteq. left. apply limx. rewrite Pos.mul_assoc. + apply belowMultiple. apply belowMultiple. + apply Qle_lteq. left. apply limz. apply belowMultiple. + rewrite Pos.mul_assoc. apply belowMultiple. simpl. field. Qed. Lemma CReal_plus_comm : forall x y : CReal, @@ -1045,39 +963,40 @@ Lemma CReal_plus_comm : forall x y : CReal, Proof. intros [xn limx] [yn limy]. apply CRealEq_diff. intros. unfold CReal_plus, proj1_sig. - setoid_replace (xn (2 * Pos.to_nat n)%nat + yn (2 * Pos.to_nat n)%nat - - (yn (2 * Pos.to_nat n)%nat + xn (2 * Pos.to_nat n)%nat))%Q + setoid_replace (xn (2 * n)%positive + yn (2 * n)%positive + - (yn (2 * n)%positive + xn (2 * n)%positive))%Q with 0%Q. unfold Qle. simpl. unfold Z.le. intro absurd. inversion absurd. field. Qed. Lemma CReal_plus_0_l : forall r : CReal, - CRealEq (CReal_plus (inject_Q 0) r) r. + inject_Q 0 + r == r. Proof. - intro r. assert (forall n:nat, le n (2 * n)). - { intro n. simpl. rewrite <- (plus_0_r n). rewrite <- plus_assoc. - apply Nat.add_le_mono_l. apply le_0_n. } - split. - - intros [n maj]. destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. + intro r. split. + - intros [n maj]. + destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. rewrite Qplus_0_l in maj. - specialize (q n (Pos.to_nat n) (mult 2 (Pos.to_nat n)) (le_refl _)). - apply (Qlt_not_le (2#n) (xn (Pos.to_nat n) - xn (2 * Pos.to_nat n)%nat)). + specialize (q n n (Pos.mul 2 n) (Pos.le_refl _)). + apply (Qlt_not_le (2#n) (xn n - xn (2 * n)%positive)). assumption. - apply (Qle_trans _ (Qabs (xn (Pos.to_nat n) - xn (2 * Pos.to_nat n)%nat))). + apply (Qle_trans _ (Qabs (xn n - xn (2 * n)%positive))). apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Qlt_le_weak. apply q. - apply H. unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_xO. - apply H. - - intros [n maj]. destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. + apply belowMultiple. + unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. + discriminate. discriminate. + - intros [n maj]. + destruct r as [xn q]; unfold CReal_plus, proj1_sig, inject_Q in maj. rewrite Qplus_0_l in maj. - specialize (q n (Pos.to_nat n) (mult 2 (Pos.to_nat n)) (le_refl _)). + specialize (q n n (Pos.mul 2 n) (Pos.le_refl _)). rewrite Qabs_Qminus in q. - apply (Qlt_not_le (2#n) (xn (mult 2 (Pos.to_nat n)) - xn (Pos.to_nat n))). + apply (Qlt_not_le (2#n) (xn (Pos.mul 2 n) - xn n)). assumption. - apply (Qle_trans _ (Qabs (xn (mult 2 (Pos.to_nat n)) - xn (Pos.to_nat n)))). + apply (Qle_trans _ (Qabs (xn (Pos.mul 2 n) - xn n))). apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Qlt_le_weak. apply q. - apply H. unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_xO. - apply H. + apply belowMultiple. + unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. + discriminate. discriminate. Qed. Lemma CReal_plus_0_r : forall r : CReal, @@ -1091,14 +1010,11 @@ Lemma CReal_plus_lt_compat_l : Proof. intros. apply CRealLt_above in H. destruct H as [n maj]. - exists n. specialize (maj (xO n)). - rewrite Pos2Nat.inj_xO in maj. - setoid_replace (proj1_sig (CReal_plus x z) (Pos.to_nat n) - - proj1_sig (CReal_plus x y) (Pos.to_nat n))%Q - with (proj1_sig z (2 * Pos.to_nat n)%nat - proj1_sig y (2 * Pos.to_nat n)%nat)%Q. - apply maj. apply Pos2Nat.inj_le. - rewrite <- (plus_0_r (Pos.to_nat n)). rewrite Pos2Nat.inj_xO. - simpl. apply Nat.add_le_mono_l. apply le_0_n. + exists n. specialize (maj (2 * n)%positive). + setoid_replace (proj1_sig (CReal_plus x z) n + - proj1_sig (CReal_plus x y) n)%Q + with (proj1_sig z (2 * n)%positive - proj1_sig y (2 * n)%positive)%Q. + apply maj. apply belowMultiple. simpl. destruct x as [xn limx], y as [yn limy], z as [zn limz]. simpl; ring. Qed. @@ -1114,12 +1030,13 @@ Lemma CReal_plus_lt_reg_l : forall x y z : CReal, x + y < x + z -> y < z. Proof. intros. destruct H as [n maj]. exists (2*n)%positive. - setoid_replace (proj1_sig z (Pos.to_nat (2 * n)) - proj1_sig y (Pos.to_nat (2 * n)))%Q - with (proj1_sig (CReal_plus x z) (Pos.to_nat n) - proj1_sig (CReal_plus x y) (Pos.to_nat n))%Q. - apply (Qle_lt_trans _ (2#n)). unfold Qle, Z.le; simpl. apply Pos2Nat.inj_le. - rewrite <- (plus_0_r (Pos.to_nat n~0)). rewrite (Pos2Nat.inj_xO (n~0)). - simpl. apply Nat.add_le_mono_l. apply le_0_n. - apply maj. rewrite Pos2Nat.inj_xO. + setoid_replace (proj1_sig z (2 * n)%positive - proj1_sig y (2 * n)%positive)%Q + with (proj1_sig (CReal_plus x z) n - proj1_sig (CReal_plus x y) n)%Q. + apply (Qle_lt_trans _ (2#n)). + setoid_replace (2 # 2 * n)%Q with (1 # n)%Q. 2: reflexivity. + unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. + discriminate. discriminate. + apply maj. destruct x as [xn limx], y as [yn limy], z as [zn limz]. simpl; ring. Qed. @@ -1173,7 +1090,7 @@ Lemma CReal_plus_opp_r : forall x : CReal, Proof. intros [xn limx]. apply CRealEq_diff. intros. unfold CReal_plus, CReal_opp, inject_Q, proj1_sig. - setoid_replace (xn (2 * Pos.to_nat n)%nat + - xn (2 * Pos.to_nat n)%nat - 0)%Q + setoid_replace (xn (2 * n)%positive + - xn (2 * n)%positive - 0)%Q with 0%Q. unfold Qle. simpl. unfold Z.le. intro absurd. inversion absurd. field. Qed. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v index fa24bd988e..f3a59b493f 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v @@ -20,82 +20,57 @@ Require CMorphisms. Local Open Scope CReal_scope. -Fixpoint BoundFromZero (qn : nat -> Q) (k : nat) (A : positive) { struct k } - : (forall n:nat, le k n -> Qlt (Qabs (qn n)) (Z.pos A # 1)) - -> { B : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos B # 1) }. -Proof. - intro H. destruct k. - - exists A. intros. apply H. apply le_0_n. - - destruct (Qarchimedean (Qabs (qn k))) as [a maj]. - apply (BoundFromZero qn k (Pos.max A a)). - intros n H0. destruct (Nat.le_gt_cases n k). - + pose proof (Nat.le_antisymm n k H1 H0). subst k. - apply (Qlt_le_trans _ (Z.pos a # 1)). apply maj. - unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. - apply Pos.le_max_r. - + apply (Qlt_le_trans _ (Z.pos A # 1)). apply H. - apply H1. unfold Qle; simpl. rewrite Pos.mul_1_r. rewrite Pos.mul_1_r. - apply Pos.le_max_l. -Qed. - -Lemma QCauchySeq_bounded (qn : nat -> Q) (cvmod : positive -> nat) +Definition QCauchySeq_bound (qn : positive -> Q) (cvmod : positive -> positive) + : positive + := match Qnum (qn (cvmod 1%positive)) with + | Z0 => 1%positive + | Z.pos p => p + 1 + | Z.neg p => p + 1 + end. + +Lemma QCauchySeq_bounded_prop (qn : positive -> Q) (cvmod : positive -> positive) : QCauchySeq qn cvmod - -> { A : positive | forall n:nat, Qlt (Qabs (qn n)) (Z.pos A # 1) }. -Proof. - intros. remember (Zplus (Qnum (Qabs (qn (cvmod xH)))) 1) as z. - assert (Z.lt 0 z) as zPos. - { subst z. assert (Qle 0 (Qabs (qn (cvmod 1%positive)))). - apply Qabs_nonneg. destruct (Qabs (qn (cvmod 1%positive))). simpl. - unfold Qle in H0. simpl in H0. rewrite Zmult_1_r in H0. - apply (Z.lt_le_trans 0 1). unfold Z.lt. auto. - rewrite <- (Zplus_0_l 1). rewrite Zplus_assoc. apply Zplus_le_compat_r. - rewrite Zplus_0_r. assumption. } - assert { A : positive | forall n:nat, - le (cvmod xH) n -> Qlt ((Qabs (qn n)) * (1#A)) 1 }. - destruct z eqn:des. - - exfalso. apply (Z.lt_irrefl 0). assumption. - - exists p. intros. specialize (H xH (cvmod xH) n (le_refl _) H0). - assert (Qlt (Qabs (qn n)) (Qabs (qn (cvmod 1%positive)) + 1)). - { apply (Qplus_lt_l _ _ (-Qabs (qn (cvmod 1%positive)))). - rewrite <- (Qplus_comm 1). rewrite <- Qplus_assoc. rewrite Qplus_opp_r. - rewrite Qplus_0_r. apply (Qle_lt_trans _ (Qabs (qn n - qn (cvmod 1%positive)))). - apply Qabs_triangle_reverse. rewrite Qabs_Qminus. assumption. } - apply (Qlt_le_trans _ ((Qabs (qn (cvmod 1%positive)) + 1) * (1#p))). - apply Qmult_lt_r. unfold Qlt. simpl. unfold Z.lt. auto. assumption. - unfold Qle. simpl. rewrite Zmult_1_r. rewrite Zmult_1_r. rewrite Zmult_1_r. - rewrite Pos.mul_1_r. rewrite Pos2Z.inj_mul. rewrite Heqz. - destruct (Qabs (qn (cvmod 1%positive))) eqn:desAbs. - rewrite Z.mul_add_distr_l. rewrite Zmult_1_r. - apply Zplus_le_compat_r. rewrite <- (Zmult_1_l (QArith_base.Qnum (Qnum # Qden))). - rewrite Zmult_assoc. apply Zmult_le_compat_r. rewrite Zmult_1_r. - simpl. unfold Z.le. rewrite <- Pos2Z.inj_compare. - unfold Pos.compare. destruct Qden; discriminate. - simpl. assert (Qle 0 (Qnum # Qden)). rewrite <- desAbs. - apply Qabs_nonneg. unfold Qle in H2. simpl in H2. rewrite Zmult_1_r in H2. - assumption. - - exfalso. inversion zPos. - - destruct H0. apply (BoundFromZero _ (cvmod xH) x). intros n H0. - specialize (q n H0). setoid_replace (Z.pos x # 1)%Q with (/(1#x))%Q. - rewrite <- (Qmult_1_l (/(1#x))). apply Qlt_shift_div_l. - reflexivity. apply q. reflexivity. + -> forall n:positive, Pos.le (cvmod 1%positive) n + -> Qlt (Qabs (qn n)) (Z.pos (QCauchySeq_bound qn cvmod) # 1). +Proof. + intros H n H0. unfold QCauchySeq_bound. + specialize (H 1%positive (cvmod 1%positive) n (Pos.le_refl _) H0). + destruct (qn (cvmod 1%positive)) as [a b]. unfold Qnum. + rewrite Qabs_Qminus in H. + apply (Qplus_lt_l _ _ (-Qabs (a#b))). + apply (Qlt_le_trans _ 1). + exact (Qle_lt_trans _ _ _ (Qabs_triangle_reverse (qn n) (a#b)) H). + assert (forall p : positive, + (1 <= (Z.pos (p + 1) # 1) + - (Z.pos p # b))%Q). + { intro p. unfold Qle, Qopp, Qplus, Qnum, Qden. + rewrite Z.mul_1_r, Z.mul_1_r, Pos2Z.inj_add, Pos.mul_1_l. + apply (Z.add_le_mono_l _ _ (Z.pos p -Z.pos b)). + ring_simplify. apply (Z.le_trans _ (Z.pos p * 1)). + rewrite Z.mul_1_r. apply Z.le_refl. + apply Z.mul_le_mono_nonneg_l. discriminate. destruct b; discriminate. } + destruct a. + - setoid_replace (Qabs (0#b)) with 0%Q. 2: reflexivity. + rewrite Qplus_0_r. apply Qle_refl. + - apply H1. + - apply H1. Qed. Lemma CReal_mult_cauchy - : forall (xn yn zn : nat -> Q) (Ay Az : positive) (cvmod : positive -> nat), + : forall (xn yn zn : positive -> Q) (Ay Az : positive) (cvmod : positive -> positive), QSeqEquiv xn yn cvmod - -> QCauchySeq zn Pos.to_nat - -> (forall n:nat, Qlt (Qabs (yn n)) (Z.pos Ay # 1)) - -> (forall n:nat, Qlt (Qabs (zn n)) (Z.pos Az # 1)) - -> QSeqEquiv (fun n:nat => xn n * zn n) (fun n:nat => yn n * zn n) - (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) - (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). + -> QCauchySeq zn id + -> (forall n:positive, Pos.le (cvmod 2%positive) n + -> Qlt (Qabs (yn n)) (Z.pos Ay # 1)) + -> (forall n:positive, Pos.le 1 n + -> Qlt (Qabs (zn n)) (Z.pos Az # 1)) + -> QSeqEquiv (fun n:positive => xn n * zn n) (fun n:positive => yn n * zn n) + (fun p => Pos.max (Pos.max (cvmod 2%positive) + (cvmod (2 * (Pos.max Ay Az) * p)%positive)) + (2 * (Pos.max Ay Az) * p)%positive). Proof. intros xn yn zn Ay Az cvmod limx limz majy majz. remember (Pos.mul 2 (Pos.max Ay Az)) as z. intros k p q H H0. - assert (Pos.to_nat k <> O) as kPos. - { intro absurd. pose proof (Pos2Nat.is_pos k). - rewrite absurd in H1. inversion H1. } setoid_replace (xn p * zn p - yn q * zn q)%Q with ((xn p - yn q) * zn p + yn q * (zn p - zn q))%Q. 2: ring. @@ -106,30 +81,39 @@ Proof. apply Qplus_lt_le_compat. - apply (Qle_lt_trans _ ((1#z * k) * Qabs (zn p)%nat)). + apply Qmult_le_compat_r. apply Qle_lteq. left. apply limx. - apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). - apply Nat.le_max_l. assumption. - apply (le_trans _ (Init.Nat.max (cvmod (z * k)%positive) (Pos.to_nat (z * k)))). - apply Nat.le_max_l. assumption. apply Qabs_nonneg. + apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) (z * k))). + apply Pos.le_max_l. refine (Pos.le_trans _ _ _ _ H). + rewrite <- Pos.max_assoc. apply Pos.le_max_r. + apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) (z * k))). + apply Pos.le_max_l. refine (Pos.le_trans _ _ _ _ H0). + rewrite <- Pos.max_assoc. apply Pos.le_max_r. apply Qabs_nonneg. + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. - apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. + apply Qmult_lt_l. reflexivity. apply (Qle_lt_trans _ (Qabs (zn p)%nat * (1 # Az))). rewrite <- (Qmult_comm (1 # Az)). apply Qmult_le_compat_r. unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_r. apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Az)). + 2: intro abs; inversion abs. rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. - setoid_replace (/(1#Az))%Q with (Z.pos Az # 1)%Q. apply majz. - reflexivity. intro abs. inversion abs. + setoid_replace (/(1#Az))%Q with (Z.pos Az # 1)%Q. + 2: reflexivity. + apply majz. refine (Pos.le_trans _ _ _ _ H). + apply (Pos.le_trans _ (2 * Pos.max Ay Az * k)). + discriminate. apply Pos.le_max_r. - apply (Qle_trans _ ((1 # z * k) * Qabs (yn q)%nat)). + rewrite Qmult_comm. apply Qmult_le_compat_r. apply Qle_lteq. left. apply limz. - apply (le_trans _ (max (cvmod (z * k)%positive) - (Pos.to_nat (z * k)%positive))). - apply Nat.le_max_r. assumption. - apply (le_trans _ (max (cvmod (z * k)%positive) - (Pos.to_nat (z * k)%positive))). - apply Nat.le_max_r. assumption. apply Qabs_nonneg. + apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) + (z * k)%positive)). + apply Pos.le_max_r. refine (Pos.le_trans _ _ _ _ H). + rewrite <- Pos.max_assoc. apply Pos.le_max_r. + apply (Pos.le_trans _ (Pos.max (cvmod (z * k)%positive) + (z * k)%positive)). + apply Pos.le_max_r. refine (Pos.le_trans _ _ _ _ H0). + rewrite <- Pos.max_assoc. apply Pos.le_max_r. + apply Qabs_nonneg. + subst z. rewrite <- (Qmult_1_r (1 # 2 * k)). rewrite <- Pos.mul_assoc. rewrite <- (Pos.mul_comm k). rewrite Pos.mul_assoc. rewrite (factorDenom _ _ (2 * k)). rewrite <- Qmult_assoc. @@ -139,165 +123,196 @@ Proof. rewrite <- (Qmult_comm (1 # Ay)). apply Qmult_le_compat_r. unfold Qle. simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. apply Qabs_nonneg. rewrite <- (Qmult_inv_r (1#Ay)). + 2: intro abs; inversion abs. rewrite Qmult_comm. apply Qmult_lt_l. reflexivity. - setoid_replace (/(1#Ay))%Q with (Z.pos Ay # 1)%Q. apply majy. - reflexivity. intro abs. inversion abs. + setoid_replace (/(1#Ay))%Q with (Z.pos Ay # 1)%Q. 2: reflexivity. + apply majy. refine (Pos.le_trans _ _ _ _ H0). + rewrite <- Pos.max_assoc. apply Pos.le_max_l. - rewrite Qinv_plus_distr. unfold Qeq. reflexivity. Qed. -Lemma linear_max : forall (p Ax Ay : positive) (i : nat), - le (Pos.to_nat p) i - -> (Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) - (Pos.to_nat (2 * Pos.max Ax Ay * p)) <= Pos.to_nat (2 * Pos.max Ax Ay) * i)%nat. -Proof. - intros. rewrite max_l. 2: apply le_refl. - rewrite Pos2Nat.inj_mul. apply Nat.mul_le_mono_nonneg. - apply le_0_n. apply le_refl. apply le_0_n. apply H. +Lemma linear_max : forall (p Ax Ay i : positive), + Pos.le p i + -> (Pos.max (Pos.max 2 (2 * Pos.max Ax Ay * p)) + (2 * Pos.max Ax Ay * p) + <= (2 * Pos.max Ax Ay) * i)%positive. +Proof. + intros. rewrite Pos.max_l. 2: apply Pos.le_max_r. rewrite Pos.max_r. + apply Pos.mul_le_mono_l. exact H. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2). + destruct (Pos.max Ax Ay * p)%positive; discriminate. Qed. Definition CReal_mult (x y : CReal) : CReal. Proof. destruct x as [xn limx]. destruct y as [yn limy]. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). - exists (fun n : nat => xn (Pos.to_nat (2 * Pos.max Ax Ay)* n)%nat - * yn (Pos.to_nat (2 * Pos.max Ax Ay) * n)%nat). + pose (QCauchySeq_bound xn id) as Ax. + pose (QCauchySeq_bound yn id) as Ay. + exists (fun n : positive => xn ((2 * Pos.max Ax Ay) * n)%positive + * yn ((2 * Pos.max Ax Ay) * n)%positive). intros p n k H0 H1. - apply H; apply linear_max; assumption. + apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). + intros. apply (QCauchySeq_bounded_prop xn id limx). + apply (Pos.le_trans _ 2). discriminate. exact H. + intros. exact (QCauchySeq_bounded_prop yn id limy _ H). + apply linear_max; assumption. apply linear_max; assumption. Defined. Infix "*" := CReal_mult : CReal_scope. Lemma CReal_mult_unfold : forall x y : CReal, QSeqEquivEx (proj1_sig (CReal_mult x y)) - (fun n : nat => proj1_sig x n * proj1_sig y n)%Q. + (fun n : positive => proj1_sig x n * proj1_sig y n)%Q. Proof. intros [xn limx] [yn limy]. unfold CReal_mult ; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - simpl. - pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop yn id limy) as majy. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) - (Pos.to_nat (2 * Pos.max Ax Ay * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - apply H. apply linear_max. - apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). - rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. - apply le_0_n. apply le_refl. apply H0. rewrite max_l. - apply H1. apply le_refl. + Pos.max (2 * Pos.max Ax Ay * p) + (2 * Pos.max Ax Ay * p)). + intros p n k H0 H1. rewrite Pos.max_l in H0, H1. + apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). + 2: apply majy. intros. apply majx. + refine (Pos.le_trans _ _ _ _ H). discriminate. + 3: apply Pos.le_refl. 3: apply Pos.le_refl. + apply linear_max. refine (Pos.le_trans _ _ _ _ H0). + apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. + rewrite Pos.max_l. + rewrite Pos.max_r. apply H1. 2: apply Pos.le_max_r. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. unfold id. + rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). + destruct (Pos.max Ax Ay * p)%positive; discriminate. Qed. -Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : nat -> Q), +Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : positive -> Q), QSeqEquivEx xn yn (* both are Cauchy with same limit *) - -> QSeqEquiv zn zn Pos.to_nat + -> QSeqEquiv zn zn id -> QSeqEquivEx (fun n => xn n * zn n)%Q (fun n => yn n * zn n)%Q. Proof. - intros. destruct H as [cvmod cveq]. - destruct (QCauchySeq_bounded yn (fun k => cvmod (2 * k)%positive) - (QSeqEquiv_cau_r xn yn cvmod cveq)) - as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat H0) as [Az majz]. - exists (fun p => max (cvmod (2 * (Pos.max Ay Az) * p)%positive) - (Pos.to_nat (2 * (Pos.max Ay Az) * p)%positive)). - apply CReal_mult_cauchy; assumption. + intros xn yn zn [cvmod cveq] H0. + exists (fun p => Pos.max (Pos.max (cvmod 2%positive) (cvmod (2 * (Pos.max (QCauchySeq_bound yn (fun k : positive => cvmod (2 * k)%positive)) (QCauchySeq_bound zn id)) * p)%positive)) + (2 * (Pos.max (QCauchySeq_bound yn (fun k : positive => cvmod (2 * k)%positive)) (QCauchySeq_bound zn id)) * p)%positive). + apply (CReal_mult_cauchy _ _ _ _ _ _ cveq H0). + exact (QCauchySeq_bounded_prop + yn (fun k => cvmod (2 * k)%positive) + (QSeqEquiv_cau_r xn yn cvmod cveq)). + exact (QCauchySeq_bounded_prop zn id H0). Qed. -Lemma CReal_mult_assoc : forall x y z : CReal, - CRealEq (CReal_mult (CReal_mult x y) z) - (CReal_mult x (CReal_mult y z)). +Lemma CReal_mult_assoc : forall x y z : CReal, (x * y) * z == x * (y * z). Proof. intros. apply CRealEq_diff. apply CRealEq_modindep. apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n * proj1_sig z n)%Q). - apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n * proj1_sig z n)%Q). apply CReal_mult_unfold. destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - apply CReal_mult_assoc_bounded_r. 2: apply limz. - simpl. - pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy majx majy). + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop yn id limy) as majy. + pose proof (QCauchySeq_bounded_prop zn id limz) as majz. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + remember (QCauchySeq_bound zn id) as Az. + apply CReal_mult_assoc_bounded_r. 2: exact limz. exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ax Ay * p)) - (Pos.to_nat (2 * Pos.max Ax Ay * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - apply H. apply linear_max. - apply (le_trans _ (Pos.to_nat (2 * Pos.max Ax Ay * p))). - rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. - apply le_0_n. apply le_refl. apply H0. rewrite max_l. - apply H1. apply le_refl. - - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig (CReal_mult y z) n)%Q). + Pos.max (2 * Pos.max Ax Ay * p) + (2 * Pos.max Ax Ay * p)). + intros p n k H0 H1. + apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). + 2: exact majy. intros. apply majx. refine (Pos.le_trans _ _ _ _ H). + discriminate. rewrite Pos.max_l in H0, H1. + 2: apply Pos.le_refl. 2: apply Pos.le_refl. + apply linear_max. + apply (Pos.le_trans _ (2 * Pos.max Ax Ay * p)). + apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. + exact H0. rewrite Pos.max_l. 2: apply Pos.le_max_r. + rewrite Pos.max_r in H1. 2: apply Pos.le_refl. + refine (Pos.le_trans _ _ _ _ H1). rewrite Pos.max_r. + apply Pos.le_refl. apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + unfold id. + rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). + destruct (Pos.max Ax Ay * p)%positive; discriminate. + - apply (QSeqEquivEx_trans + _ (fun n => proj1_sig x n * proj1_sig (CReal_mult y z) n)%Q). 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. destruct x as [xn limx], y as [yn limy], z as [zn limz]; unfold CReal_mult; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - simpl. - pose proof (CReal_mult_assoc_bounded_r (fun n0 : nat => yn n0 * zn n0)%Q (fun n : nat => - yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat - * zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat)%Q xn) + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop yn id limy) as majy. + pose proof (QCauchySeq_bounded_prop zn id limz) as majz. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + remember (QCauchySeq_bound zn id) as Az. + pose proof (CReal_mult_assoc_bounded_r (fun n0 : positive => yn n0 * zn n0)%Q (fun n : positive => + yn ((Pos.max Ay Az)~0 * n)%positive + * zn ((Pos.max Ay Az)~0 * n)%positive)%Q xn) as [cvmod cveq]. - - pose proof (CReal_mult_cauchy yn yn zn Ay Az Pos.to_nat limy limz majy majz). - exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Az * p)) - (Pos.to_nat (2 * Pos.max Ay Az * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - apply H. rewrite max_l. apply H0. apply le_refl. - apply linear_max. - apply (le_trans _ (Pos.to_nat (2 * Pos.max Ay Az * p))). - rewrite <- (mult_1_l (Pos.to_nat p)). rewrite Pos2Nat.inj_mul. - apply Nat.mul_le_mono_nonneg. auto. apply Pos2Nat.is_pos. - apply le_0_n. apply le_refl. apply H1. - apply limx. - exists cvmod. intros p k n H1 H2. specialize (cveq p k n H1 H2). - setoid_replace (xn k * yn k * zn k - - xn n * - (yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * - zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat))%Q - with ((fun n : nat => yn n * zn n * xn n) k - - (fun n : nat => - yn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * - zn (Pos.to_nat (Pos.max Ay Az)~0 * n)%nat * - xn n) n)%Q. - apply cveq. ring. + + exists (fun p : positive => + Pos.max (2 * Pos.max Ay Az * p) + (2 * Pos.max Ay Az * p)). + intros p n k H0 H1. rewrite Pos.max_l in H0, H1. + apply (CReal_mult_cauchy yn yn zn Ay Az id limy limz). + 2: exact majz. intros. apply majy. refine (Pos.le_trans _ _ _ _ H). + discriminate. + 3: apply Pos.le_refl. 3: apply Pos.le_refl. + rewrite Pos.max_l. rewrite Pos.max_r. apply H0. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. unfold id. + rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). + destruct (Pos.max Ay Az * p)%positive; discriminate. + apply Pos.le_max_r. + apply linear_max. refine (Pos.le_trans _ _ _ _ H1). + apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. + + exact limx. + + exists cvmod. intros p k n H1 H2. specialize (cveq p k n H1 H2). + setoid_replace (xn k * yn k * zn k - + xn n * + (yn ((Pos.max Ay Az)~0 * n)%positive * + zn ((Pos.max Ay Az)~0 * n)%positive))%Q + with ((fun n : positive => yn n * zn n * xn n) k - + (fun n : positive => + yn ((Pos.max Ay Az)~0 * n)%positive * + zn ((Pos.max Ay Az)~0 * n)%positive * + xn n) n)%Q. + apply cveq. ring. Qed. -Lemma CReal_mult_comm : forall x y : CReal, - CRealEq (CReal_mult x y) (CReal_mult y x). +Lemma CReal_mult_comm : forall x y : CReal, x * y == y * x. Proof. intros. apply CRealEq_diff. apply CRealEq_modindep. apply (QSeqEquivEx_trans _ (fun n => proj1_sig y n * proj1_sig x n)%Q). destruct x as [xn limx], y as [yn limy]; simpl. 2: apply QSeqEquivEx_sym; apply CReal_mult_unfold. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]; simpl. + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop yn id limy) as majy. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. apply QSeqEquivEx_sym. - - pose proof (CReal_mult_cauchy yn yn xn Ay Ax Pos.to_nat limy limx majy majx). exists (fun p : positive => - Init.Nat.max (Pos.to_nat (2 * Pos.max Ay Ax * p)) - (Pos.to_nat (2 * Pos.max Ay Ax * p))). - intros p n k H0 H1. rewrite max_l in H0, H1. - 2: apply le_refl. 2: apply le_refl. - rewrite (Qmult_comm (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)). - apply (H p n). rewrite max_l. apply H0. apply le_refl. - rewrite max_l. apply (le_trans _ k). apply H1. - rewrite <- (mult_1_l k). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. - apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. - apply le_refl. + Pos.max (2 * Pos.max Ay Ax * p) + (2 * Pos.max Ay Ax * p)). + intros p n k H0 H1. rewrite Pos.max_l in H0, H1. + 2: apply Pos.le_refl. 2: apply Pos.le_refl. + rewrite (Qmult_comm (xn ((Pos.max Ax Ay)~0 * k)%positive)). + apply (CReal_mult_cauchy yn yn xn Ay Ax id limy limx). + 2: exact majx. intros. apply majy. refine (Pos.le_trans _ _ _ _ H). + discriminate. + rewrite Pos.max_l. rewrite Pos.max_r. apply H0. + unfold id. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- (Pos.mul_le_mono_l 2 1). + destruct (Pos.max Ay Ax * p)%positive; discriminate. + apply Pos.le_max_r. rewrite (Pos.max_comm Ax Ay). + apply linear_max. refine (Pos.le_trans _ _ _ _ H1). + apply (Pos.le_trans _ (1*p)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. Qed. Lemma CReal_mult_proper_l : forall x y z : CReal, - CRealEq y z -> CRealEq (CReal_mult x y) (CReal_mult x z). + y == z -> x * y == x * z. Proof. intros. apply CRealEq_diff. apply CRealEq_modindep. apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n)%Q). @@ -307,46 +322,48 @@ Proof. apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig z n)%Q). apply CReal_mult_unfold. destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. - destruct H. simpl in H. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - pose proof (CReal_mult_cauchy yn zn xn Az Ax x H limx majz majx). + destruct H as [cvmod H]. simpl in H. + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop + zn (fun k => cvmod (2 * k)%positive) + (QSeqEquiv_cau_r yn zn cvmod H)) as majz. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound zn (fun k => cvmod (2 * k)%positive)) as Az. apply QSeqEquivEx_sym. exists (fun p : positive => - Init.Nat.max (x (2 * Pos.max Az Ax * p)%positive) - (Pos.to_nat (2 * Pos.max Az Ax * p))). - intros p n k H1 H2. specialize (H0 p n k H1 H2). + Pos.max (Pos.max (cvmod (2%positive)) (cvmod (2 * Pos.max Az Ax * p)%positive)) + (2 * Pos.max Az Ax * p)). + intros p n k H1 H2. setoid_replace (xn n * yn n - xn k * zn k)%Q - with (yn n * xn n - zn k * xn k)%Q. - apply H0. ring. + with (yn n * xn n - zn k * xn k)%Q. 2: ring. + apply (CReal_mult_cauchy yn zn xn Az Ax cvmod H limx majz majx). + exact H1. exact H2. Qed. Lemma CReal_mult_lt_0_compat : forall x y : CReal, - CRealLt (inject_Q 0) x - -> CRealLt (inject_Q 0) y - -> CRealLt (inject_Q 0) (CReal_mult x y). + inject_Q 0 < x + -> inject_Q 0 < y + -> inject_Q 0 < x * y. Proof. intros. destruct H as [x0 H], H0 as [x1 H0]. pose proof (CRealLt_aboveSig (inject_Q 0) x x0 H). pose proof (CRealLt_aboveSig (inject_Q 0) y x1 H0). - destruct x as [xn limx], y as [yn limy]. - simpl in H, H1, H2. simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (Qarchimedean (/ (xn (Pos.to_nat x0) - 0 - (2 # x0)))). - destruct (Qarchimedean (/ (yn (Pos.to_nat x1) - 0 - (2 # x1)))). + destruct x as [xn limx], y as [yn limy]; simpl in H, H1, H2, H0. + pose proof (QCauchySeq_bounded_prop xn id limx) as majx. + pose proof (QCauchySeq_bounded_prop yn id limy) as majy. + destruct (Qarchimedean (/ (xn x0 - 0 - (2 # x0)))). + destruct (Qarchimedean (/ (yn x1 - 0 - (2 # x1)))). exists (Pos.max x0 x~0 * Pos.max x1 x2~0)%positive. - simpl. unfold Qminus. rewrite Qplus_0_r. - rewrite <- Pos2Nat.inj_mul. + simpl. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + unfold Qminus. rewrite Qplus_0_r. unfold Qminus in H1, H2. specialize (H1 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive). assert (Pos.max x1 x2~0 <= (Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive. - { apply Pos2Nat.inj_le. - rewrite Pos.mul_assoc. rewrite Pos2Nat.inj_mul. - rewrite <- (mult_1_l (Pos.to_nat (Pos.max x1 x2~0))). - rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. - rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. - apply le_refl. } + { rewrite Pos.mul_assoc. + rewrite <- (Pos.mul_1_l (Pos.max x1 x2~0)). + rewrite Pos.mul_assoc. apply Pos.mul_le_mono_r. discriminate. } specialize (H2 ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive H3). rewrite Qplus_0_r in H1, H2. apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (2 # Pos.max x1 x2~0))). @@ -355,7 +372,7 @@ Proof. replace (Z.pos p~0) with (2 * Z.pos p)%Z. apply Z.mul_lt_mono_pos_r. apply Pos2Z.is_pos. reflexivity. reflexivity. apply H4. - apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (yn (Pos.to_nat ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0)))))). + apply (Qlt_trans _ ((2 # Pos.max x0 x~0) * (yn ((Pos.max Ax Ay)~0 * (Pos.max x0 x~0 * Pos.max x1 x2~0))%positive))). apply Qmult_lt_l. reflexivity. apply H2. apply Qmult_lt_r. apply (Qlt_trans 0 (2 # Pos.max x1 x2~0)). reflexivity. apply H2. apply H1. rewrite Pos.mul_comm. apply Pos2Nat.inj_le. @@ -375,115 +392,136 @@ Proof. apply CReal_mult_unfold. apply (QSeqEquivEx_trans _ (fun n => proj1_sig (CReal_mult x y) n + proj1_sig (CReal_mult x z) n))%Q. - 2: apply QSeqEquivEx_sym; exists (fun p => Pos.to_nat (2 * p)) + 2: apply QSeqEquivEx_sym; exists (fun p:positive => 2 * p)%positive ; apply CReal_plus_unfold. apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * (proj1_sig y n + proj1_sig z n))%Q). - pose proof (CReal_plus_unfold y z). destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl; simpl in H. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - pose proof (CReal_mult_cauchy (fun n => yn (n + (n + 0))%nat + zn (n + (n + 0))%nat)%Q + pose proof (QCauchySeq_bounded_prop xn id) as majx. + pose proof (QCauchySeq_bounded_prop yn id) as majy. + pose proof (QCauchySeq_bounded_prop zn id) as majz. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + remember (QCauchySeq_bound zn id) as Az. + pose proof (CReal_mult_cauchy (fun n => yn (n~0)%positive + zn (n~0)%positive)%Q (fun n => yn n + zn n)%Q xn (Ay + Az) Ax - (fun p => Pos.to_nat (2 * p)) H limx). - exists (fun p : positive => (Pos.to_nat (2 * (2 * Pos.max (Ay + Az) Ax * p)))). + (fun p:positive => 2 * p)%positive H limx). + exists (fun p : positive => (2 * (2 * Pos.max (Ay + Az) Ax * p))%positive). intros p n k H1 H2. - setoid_replace (xn n * (yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) - xn k * (yn k + zn k))%Q - with ((yn (n + (n + 0))%nat + zn (n + (n + 0))%nat) * xn n - (yn k + zn k) * xn k)%Q. + setoid_replace (xn n * (yn (n~0)%positive + zn (n~0)%positive) - xn k * (yn k + zn k))%Q + with ((yn (n~0)%positive + zn (n~0)%positive) * xn n - (yn k + zn k) * xn k)%Q. 2: ring. - assert (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p) <= - Pos.to_nat 2 * Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))%nat. - { rewrite (Pos2Nat.inj_mul 2). - rewrite <- (mult_1_l (Pos.to_nat (2 * Pos.max (Ay + Az) Ax * p))). - rewrite mult_assoc. apply Nat.mul_le_mono_nonneg. auto. - simpl. auto. apply le_0_n. apply le_refl. } - apply H0. intro n0. apply (Qle_lt_trans _ (Qabs (yn n0) + Qabs (zn n0))). - apply Qabs_triangle. rewrite Pos2Z.inj_add. - rewrite <- Qinv_plus_distr. apply Qplus_lt_le_compat. - apply majy. apply Qlt_le_weak. apply majz. - apply majx. rewrite max_l. - apply H1. rewrite (Pos2Nat.inj_mul 2). apply H3. - rewrite max_l. apply H2. rewrite (Pos2Nat.inj_mul 2). - apply H3. + assert ((2 * Pos.max (Ay + Az) Ax * p) <= + 2 * (2 * Pos.max (Ay + Az) Ax * p))%positive. + { rewrite <- Pos.mul_assoc. + apply Pos.mul_le_mono_l. + apply (Pos.le_trans _ (1*(Pos.max (Ay + Az) Ax * p))). + apply Pos.le_refl. apply Pos.mul_le_mono_r. discriminate. } + apply H0. intros n0 H4. + apply (Qle_lt_trans _ _ _ (Qabs_triangle _ _)). + rewrite Pos2Z.inj_add, <- Qinv_plus_distr. apply Qplus_lt_le_compat. + apply majy. exact limy. + refine (Pos.le_trans _ _ _ _ H4); discriminate. + apply Qlt_le_weak. apply majz. exact limz. + refine (Pos.le_trans _ _ _ _ H4); discriminate. + apply majx. exact limx. refine (Pos.le_trans _ _ _ _ H1). + rewrite Pos.max_l. rewrite Pos.max_r. apply Pos.le_refl. + rewrite <- (Pos.mul_le_mono_l 2). + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max (Ay + Az) Ax * p)%positive; discriminate. + apply (Pos.le_trans _ (2 * (2 * Pos.max (Ay + Az) Ax * p))). + 2: apply Pos.le_max_r. + rewrite <- Pos.mul_assoc. rewrite (Pos.mul_assoc 2 2). + rewrite <- Pos.mul_le_mono_r. discriminate. + refine (Pos.le_trans _ _ _ _ H2). rewrite <- Pos.max_comm. + rewrite Pos.max_assoc. rewrite Pos.max_r. apply Pos.le_refl. + apply Pos.max_lub. apply H3. + rewrite <- Pos.mul_le_mono_l. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max (Ay + Az) Ax * p)%positive; discriminate. - destruct x as [xn limx], y as [yn limy], z as [zn limz]; simpl. - destruct (QCauchySeq_bounded xn Pos.to_nat limx) as [Ax majx]. - destruct (QCauchySeq_bounded yn Pos.to_nat limy) as [Ay majy]. - destruct (QCauchySeq_bounded zn Pos.to_nat limz) as [Az majz]. - simpl. - exists (fun p : positive => (Pos.to_nat (2 * (Pos.max (Pos.max Ax Ay) Az) * (2 * p)))). + pose proof (QCauchySeq_bounded_prop xn id) as majx. + pose proof (QCauchySeq_bounded_prop yn id) as majy. + pose proof (QCauchySeq_bounded_prop zn id) as majz. + remember (QCauchySeq_bound xn id) as Ax. + remember (QCauchySeq_bound yn id) as Ay. + remember (QCauchySeq_bound zn id) as Az. + exists (fun p : positive => (2 * (Pos.max (Pos.max Ax Ay) Az) * (2 * p))%positive). intros p n k H H0. setoid_replace (xn n * (yn n + zn n) - - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * - yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat + - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * - zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q - with (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * - yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat) - + (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * - zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))%Q. + (xn ((Pos.max Ax Ay)~0 * k)%positive * + yn ((Pos.max Ax Ay)~0 * k)%positive + + xn ((Pos.max Ax Az)~0 * k)%positive * + zn ((Pos.max Ax Az)~0 * k)%positive))%Q + with (xn n * yn n - (xn ((Pos.max Ax Ay)~0 * k)%positive * + yn ((Pos.max Ax Ay)~0 * k)%positive) + + (xn n * zn n - xn ((Pos.max Ax Az)~0 * k)%positive * + zn ((Pos.max Ax Az)~0 * k)%positive))%Q. 2: ring. - apply (Qle_lt_trans _ (Qabs (xn n * yn n - (xn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat * - yn (Pos.to_nat (Pos.max Ax Ay)~0 * k)%nat)) - + Qabs (xn n * zn n - xn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat * - zn (Pos.to_nat (Pos.max Ax Az)~0 * k)%nat))). + apply (Qle_lt_trans _ (Qabs (xn n * yn n - (xn ((Pos.max Ax Ay)~0 * k)%positive * + yn ((Pos.max Ax Ay)~0 * k)%positive)) + + Qabs (xn n * zn n - xn ((Pos.max Ax Az)~0 * k)%positive * + zn ((Pos.max Ax Az)~0 * k)%positive))). apply Qabs_triangle. setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. apply Qplus_lt_le_compat. - + pose proof (CReal_mult_cauchy xn xn yn Ax Ay Pos.to_nat limx limy). - apply H1. apply majx. apply majy. rewrite max_l. - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H. apply le_refl. - rewrite max_l. apply (le_trans _ k). - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H0. - rewrite <- (mult_1_l k). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. - rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. - apply le_refl. apply le_refl. + + apply (CReal_mult_cauchy xn xn yn Ax Ay id limx limy). + intros. apply majx. exact limx. + refine (Pos.le_trans _ _ _ _ H1). discriminate. + apply majy. exact limy. + rewrite <- Pos.max_assoc. + rewrite (Pos.max_l ((2 * Pos.max Ax Ay * (2 * p)))). + 2: apply Pos.le_refl. + refine (Pos.le_trans _ _ _ _ H). apply Pos.max_lub. + apply (Pos.le_trans _ (2*1)). + apply Pos.le_refl. rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max (Pos.max Ax Ay) Az * (2 * p))%positive; discriminate. + rewrite <- Pos.mul_assoc, <- Pos.mul_assoc. + rewrite <- Pos.mul_le_mono_l, <- Pos.mul_le_mono_r. + apply Pos.le_max_l. + rewrite <- Pos.max_assoc. + rewrite (Pos.max_l ((2 * Pos.max Ax Ay * (2 * p)))). + 2: apply Pos.le_refl. + rewrite Pos.max_r. apply (Pos.le_trans _ (1*k)). + rewrite Pos.mul_1_l. refine (Pos.le_trans _ _ _ _ H0). + rewrite <- Pos.mul_assoc, <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + rewrite <- Pos.mul_le_mono_r. + apply Pos.le_max_l. apply Pos.mul_le_mono_r. discriminate. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max Ax Ay * (2 * p))%positive; discriminate. + apply Qlt_le_weak. - pose proof (CReal_mult_cauchy xn xn zn Ax Az Pos.to_nat limx limz). - apply H1. apply majx. apply majz. rewrite max_l. 2: apply le_refl. - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). - rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H. - rewrite max_l. apply (le_trans _ k). - apply (le_trans _ (Pos.to_nat (2 * Pos.max (Pos.max Ax Ay) Az * (2 * p)))). - rewrite (Pos.mul_comm 2). rewrite <- Pos.mul_assoc. - rewrite <- (Pos.mul_comm (Pos.max (Pos.max Ax Ay) Az)). - rewrite <- Pos.mul_assoc. - rewrite Pos2Nat.inj_mul. - rewrite (Pos2Nat.inj_mul (Pos.max (Pos.max Ax Ay) Az)). - apply Nat.mul_le_mono_nonneg. apply le_0_n. - rewrite <- Pos.max_assoc. rewrite (Pos.max_comm Ay Az). - rewrite Pos.max_assoc. apply Pos2Nat.inj_le. apply Pos.le_max_l. - apply le_0_n. apply le_refl. apply H0. - rewrite <- (mult_1_l k). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. - rewrite mult_1_r. apply Pos2Nat.is_pos. apply le_0_n. - apply le_refl. apply le_refl. + apply (CReal_mult_cauchy xn xn zn Ax Az id limx limz). + intros. apply majx. exact limx. + refine (Pos.le_trans _ _ _ _ H1). discriminate. + intros. apply majz. exact limz. exact H1. + rewrite <- Pos.max_assoc. + rewrite (Pos.max_l ((2 * Pos.max Ax Az * (2 * p)))). + 2: apply Pos.le_refl. + refine (Pos.le_trans _ _ _ _ H). apply Pos.max_lub. + apply (Pos.le_trans _ (2*1)). + apply Pos.le_refl. rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max (Pos.max Ax Ay) Az * (2 * p))%positive; discriminate. + rewrite <- Pos.mul_assoc, <- Pos.mul_assoc. + rewrite <- Pos.mul_le_mono_l, <- Pos.mul_le_mono_r. + rewrite <- Pos.max_assoc, (Pos.max_comm Ay Az), Pos.max_assoc. + apply Pos.le_max_l. + rewrite <- Pos.max_assoc. + rewrite (Pos.max_l ((2 * Pos.max Ax Az * (2 * p)))). + 2: apply Pos.le_refl. + rewrite Pos.max_r. apply (Pos.le_trans _ (1*k)). + rewrite Pos.mul_1_l. refine (Pos.le_trans _ _ _ _ H0). + rewrite <- Pos.mul_assoc, <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + rewrite <- Pos.mul_le_mono_r. + rewrite <- Pos.max_assoc, (Pos.max_comm Ay Az), Pos.max_assoc. + apply Pos.le_max_l. apply Pos.mul_le_mono_r. discriminate. + apply (Pos.le_trans _ (2*1)). apply Pos.le_refl. + rewrite <- Pos.mul_assoc, <- Pos.mul_le_mono_l. + destruct (Pos.max Ax Az * (2 * p))%positive; discriminate. + rewrite Qinv_plus_distr. unfold Qeq. reflexivity. Qed. @@ -500,34 +538,38 @@ Lemma CReal_mult_1_l : forall r: CReal, 1 * r == r. Proof. intros [rn limr]. split. - intros [m maj]. simpl in maj. - destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). - destruct (QCauchySeq_bounded rn Pos.to_nat limr). - simpl in maj. rewrite Qmult_1_l in maj. + rewrite Qmult_1_l in maj. + pose proof (QCauchySeq_bounded_prop (fun _ : positive => 1%Q) id (ConstCauchy 1)). + pose proof (QCauchySeq_bounded_prop rn id limr). + remember (QCauchySeq_bound (fun _ : positive => 1%Q) id) as x. + remember (QCauchySeq_bound rn id) as x0. specialize (limr m). apply (Qlt_not_le (2 # m) (1 # m)). - apply (Qlt_trans _ (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat)). + apply (Qlt_trans _ (rn m + - rn ((Pos.max x x0)~0 * m)%positive)). apply maj. - apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat m) - rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat))). - apply Qle_Qabs. apply limr. apply le_refl. - rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. - apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. + apply (Qle_lt_trans _ (Qabs (rn m - rn ((Pos.max x x0)~0 * m)%positive))). + apply Qle_Qabs. apply limr. apply Pos.le_refl. + rewrite <- (Pos.mul_1_l m). rewrite Pos.mul_assoc. unfold id. + apply Pos.mul_le_mono_r. discriminate. apply Z.mul_le_mono_nonneg. discriminate. discriminate. discriminate. apply Z.le_refl. - intros [m maj]. simpl in maj. - destruct (QCauchySeq_bounded (fun _ : nat => 1%Q) Pos.to_nat (ConstCauchy 1)). - destruct (QCauchySeq_bounded rn Pos.to_nat limr). + pose proof (QCauchySeq_bounded_prop (fun _ : positive => 1%Q) id (ConstCauchy 1)). + pose proof (QCauchySeq_bounded_prop rn id limr). + remember (QCauchySeq_bound (fun _ : positive => 1%Q) id) as x. + remember (QCauchySeq_bound rn id) as x0. simpl in maj. rewrite Qmult_1_l in maj. specialize (limr m). apply (Qlt_not_le (2 # m) (1 # m)). - apply (Qlt_trans _ (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m))). + apply (Qlt_trans _ (rn ((Pos.max x x0)~0 * m)%positive - rn m)). apply maj. - apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (Pos.max x x0)~0 * Pos.to_nat m)%nat - rn (Pos.to_nat m)))). + apply (Qle_lt_trans _ (Qabs (rn ((Pos.max x x0)~0 * m)%positive - rn m))). apply Qle_Qabs. apply limr. - rewrite <- (mult_1_l (Pos.to_nat m)). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg. auto. rewrite mult_1_r. - apply Pos2Nat.is_pos. apply le_0_n. apply le_refl. - apply le_refl. apply Z.mul_le_mono_nonneg. discriminate. discriminate. + rewrite <- (Pos.mul_1_l m). rewrite Pos.mul_assoc. unfold id. + apply Pos.mul_le_mono_r. discriminate. + apply Pos.le_refl. + apply Z.mul_le_mono_nonneg. discriminate. discriminate. discriminate. apply Z.le_refl. Qed. @@ -684,11 +726,11 @@ Proof. Qed. Lemma CReal_abs_appart_zero : forall (x : CReal) (n : positive), - Qlt (2#n) (Qabs (proj1_sig x (Pos.to_nat n))) + Qlt (2#n) (Qabs (proj1_sig x n)) -> 0 # x. Proof. intros. destruct x as [xn xcau]. simpl in H. - destruct (Qlt_le_dec 0 (xn (Pos.to_nat n))). + destruct (Qlt_le_dec 0 (xn n)). - left. exists n; simpl. rewrite Qabs_pos in H. ring_simplify. exact H. apply Qlt_le_weak. exact q. - right. exists n; simpl. rewrite Qabs_neg in H. @@ -705,39 +747,40 @@ Lemma CRealArchimedean Proof. (* Locate x within 1/4 and pick the first integer above this interval. *) intros [xn limx]. - pose proof (Qlt_floor (xn 4%nat + (1#4))). unfold inject_Z in H. - pose proof (Qfloor_le (xn 4%nat + (1#4))). unfold inject_Z in H0. - remember (Qfloor (xn 4%nat + (1#4)))%Z as n. + pose proof (Qlt_floor (xn 4%positive + (1#4))). unfold inject_Z in H. + pose proof (Qfloor_le (xn 4%positive + (1#4))). unfold inject_Z in H0. + remember (Qfloor (xn 4%positive + (1#4)))%Z as n. exists (n+1)%Z. split. - - assert (Qlt 0 ((n + 1 # 1) - (xn 4%nat + (1 # 4)))) as epsPos. + - assert (Qlt 0 ((n + 1 # 1) - (xn 4%positive + (1 # 4)))) as epsPos. { unfold Qminus. rewrite <- Qlt_minus_iff. exact H. } - destruct (Qarchimedean (/((1#2)*((n + 1 # 1) - (xn 4%nat + (1 # 4)))))) as [k kmaj]. + destruct (Qarchimedean (/((1#2)*((n + 1 # 1) - (xn 4%positive + (1 # 4)))))) as [k kmaj]. exists (Pos.max 4 k). simpl. - apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%nat + (1 # 4)))). + apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%positive + (1 # 4)))). + setoid_replace (Z.pos k # 1)%Q with (/(1#k))%Q in kmaj. 2: reflexivity. rewrite <- Qinv_lt_contravar in kmaj. 2: reflexivity. apply (Qle_lt_trans _ (2#k)). rewrite <- (Qmult_le_l _ _ (1#2)). setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. 2: reflexivity. - setoid_replace ((1 # 2) * (2 # Pos.max 4 k))%Q with (1#Pos.max 4 k)%Q. 2: reflexivity. + setoid_replace ((1 # 2) * (2 # Pos.max 4 k))%Q with (1#Pos.max 4 k)%Q. + 2: reflexivity. unfold Qle; simpl. apply Pos2Z.pos_le_pos. apply Pos.le_max_r. reflexivity. rewrite <- (Qmult_lt_l _ _ (1#2)). setoid_replace ((1 # 2) * (2 # k))%Q with (1#k)%Q. exact kmaj. reflexivity. reflexivity. rewrite <- (Qmult_0_r (1#2)). rewrite Qmult_lt_l. exact epsPos. reflexivity. - + rewrite <- (Qplus_lt_r _ _ (xn (Pos.to_nat (Pos.max 4 k)) - (n + 1 # 1) + (1#4))). + + rewrite <- (Qplus_lt_r _ _ (xn (Pos.max 4 k) - (n + 1 # 1) + (1#4))). ring_simplify. - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max 4 k)) - xn 4%nat))). + apply (Qle_lt_trans _ (Qabs (xn (Pos.max 4 k) - xn 4%positive))). apply Qle_Qabs. apply limx. - rewrite Pos2Nat.inj_max. apply Nat.le_max_l. apply le_refl. + apply Pos.le_max_l. apply Pos.le_refl. - apply (CReal_plus_lt_reg_l (-(2))). ring_simplify. exists 4%positive. simpl. rewrite <- Qinv_plus_distr. rewrite <- (Qplus_lt_r _ _ ((n#1) - (1#2))). ring_simplify. - apply (Qle_lt_trans _ (xn 4%nat + (1 # 4)) _ H0). + apply (Qle_lt_trans _ (xn 4%positive + (1 # 4)) _ H0). unfold Pos.to_nat; simpl. - rewrite <- (Qplus_lt_r _ _ (-xn 4%nat)). ring_simplify. + rewrite <- (Qplus_lt_r _ _ (-xn 4%positive)). ring_simplify. reflexivity. Defined. @@ -757,9 +800,10 @@ Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal, (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b + CRealLt c d. Proof. intros. + (* Convert to nat to use indefinite description. *) assert (exists n : nat, n <> O /\ - (Qlt (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n) - \/ Qlt (2 # Pos.of_nat n) (proj1_sig d n - proj1_sig c n))). + (Qlt (2 # Pos.of_nat n) (proj1_sig b (Pos.of_nat n) - proj1_sig a (Pos.of_nat n)) + \/ Qlt (2 # Pos.of_nat n) (proj1_sig d (Pos.of_nat n) - proj1_sig c (Pos.of_nat n)))). { destruct H. destruct H as [n maj]. exists (Pos.to_nat n). split. intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. inversion abs. left. rewrite Pos2Nat.id. apply maj. @@ -769,72 +813,73 @@ Proof. apply constructive_indefinite_ground_description_nat in H0. - destruct H0 as [n [nPos maj]]. destruct (Qlt_le_dec (2 # Pos.of_nat n) - (proj1_sig b n - proj1_sig a n)). - left. exists (Pos.of_nat n). rewrite Nat2Pos.id. apply q. apply nPos. - assert (2 # Pos.of_nat n < proj1_sig d n - proj1_sig c n)%Q. + (proj1_sig b (Pos.of_nat n) - proj1_sig a (Pos.of_nat n))). + left. exists (Pos.of_nat n). apply q. + assert (2 # Pos.of_nat n < proj1_sig d (Pos.of_nat n) - proj1_sig c (Pos.of_nat n))%Q. destruct maj. exfalso. - apply (Qlt_not_le (2 # Pos.of_nat n) (proj1_sig b n - proj1_sig a n)); assumption. - assumption. clear maj. right. exists (Pos.of_nat n). rewrite Nat2Pos.id. - apply H0. apply nPos. + apply (Qlt_not_le (2 # Pos.of_nat n) (proj1_sig b (Pos.of_nat n) - proj1_sig a (Pos.of_nat n))); assumption. + assumption. clear maj. right. exists (Pos.of_nat n). + apply H0. - clear H0. clear H. intro n. destruct n. right. intros [abs _]. exact (abs (eq_refl O)). - destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig b (S n) - proj1_sig a (S n))). + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig b (Pos.of_nat (S n)) - proj1_sig a (Pos.of_nat (S n)))). left. split. discriminate. left. apply q. - destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig d (S n) - proj1_sig c (S n))). + destruct (Qlt_le_dec (2 # Pos.of_nat (S n)) (proj1_sig d (Pos.of_nat (S n)) - proj1_sig c (Pos.of_nat (S n)))). left. split. discriminate. right. apply q0. right. intros [_ [abs|abs]]. apply (Qlt_not_le (2 # Pos.of_nat (S n)) - (proj1_sig b (S n) - proj1_sig a (S n))); assumption. + (proj1_sig b (Pos.of_nat (S n)) - proj1_sig a (Pos.of_nat (S n)))); assumption. apply (Qlt_not_le (2 # Pos.of_nat (S n)) - (proj1_sig d (S n) - proj1_sig c (S n))); assumption. + (proj1_sig d (Pos.of_nat (S n)) - proj1_sig c (Pos.of_nat (S n)))); assumption. Qed. -Lemma CRealShiftReal : forall (x : CReal) (k : nat), - QCauchySeq (fun n => proj1_sig x (plus n k)) Pos.to_nat. +Lemma CRealShiftReal : forall (x : CReal) (k : positive), + QCauchySeq (fun n => proj1_sig x (Pos.add n k)) id. Proof. - intros x k n p q H H0. + assert (forall p k : positive, (p <= p + k)%positive). + { intros. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_add. + apply (le_trans _ (Pos.to_nat p + 0)). + rewrite plus_0_r. apply le_refl. apply Nat.add_le_mono_l. + apply le_0_n. } + intros x k n p q H0 H1. destruct x as [xn cau]; unfold proj1_sig. - destruct k. rewrite plus_0_r. rewrite plus_0_r. apply cau; assumption. - specialize (cau (n + Pos.of_nat (S k))%positive (p + S k)%nat (q + S k)%nat). - apply (Qlt_trans _ (1 # n + Pos.of_nat (S k))). - apply cau. rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. - apply Nat.add_le_mono_r. apply H. discriminate. - rewrite Pos2Nat.inj_add. rewrite Nat2Pos.id. - apply Nat.add_le_mono_r. apply H0. discriminate. - apply Pos2Nat.inj_lt; simpl. rewrite Pos2Nat.inj_add. - rewrite <- (plus_0_r (Pos.to_nat n)). rewrite <- plus_assoc. - apply Nat.add_lt_mono_l. apply Pos2Nat.is_pos. + apply cau. apply (Pos.le_trans _ _ _ H0). apply H. + apply (Pos.le_trans _ _ _ H1). apply H. Qed. -Lemma CRealShiftEqual : forall (x : CReal) (k : nat), - CRealEq x (exist _ (fun n => proj1_sig x (plus n k)) (CRealShiftReal x k)). +Lemma CRealShiftEqual : forall (x : CReal) (k : positive), + CRealEq x (exist _ (fun n => proj1_sig x (Pos.add n k)) (CRealShiftReal x k)). Proof. intros. split. - intros [n maj]. destruct x as [xn cau]; simpl in maj. - specialize (cau n (Pos.to_nat n + k)%nat (Pos.to_nat n)). + specialize (cau n (n + k)%positive n). apply Qlt_not_le in maj. apply maj. clear maj. - apply (Qle_trans _ (Qabs (xn (Pos.to_nat n + k)%nat - xn (Pos.to_nat n)))). + apply (Qle_trans _ (Qabs (xn (n + k)%positive - xn n))). apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. - apply cau. rewrite <- (plus_0_r (Pos.to_nat n)). - rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. - apply le_refl. apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. - discriminate. + apply cau. unfold id. apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_add. + apply (le_trans _ (Pos.to_nat n + 0)). + rewrite plus_0_r. apply le_refl. apply Nat.add_le_mono_l. + apply le_0_n. apply Pos.le_refl. + apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. discriminate. - intros [n maj]. destruct x as [xn cau]; simpl in maj. - specialize (cau n (Pos.to_nat n) (Pos.to_nat n + k)%nat). + specialize (cau n n (n + k)%positive). apply Qlt_not_le in maj. apply maj. clear maj. - apply (Qle_trans _ (Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat n + k)%nat))). + apply (Qle_trans _ (Qabs (xn n - xn (n + k)%positive))). apply Qle_Qabs. apply (Qle_trans _ (1#n)). apply Zlt_le_weak. - apply cau. apply le_refl. rewrite <- (plus_0_r (Pos.to_nat n)). - rewrite <- plus_assoc. apply Nat.add_le_mono_l. apply le_0_n. + apply cau. apply Pos.le_refl. + apply Pos2Nat.inj_le. rewrite Pos2Nat.inj_add. + apply (le_trans _ (Pos.to_nat n + 0)). + rewrite plus_0_r. apply le_refl. apply Nat.add_le_mono_l. + apply le_0_n. apply Z.mul_le_mono_pos_r. apply Pos2Z.is_pos. discriminate. Qed. (* Find an equal negative real number, which rational sequence stays below 0, so that it can be inversed. *) Definition CRealNegShift (x : CReal) - : CRealLt x (inject_Q 0) - -> { y : prod positive CReal | CRealEq x (snd y) - /\ forall n:nat, Qlt (proj1_sig (snd y) n) (-1 # fst y) }. + : x < inject_Q 0 + -> { y : prod positive CReal + | x == (snd y) /\ forall n:positive, Qlt (proj1_sig (snd y) n) (-1 # fst y) }. Proof. intro xNeg. pose proof (CRealLt_aboveSig x (inject_Q 0)). @@ -842,36 +887,26 @@ Proof. pose proof (CRealShiftEqual x). destruct xNeg as [n maj], x as [xn cau]; simpl in maj. specialize (H n maj); simpl in H. - destruct (Qarchimedean (/ (0 - xn (Pos.to_nat n) - (2 # n)))) as [a _]. + destruct (Qarchimedean (/ (0 - xn n - (2 # n)))) as [a _]. remember (Pos.max n a~0) as k. clear Heqk. clear maj. clear n. - exists (pair k - (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). + exists (pair k (exist _ (fun n => xn (Pos.add n k)) (H0 k))). split. apply H1. intro n. simpl. apply Qlt_minus_iff. - destruct n. - - specialize (H k). - unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. - unfold Qminus. rewrite Qplus_comm. - apply (Qlt_trans _ (- xn (Pos.to_nat k)%nat - (2 #k))). apply H. - unfold Qminus. simpl. apply Qplus_lt_r. - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. apply Pos.le_refl. - - apply (Qlt_trans _ (-(2 # k) - xn (S n + Pos.to_nat k)%nat)). - rewrite <- (Nat2Pos.id (S n)). rewrite <- Pos2Nat.inj_add. - specialize (H (Pos.of_nat (S n) + k)%positive). - unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. - unfold Qminus. rewrite Qplus_comm. apply H. apply Pos2Nat.inj_le. - rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. - apply Nat.add_le_mono_r. apply le_0_n. discriminate. - apply Qplus_lt_l. - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. + apply (Qlt_trans _ (-(2 # k) - xn (n + k)%positive)). + specialize (H (n + k)%positive). + unfold Qminus in H. rewrite Qplus_0_l in H. apply Qlt_minus_iff in H. + unfold Qminus. rewrite Qplus_comm. apply H. apply Pos2Nat.inj_le. + rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. + apply Nat.add_le_mono_r. apply le_0_n. + apply Qplus_lt_l. + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. Qed. Definition CRealPosShift (x : CReal) : inject_Q 0 < x - -> { y : prod positive CReal | CRealEq x (snd y) - /\ forall n:nat, Qlt (1 # fst y) (proj1_sig (snd y) n) }. + -> { y : prod positive CReal + | x == (snd y) /\ forall n:positive, Qlt (1 # fst y) (proj1_sig (snd y) n) }. Proof. intro xPos. pose proof (CRealLt_aboveSig (inject_Q 0) x). @@ -879,66 +914,57 @@ Proof. pose proof (CRealShiftEqual x). destruct xPos as [n maj], x as [xn cau]; simpl in maj. simpl in H. specialize (H n). - destruct (Qarchimedean (/ (xn (Pos.to_nat n) - 0 - (2 # n)))) as [a _]. + destruct (Qarchimedean (/ (xn n - 0 - (2 # n)))) as [a _]. specialize (H maj); simpl in H. remember (Pos.max n a~0) as k. clear Heqk. clear maj. clear n. - exists (pair k - (exist _ (fun n => xn (plus n (Pos.to_nat k))) (H0 (Pos.to_nat k)))). + exists (pair k (exist _ (fun n => xn (Pos.add n k)) (H0 k))). split. apply H1. intro n. simpl. apply Qlt_minus_iff. - destruct n. - - specialize (H k). - unfold Qminus in H. rewrite Qplus_0_r in H. - simpl. rewrite <- Qlt_minus_iff. - apply (Qlt_trans _ (2 #k)). - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. apply H. apply Pos.le_refl. - - rewrite <- Qlt_minus_iff. apply (Qlt_trans _ (2 # k)). - apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. - reflexivity. specialize (H (Pos.of_nat (S n) + k)%positive). - unfold Qminus in H. rewrite Qplus_0_r in H. - rewrite Pos2Nat.inj_add in H. rewrite Nat2Pos.id in H. - apply H. apply Pos2Nat.inj_le. - rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. - apply Nat.add_le_mono_r. apply le_0_n. discriminate. + rewrite <- Qlt_minus_iff. apply (Qlt_trans _ (2 # k)). + apply Z.mul_lt_mono_pos_r. simpl. apply Pos2Z.is_pos. + reflexivity. specialize (H (n + k)%positive). + unfold Qminus in H. rewrite Qplus_0_r in H. + apply H. apply Pos2Nat.inj_le. + rewrite <- (plus_0_l (Pos.to_nat k)). rewrite Pos2Nat.inj_add. + apply Nat.add_le_mono_r. apply le_0_n. Qed. -Lemma CReal_inv_neg : forall (yn : nat -> Q) (k : positive), - (QCauchySeq yn Pos.to_nat) - -> (forall n : nat, yn n < -1 # k)%Q - -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. +Lemma CReal_inv_neg : forall (yn : positive -> Q) (k : positive), + (QCauchySeq yn id) + -> (forall n : positive, yn n < -1 # k)%Q + -> QCauchySeq (fun n : positive => / yn (k ^ 2 * n)%positive) id. Proof. (* Prove the inverse sequence is Cauchy *) intros yn k cau maj n p q H0 H1. - setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - - / yn (Pos.to_nat k ^ 2 * q)%nat)%Q - with ((yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) - / (yn (Pos.to_nat k ^ 2 * q)%nat * - yn (Pos.to_nat k ^ 2 * p)%nat)). - + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) + setoid_replace (/ yn (k ^ 2 * p)%positive - + / yn (k ^ 2 * q)%positive)%Q + with ((yn (k ^ 2 * q)%positive - + yn (k ^ 2 * p)%positive) + / (yn (k ^ 2 * q)%positive * + yn (k ^ 2 * p)%positive)). + + apply (Qle_lt_trans _ (Qabs (yn (k ^ 2 * q)%positive + - yn (k ^ 2 * p)%positive) / (1 # (k^2)))). assert (1 # k ^ 2 - < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. + < Qabs (yn (k ^ 2 * q)%positive * yn (k ^ 2 * p)%positive))%Q. { rewrite Qabs_Qmult. unfold "^"%positive; simpl. rewrite factorDenom. rewrite Pos.mul_1_r. - apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). + apply (Qlt_trans _ ((1#k) * Qabs (yn (k * (k * 1) * p)%positive))). apply Qmult_lt_l. reflexivity. rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + specialize (maj (k * (k * 1) * p)%positive). apply Qlt_minus_iff in maj. apply Qlt_minus_iff. rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. - apply maj. discriminate. + apply maj. discriminate. rewrite Pos.mul_1_r. apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + specialize (maj (k * k * p)%positive). apply Qlt_minus_iff in maj. apply Qlt_minus_iff. - rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. - reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. + rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. + apply maj. reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. apply maj. discriminate. rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + specialize (maj (k * k * q)%positive). apply Qlt_minus_iff in maj. apply Qlt_minus_iff. rewrite Qplus_comm. setoid_replace (-(1#k))%Q with (-1 # k)%Q. apply maj. reflexivity. apply (Qle_trans _ (-1 # k)). apply Zlt_le_weak. @@ -952,66 +978,56 @@ Proof. reflexivity. rewrite Qmult_1_l. apply H. apply Qabs_nonneg. simpl in maj. specialize (cau (n * (k^2))%positive - (Pos.to_nat k ^ 2 * q)%nat - (Pos.to_nat k ^ 2 * p)%nat). + (k ^ 2 * q)%positive + (k ^ 2 * p)%positive). apply Qlt_shift_div_r. reflexivity. apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. + rewrite Pos.mul_comm. + unfold "^"%positive. simpl. + unfold id. rewrite Pos.mul_1_r. + rewrite <- Pos.mul_le_mono_l. exact H1. + unfold id. rewrite Pos.mul_comm. + apply Pos.mul_le_mono_l. exact H0. rewrite factorDenom. apply Qle_refl. + field. split. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + specialize (maj (k ^ 2 * p)%positive). rewrite abs in maj. inversion maj. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + specialize (maj (k ^ 2 * q)%positive). rewrite abs in maj. inversion maj. Qed. -Lemma CReal_inv_pos : forall (yn : nat -> Q) (k : positive), - (QCauchySeq yn Pos.to_nat) - -> (forall n : nat, 1 # k < yn n)%Q - -> QCauchySeq (fun n : nat => / yn (Pos.to_nat k ^ 2 * n)%nat) Pos.to_nat. +Lemma CReal_inv_pos : forall (yn : positive -> Q) (k : positive), + (QCauchySeq yn id) + -> (forall n : positive, 1 # k < yn n)%Q + -> QCauchySeq (fun n : positive => / yn (k ^ 2 * n)%positive) id. Proof. intros yn k cau maj n p q H0 H1. - setoid_replace (/ yn (Pos.to_nat k ^ 2 * p)%nat - - / yn (Pos.to_nat k ^ 2 * q)%nat)%Q - with ((yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) - / (yn (Pos.to_nat k ^ 2 * q)%nat * - yn (Pos.to_nat k ^ 2 * p)%nat)). - + apply (Qle_lt_trans _ (Qabs (yn (Pos.to_nat k ^ 2 * q)%nat - - yn (Pos.to_nat k ^ 2 * p)%nat) + setoid_replace (/ yn (k ^ 2 * p)%positive - + / yn (k ^ 2 * q)%positive)%Q + with ((yn (k ^ 2 * q)%positive - + yn (k ^ 2 * p)%positive) + / (yn (k ^ 2 * q)%positive * + yn (k ^ 2 * p)%positive)). + + apply (Qle_lt_trans _ (Qabs (yn (k ^ 2 * q)%positive + - yn (k ^ 2 * p)%positive) / (1 # (k^2)))). assert (1 # k ^ 2 - < Qabs (yn (Pos.to_nat k ^ 2 * q)%nat * yn (Pos.to_nat k ^ 2 * p)%nat))%Q. + < Qabs (yn (k ^ 2 * q)%positive * yn (k ^ 2 * p)%positive))%Q. { rewrite Qabs_Qmult. unfold "^"%positive; simpl. rewrite factorDenom. rewrite Pos.mul_1_r. - apply (Qlt_trans _ ((1#k) * Qabs (yn (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat))). + apply (Qlt_trans _ ((1#k) * Qabs (yn (k * k * p)%positive))). apply Qmult_lt_l. reflexivity. rewrite Qabs_pos. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + specialize (maj (k * k * p)%positive). apply maj. apply (Qle_trans _ (1 # k)). discriminate. apply Zlt_le_weak. apply maj. apply Qmult_lt_r. apply (Qlt_trans 0 (1#k)). reflexivity. rewrite Qabs_pos. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + specialize (maj (k * k * p)%positive). apply maj. apply (Qle_trans _ (1 # k)). discriminate. apply Zlt_le_weak. apply maj. rewrite Qabs_pos. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + specialize (maj (k * k * q)%positive). apply maj. apply (Qle_trans _ (1 # k)). discriminate. apply Zlt_le_weak. apply maj. } unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. @@ -1023,32 +1039,20 @@ Proof. reflexivity. rewrite Qmult_1_l. apply H. apply Qabs_nonneg. simpl in maj. specialize (cau (n * (k^2))%positive - (Pos.to_nat k ^ 2 * q)%nat - (Pos.to_nat k ^ 2 * p)%nat). + (k ^ 2 * q)%positive + (k ^ 2 * p)%positive). apply Qlt_shift_div_r. reflexivity. apply (Qlt_le_trans _ (1 # n * k ^ 2)). apply cau. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive. simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (q+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. - rewrite Pos2Nat.inj_mul. rewrite mult_comm. - unfold "^"%positive; simpl. rewrite Pos2Nat.inj_mul. - rewrite <- mult_assoc. rewrite <- mult_assoc. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - rewrite (mult_1_r). rewrite Pos.mul_1_r. - apply Nat.mul_le_mono_nonneg_l. apply le_0_n. - apply (le_trans _ (p+0)). rewrite plus_0_r. assumption. - rewrite plus_0_r. apply le_refl. + rewrite Pos.mul_comm. unfold id. + apply Pos.mul_le_mono_l. exact H1. + unfold id. rewrite Pos.mul_comm. + apply Pos.mul_le_mono_l. exact H0. rewrite factorDenom. apply Qle_refl. + field. split. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + specialize (maj (k ^ 2 * p)%positive). rewrite abs in maj. inversion maj. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + specialize (maj (k ^ 2 * q)%positive). rewrite abs in maj. inversion maj. Qed. @@ -1057,11 +1061,11 @@ Proof. destruct xnz as [xNeg | xPos]. - destruct (CRealNegShift x xNeg) as [[k y] [_ maj]]. destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. - exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). + exists (fun n:positive => Qinv (yn (Pos.mul (k^2) n)%positive)). apply (CReal_inv_neg yn). apply cau. apply maj. - destruct (CRealPosShift x xPos) as [[k y] [_ maj]]. destruct y as [yn cau]; unfold proj1_sig, snd, fst in maj. - exists (fun n => Qinv (yn (mult (Pos.to_nat k^2) n))). + exists (fun n => Qinv (yn (Pos.mul (k^2) n))). apply (CReal_inv_pos yn). apply cau. apply maj. Defined. @@ -1077,19 +1081,20 @@ Proof. - destruct (CRealPosShift r c) as [[k rpos] [req maj]]. clear req. destruct rpos as [rn cau]; simpl in maj. unfold CRealLt; simpl. - destruct (Qarchimedean (rn 1%nat)) as [A majA]. + destruct (Qarchimedean (rn 1%positive)) as [A majA]. exists (2 * (A + 1))%positive. unfold Qminus. rewrite Qplus_0_r. - rewrite <- (Qmult_1_l (Qinv (rn (Pos.to_nat k * (Pos.to_nat k * 1) * Pos.to_nat (2 * (A + 1)))%nat))). + rewrite <- (Qmult_1_l (Qinv (rn (k * (k * 1) * (2 * (A + 1)))%positive))). apply Qlt_shift_div_l. apply (Qlt_trans 0 (1#k)). reflexivity. apply maj. rewrite <- (Qmult_inv_r (Z.pos A + 1 # 1)). setoid_replace (2 # 2 * (A + 1))%Q with (Qinv (Z.pos A + 1 # 1)). 2: reflexivity. rewrite Qmult_comm. apply Qmult_lt_r. reflexivity. - rewrite mult_1_r. rewrite <- Pos2Nat.inj_mul. rewrite <- Pos2Nat.inj_mul. - rewrite <- (Qplus_lt_l _ _ (- rn 1%nat)). - apply (Qle_lt_trans _ (Qabs (rn (Pos.to_nat (k * k * (2 * (A + 1)))) + - rn 1%nat))). + rewrite Pos.mul_1_r. + rewrite <- (Qplus_lt_l _ _ (- rn 1%positive)). + apply (Qle_lt_trans _ (Qabs (rn (k * k * (2 * (A + 1)))%positive + - rn 1%positive))). apply Qle_Qabs. apply (Qlt_le_trans _ 1). apply cau. - apply Pos2Nat.is_pos. apply le_refl. + destruct (k * k * (2 * (A + 1)))%positive; discriminate. + apply Pos.le_refl. rewrite <- Qinv_plus_distr. rewrite <- (Qplus_comm 1). rewrite <- Qplus_0_r. rewrite <- Qplus_assoc. rewrite <- Qplus_assoc. rewrite Qplus_le_r. rewrite Qplus_0_l. apply Qlt_le_weak. @@ -1097,32 +1102,30 @@ Proof. intro abs. inversion abs. Qed. -Lemma CReal_linear_shift : forall (x : CReal) (k : nat), - le 1 k -> QCauchySeq (fun n => proj1_sig x (k * n)%nat) Pos.to_nat. -Proof. - intros [xn limx] k lek p n m H H0. unfold proj1_sig. - apply limx. apply (le_trans _ n). apply H. - rewrite <- (mult_1_l n). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg_r. apply le_0_n. - rewrite mult_1_r. apply lek. apply (le_trans _ m). apply H0. - rewrite <- (mult_1_l m). rewrite mult_assoc. - apply Nat.mul_le_mono_nonneg_r. apply le_0_n. - rewrite mult_1_r. apply lek. +Lemma CReal_linear_shift : forall (x : CReal) (k : positive), + QCauchySeq (fun n => proj1_sig x (k * n)%positive) id. +Proof. + intros [xn limx] k p n m H H0. unfold proj1_sig. + apply limx. apply (Pos.le_trans _ n). apply H. + rewrite <- (Pos.mul_1_l n). rewrite Pos.mul_assoc. + apply Pos.mul_le_mono_r. destruct (k*1)%positive; discriminate. + apply (Pos.le_trans _ (1*m)). exact H0. + apply Pos.mul_le_mono_r. destruct k; discriminate. Qed. -Lemma CReal_linear_shift_eq : forall (x : CReal) (k : nat) (kPos : le 1 k), +Lemma CReal_linear_shift_eq : forall (x : CReal) (k : positive), CRealEq x - (exist (fun n : nat -> Q => QCauchySeq n Pos.to_nat) - (fun n : nat => proj1_sig x (k * n)%nat) (CReal_linear_shift x k kPos)). + (exist (fun n : positive -> Q => QCauchySeq n id) + (fun n : positive => proj1_sig x (k * n)%positive) (CReal_linear_shift x k)). Proof. intros. apply CRealEq_diff. intro n. destruct x as [xn limx]; unfold proj1_sig. - specialize (limx n (Pos.to_nat n) (k * Pos.to_nat n)%nat). + specialize (limx n n (k * n)%positive). apply (Qle_trans _ (1 # n)). apply Qlt_le_weak. apply limx. - apply le_refl. rewrite <- (mult_1_l (Pos.to_nat n)). - rewrite mult_assoc. apply Nat.mul_le_mono_nonneg_r. apply le_0_n. - rewrite mult_1_r. apply kPos. apply Z.mul_le_mono_nonneg_r. - discriminate. discriminate. + apply Pos.le_refl. rewrite <- (Pos.mul_1_l n). + rewrite Pos.mul_assoc. apply Pos.mul_le_mono_r. + destruct (k*1)%positive; discriminate. + apply Z.mul_le_mono_nonneg_r. discriminate. discriminate. Qed. Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), @@ -1135,51 +1138,55 @@ Proof. apply (QSeqEquivEx_trans _ (proj1_sig (CReal_mult ((let (yn, cau) as s - return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in - fun maj0 : forall n : nat, yn n < -1 # k => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n))%nat) + return ((forall n : positive, proj1_sig s n < -1 # k) -> CReal) := rneg in + fun maj0 : forall n : positive, yn n < -1 # k => + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => Qinv (yn (k * (k * 1) * n))%positive) (CReal_inv_neg yn k cau maj0)) maj) rneg)))%Q. + apply CRealEq_modindep. apply CRealEq_diff. apply CReal_mult_proper_l. apply req. - + assert (le 1 (Pos.to_nat k * (Pos.to_nat k * 1))%nat). rewrite mult_1_r. - rewrite <- Pos2Nat.inj_mul. apply Pos2Nat.is_pos. - apply (QSeqEquivEx_trans _ + + apply (QSeqEquivEx_trans _ (proj1_sig (CReal_mult ((let (yn, cau) as s - return ((forall n : nat, proj1_sig s n < -1 # k) -> CReal) := rneg in - fun maj0 : forall n : nat, yn n < -1 # k => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + return ((forall n : positive, proj1_sig s n < -1 # k) -> CReal) := rneg in + fun maj0 : forall n : positive, yn n < -1 # k => + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => Qinv (yn (k * (k * 1) * n)%positive)) (CReal_inv_neg yn k cau maj0)) maj) - (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. + (exist _ (fun n => proj1_sig rneg (k * (k * 1) * n)%positive) (CReal_linear_shift rneg _)))))%Q. apply CRealEq_modindep. apply CRealEq_diff. apply CReal_mult_proper_l. apply CReal_linear_shift_eq. destruct r as [rn limr], rneg as [rnn limneg]; simpl. - destruct (QCauchySeq_bounded - (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) - Pos.to_nat (CReal_inv_neg rnn k limneg maj)). - destruct (QCauchySeq_bounded - (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) - Pos.to_nat + pose proof (QCauchySeq_bounded_prop + (fun n : positive => Qinv (rnn (k * (k * 1) * n)%positive)) + id (CReal_inv_neg rnn k limneg maj)). + pose proof (QCauchySeq_bounded_prop + (fun n : positive => rnn (k * (k * 1) * n)%positive) + id (CReal_linear_shift - (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) - (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. - exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. + (exist (fun x0 : positive -> Q => QCauchySeq x0 id) rnn limneg) + (k * (k * 1)))) ; simpl. + remember (QCauchySeq_bound + (fun n0 : positive => / rnn (k * (k * 1) * n0)%positive)%Q + id) as x. + remember (QCauchySeq_bound + (fun n0 : positive => rnn (k * (k * 1) * n0)%positive) + id) as x0. + exists (fun n => 1%positive). intros p n m H2 H3. rewrite Qmult_comm. rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. reflexivity. intro abs. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) - * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). - simpl in maj. rewrite abs in maj. inversion maj. + unfold snd,fst, proj1_sig in maj. + specialize (maj (k * (k * 1) * (Pos.max x x0 * n)~0)%positive). + rewrite abs in maj. inversion maj. - (* r > 0 *) destruct (CRealPosShift r c) as [[k rneg] [req maj]]. simpl in req. apply CRealEq_diff. apply CRealEq_modindep. apply (QSeqEquivEx_trans _ (proj1_sig (CReal_mult ((let (yn, cau) as s - return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in - fun maj0 : forall n : nat, 1 # k < yn n => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + return ((forall n : positive, 1 # k < proj1_sig s n) -> CReal) := rneg in + fun maj0 : forall n : positive, 1 # k < yn n => + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => Qinv (yn (k * (k * 1) * n)%positive)) (CReal_inv_pos yn k cau maj0)) maj) rneg)))%Q. + apply CRealEq_modindep. apply CRealEq_diff. apply CReal_mult_proper_l. apply req. @@ -1188,29 +1195,34 @@ Proof. apply (QSeqEquivEx_trans _ (proj1_sig (CReal_mult ((let (yn, cau) as s - return ((forall n : nat, 1 # k < proj1_sig s n) -> CReal) := rneg in - fun maj0 : forall n : nat, 1 # k < yn n => - exist (fun x : nat -> Q => QCauchySeq x Pos.to_nat) - (fun n : nat => Qinv (yn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) + return ((forall n : positive, 1 # k < proj1_sig s n) -> CReal) := rneg in + fun maj0 : forall n : positive, 1 # k < yn n => + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => Qinv (yn (k * (k * 1) * n)%positive)) (CReal_inv_pos yn k cau maj0)) maj) - (exist _ (fun n => proj1_sig rneg (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) (CReal_linear_shift rneg _ H)))))%Q. + (exist _ (fun n => proj1_sig rneg (k * (k * 1) * n)%positive) (CReal_linear_shift rneg _)))))%Q. apply CRealEq_modindep. apply CRealEq_diff. apply CReal_mult_proper_l. apply CReal_linear_shift_eq. destruct r as [rn limr], rneg as [rnn limneg]; simpl. - destruct (QCauchySeq_bounded - (fun n : nat => Qinv (rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat)) - Pos.to_nat (CReal_inv_pos rnn k limneg maj)). - destruct (QCauchySeq_bounded - (fun n : nat => rnn (Pos.to_nat k * (Pos.to_nat k * 1) * n)%nat) - Pos.to_nat + pose proof (QCauchySeq_bounded_prop + (fun n : positive => Qinv (rnn (k * (k * 1) * n)%positive)) + id (CReal_inv_pos rnn k limneg maj)). + pose proof (QCauchySeq_bounded_prop + (fun n : positive => rnn (k * (k * 1) * n)%positive) + id (CReal_linear_shift - (exist (fun x0 : nat -> Q => QCauchySeq x0 Pos.to_nat) rnn limneg) - (Pos.to_nat k * (Pos.to_nat k * 1)) H)) ; simpl. - exists (fun n => 1%nat). intros p n m H0 H1. rewrite Qmult_comm. + (exist (fun x0 : positive -> Q => QCauchySeq x0 id) rnn limneg) + (k * (k * 1)))) ; simpl. + remember (QCauchySeq_bound + (fun n0 : positive => / rnn (k * (k * 1) * n0)%positive) + id)%Q as x. + remember (QCauchySeq_bound + (fun n0 : positive => rnn (k * (k * 1) * n0)%positive) + id) as x0. + exists (fun n => 1%positive). intros p n m H2 H3. rewrite Qmult_comm. rewrite Qmult_inv_r. unfold Qminus. rewrite Qplus_opp_r. reflexivity. intro abs. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) - * (Pos.to_nat (Pos.max x x0)~0 * n))%nat). + specialize (maj ((k * (k * 1) * (Pos.max x x0 * n)~0)%positive)). simpl in maj. rewrite abs in maj. inversion maj. Qed. @@ -1293,12 +1305,13 @@ Proof. apply CRealLt_above in c. destruct c as [i imaj]. simpl in imaj. apply CRealLt_above in c0. destruct c0 as [j jmaj]. simpl in jmaj. pose proof (CReal_abs_appart_zero y). - destruct x as [xn xcau], y as [yn ycau]. simpl in kmaj. - destruct (QCauchySeq_bounded xn Pos.to_nat xcau) as [a amaj], - (QCauchySeq_bounded yn Pos.to_nat ycau) as [b bmaj]; simpl in kmaj. - clear amaj bmaj. simpl in imaj, jmaj. simpl in H0. + destruct x as [xn xcau], y as [yn ycau]. + unfold CReal_mult, proj1_sig in kmaj. + remember (QCauchySeq_bound xn id) as a. + remember (QCauchySeq_bound yn id) as b. + simpl in imaj, jmaj. simpl in H0. specialize (kmaj (Pos.max k (Pos.max i j)) (Pos.le_max_l _ _)). - destruct (H0 ((Pos.max a b)~0 * (Pos.max k (Pos.max i j)))%positive). + destruct (H0 (2*(Pos.max a b) * (Pos.max k (Pos.max i j)))%positive). - apply (Qlt_trans _ (2#k)). + unfold Qlt. rewrite <- Z.mul_lt_mono_pos_l. 2: reflexivity. unfold Qden. apply Pos2Z.pos_lt_pos. @@ -1309,11 +1322,8 @@ Proof. fold (2*Pos.max a b)%positive. rewrite Pos2Nat.inj_mul. apply Nat.lt_1_mul_pos. auto. apply Pos2Nat.is_pos. + apply (Qlt_le_trans _ _ _ kmaj). unfold Qminus. rewrite Qplus_0_r. - rewrite <- (Qmult_1_l (Qabs (yn (Pos.to_nat ((Pos.max a b)~0 * Pos.max k (Pos.max i j)))))). + rewrite <- (Qmult_1_l (Qabs (yn (2*(Pos.max a b) * Pos.max k (Pos.max i j))%positive))). apply (Qle_trans _ _ _ (Qle_Qabs _)). rewrite Qabs_Qmult. - replace (Pos.to_nat (Pos.max a b)~0 * Pos.to_nat (Pos.max k (Pos.max i j)))%nat - with (Pos.to_nat ((Pos.max a b)~0 * Pos.max k (Pos.max i j))). - 2: apply Pos2Nat.inj_mul. apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply Qabs_Qle_condition. split. apply Qlt_le_weak. apply Qlt_minus_iff, (Qlt_trans _ (2#j)). @@ -1322,18 +1332,14 @@ Proof. rewrite Pos.mul_1_l. apply (Pos.le_trans _ (Pos.max i j) _ (Pos.le_max_r _ _)). apply Pos.le_max_r. - apply Pos2Nat.inj_le. do 2 rewrite Pos2Nat.inj_mul. - rewrite <- Nat.mul_le_mono_pos_r. 2: apply Pos2Nat.is_pos. - apply Pos2Nat.is_pos. + rewrite <- Pos.mul_le_mono_r. discriminate. apply Qlt_le_weak. apply Qlt_minus_iff, (Qlt_trans _ (2#i)). reflexivity. apply imaj. apply (Pos.le_trans _ (1 * Pos.max k (Pos.max i j))). rewrite Pos.mul_1_l. apply (Pos.le_trans _ (Pos.max i j) _ (Pos.le_max_l _ _)). apply Pos.le_max_r. - apply Pos2Nat.inj_le. do 2 rewrite Pos2Nat.inj_mul. - rewrite <- Nat.mul_le_mono_pos_r. 2: apply Pos2Nat.is_pos. - apply Pos2Nat.is_pos. + rewrite <- Pos.mul_le_mono_r. discriminate. - left. apply (CReal_mult_lt_reg_r (exist _ yn ycau) _ _ c). rewrite CReal_mult_0_l. exact H. - right. apply (CReal_mult_lt_reg_r (CReal_opp (exist _ yn ycau))). @@ -1357,16 +1363,14 @@ Proof. Qed. Lemma CReal_invQ : forall (b : positive) (pos : Qlt 0 (Z.pos b # 1)), - CRealEq (CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos))) - (inject_Q (1 # b)). + CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos)) + == inject_Q (1 # b). Proof. intros. apply (CReal_mult_eq_reg_l (inject_Q (Z.pos b # 1))). - right. apply CReal_injectQPos. exact pos. - rewrite CReal_mult_comm, CReal_inv_l. - apply CRealEq_diff. intro n. simpl; - destruct (QCauchySeq_bounded (fun _ : nat => 1 # b)%Q Pos.to_nat (ConstCauchy (1 # b))), - (QCauchySeq_bounded (fun _ : nat => Z.pos b # 1)%Q Pos.to_nat (ConstCauchy (Z.pos b # 1))); simpl. + apply CRealEq_diff. intro n. simpl. do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag. discriminate. Qed. @@ -1376,11 +1380,11 @@ Proof. (* Locate a and b at the index given by a<b, and pick the middle rational number. *) intros [p pmaj]. - exists ((proj1_sig a (Pos.to_nat p) + proj1_sig b (Pos.to_nat p)) * (1#2))%Q. + exists ((proj1_sig a p + proj1_sig b p) * (1#2))%Q. split. - apply (CReal_le_lt_trans _ _ _ (inject_Q_compare a p)). apply inject_Q_lt. apply (Qmult_lt_l _ _ 2). reflexivity. - apply (Qplus_lt_l _ _ (-2*proj1_sig a (Pos.to_nat p))). + apply (Qplus_lt_l _ _ (-2*proj1_sig a p)). field_simplify. field_simplify in pmaj. setoid_replace (-2#2)%Q with (-1)%Q. 2: reflexivity. setoid_replace (2*(1#p))%Q with (2#p)%Q. 2: reflexivity. @@ -1388,12 +1392,12 @@ Proof. - apply (CReal_plus_lt_reg_l (-b)). rewrite CReal_plus_opp_l. apply (CReal_plus_lt_reg_r - (-inject_Q ((proj1_sig a (Pos.to_nat p) + proj1_sig b (Pos.to_nat p)) * (1 # 2)))). + (-inject_Q ((proj1_sig a p + proj1_sig b p) * (1 # 2)))). rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r, CReal_plus_0_l. rewrite <- opp_inject_Q. apply (CReal_le_lt_trans _ _ _ (inject_Q_compare (-b) p)). apply inject_Q_lt. apply (Qmult_lt_l _ _ 2). reflexivity. - apply (Qplus_lt_l _ _ (2*proj1_sig b (Pos.to_nat p))). + apply (Qplus_lt_l _ _ (2*proj1_sig b p)). destruct b as [bn bcau]; simpl. simpl in pmaj. field_simplify. field_simplify in pmaj. setoid_replace (-2#2)%Q with (-1)%Q. 2: reflexivity. @@ -1405,12 +1409,8 @@ Lemma inject_Q_mult : forall q r : Q, Proof. split. - intros [n maj]. simpl in maj. - destruct (QCauchySeq_bounded (fun _ : nat => q) Pos.to_nat (ConstCauchy q)). - destruct (QCauchySeq_bounded (fun _ : nat => r) Pos.to_nat (ConstCauchy r)). simpl in maj. ring_simplify in maj. discriminate maj. - intros [n maj]. simpl in maj. - destruct (QCauchySeq_bounded (fun _ : nat => q) Pos.to_nat (ConstCauchy q)). - destruct (QCauchySeq_bounded (fun _ : nat => r) Pos.to_nat (ConstCauchy r)). simpl in maj. ring_simplify in maj. discriminate maj. Qed. diff --git a/theories/Reals/Cauchy/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index 51fd0dd7f9..6f36e888ed 100644 --- a/theories/Reals/Cauchy/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -47,44 +47,6 @@ Proof. intros. apply (seq_cv_proper un y). exact H0. symmetry. exact H. Qed. -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. - 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. - - (* Sharpen the archimedean property : constructive versions of the usual floor and ceiling functions. *) @@ -157,15 +119,6 @@ Proof. unfold Qeq; simpl. rewrite Pos.mul_1_r, Z.mul_1_r. reflexivity. Qed. -Definition RQ_limit : forall (x : CReal) (n:nat), - { q:Q & x < inject_Q q < x + inject_Q (1 # Pos.of_nat n) }. -Proof. - intros x n. apply (FQ_dense x (x + inject_Q (1 # Pos.of_nat n))). - rewrite <- (CReal_plus_0_r x). rewrite CReal_plus_assoc. - apply CReal_plus_lt_compat_l. rewrite CReal_plus_0_l. apply inject_Q_lt. - reflexivity. -Qed. - Lemma Qabs_Rabs : forall q : Q, inject_Q (Qabs q) == CReal_abs (inject_Q q). Proof. @@ -176,173 +129,86 @@ Proof. 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 - -> (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 - -> Un_cauchy_Q (fun n:nat => let (l,_) := RQ_limit (xn n) n in l). -Proof. - intros xn H p. specialize (H (2 * p)%positive) as [k cv]. - exists (max k (2 * Pos.to_nat p)). intros. - specialize (cv p0 q - (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 (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 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 rmaj. - apply CRealLt_asym. - rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. - 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 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 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 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 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 (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 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. - 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 - -> seq_cv (fun n => inject_Q (qn n)) x. +(* For instance the rational sequence 1/n converges to 0. *) +Lemma CReal_cv_self : forall (x : CReal) (n : positive), + CReal_abs (x - inject_Q (proj1_sig x n)) <= inject_Q (1#n). Proof. - intros qn x cvmod H p. - specialize (H (2*p)%positive). exists (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. - setoid_replace (proj1_sig (CReal_plus (inject_Q (qn p0)) (CReal_opp x)) (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))) - with (qn p0 - proj1_sig x (2 * (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive)))))%nat)%Q. - 2: destruct x; reflexivity. - apply (Qle_lt_trans _ (1 # 2 * p)). - unfold Qle; simpl. rewrite Pos2Z.inj_max. apply Z.le_max_l. - rewrite <- (Qplus_lt_r - _ _ (Qabs - (qn p0 - - proj1_sig x - (2 * Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))%nat) - -(1#2*p))). - ring_simplify. - setoid_replace (-1 * (1 # 2 * p) + (1 # p))%Q with (1 # 2 * p)%Q. - apply H. apply H0. rewrite Pos2Nat.inj_max. - apply (le_trans _ (1 * Nat.max (Pos.to_nat (4 * p)) (Pos.to_nat (Pos.of_nat (cvmod (2 * p)%positive))))). - destruct (cvmod (2*p)%positive). apply le_0_n. rewrite mult_1_l. - rewrite Nat2Pos.id. 2: discriminate. apply Nat.le_max_r. - apply Nat.mul_le_mono_nonneg_r. apply le_0_n. auto. - setoid_replace (1 # p)%Q with (2 # 2 * p)%Q. - rewrite Qplus_comm. rewrite Qinv_minus_distr. - reflexivity. reflexivity. + intros x n [k kmaj]. + destruct x as [xn cau]. + unfold CReal_abs, CReal_minus, CReal_plus, CReal_opp, inject_Q, proj1_sig in kmaj. + apply (Qlt_not_le _ _ kmaj). clear kmaj. + unfold QCauchySeq, QSeqEquiv in cau. + rewrite <- (Qplus_le_l _ _ (1#n)). ring_simplify. unfold id in cau. + destruct (Pos.lt_total (2*k) n). 2: destruct H. + - specialize (cau k (2*k)%positive n). + assert (k <= 2 * k)%positive. + { apply (Pos.le_trans _ (1*k)). apply Pos.le_refl. + apply Pos.mul_le_mono_r. discriminate. } + apply (Qle_trans _ (1#k)). apply Qlt_le_weak, cau. + exact H0. apply (Pos.le_trans _ _ _ H0). apply Pos.lt_le_incl, H. + rewrite <- (Qinv_plus_distr 1 1). + apply (Qplus_le_l _ _ (-(1#k))). ring_simplify. discriminate. + - subst n. rewrite Qplus_opp_r. discriminate. + - specialize (cau n (2*k)%positive n). + apply (Qle_trans _ (1#n)). apply Qlt_le_weak, cau. + apply Pos.lt_le_incl, H. apply Pos.le_refl. + apply (Qplus_le_l _ _ (-(1#n))). ring_simplify. discriminate. 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 & seq_cv (fun n:nat => inject_Q (qn n)) r }. +(* We can probably reduce the factor 4. *) +Lemma Rcauchy_limit : forall (xn : nat -> CReal) (xcau : Un_cauchy_mod xn), + QCauchySeq + (fun n : positive => + let (p, _) := xcau (4 * n)%positive in proj1_sig (xn p) (4 * n)%positive) id. Proof. - (* qn is an element of CReal. Show that inject_Q qn - converges to it in CReal. *) - intros. - 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) _ 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). - apply (CReal_cv_self qn (exist _ (fun n : nat => - qn (increasing_modulus (fun p : positive => proj1_sig (H (Pos.succ p))) n)) H0) - (fun p : positive => Init.Nat.max (proj1_sig (H (Pos.succ p))) (Pos.to_nat p))). - apply H1. + intros xn xcau n p q H0 H1. + destruct (xcau (4 * p)%positive) as [i imaj], + (xcau (4 * q)%positive) as [j jmaj]. + assert (CReal_abs (xn i - xn j) <= inject_Q (1 # 4 * n)). + { destruct (le_lt_dec i j). + apply (CReal_le_trans _ _ _ (imaj i j (le_refl _) l)). + apply inject_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos.mul_le_mono_l, H0. apply le_S, le_S_n in l. + apply (CReal_le_trans _ _ _ (jmaj i j l (le_refl _))). + apply inject_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos.mul_le_mono_l, H1. } + clear jmaj imaj. + setoid_replace (1#n)%Q with ((1#(3*n)) + ((1#(3*n)) + (1#(3*n))))%Q. + 2: rewrite Qinv_plus_distr, Qinv_plus_distr; reflexivity. + apply lt_inject_Q. rewrite inject_Q_plus. + rewrite Qabs_Rabs. + apply (CReal_le_lt_trans _ (CReal_abs (inject_Q (proj1_sig (xn i) (4 * p)%positive) - xn i) + CReal_abs (xn i - inject_Q(proj1_sig (xn j) (4 * q)%positive)))). + unfold Qminus. + rewrite inject_Q_plus, opp_inject_Q. + setoid_replace (inject_Q (proj1_sig (xn i) (4 * p)%positive) + + - inject_Q (proj1_sig (xn j) (4 * q)%positive)) + with (inject_Q (proj1_sig (xn i) (4 * p)%positive) - xn i + + (xn i - inject_Q (proj1_sig (xn j) (4 * q)%positive))). + 2: ring. + apply CReal_abs_triang. apply CReal_plus_le_lt_compat. + rewrite CReal_abs_minus_sym. apply (CReal_le_trans _ (inject_Q (1# 4*p))). + apply CReal_cv_self. apply inject_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos. apply (Pos.le_trans _ (4*n)). + apply Pos.mul_le_mono_r. discriminate. + apply Pos.mul_le_mono_l. exact H0. + apply (CReal_le_lt_trans + _ (CReal_abs (xn i - xn j + (xn j - inject_Q (proj1_sig (xn j) (4 * q)%positive))))). + apply CReal_abs_morph. ring. + apply (CReal_le_lt_trans _ _ _ (CReal_abs_triang _ _)). + rewrite inject_Q_plus. apply CReal_plus_le_lt_compat. + apply (CReal_le_trans _ _ _ H). apply inject_Q_le. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos. apply Pos.mul_le_mono_r. discriminate. + apply (CReal_le_lt_trans _ (inject_Q (1#4*q))). + apply CReal_cv_self. apply inject_Q_lt. unfold Qlt, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_lt_pos. apply (Pos.lt_le_trans _ (4*n)). + apply Pos.mul_lt_mono_r. reflexivity. + apply Pos.mul_le_mono_l. exact H1. Qed. Lemma Rcauchy_complete : forall (xn : nat -> CReal), @@ -350,49 +216,63 @@ Lemma Rcauchy_complete : forall (xn : nat -> CReal), -> { 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 (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_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. - do 2 rewrite <- (CReal_plus_comm (-l)). apply CReal_plus_le_compat_l. - apply (CReal_plus_le_reg_r (inject_Q (1 # 2 * p))). - ring_simplify. rewrite CReal_plus_comm. - apply (CReal_le_trans _ (xn p0 + inject_Q (1 # Pos.of_nat p0))). - apply CRealLt_asym, maj. 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 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))). - 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. + exists (exist _ (fun n : positive => + let (p, _) := cau (4 * n)%positive in + proj1_sig (xn p) (4 * n)%positive) + (Rcauchy_limit xn cau)). + intro p. + pose proof (CReal_cv_self (exist _ (fun n : positive => + let (p, _) := cau (4 * n)%positive in + proj1_sig (xn p) (4 * n)%positive) + (Rcauchy_limit xn cau)) (2*p)) as H. + simpl (inject_Q + (proj1_sig + (exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => + let (p, _) := cau (4 * n)%positive in + proj1_sig (xn p) (4 * n)%positive) (Rcauchy_limit xn cau)) + (2 * p)%positive)) in H. + pose proof (cau (2*p)%positive) as [k cv]. + destruct (cau (p~0~0~0)%positive) as [i imaj]. + (* The convergence modulus does not matter here, because a converging Cauchy + sequence always converges to its limit with twice the Cauchy modulus. *) + exists (max k i). + intros j H0. + setoid_replace (xn j - + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => + let (p0, _) := cau (4 * n)%positive in proj1_sig (xn p0) (4 * n)%positive) + (Rcauchy_limit xn cau)) + with (xn j - inject_Q (proj1_sig (xn i) (p~0~0~0)%positive) + + (inject_Q (proj1_sig (xn i) (p~0~0~0)%positive) - + exist (fun x : positive -> Q => QCauchySeq x id) + (fun n : positive => + let (p0, _) := cau (4 * n)%positive in proj1_sig (xn p0) (4 * n)%positive) + (Rcauchy_limit xn cau))). + 2: ring. apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)). + apply (CReal_le_trans _ (inject_Q (1#2*p) + inject_Q (1#2*p))). + apply CReal_plus_le_compat. + 2: rewrite CReal_abs_minus_sym; exact H. + specialize (imaj j i (le_trans _ _ _ (Nat.le_max_r _ _) H0) (le_refl _)). + apply (CReal_le_trans _ (inject_Q (1 # 4 * p) + inject_Q (1 # 4 * p))). + setoid_replace (xn j - inject_Q (proj1_sig (xn i) (p~0~0~0)%positive)) + with (xn j - xn i + + (xn i - inject_Q (proj1_sig (xn i) (p~0~0~0)%positive))). + 2: ring. apply (CReal_le_trans _ _ _ (CReal_abs_triang _ _)). + apply CReal_plus_le_compat. apply (CReal_le_trans _ _ _ imaj). + apply inject_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos. + apply (Pos.mul_le_mono_r p 4 8). discriminate. + apply (CReal_le_trans _ _ _ (CReal_cv_self (xn i) (8*p))). + apply inject_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos. + apply (Pos.mul_le_mono_r p 4 8). discriminate. + rewrite <- inject_Q_plus. rewrite (inject_Q_morph _ (1#2*p)). + apply CRealLe_refl. rewrite Qinv_plus_distr; reflexivity. + rewrite <- inject_Q_plus. rewrite (inject_Q_morph _ (1#p)). + apply CRealLe_refl. rewrite Qinv_plus_distr; reflexivity. Qed. Lemma CRealLtIsLinear : isLinearOrder CRealLt. diff --git a/theories/Reals/ClassicalDedekindReals.v b/theories/Reals/ClassicalDedekindReals.v index bb1ee93610..21f3a9cfca 100644 --- a/theories/Reals/ClassicalDedekindReals.v +++ b/theories/Reals/ClassicalDedekindReals.v @@ -149,32 +149,31 @@ Definition DRealAbstr : CReal -> DReal. Proof. intro x. assert (forall (q : Q) (n : nat), - {(fun n0 : nat => (proj1_sig x (S n0) <= q + (1 # Pos.of_nat (S n0)))%Q) n} + - {~ (fun n0 : nat => (proj1_sig x (S n0) <= q + (1 # Pos.of_nat (S n0)))%Q) n}). - { intros. destruct (Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (proj1_sig x (S n))). + {(fun n0 : nat => (proj1_sig x (Pos.of_nat (S n0)) <= q + (1 # Pos.of_nat (S n0)))%Q) n} + + {~ (fun n0 : nat => (proj1_sig x (Pos.of_nat (S n0)) <= q + (1 # Pos.of_nat (S n0)))%Q) n}). + { intros. destruct (Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (proj1_sig x (Pos.of_nat (S n)))). right. apply (Qlt_not_le _ _ q0). left. exact q0. } - exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (proj1_sig x (S n)) (q + (1#Pos.of_nat (S n)))) (H q) + exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (proj1_sig x (Pos.of_nat (S n))) (q + (1#Pos.of_nat (S n)))) (H q) then true else false). repeat split. - intros. - destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= q + (1 # Pos.of_nat (S n)))%Q) + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q) (H q)). reflexivity. exfalso. - destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= r + (1 # Pos.of_nat (S n)))%Q) + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= r + (1 # Pos.of_nat (S n)))%Q) (H r)). destruct s. apply n. apply (Qle_trans _ _ _ (q0 x0)). apply Qplus_le_l. exact H0. discriminate. - intro abs. destruct (Rfloor x) as [z [_ zmaj]]. specialize (abs (z+3 # 1)%Q). - destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= (z+3 # 1) + (1 # Pos.of_nat (S n)))%Q) + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= (z+3 # 1) + (1 # Pos.of_nat (S n)))%Q) (H (z+3 # 1)%Q)). 2: exfalso; discriminate. clear abs. destruct s as [n nmaj]. apply nmaj. rewrite <- (inject_Q_plus (z#1) 2) in zmaj. apply CRealLt_asym in zmaj. rewrite <- CRealLe_not_lt in zmaj. specialize (zmaj (Pos.of_nat (S n))). unfold inject_Q, proj1_sig in zmaj. - rewrite Nat2Pos.id in zmaj. 2: discriminate. destruct x as [xn xcau]; unfold proj1_sig. rewrite Qinv_plus_distr in zmaj. apply (Qplus_le_l _ _ (-(z + 2 # 1))). apply (Qle_trans _ _ _ zmaj). @@ -187,7 +186,7 @@ Proof. replace (z + 3 + - (z + 2))%Z with 1%Z. apply Qle_refl. ring. - intro abs. destruct (Rfloor x) as [z [zmaj _]]. specialize (abs (z-4 # 1)%Q). - destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= (z-4 # 1) + (1 # Pos.of_nat (S n)))%Q) + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= (z-4 # 1) + (1 # Pos.of_nat (S n)))%Q) (H (z-4 # 1)%Q)). exfalso; discriminate. clear abs. apply CRealLt_asym in zmaj. apply zmaj. clear zmaj. @@ -195,30 +194,30 @@ Proof. specialize (q O). destruct x as [xn xcau]; unfold proj1_sig; unfold proj1_sig in q. unfold Pos.of_nat in q. rewrite Qinv_plus_distr in q. - unfold Pos.to_nat; simpl. apply (Qplus_lt_l _ _ (xn 1%nat - 2)). + apply (Qplus_lt_l _ _ (xn 1%positive - 2)). ring_simplify. rewrite Qinv_plus_distr. apply (Qle_lt_trans _ _ _ q). apply Qlt_minus_iff. unfold Qopp, Qnum, Qden. rewrite Qinv_plus_distr. replace (z + -2 + - (z - 4 + 1))%Z with 1%Z. 2: ring. reflexivity. - intros q H0 abs. - destruct (sig_forall_dec (fun n : nat => (proj1_sig x (S n) <= q + (1 # Pos.of_nat (S n)))%Q) (H q)). + destruct (sig_forall_dec (fun n : nat => (proj1_sig x (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q) (H q)). 2: exfalso; discriminate. clear H0. destruct x as [xn xcau]; unfold proj1_sig in abs, s. destruct s as [n nmaj]. (* We have that q < x as real numbers. The middle (q + xSn - 1/Sn)/2 is also lower than x, witnessed by the same index n. *) - specialize (abs ((q + xn (S n) - (1 # Pos.of_nat (S n))%Q)/2)%Q). + specialize (abs ((q + xn (Pos.of_nat (S n)) - (1 # Pos.of_nat (S n))%Q)/2)%Q). destruct abs. + apply (Qmult_le_r _ _ 2) in H0. field_simplify in H0. apply (Qplus_le_r _ _ ((1 # Pos.of_nat (S n)) - q)) in H0. ring_simplify in H0. apply nmaj. rewrite Qplus_comm. exact H0. reflexivity. + destruct (sig_forall_dec (fun n0 : nat => - (xn (S n0) <= (q + xn (S n) - (1 # Pos.of_nat (S n))) / 2 + (1 # Pos.of_nat (S n0)))%Q) - (H ((q + xn (S n) - (1 # Pos.of_nat (S n))) / 2)%Q)). + (xn (Pos.of_nat (S n0)) <= (q + xn (Pos.of_nat (S n)) - (1 # Pos.of_nat (S n))) / 2 + (1 # Pos.of_nat (S n0)))%Q) + (H ((q + xn (Pos.of_nat (S n)) - (1 # Pos.of_nat (S n))) / 2)%Q)). discriminate. clear H0. specialize (q0 n). apply (Qmult_le_l _ _ 2) in q0. field_simplify in q0. - apply (Qplus_le_l _ _ (-xn (S n))) in q0. ring_simplify in q0. + apply (Qplus_le_l _ _ (-xn (Pos.of_nat (S n)))) in q0. ring_simplify in q0. contradiction. reflexivity. Defined. @@ -234,23 +233,24 @@ Qed. Definition DRealRepr : DReal -> CReal. Proof. - intro x. exists (fun n => proj1_sig (DRealQlim x n)). + intro x. exists (fun n:positive => proj1_sig (DRealQlim x (Pos.to_nat n))). intros n p q H H0. - destruct (DRealQlim x p), (DRealQlim x q); unfold proj1_sig. + destruct (DRealQlim x (Pos.to_nat p)), (DRealQlim x (Pos.to_nat q)) + ; unfold proj1_sig. destruct x as [f low]; unfold proj1_sig in a0, a. apply Qabs_case. - - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S q))). + - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S (Pos.to_nat q)))). apply (Qplus_lt_l _ _ x1). ring_simplify. apply (UpperAboveLower f). exact low. apply a. apply a0. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. - apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply (le_trans _ _ _ H0), le_S, le_refl. - discriminate. - - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S p))). + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. + apply le_S, Pos2Nat.inj_le, H0. discriminate. + - intros. apply (Qlt_le_trans _ (1 # Pos.of_nat (S (Pos.to_nat p)))). apply (Qplus_lt_l _ _ x0). ring_simplify. apply (UpperAboveLower f). exact low. apply a0. apply a. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. - apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply (le_trans _ _ _ H), le_S, le_refl. - discriminate. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. + apply le_S, Pos2Nat.inj_le, H. discriminate. Defined. Definition Rle (x y : DReal) @@ -390,15 +390,15 @@ Qed. Lemma DRealAbstrFalse : forall (x : CReal) (q : Q) (n : nat), proj1_sig (DRealAbstr x) q = false - -> (proj1_sig x (S n) <= q + (1 # Pos.of_nat (S n)))%Q. + -> (proj1_sig x (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q. Proof. intros. destruct x as [xn xcau]. unfold DRealAbstr, proj1_sig in H. destruct ( - sig_forall_dec (fun n : nat => (xn (S n) <= q + (1 # Pos.of_nat (S n)))%Q) + sig_forall_dec (fun n : nat => (xn (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q) (fun n : nat => - match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (S n)) with - | left q0 => right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (S n)) q0) + match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) with + | left q0 => right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) q0) | right q0 => left q0 end)). discriminate. apply q0. @@ -417,9 +417,10 @@ Proof. unfold proj1_sig in qmaj. rewrite Nat.succ_pred in qmaj. apply (Qlt_not_le _ _ pmaj), (Qplus_le_l _ _ q). - ring_simplify. apply (Qle_trans _ _ _ qmaj). + ring_simplify. rewrite Pos2Nat.id in qmaj. + apply (Qle_trans _ _ _ qmaj). rewrite <- Qplus_assoc. apply Qplus_le_r. - rewrite Pos2Nat.id. apply (Qle_trans _ ((1#p)+(1#p))). + apply (Qle_trans _ ((1#p)+(1#p))). apply Qplus_le_l. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. @@ -434,30 +435,32 @@ Proof. (* By pmaj, x < q - 1/p *) unfold DRealAbstr, proj1_sig in qmaj. destruct ( - sig_forall_dec (fun n : nat => (xn (S n) <= q + (1 # Pos.of_nat (S n)))%Q) + sig_forall_dec (fun n : nat => (xn (Pos.of_nat (S n)) <= q + (1 # Pos.of_nat (S n)))%Q) (fun n : nat => - match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (S n)) with + match Qlt_le_dec (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) with | left q0 => - right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (S n)) q0) + right (Qlt_not_le (q + (1 # Pos.of_nat (S n))) (xn (Pos.of_nat (S n))) q0) | right q0 => left q0 end)). 2: discriminate. clear qmaj. destruct s as [n nmaj]. apply nmaj. - apply (Qplus_lt_l _ _ (xn (Pos.to_nat p) + (1#Pos.of_nat (S n)))) in pmaj. + apply (Qplus_lt_l _ _ (xn p + (1#Pos.of_nat (S n)))) in pmaj. ring_simplify in pmaj. apply Qlt_le_weak. rewrite Qplus_comm. - apply (Qlt_trans _ ((2 # p) + xn (Pos.to_nat p) + (1 # Pos.of_nat (S n)))). + apply (Qlt_trans _ ((2 # p) + xn p + (1 # Pos.of_nat (S n)))). 2: exact pmaj. - apply (Qplus_lt_l _ _ (-xn (Pos.to_nat p))). + apply (Qplus_lt_l _ _ (-xn p)). apply (Qle_lt_trans _ _ _ (Qle_Qabs _)). destruct (le_lt_dec (S n) (Pos.to_nat p)). - + specialize (xcau (Pos.of_nat (S n)) (S n) (Pos.to_nat p)). + + specialize (xcau (Pos.of_nat (S n)) (Pos.of_nat (S n)) p). apply (Qlt_trans _ (1# Pos.of_nat (S n))). apply xcau. - rewrite Nat2Pos.id. apply le_refl. discriminate. + apply Pos.le_refl. unfold id. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. exact l. discriminate. apply (Qplus_lt_l _ _ (-(1#Pos.of_nat (S n)))). ring_simplify. reflexivity. + apply (Qlt_trans _ (1#p)). apply xcau. - apply le_S_n in l. apply le_S, l. apply le_refl. + apply le_S_n in l. unfold id. apply Pos2Nat.inj_le. + rewrite Nat2Pos.id. + apply le_S, l. discriminate. apply Pos.le_refl. ring_simplify. apply (Qlt_trans _ (2#p)). unfold Qlt, Qnum, Qden. apply Z.mul_lt_mono_pos_r. reflexivity. reflexivity. diff --git a/theories/Sorting/CPermutation.v b/theories/Sorting/CPermutation.v new file mode 100644 index 0000000000..fac9cd1d6d --- /dev/null +++ b/theories/Sorting/CPermutation.v @@ -0,0 +1,283 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** * Circular Shifts (aka Cyclic Permutations) *) + +(** The main inductive [CPermutation] relates lists up to circular shifts of their elements. + +For example: [CPermutation [a1;a2;a3;a4;a5] [a4;a5;a1;a2;a3]] + +Note: Terminology does not seem to be strongly fixed in English. For the record, it is "permutations circulaires" in French. +*) + +Require Import List Permutation Morphisms PeanoNat. +Import ListNotations. (* For notations [] and [a;b;c] *) +Set Implicit Arguments. + +Section CPermutation. + +Variable A:Type. + +(** Definition *) + +Inductive CPermutation : list A -> list A -> Prop := +| cperm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). + +Instance CPermutation_Permutation : Proper (CPermutation ==> (@Permutation A)) id. +Proof. intros ? ? [? ?]; apply Permutation_app_comm. Qed. + +(** Some facts about [CPermutation] *) + +Theorem CPermutation_nil : forall l, CPermutation [] l -> l = []. +Proof. +intros l HC; inversion HC as [l1 l2 Heq]; subst. +now apply app_eq_nil in Heq; destruct Heq; subst. +Qed. + +Theorem CPermutation_nil_cons : forall l a, ~ CPermutation [] (a :: l). +Proof. intros l a HC; apply CPermutation_nil in HC; inversion HC. Qed. + +Theorem CPermutation_nil_app_cons : forall l1 l2 a, + ~ CPermutation [] (l1 ++ a ::l2). +Proof. +intros l1 l2 a HC; apply CPermutation_nil in HC; destruct l1; inversion HC. +Qed. + +Lemma CPermutation_split : forall l1 l2, + CPermutation l1 l2 <-> exists n, l2 = skipn n l1 ++ firstn n l1. +Proof. +intros l1 l2; split. +- intros [l1' l2']. + exists (length l1'). + rewrite skipn_app, skipn_all, Nat.sub_diag; simpl; f_equal. + now rewrite firstn_app, firstn_all, Nat.sub_diag; simpl; rewrite app_nil_r. +- now intros [n ->]; rewrite <- (firstn_skipn n) at 1. +Qed. + + +(** Equivalence relation *) + +Theorem CPermutation_refl : forall l, CPermutation l l. +Proof. +intros l; now rewrite <- (app_nil_l l) at 1; rewrite <- (app_nil_r l) at 2. +Qed. + +Instance CPermutation_refl' : Proper (Logic.eq ==> CPermutation) id. +Proof. intros ? ? ->; apply CPermutation_refl. Qed. + +Theorem CPermutation_sym : forall l l', CPermutation l l' -> CPermutation l' l. +Proof. now intros ? ? [? ?]. Qed. + +Theorem CPermutation_trans : forall l l' l'', + CPermutation l l' -> CPermutation l' l'' -> CPermutation l l''. +Proof. +intros l l' l'' HC1 HC2. +inversion HC1 as [l1 l2]; inversion HC2 as [l3 l4 Heq Heq']; subst. +clear - Heq; revert l1 l2 l4 Heq; clear; induction l3; simpl; intros. +- now subst; rewrite app_nil_r. +- destruct l2 as [| b]. + + simpl in Heq; subst. + now rewrite app_nil_r, app_comm_cons. + + inversion Heq as [[Heqb Heq']]; subst. + replace (l1 ++ b :: l2) with ((l1 ++ b :: nil) ++ l2) + by now rewrite <- app_assoc, <- app_comm_cons. + replace (l4 ++ b :: l3) with ((l4 ++ b :: nil) ++ l3) + by now rewrite <- app_assoc, <- app_comm_cons. + apply IHl3. + now rewrite 2 app_assoc, Heq'. +Qed. + +End CPermutation. + +Hint Resolve CPermutation_refl : core. + +(* These hints do not reduce the size of the problem to solve and they + must be used with care to avoid combinatoric explosions *) + +Local Hint Resolve cperm CPermutation_sym CPermutation_trans : core. + +Instance CPermutation_Equivalence A : Equivalence (@CPermutation A) | 10 := { + Equivalence_Reflexive := @CPermutation_refl A ; + Equivalence_Symmetric := @CPermutation_sym A ; + Equivalence_Transitive := @CPermutation_trans A }. + + +Section CPermutation_properties. + +Variable A B:Type. + +Implicit Types a b : A. +Implicit Types l : list A. + +(** Compatibility with others operations on lists *) + +Lemma CPermutation_app : forall l1 l2 l3, + CPermutation (l1 ++ l2) l3 -> CPermutation (l2 ++ l1) l3. +Proof. intros l1 l2 l3 HC; now transitivity (l1 ++ l2). Qed. + +Theorem CPermutation_app_comm : forall l1 l2, CPermutation (l1 ++ l2) (l2 ++ l1). +Proof. apply cperm. Qed. + +Lemma CPermutation_app_rot : forall l1 l2 l3, + CPermutation (l1 ++ l2 ++ l3) (l2 ++ l3 ++ l1). +Proof. intros l1 l2 l3; now rewrite (app_assoc l2). Qed. + +Lemma CPermutation_cons_append : forall l a, + CPermutation (a :: l) (l ++ [a]). +Proof. intros l a; now rewrite <- (app_nil_l l), app_comm_cons. Qed. + +Lemma CPermutation_morph_cons : forall P : list A -> Prop, + (forall a l, P (l ++ [a]) -> P (a :: l)) -> + Proper (@CPermutation A ==> iff) P. +Proof. +enough (forall P : list A -> Prop, + (forall a l, P (l ++ [a]) -> P (a :: l)) -> + forall l1 l2, CPermutation l1 l2 -> P l1 -> P l2) + as Himp + by now intros P HP l1 l2 HC; split; [ | symmetry in HC ]; apply Himp. +intros P HP l1 l2 [l1' l2']. +revert l1'; induction l2' using rev_ind; intros l1' HPl. +- now rewrite app_nil_r in HPl. +- rewrite app_assoc in HPl. + apply HP in HPl. + rewrite <- app_assoc, <- app_comm_cons, app_nil_l. + now apply IHl2'. +Qed. + +Lemma CPermutation_length_1 : forall a b, CPermutation [a] [b] -> a = b. +Proof. intros; now apply Permutation_length_1, CPermutation_Permutation. Qed. + +Lemma CPermutation_length_1_inv : forall l a, CPermutation [a] l -> l = [a]. +Proof. intros; now apply Permutation_length_1_inv, CPermutation_Permutation. Qed. + +Lemma CPermutation_swap : forall a b, CPermutation [a; b] [b; a]. +Proof. +intros; now change [a; b] with ([a] ++ [b]); change [b; a] with ([b] ++ [a]). +Qed. + +Lemma CPermutation_length_2 : forall a1 a2 b1 b2, + CPermutation [a1; a2] [b1; b2] -> + a1 = b1 /\ a2 = b2 \/ a1 = b2 /\ a2 = b1. +Proof. intros; now apply Permutation_length_2, CPermutation_Permutation. Qed. + +Lemma CPermutation_length_2_inv : forall a b l, + CPermutation [a; b] l -> l = [a; b] \/ l = [b; a]. +Proof. intros; now apply Permutation_length_2_inv, CPermutation_Permutation. Qed. + +Lemma CPermutation_vs_elt_inv : forall l l1 l2 a, + CPermutation l (l1 ++ a :: l2) -> + exists l' l'', l2 ++ l1 = l'' ++ l' /\ l = l' ++ a :: l''. +Proof. +intros l l1 l2 a HC. +inversion HC as [l1' l2' Heq' Heq]; clear HC; subst. +enough (exists l3, (l2' ++ l3 = l1 /\ l1' = l3 ++ a :: l2) + \/ (l2' = l1 ++ a :: l3 /\ l3 ++ l1' = l2)) + as [l3 [[<- ->]|[-> <-]]]. +- exists l3, (l2 ++ l2'); rewrite app_comm_cons; intuition. +- exists (l1' ++ l1), l3; intuition. +- revert l1' l2' l2 Heq; induction l1; simpl; intros l1' l2' l2 Heq. + + destruct l2'; inversion Heq; subst. + * exists nil; intuition. + * exists l2'; intuition. + + destruct l2'; inversion Heq; subst. + * exists (a0 :: l1); intuition. + * apply IHl1 in H1 as [l3 [[<- ->]|[-> <-]]]; exists l3; intuition. +Qed. + +Lemma CPermutation_vs_cons_inv : forall l l0 a, + CPermutation l (a :: l0) -> exists l' l'', l0 = l'' ++ l' /\ l = l' ++ a :: l''. +Proof. intros; rewrite <- (app_nil_r l0); now apply CPermutation_vs_elt_inv. Qed. + +End CPermutation_properties. + + +(** [rev], [in], [map], [Forall], [Exists], etc. *) + +Global Instance CPermutation_rev A : + Proper (@CPermutation A ==> @CPermutation A) (@rev A) | 10. +Proof. +intro l; induction l; intros l' HC. +- now apply CPermutation_nil in HC; subst. +- symmetry in HC. + destruct (CPermutation_vs_cons_inv HC) as [l1 [l2 [-> ->]]]. + simpl; rewrite ? rev_app_distr; simpl. + now rewrite <- app_assoc. +Qed. + +Global Instance CPermutation_in A a : + Proper (@CPermutation A ==> Basics.impl) (In a). +Proof. +intros l l' HC Hin. +now apply Permutation_in with l; [ apply CPermutation_Permutation | ]. +Qed. + +Global Instance CPermutation_in' A : + Proper (Logic.eq ==> @CPermutation A ==> iff) (@In A) | 10. +Proof. intros a a' <- l l' HC; split; now apply CPermutation_in. Qed. + +Global Instance CPermutation_map A B (f : A -> B) : + Proper (@CPermutation A ==> @CPermutation B) (map f) | 10. +Proof. now intros ? ? [l1 l2]; rewrite 2 map_app. Qed. + +Lemma CPermutation_map_inv A B : forall (f : A -> B) m l, + CPermutation m (map f l) -> exists l', m = map f l' /\ CPermutation l l'. +Proof. +induction m as [| b m]; intros l HC. +- exists nil; split; auto. + destruct l; auto. + apply CPermutation_nil in HC; inversion HC. +- symmetry in HC. + destruct (CPermutation_vs_cons_inv HC) as [m1 [m2 [-> Heq]]]. + apply map_eq_app in Heq as [l1 [l1' [-> [-> Heq]]]]. + symmetry in Heq. + apply map_eq_cons in Heq as [a [l1'' [-> [-> ->]]]]. + exists (a :: l1'' ++ l1); split. + + now simpl; rewrite map_app. + + now rewrite app_comm_cons. +Qed. + +Lemma CPermutation_image A B : forall (f : A -> B) a l l', + CPermutation (a :: l) (map f l') -> exists a', a = f a'. +Proof. +intros f a l l' HP. +now apply CPermutation_Permutation, Permutation_image in HP. +Qed. + +Instance CPermutation_Forall A (P : A -> Prop) : + Proper (@CPermutation A ==> Basics.impl) (Forall P). +Proof. +intros ? ? [? ?] HF. +now apply Forall_app in HF; apply Forall_app. +Qed. + +Instance CPermutation_Exists A (P : A -> Prop) : + Proper (@CPermutation A ==> Basics.impl) (Exists P). +Proof. +intros ? ? [? ?] HE. +apply Exists_app in HE; apply Exists_app; intuition. +Qed. + +Lemma CPermutation_Forall2 A B (P : A -> B -> Prop) : + forall l1 l1' l2, CPermutation l1 l1' -> Forall2 P l1 l2 -> exists l2', + CPermutation l2 l2' /\ Forall2 P l1' l2'. +Proof. +intros ? ? ? [? ?] HF. +apply Forall2_app_inv_l in HF as (l2' & l2'' & HF' & HF'' & ->). +exists (l2'' ++ l2'); intuition. +now apply Forall2_app. +Qed. + + +(** As an equivalence relation compatible with some operations, +[CPermutation] can be used through [rewrite]. *) +Example CPermutation_rewrite_rev A (l1 l2 l3: list A) : + CPermutation l1 l2 -> + CPermutation (rev l1) l3 -> CPermutation l3 (rev l2). +Proof. intros HP1 HP2; rewrite <- HP1, HP2; reflexivity. Qed. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 86eebc6b4f..ffef8a216d 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -499,11 +499,13 @@ Proof. rewrite (NoDup_Add AD) in Hl'. tauto. Qed. -Lemma NoDup_Permutation_bis l l' : NoDup l -> NoDup l' -> +Lemma NoDup_Permutation_bis l l' : NoDup l -> length l' <= length l -> incl l l' -> Permutation l l'. Proof. intros. apply NoDup_Permutation; auto. - split; auto. apply NoDup_length_incl; trivial. + - now apply NoDup_incl_NoDup with l. + - split; auto. + apply NoDup_length_incl; trivial. Qed. Lemma Permutation_NoDup l l' : Permutation l l' -> NoDup l -> NoDup l'. diff --git a/theories/ltac/Ltac.v b/theories/ltac/Ltac.v deleted file mode 100644 index e69de29bb2..0000000000 --- a/theories/ltac/Ltac.v +++ /dev/null diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index d6f51d7b78..def1cbbcf8 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -821,7 +821,7 @@ module Html = struct | Some n -> if lev <= n then add_toc_entry (Toc_section (lev, f, r)) else ()); stop_item (); - printf "<a name=\"%s\"></a><h%d class=\"section\">" lab lev; + printf "<a id=\"%s\"></a><h%d class=\"section\">" lab lev; f (); printf "</h%d>\n" lev @@ -835,7 +835,7 @@ module Html = struct let letter_index category idx (c,l) = if l <> [] then begin let cat = if category && idx <> "global" then "(" ^ idx ^ ")" else "" in - printf "<a name=\"%s_%c\"></a><h2>%s %s</h2>\n" idx c (display_letter c) cat; + printf "<a id=\"%s_%c\"></a><h2>%s %s</h2>\n" idx c (display_letter c) cat; List.iter (fun (id,(text,link,t)) -> let id' = prepare_entry id t in diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index cfc89782a1..17435c051e 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -44,7 +44,6 @@ type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; toplevel_name : Stm.interactive_top; - cumulative_sprop : bool; } type coqargs_config = { @@ -110,7 +109,6 @@ let default_logic_config = { impredicative_set = Declarations.PredicativeSet; indices_matter = false; toplevel_name = Stm.TopLogical default_toplevel; - cumulative_sprop = false; } let default_config = { @@ -198,6 +196,10 @@ let set_query opts q = | Queries queries -> Queries (queries@[q]) } +let warn_deprecated_sprop_cumul = + CWarnings.create ~name:"deprecated-spropcumul" ~category:"deprecated" + (fun () -> Pp.strbrk "Use the \"Cumulative StrictProp\" flag instead.") + let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") @@ -520,7 +522,9 @@ let parse_args ~help ~init arglist : t * string list = add_set_option oval Vernacentries.allow_sprop_opt_name (OptionSet None) |"-disallow-sprop" -> add_set_option oval Vernacentries.allow_sprop_opt_name OptionUnset - |"-sprop-cumulative" -> set_logic (fun o -> { o with cumulative_sprop = true }) oval + |"-sprop-cumulative" -> + warn_deprecated_sprop_cumul(); + add_set_option oval Vernacentries.cumul_sprop_opt_name (OptionSet None) |"-indices-matter" -> set_logic (fun o -> { o with indices_matter = true }) oval |"-m"|"--memory" -> { oval with post = { oval.post with memory_stat = true }} |"-noinit"|"-nois" -> { oval with pre = { oval.pre with load_init = false }} diff --git a/toplevel/coqargs.mli b/toplevel/coqargs.mli index 8723d21bb4..a51ed6766a 100644 --- a/toplevel/coqargs.mli +++ b/toplevel/coqargs.mli @@ -20,7 +20,6 @@ type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; indices_matter : bool; toplevel_name : Stm.interactive_top; - cumulative_sprop : bool; } type coqargs_config = { diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 1175494bad..7aad856d0a 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -199,7 +199,6 @@ let init_execution opts custom_init = Global.set_VM opts.config.enable_VM; Flags.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); Global.set_native_compiler (match opts.config.native_compiler with NativeOff -> false | NativeOn _ -> true); - if opts.config.logic.cumulative_sprop then Global.make_sprop_cumulative (); (* Native output dir *) Nativelib.output_dir := opts.config.native_output_dir; diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 57d59fc2ef..13c4d667a0 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -145,10 +145,10 @@ GRAMMAR EXTEND Gram { CAst.make ~loc @@ CTacCse (e, bl) } ] | "4" LEFTA [ ] - | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> + | "3" [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> { let el = e0 :: el in CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] - | "::" RIGHTA + | "2" RIGHTA [ e1 = tac2expr; "::"; e2 = tac2expr -> { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } ] diff --git a/vernac/.ocamlformat-enable b/vernac/.ocamlformat-enable new file mode 100644 index 0000000000..ffaa7e70f4 --- /dev/null +++ b/vernac/.ocamlformat-enable @@ -0,0 +1 @@ +comHints.ml diff --git a/vernac/classes.mli b/vernac/classes.mli index 9698c14452..f410cddfef 100644 --- a/vernac/classes.mli +++ b/vernac/classes.mli @@ -22,7 +22,7 @@ val declare_instance : ?warn:bool -> env -> Evd.evar_map -> Does nothing — or emit a “not-a-class” warning if the [warn] argument is set — when said type is not a registered type class. *) -val existing_instance : bool -> qualid -> Hints.hint_info_expr option -> unit +val existing_instance : bool -> qualid -> ComHints.hint_info_expr option -> unit (** globality, reference, optional priority and pattern information *) val new_instance_interactive @@ -34,7 +34,7 @@ val new_instance_interactive -> ?generalize:bool -> ?tac:unit Proofview.tactic -> ?hook:(GlobRef.t -> unit) - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> (bool * constr_expr) option -> Id.t * Lemmas.t @@ -47,7 +47,7 @@ val new_instance -> (bool * constr_expr) -> ?generalize:bool -> ?hook:(GlobRef.t -> unit) - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> Id.t val new_instance_program @@ -59,7 +59,7 @@ val new_instance_program -> (bool * constr_expr) option -> ?generalize:bool -> ?hook:(GlobRef.t -> unit) - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> Id.t val declare_new_instance @@ -69,7 +69,7 @@ val declare_new_instance -> ident_decl -> local_binder_expr list -> constr_expr - -> Hints.hint_info_expr + -> ComHints.hint_info_expr -> unit (** {6 Low level interface used by Add Morphism, do not use } *) diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 43e86fa9bd..776ffd6b9f 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -91,7 +91,7 @@ let declare_assumptions ~poly ~scope ~kind univs nl l = let () = match scope with | Discharge -> (* declare universes separately for variables *) - Declare.declare_universe_context ~poly (context_set_of_entry (fst univs)) + DeclareUctx.declare_universe_context ~poly (context_set_of_entry (fst univs)) | Global _ -> () in let _, _ = List.fold_left (fun (subst,univs) ((is_coe,idl),typ,imps) -> @@ -191,7 +191,7 @@ let context_subst subst (name,b,t,impl) = let context_insection sigma ~poly ctx = let uctx = Evd.universe_context_set sigma in - let () = Declare.declare_universe_context ~poly uctx in + let () = DeclareUctx.declare_universe_context ~poly uctx in let fn subst (name,_,_,_ as d) = let d = context_subst subst d in let () = match d with @@ -226,7 +226,7 @@ let context_nosection sigma ~poly ctx = (* Multiple monomorphic axioms: declare universes separately to avoid redeclaring them. *) let uctx = Evd.universe_context_set sigma in - let () = Declare.declare_universe_context ~poly uctx in + let () = DeclareUctx.declare_universe_context ~poly uctx in Monomorphic_entry Univ.ContextSet.empty in let fn subst d = diff --git a/vernac/comHints.ml b/vernac/comHints.ml new file mode 100644 index 0000000000..5a48e9c16c --- /dev/null +++ b/vernac/comHints.ml @@ -0,0 +1,174 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +open Util + +(** (Partial) implementation of the [Hint] command; some more + functionality still lives in tactics/hints.ml *) + +type hint_info_expr = Constrexpr.constr_pattern_expr Typeclasses.hint_info_gen + +type reference_or_constr = + | HintsReference of Libnames.qualid + | HintsConstr of Constrexpr.constr_expr + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * Libnames.qualid list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of Libnames.qualid list + | HintsTransparency of Libnames.qualid Hints.hints_transparency_target * bool + | HintsMode of Libnames.qualid * Hints.hint_mode list + | HintsConstructors of Libnames.qualid list + | HintsExtern of + int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + +let project_hint ~poly pri l2r r = + let open EConstr in + let open Coqlib in + let gr = Smartlocate.global_with_alias r in + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, c = Evd.fresh_global env sigma gr in + let t = Retyping.get_type_of env sigma c in + let t = + Tacred.reduce_to_quantified_ref env sigma (lib_ref "core.iff.type") t + in + let sign, ccl = decompose_prod_assum sigma t in + let a, b = + match snd (decompose_app sigma ccl) with + | [a; b] -> (a, b) + | _ -> assert false + in + let p = if l2r then lib_ref "core.iff.proj1" else lib_ref "core.iff.proj2" in + let sigma, p = Evd.fresh_global env sigma p in + let c = + Reductionops.whd_beta sigma + (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) + in + let c = + it_mkLambda_or_LetIn + (mkApp + ( p + , [| mkArrow a Sorts.Relevant (Vars.lift 1 b) + ; mkArrow b Sorts.Relevant (Vars.lift 1 a) + ; c |] )) + sign + in + let name = + Nameops.add_suffix + (Nametab.basename_of_global gr) + ("_proj_" ^ if l2r then "l2r" else "r2l") + in + let ctx = Evd.univ_entry ~poly sigma in + let c = EConstr.to_constr sigma c in + let cb = + Declare.(DefinitionEntry (definition_entry ~univs:ctx ~opaque:false c)) + in + let c = + Declare.declare_constant ~local:Declare.ImportDefaultBehavior ~name + ~kind:Decls.(IsDefinition Definition) + cb + in + let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in + (info, false, true, Hints.PathAny, Hints.IsGlobRef (Names.GlobRef.ConstRef c)) + +let warn_deprecated_hint_constr = + CWarnings.create ~name:"deprecated-hint-constr" ~category:"deprecated" + (fun () -> + Pp.strbrk + "Declaring arbitrary terms as hints is deprecated; declare a global \ + reference instead") + +let interp_hints ~poly h = + let env = Global.env () in + let sigma = Evd.from_env env in + let f poly c = + let evd, c = Constrintern.interp_open_constr env sigma c in + let env = Global.env () in + let sigma = Evd.from_env env in + let c, diff = Hints.prepare_hint true env sigma (evd, c) in + if poly then (Hints.IsConstr (c, diff) [@ocaml.warning "-3"]) + else + let () = DeclareUctx.declare_universe_context ~poly:false diff in + (Hints.IsConstr (c, Univ.ContextSet.empty) [@ocaml.warning "-3"]) + in + let fref r = + let gr = Smartlocate.global_with_alias r in + Dumpglob.add_glob ?loc:r.CAst.loc gr; + gr + in + let fr r = Tacred.evaluable_of_global_reference env (fref r) in + let fi c = + let open Hints in + match c with + | HintsReference c -> + let gr = Smartlocate.global_with_alias c in + (PathHints [gr], poly, IsGlobRef gr) + | HintsConstr c -> + let () = warn_deprecated_hint_constr () in + (PathAny, poly, f poly c) + in + let fp = Constrintern.intern_constr_pattern env sigma in + let fres (info, b, r) = + let path, poly, gr = fi r in + let info = + { info with + Typeclasses.hint_pattern = Option.map fp info.Typeclasses.hint_pattern + } + in + (info, poly, b, path, gr) + in + let ft = + let open Hints in + function + | HintsVariables -> HintsVariables + | HintsConstants -> HintsConstants + | HintsReferences lhints -> HintsReferences (List.map fr lhints) + in + let fp = Constrintern.intern_constr_pattern (Global.env ()) in + let open Hints in + match h with + | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) + | HintsResolveIFF (l2r, lc, n) -> + HintsResolveEntry (List.map (project_hint ~poly n l2r) lc) + | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) + | HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints) + | HintsTransparency (t, b) -> HintsTransparencyEntry (ft t, b) + | HintsMode (r, l) -> HintsModeEntry (fref r, l) + | HintsConstructors lqid -> + let constr_hints_of_ind qid = + let ind = Smartlocate.global_inductive_with_alias qid in + let mib, _ = Global.lookup_inductive ind in + Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" + (Libnames.string_of_qualid qid) + "ind"; + List.init (Inductiveops.nconstructors env ind) (fun i -> + let c = (ind, i + 1) in + let gr = Names.GlobRef.ConstructRef c in + ( empty_hint_info + , Declareops.inductive_is_polymorphic mib + , true + , PathHints [gr] + , IsGlobRef gr )) + in + HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) + | HintsExtern (pri, patcom, tacexp) -> + let pat = Option.map (fp sigma) patcom in + let l = match pat with None -> [] | Some (l, _) -> l in + let ltacvars = + List.fold_left + (fun accu x -> Names.Id.Set.add x accu) + Names.Id.Set.empty l + in + let env = Genintern.{(empty_glob_sign env) with ltacvars} in + let _, tacexp = Genintern.generic_intern env tacexp in + HintsExternEntry + ({Typeclasses.hint_priority = Some pri; hint_pattern = pat}, tacexp) diff --git a/vernac/comHints.mli b/vernac/comHints.mli new file mode 100644 index 0000000000..77fbef5387 --- /dev/null +++ b/vernac/comHints.mli @@ -0,0 +1,29 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +open Typeclasses + +type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen + +type reference_or_constr = + | HintsReference of Libnames.qualid + | HintsConstr of Constrexpr.constr_expr + +type hints_expr = + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list + | HintsResolveIFF of bool * Libnames.qualid list * int option + | HintsImmediate of reference_or_constr list + | HintsUnfold of Libnames.qualid list + | HintsTransparency of Libnames.qualid Hints.hints_transparency_target * bool + | HintsMode of Libnames.qualid * Hints.hint_mode list + | HintsConstructors of Libnames.qualid list + | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument + +val interp_hints : poly:bool -> hints_expr -> Hints.hints_entry diff --git a/tactics/declare.ml b/vernac/declare.ml index cce43e833e..366dd2d026 100644 --- a/tactics/declare.ml +++ b/vernac/declare.ml @@ -133,31 +133,6 @@ let _ = CErrors.register_handler (function type import_status = ImportDefaultBehavior | ImportNeedQualified -(** Monomorphic universes need to survive sections. *) - -let name_instance inst = - let map lvl = match Univ.Level.name lvl with - | None -> (* Having Prop/Set/Var as section universes makes no sense *) - assert false - | Some na -> - try - let qid = Nametab.shortest_qualid_of_universe na in - Name (Libnames.qualid_basename qid) - with Not_found -> - (* Best-effort naming from the string representation of the level. - See univNames.ml for a similar hack. *) - Name (Id.of_string_soft (Univ.Level.to_string lvl)) - in - Array.map map (Univ.Instance.to_array inst) - -let declare_universe_context ~poly ctx = - if poly then - let uctx = Univ.ContextSet.to_context ctx in - let nas = name_instance (Univ.UContext.instance uctx) in - Global.push_section_context (nas, uctx) - else - Global.push_context_set ~strict:true ctx - (** Declaration of constants and parameters *) type constant_obj = { @@ -589,7 +564,7 @@ let declare_variable ~name ~kind d = let univs = Univ.ContextSet.union body_ui entry_ui in (* We must declare the universe constraints before type-checking the term. *) - let () = declare_universe_context ~poly univs in + let () = DeclareUctx.declare_universe_context ~poly univs in let se = { Entries.secdef_body = body; secdef_secctx = de.proof_entry_secctx; @@ -899,3 +874,15 @@ module Proof = struct let update_global_env = update_global_env let get_open_goals = get_open_goals end + +let declare_definition_scheme ~internal ~univs ~role ~name c = + let kind = Decls.(IsDefinition Scheme) in + let entry = pure_definition_entry ~univs c in + let kn, eff = declare_private_constant ~role ~kind ~name entry in + let () = if internal then () else definition_message name in + kn, eff + +let _ = Ind_tables.declare_definition_scheme := declare_definition_scheme +let _ = Abstract.declare_abstract := declare_abstract + +let declare_universe_context = DeclareUctx.declare_universe_context diff --git a/tactics/declare.mli b/vernac/declare.mli index 1fabf80b2a..e23e148ddc 100644 --- a/tactics/declare.mli +++ b/vernac/declare.mli @@ -135,8 +135,6 @@ type 'a constant_entry = | ParameterEntry of parameter_entry | PrimitiveEntry of primitive_entry -val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit - val declare_variable : name:variable -> kind:Decls.logical_kind @@ -162,16 +160,6 @@ val definition_entry -> constr -> Evd.side_effects proof_entry -(** XXX: Scheduled for removal from public API, use `DeclareDef` instead *) -val pure_definition_entry - : ?fix_exn:Future.fix_exn - -> ?opaque:bool - -> ?inline:bool - -> ?types:types - -> ?univs:Entries.universes_entry - -> constr - -> unit proof_entry - type import_status = ImportDefaultBehavior | ImportNeedQualified (** [declare_constant id cd] declares a global declaration @@ -189,14 +177,6 @@ val declare_constant -> Evd.side_effects constant_entry -> Constant.t -val declare_private_constant - : ?role:Evd.side_effect_role - -> ?local:import_status - -> name:Id.t - -> kind:Decls.logical_kind - -> unit proof_entry - -> Constant.t * Evd.side_effects - (** [inline_private_constants ~sideff ~uctx env ce] will inline the constants in [ce]'s body and return the body plus the updated [UState.t]. @@ -262,19 +242,6 @@ val close_future_proof : feedback_id:Stateid.t -> Proof.t -> closed_proof_output Returns [false] if an unsafe tactic has been used. *) val by : unit Proofview.tactic -> Proof.t -> Proof.t * bool -(** Declare abstract constant; will check no evars are possible; *) -val declare_abstract : - name:Names.Id.t - -> poly:bool - -> kind:Decls.logical_kind - -> sign:EConstr.named_context - -> secsign:Environ.named_context_val - -> opaque:bool - -> solve_tac:unit Proofview.tactic - -> Evd.evar_map - -> EConstr.t - -> Evd.side_effects * Evd.evar_map * EConstr.t * EConstr.t list * bool - val build_by_tactic : ?side_eff:bool -> Environ.env @@ -312,3 +279,6 @@ val build_constant_by_tactic : EConstr.types -> unit Proofview.tactic -> Evd.side_effects proof_entry * bool * UState.t + +val declare_universe_context : poly:bool -> Univ.ContextSet.t -> unit +[@@ocaml.deprecated "Use DeclareUctx.declare_universe_context"] diff --git a/vernac/declareUniv.ml b/vernac/declareUniv.ml index 20fa43c8e7..89f3503f4d 100644 --- a/vernac/declareUniv.ml +++ b/vernac/declareUniv.ml @@ -94,7 +94,7 @@ let do_universe ~poly l = in let src = if poly then BoundUniv else UnqualifiedUniv in let () = Lib.add_anonymous_leaf (input_univ_names (src, l)) in - Declare.declare_universe_context ~poly ctx + DeclareUctx.declare_universe_context ~poly ctx let do_constraint ~poly l = let open Univ in @@ -107,4 +107,4 @@ let do_constraint ~poly l = Constraint.empty l in let uctx = ContextSet.add_constraints constraints ContextSet.empty in - Declare.declare_universe_context ~poly uctx + DeclareUctx.declare_universe_context ~poly uctx diff --git a/vernac/g_proofs.mlg b/vernac/g_proofs.mlg index 058fa691ee..e84fce5504 100644 --- a/vernac/g_proofs.mlg +++ b/vernac/g_proofs.mlg @@ -14,6 +14,7 @@ open Glob_term open Constrexpr open Vernacexpr open Hints +open ComHints open Pcoq open Pcoq.Prim diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index 7260b13ff6..6ffa88874b 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -91,12 +91,11 @@ let () = optwrite = (fun b -> rewriting_flag := b) } (* Util *) - let define ~poly name sigma c types = - let f = declare_constant ~kind:Decls.(IsDefinition Scheme) in let univs = Evd.univ_entry ~poly sigma in let entry = Declare.definition_entry ~univs ?types c in - let kn = f ~name (DefinitionEntry entry) in + let kind = Decls.(IsDefinition Scheme) in + let kn = declare_constant ~kind ~name (DefinitionEntry entry) in definition_message name; kn diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 36d79bfdb1..f1aae239aa 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -185,7 +185,7 @@ open Pputils | [] -> mt() | _ as z -> str":" ++ spc() ++ prlist_with_sep sep str z - let pr_reference_or_constr pr_c = let open Hints in function + let pr_reference_or_constr pr_c = let open ComHints in function | HintsReference r -> pr_qualid r | HintsConstr c -> pr_c c @@ -202,6 +202,7 @@ open Pputils let opth = pr_opt_hintbases db in let pph = let open Hints in + let open ComHints in match h with | HintsResolve l -> keyword "Resolve " ++ prlist_with_sep sep diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 4de12f5e3b..2b6beaf2e3 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -28,7 +28,7 @@ module Vernac_ : val command_entry : vernac_expr Entry.t val main_entry : vernac_control option Entry.t val red_expr : raw_red_expr Entry.t - val hint_info : Hints.hint_info_expr Entry.t + val hint_info : ComHints.hint_info_expr Entry.t end (* To be removed when the parser is made functional wrt the tactic diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index b7728fe699..6d5d16d94a 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -9,6 +9,8 @@ Himsg Locality Egramml Vernacextend +Declare +ComHints Ppvernac Proof_using Egramcoq diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 3926b91a55..df39c617d3 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -1275,7 +1275,7 @@ let vernac_hints ~atts dbnames h = "This command does not support the export attribute in sections."); | OptDefault | OptLocal -> () in - Hints.add_hints ~locality dbnames (Hints.interp_hints ~poly h) + Hints.add_hints ~locality dbnames (ComHints.interp_hints ~poly h) let vernac_syntactic_definition ~atts lid x only_parsing = let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in @@ -1302,6 +1302,7 @@ let vernac_generalizable ~local = Implicit_quantifiers.declare_generalizable ~local let allow_sprop_opt_name = ["Allow";"StrictProp"] +let cumul_sprop_opt_name = ["Cumulative";"StrictProp"] let () = declare_bool_option @@ -1313,6 +1314,13 @@ let () = let () = declare_bool_option { optdepr = false; + optkey = cumul_sprop_opt_name; + optread = Global.is_cumulative_sprop; + optwrite = Global.set_cumulative_sprop } + +let () = + declare_bool_option + { optdepr = false; optkey = ["Silent"]; optread = (fun () -> !Flags.quiet); optwrite = ((:=) Flags.quiet) } @@ -1487,21 +1495,21 @@ let () = optread = CWarnings.get_flags; optwrite = CWarnings.set_flags } -let _ = +let () = declare_bool_option { optdepr = false; optkey = ["Guard"; "Checking"]; optread = (fun () -> (Global.typing_flags ()).Declarations.check_guarded); optwrite = (fun b -> Global.set_check_guarded b) } -let _ = +let () = declare_bool_option { optdepr = false; optkey = ["Positivity"; "Checking"]; optread = (fun () -> (Global.typing_flags ()).Declarations.check_positive); optwrite = (fun b -> Global.set_check_positive b) } -let _ = +let () = declare_bool_option { optdepr = false; optkey = ["Universe"; "Checking"]; @@ -1719,7 +1727,8 @@ let vernac_print ~pstate ~atts = | PrintHintGoal -> begin match pstate with | Some pstate -> - Hints.pr_applicable_hint pstate + let pf = Declare.Proof.get_proof pstate in + Hints.pr_applicable_hint pf | None -> str "No proof in progress" end diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index 2ac8458ad5..cf233248d7 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -26,3 +26,4 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr val command_focus : unit Proof.focus_kind val allow_sprop_opt_name : string list +val cumul_sprop_opt_name : string list diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index e46186288e..b65a0da1cc 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -336,18 +336,18 @@ type nonrec vernac_expr = local_binder_expr list * (* binders *) constr_expr * (* type *) (bool * constr_expr) option * (* body (bool=true when using {}) *) - Hints.hint_info_expr + ComHints.hint_info_expr | VernacDeclareInstance of ident_decl * (* name *) local_binder_expr list * (* binders *) constr_expr * (* type *) - Hints.hint_info_expr + ComHints.hint_info_expr | VernacContext of local_binder_expr list | VernacExistingInstance of - (qualid * Hints.hint_info_expr) list (* instances names, priorities and patterns *) + (qualid * ComHints.hint_info_expr) list (* instances names, priorities and patterns *) | VernacExistingClass of qualid (* inductive or definition name *) @@ -387,7 +387,7 @@ type nonrec vernac_expr = (* Commands *) | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * qualid list - | VernacHints of string list * Hints.hints_expr + | VernacHints of string list * ComHints.hints_expr | VernacSyntacticDefinition of lident * (Id.t list * constr_expr) * onlyparsing_flag |