diff options
197 files changed, 4059 insertions, 4227 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f439b0c34f..1a1d31bdd7 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -716,7 +716,11 @@ library:ci-fiat-crypto: - plugin:ci-rewriter library:ci-flocq: - extends: .ci-template + extends: .ci-template-flambda + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci library:ci-corn: extends: .ci-template-flambda @@ -772,6 +776,13 @@ library:ci-verdi-raft: library:ci-vst: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-flocq + dependencies: + - build:edge+flambda + - library:ci-flocq # Plugins are by definition the projects that depend on Coq's ML API diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 201d740073..3582d18cf6 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -30,17 +30,18 @@ well. - [Helping triage existing issues](#helping-triage-existing-issues) - [Code changes](#code-changes) - [Using GitHub pull requests](#using-github-pull-requests) + - [Fixing bugs and performing small changes](#fixing-bugs-and-performing-small-changes) + - [Proposing large changes: Coq Enhancement Proposals](#proposing-large-changes-coq-enhancement-proposals) + - [Seeking early feedback on work-in-progress](#seeking-early-feedback-on-work-in-progress) - [Taking feedback into account](#taking-feedback-into-account) - [Understanding automatic feedback](#understanding-automatic-feedback) - [Understanding reviewers' feedback](#understanding-reviewers-feedback) - [Fixing your branch](#fixing-your-branch) - [Improving the official documentation](#improving-the-official-documentation) - [Contributing to the standard library](#contributing-to-the-standard-library) - - [Fixing bugs and performing small changes](#fixing-bugs-and-performing-small-changes) - - [Proposing large changes: Coq Enhancement Proposals](#proposing-large-changes-coq-enhancement-proposals) - - [Collaborating on a pull request](#collaborating-on-a-pull-request) - [Becoming a maintainer](#becoming-a-maintainer) - [Reviewing pull requests](#reviewing-pull-requests) + - [Collaborating on a pull request](#collaborating-on-a-pull-request) - [Merging pull requests](#merging-pull-requests) - [Additional notes for pull request reviewers and assignees](#additional-notes-for-pull-request-reviewers-and-assignees) - [Joining / leaving maintainer teams](#joining--leaving-maintainer-teams) @@ -443,6 +444,72 @@ several months after your PR is merged). That said, you can start using the latest Coq `master` branch to take advantage of all the new features, improvements, and fixes. +#### Fixing bugs and performing small changes #### + +Before fixing a bug, it is best to check that it was reported before: + +- If it was already reported and you intend to fix it, self-assign the + issue (if you have the permission), or leave a comment marking your + intention to work on it (and a contributor with write-access may + then assign the issue to you). + +- If the issue already has an assignee, you should check with them if + they still intend to work on it. If the assignment is several + weeks, months, or even years (!) old, there are good chances that it + does not reflect their current priorities. + +- If the bug has not been reported before, it can be a good idea to + open an issue about it, while stating that you are preparing a fix. + The issue can be the place to discuss about the bug itself while the + PR will be the place to discuss your proposed fix. + +It is generally a good idea to add a regression test to the +test-suite. See the test-suite [README][test-suite-README] for how to +do so. + +Small fixes do not need any documentation, or changelog update. New, +or updated, user-facing features, and major bug fixes do. See above +on how to contribute to the documentation, and the README in +[`doc/changelog`][user-changelog] for how to add a changelog entry. + +#### Proposing large changes: Coq Enhancement Proposals #### + +You are always welcome to open a PR for a change of any size. +However, you should be aware that the larger the change, the higher +the chances it will take very long to review, and possibly never get +merged. + +So it is recommended that before spending a lot of time coding, you +seek feedback from maintainers to see if your change would be +supported, and if they have recommendations about its implementation. +You can do this informally by opening an issue, or more formally by +producing a design document as a [Coq Enhancement Proposal][CEP]. + +Another recommendation is that you do not put several unrelated +changes in the same PR (even if you produced them together). In +particular, make sure you split bug fixes into separate PRs when this +is possible. More generally, smaller-sized PRs, or PRs changing less +components, are more likely to be reviewed and merged promptly. + +#### Seeking early feedback on work-in-progress #### + +You should always feel free to open your PR before the documentation, +changelog entry and tests are ready. That's the purpose of the +checkboxes in the PR template which you can leave unticked. This can +be a way of getting reviewers' approval before spending time on +writing the documentation (but you should still do it before your PR +can be merged). + +If even the implementation is not ready but you are still looking for +early feedback on your code changes, please use the [draft +PR](#draft-pull-requests) mechanism. + +If you are looking for feedback on the design of your change, rather +than on its implementation, then please refrain from opening a PR. +You may open an issue to start a discussion, or create a [Coq +Enhancement Proposal][CEP] if you have a clear enough view of the +design to write a document about it. + ### Taking feedback into account ### #### Understanding automatic feedback #### @@ -644,59 +711,35 @@ Add coqdoc comments to extend the [standard library documentation][stdlib-doc]. See the [coqdoc documentation][coqdoc-documentation] to learn more. -### Fixing bugs and performing small changes ### - -Before fixing a bug, it is best to check that it was reported before: - -- If it was already reported and you intend to fix it, self-assign the - issue (if you have the permission), or leave a comment marking your - intention to work on it (and a contributor with write-access may - then assign the issue to you). - -- If the issue already has an assignee, you should check with them if - they still intend to work on it. If the assignment is several - weeks, months, or even years (!) old, there are good chances that it - does not reflect their current priorities. - -- If the bug has not been reported before, it can be a good idea to - open an issue about it, while stating that you are preparing a fix. - The issue can be the place to discuss about the bug itself while the - PR will be the place to discuss your proposed fix. - -In any case, feel free to just ignore the recommendation above, and -jump ahead and open a PR with your fix. If it is not yet complete, do -not hesitate to open a [*draft PR*][GitHub-draft-PR] to get early -feedback, and talk to developers on [Gitter][]. - -It is generally a good idea to add a regression test to the -test-suite. See the test-suite [README][test-suite-README] for how to -do so. - -Small fixes do not need any documentation, or changelog update. New, -or updated, user-facing features, and major bug fixes do. See above -on how to contribute to the documentation, and the README in -[`doc/changelog`][user-changelog] for how to add a changelog entry. +## Becoming a maintainer ## -### Proposing large changes: Coq Enhancement Proposals ### +### Reviewing pull requests ### -You are always welcome to open a PR for a change of any size. -However, you should be aware that the larger the change, the higher -the chances it will take very long to review, and possibly never get -merged. +You can start reviewing PRs as soon as you feel comfortable doing so +(anyone can review anything, although some designated reviewers +will have to give a final approval before a PR can be merged, as is +explained in the next sub-section). -So it is recommended that before spending a lot of time coding, you -seek feedback from maintainers to see if your change would be -supported, and if they have recommendations about its implementation. -You can do this informally by opening an issue, or more formally by -producing a design document as a [Coq Enhancement Proposal][CEP]. +Reviewers should ensure that the code that is changed or introduced is +in good shape and will not be a burden to maintain, is unlikely to +break anything, or the compatibility-breakage has been identified and +validated, includes documentation, changelog entries, and test files +when necessary. Reviewers can use labels, or change requests to +further emphasize what remains to be changed before they can approve +the PR. Once reviewers are satisfied (regarding the part they +reviewed), they should formally approve the PR, possibly stating what +they reviewed. -Another recommendation is that you do not put several unrelated -changes in the same PR (even if you produced them together). In -particular, make sure you split bug fixes into separate PRs when this -is possible. More generally, smaller-sized PRs, or PRs changing less -components, are more likely to be reviewed and merged promptly. +That being said, reviewers should also make sure that they do not make +the contributing process harder than necessary: they should make it +clear which comments are really required to perform before approving, +and which are just suggestions. They should strive to reduce the +number of rounds of feedback that are needed by posting most of their +comments at the same time. If they are opposed to the change, they +should clearly say so from the beginning to avoid the contributor +spending time in vain. -### Collaborating on a pull request ### +#### Collaborating on a pull request #### Beyond making suggestions to a PR author during the review process, you may want to collaborate further by checking out the code, making @@ -721,42 +764,14 @@ else), this should be reflected by adding ["Co-authored-by:" tags][GitHub-co-authored-by] at the end of the commit message. The line should contain the co-author name and committer e-mail address. -## Becoming a maintainer ## - -### Reviewing pull requests ### - -You can start reviewing PRs as soon as you feel comfortable doing so -(anyone can review anything, although some designated reviewers -will have to give a final approval before a PR can be merged, as is -explained in the next sub-section). - -Reviewers should ensure that the code that is changed or introduced is -in good shape and will not be a burden to maintain, is unlikely to -break anything, or the compatibility-breakage has been identified and -validated, includes documentation, changelog entries, and test files -when necessary. Reviewers can use labels, or change requests to -further emphasize what remains to be changed before they can approve -the PR. Once reviewers are satisfied (regarding the part they -reviewed), they should formally approve the PR, possibly stating what -they reviewed. - -That being said, reviewers should also make sure that they do not make -the contributing process harder than necessary: they should make it -clear which comments are really required to perform before approving, -and which are just suggestions. They should strive to reduce the -number of rounds of feedback that are needed by posting most of their -comments at the same time. If they are opposed to the change, they -should clearly say so from the beginning to avoid the contributor -spending time in vain. - ### Merging pull requests ### Our [CODEOWNERS][] file associates a team of maintainers to each -component. When a PR is opened (or a draft PR is marked as ready for -review), GitHub will automatically request reviews to maintainer teams -of affected components. As soon as it is the case, one available -member of a team that was requested a review should self-assign the -PR, and will act as its shepherd from then on. +component. When a PR is opened (or a [draft PR](#draft-pull-requests) +is marked as ready for review), GitHub will automatically request +reviews to maintainer teams of affected components. As soon as it is +the case, one available member of a team that was requested a review +should self-assign the PR, and will act as its shepherd from then on. The PR assignee is responsible for making sure that all the proposed changes have been reviewed by relevant maintainers (at least one @@ -1100,6 +1115,33 @@ interface to mark as read, save for later or mute threads. You can also manage your GitHub web notifications using a tool such as [Octobox][]. +##### Draft pull requests ##### + +[Draft PRs][GitHub-draft-PR] are a mechanism proposed by GitHub to +open a pull request before it is ready for review. + +Opening a draft PR is a way of announcing a change and seeking early +feedback without formally requesting maintainers' reviews. Indeed, +you should avoid cluttering our maintainers' review request lists +before a change is ready on your side. + +When opening a draft PR, make sure to give it a descriptive enough +title so that interested developers still notice it in their +notification feed. You may also advertise it by talking about it in +our [developer chat][Gitter]. If you know which developer would be +able to provide useful feedback to you, you may also ping them. + +###### Turning a PR into draft mode ###### + +If a PR was opened as ready for review, but it turns out that it still +needs work, it can be transformed into a draft PR. + +In this case, previous review requests won't be removed automatically. +Someone with write access to the repository should remove them +manually. Afterwards, upon marking the PR as ready for review, +someone with write access will have to manually add the review +requests that were previously removed. + #### GitLab documentation, tips and tricks #### We use GitLab mostly for its CI service. The [Coq organization on diff --git a/Makefile.build b/Makefile.build index 7879580e18..d705219757 100644 --- a/Makefile.build +++ b/Makefile.build @@ -201,7 +201,7 @@ DEPENDENCIES := \ # Default timing command # Use /usr/bin/env time on linux, gtime on Mac OS -TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" +TIMEFMT?="$@ (real: %e, user: %U, sys: %S, mem: %M ko)" ifneq (,$(TIMED)) ifeq (0,$(shell /usr/bin/env time -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=/usr/bin/env time -f $(TIMEFMT) @@ -269,10 +269,6 @@ OPT:= BESTOBJ:=.cmo BESTLIB:=.cma BESTDYN:=.cma - -# needed while booting if non -local -CAML_LD_LIBRARY_PATH := $(PWD)/kernel/byterun:$(CAML_LD_LIBRARY_PATH) -export CAML_LD_LIBRARY_PATH endif define bestobj diff --git a/Makefile.ci b/Makefile.ci index d4383fd409..1a5e8166a2 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -76,6 +76,8 @@ ci-quickchick: ci-ext-lib ci-simple-io ci-metacoq: ci-equations +ci-vst: ci-flocq + # Generic rule, we use make to ease CI integration $(CI_TARGETS): ci-%: +./dev/ci/ci-wrapper.sh $* diff --git a/Makefile.doc b/Makefile.doc index effd624cff..8be032ceb3 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -100,6 +100,9 @@ doc-stdlib: \ full-stdlib: \ doc/stdlib/html/index.html doc/stdlib/FullLibrary.ps doc/stdlib/FullLibrary.pdf +sphinx-clean: + rm -rf $(SPHINXBUILDDIR) + .PHONY: plugin-tutorial plugin-tutorial: states tools +$(MAKE) COQBIN=$(PWD)/bin/ -C $(PLUGINTUTO) diff --git a/checker/check.ml b/checker/check.ml index 4212aac6ea..31bfebc3d5 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -255,7 +255,7 @@ let try_locate_qualified_library lib = match lib with (*s Low-level interning of libraries from files *) let raw_intern_library f = - System.raw_intern_state Coq_config.vo_magic_number f + ObjFile.open_in ~file:f (************************************************************************) (* Internalise libraries *) @@ -294,57 +294,56 @@ type intern_mode = Rec | Root | Dep (* Rec = standard, Root = -norec, Dep = depe (* Dependency graph *) let depgraph = ref LibraryMap.empty -let marshal_in_segment ~validate ~value f ch = +let marshal_in_segment ~validate ~value ~segment f ch = + let () = LargeFile.seek_in ch segment.ObjFile.pos in if validate then - let v, stop, digest = + let v = try - let stop = input_binary_int ch in let v = Analyze.parse_channel ch in let digest = Digest.input ch in - v, stop, digest + let () = if not (String.equal digest segment.ObjFile.hash) then raise Exit in + v with _ -> user_err (str "Corrupted file " ++ quote (str f)) in let () = Validate.validate value v in let v = Analyze.instantiate v in - Obj.obj v, stop, digest + Obj.obj v else - System.marshal_in_segment f ch + System.marshal_in f ch -let skip_in_segment f ch = - try - let stop = (input_binary_int ch : int) in - seek_in ch stop; - let digest = Digest.input ch in - stop, digest - with _ -> - user_err (str "Corrupted file " ++ quote (str f)) - -let marshal_or_skip ~validate ~value f ch = +let marshal_or_skip ~validate ~value ~segment f ch = if validate then - let v, pos, digest = marshal_in_segment ~validate ~value f ch in - Some v, pos, digest + let v = marshal_in_segment ~validate:true ~value ~segment f ch in + Some v else - let pos, digest = skip_in_segment f ch in - None, pos, digest + None let intern_from_file ~intern_mode (dir, f) = let validate = intern_mode <> Dep in Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try + (* First pass to read the metadata of the file *) let ch = System.with_magic_number_check raw_intern_library f in - let (sd:summary_disk), _, digest = marshal_in_segment ~validate ~value:Values.v_libsum f ch in - let (md:library_disk), _, digest = marshal_in_segment ~validate ~value:Values.v_lib f ch in - let (opaque_csts:seg_univ option), _, udg = marshal_in_segment ~validate ~value:Values.v_univopaques f ch in - let (tasks:'a option), _, _ = marshal_in_segment ~validate ~value:Values.(Opt Any) f ch in - let (table:seg_proofs option), pos, checksum = - marshal_or_skip ~validate ~value:Values.v_opaquetable f ch in + let seg_sd = ObjFile.get_segment ch ~segment:"summary" in + let seg_md = ObjFile.get_segment ch ~segment:"library" in + let seg_univs = ObjFile.get_segment ch ~segment:"universes" in + let seg_tasks = ObjFile.get_segment ch ~segment:"tasks" in + let seg_opaque = ObjFile.get_segment ch ~segment:"opaques" in + let () = ObjFile.close_in ch in + (* Actually read the data *) + let ch = open_in_bin f in + + let (sd:summary_disk) = marshal_in_segment ~validate ~value:Values.v_libsum ~segment:seg_sd f ch in + let (md:library_disk) = marshal_in_segment ~validate ~value:Values.v_lib ~segment:seg_md f ch in + let (opaque_csts:seg_univ option) = marshal_in_segment ~validate ~value:Values.v_univopaques ~segment:seg_univs f ch in + let (tasks:'a option) = marshal_in_segment ~validate ~value:Values.(Opt Any) ~segment:seg_tasks f ch in + let (table:seg_proofs option) = + marshal_or_skip ~validate ~value:Values.v_opaquetable ~segment:seg_opaque f ch in (* Verification of the final checksum *) let () = close_in ch in let ch = open_in_bin f in - if not (String.equal (Digest.channel ch pos) checksum) then - user_err ~hdr:"intern_from_file" (str "Checksum mismatch"); let () = close_in ch in if dir <> sd.md_name then user_err ~hdr:"intern_from_file" @@ -361,8 +360,9 @@ let intern_from_file ~intern_mode (dir, f) = end; Flags.if_verbose chk_pp (str" done]" ++ fnl ()); let digest = - if opaque_csts <> None then Safe_typing.Dvivo (digest,udg) - else (Safe_typing.Dvo_or_vi digest) in + let open ObjFile in + if opaque_csts <> None then Safe_typing.Dvivo (seg_md.hash, seg_univs.hash) + else (Safe_typing.Dvo_or_vi seg_md.hash) in sd,md,table,opaque_csts,digest with e -> Flags.if_verbose chk_pp (str" failed!]" ++ fnl ()); raise e in depgraph := LibraryMap.add sd.md_name sd.md_deps !depgraph; 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/checker/votour.ml b/checker/votour.ml index a83ba20dd6..3fb3ccadf4 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -349,14 +349,63 @@ let parse_header chan = let size64 = input_binary_int chan in { magic; length; size32; size64; objects } +module ObjFile = +struct + type segment = { name : string; - mutable pos : int; - typ : Values.value; + pos : int64; + len : int64; + hash : Digest.t; mutable header : header; } -let make_seg name typ = { name; typ; pos = 0; header = dummy_header } +let input_int32 ch = + let accu = ref 0l in + for _i = 0 to 3 do + let c = input_byte ch in + accu := Int32.add (Int32.shift_left !accu 8) (Int32.of_int c) + done; + !accu + +let input_int64 ch = + let accu = ref 0L in + for _i = 0 to 7 do + let c = input_byte ch in + accu := Int64.add (Int64.shift_left !accu 8) (Int64.of_int c) + done; + !accu + +let input_segment_summary ch = + let nlen = input_int32 ch in + let name = really_input_string ch (Int32.to_int nlen) in + let pos = input_int64 ch in + let len = input_int64 ch in + let hash = Digest.input ch in + { name; pos; len; hash; header = dummy_header } + +let rec input_segment_summaries ch n accu = + if Int32.equal n 0l then Array.of_list (List.rev accu) + else + let s = input_segment_summary ch in + let accu = s :: accu in + input_segment_summaries ch (Int32.pred n) accu + +let parse_segments ch = + let magic = input_int32 ch in + let version = input_int32 ch in + let summary_pos = input_int64 ch in + let () = LargeFile.seek_in ch summary_pos in + let nsum = input_int32 ch in + let seg = input_segment_summaries ch nsum [] in + for i = 0 to Array.length seg - 1 do + let () = LargeFile.seek_in ch seg.(i).pos in + let header = parse_header ch in + seg.(i).header <- header + done; + (magic, version, seg) + +end let visit_vo f = Printf.printf "\nWelcome to votour !\n"; @@ -364,13 +413,13 @@ let visit_vo f = Printf.printf "Object sizes are in words (%d bits)\n" Sys.word_size; Printf.printf "At prompt, <n> enters the <n>-th child, u goes up 1 level, x exits\n\n%!"; - let segments = [| - make_seg "summary" Values.v_libsum; - make_seg "library" Values.v_lib; - make_seg "univ constraints of opaque proofs" Values.v_univopaques; - make_seg "STM tasks" (Opt Values.v_stm_seg); - make_seg "opaque proofs" Values.v_opaquetable; - |] in + let known_segments = [ + "summary", Values.v_libsum; + "library", Values.v_lib; + "universes", Values.v_univopaques; + "tasks", (Opt Values.v_stm_seg); + "opaques", Values.v_opaquetable; + ] in let repr = if Sys.word_size = 64 then (module ReprMem : S) else (module ReprObj : S) (* On 32-bit machines, representation may exceed the max size of arrays *) @@ -379,28 +428,23 @@ let visit_vo f = let module Visit = Visit(Repr) in while true do let ch = open_in_bin f in - let magic = input_binary_int ch in - Printf.printf "File format: %d\n%!" magic; - for i=0 to Array.length segments - 1 do - let pos = input_binary_int ch in - segments.(i).pos <- pos_in ch; - let header = parse_header ch in - segments.(i).header <- header; - seek_in ch pos; - ignore(Digest.input ch); - done; + let (_magic, version, segments) = ObjFile.parse_segments ch in + Printf.printf "File format: %ld\n%!" version; Printf.printf "The file has %d segments, choose the one to visit:\n" (Array.length segments); - Array.iteri (fun i { name; pos; header } -> + Array.iteri (fun i ObjFile.{ name; pos; header } -> let size = if Sys.word_size = 64 then header.size64 else header.size32 in - Printf.printf " %d: %s, starting at byte %d (size %iw)\n" i name pos size) + Printf.printf " %d: %s, starting at byte %Ld (size %iw)\n" i name pos size) segments; match read_num (Array.length segments) with | Some seg -> - seek_in ch segments.(seg).pos; + let seg = segments.(seg) in + let open ObjFile in + LargeFile.seek_in ch seg.pos; let o = Repr.input ch in let () = Visit.init () in - Visit.visit segments.(seg).typ o [] + let typ = try List.assoc seg.name known_segments with Not_found -> Any in + Visit.visit typ o [] | None -> () done diff --git a/config/coq_config.mli b/config/coq_config.mli index 6ed4bf9b8e..12856cb6e6 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -35,7 +35,7 @@ val caml_version : string (* OCaml version used to compile Coq *) val caml_version_nums : int list (* OCaml version used to compile Coq by components *) val date : string (* release date *) val compile_date : string (* compile date *) -val vo_magic_number : int +val vo_version : int32 val state_magic_number : int val all_src_dirs : string list diff --git a/configure.ml b/configure.ml index eaa0e321b0..0eff70999d 100644 --- a/configure.ml +++ b/configure.ml @@ -983,7 +983,7 @@ let config_runtime () = ["-dllib";"-lcoqrun";"-dllpath";("\"" ^ coqtop ^ "/kernel/byterun\"")] | _ -> let ld="CAML_LD_LIBRARY_PATH" in - build_loadpath := sprintf "export %s:='%s/kernel/byterun':$(%s)" ld coqtop ld; + build_loadpath := sprintf "export %s:=%s/kernel/byterun:$(%s)" ld coqtop ld; ["-dllib";"-lcoqrun";"-dllpath";coqlib/"kernel/byterun"] let vmbyteflags = config_runtime () @@ -1059,6 +1059,7 @@ let write_configml f = let pr_s = pr "let %s = %S\n" in let pr_b = pr "let %s = %B\n" in let pr_i = pr "let %s = %d\n" in + let pr_i32 = pr "let %s = %dl\n" in let pr_p s o = pr "let %s = %S\n" s (match o with Relative s -> s | Absolute s -> s) in let pr_li n l = pr "let %s = [%s]\n" n (String.concat ";" (List.map string_of_int l)) in @@ -1086,7 +1087,7 @@ let write_configml f = pr_s "exec_extension" exe; pr "let gtk_platform = `%s\n" !idearchdef; pr_b "has_natdynlink" hasnatdynlink; - pr_i "vo_magic_number" vo_magic; + pr_i32 "vo_version" vo_magic; pr_i "state_magic_number" state_magic; pr_s "browser" browser; pr_s "wwwcoq" !prefs.coqwebsite; 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/ci-flocq.sh b/dev/ci/ci-flocq.sh index e9f8324f28..7a9531216e 100755 --- a/dev/ci/ci-flocq.sh +++ b/dev/ci/ci-flocq.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download Flocq -( cd "${CI_BUILD_DIR}/Flocq" && autoconf && ./configure && ./remake "-j${NJOBS}" ) +( cd "${CI_BUILD_DIR}/Flocq" && autoconf && ./configure && ./remake "-j${NJOBS}" && ./remake install ) diff --git a/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh b/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh new file mode 100644 index 0000000000..cd6b408813 --- /dev/null +++ b/dev/ci/user-overlays/11896-ppedrot-evar-inst-list.sh @@ -0,0 +1,24 @@ +if [ "$CI_PULL_REQUEST" = "11896" ] || [ "$CI_BRANCH" = "evar-inst-list" ]; then + + coqhammer_CI_REF="evar-inst-list" + coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer + + elpi_CI_REF="evar-inst-list" + elpi_CI_GITURL=https://github.com/ppedrot/coq-elpi + + equations_CI_REF="evar-inst-list" + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + + metacoq_CI_REF="evar-inst-list" + metacoq_CI_GITURL=https://github.com/ppedrot/metacoq + + mtac2_CI_REF="evar-inst-list" + mtac2_CI_GITURL=https://github.com/ppedrot/Mtac2 + + quickchick_CI_REF="evar-inst-list" + quickchick_CI_GITURL=https://github.com/ppedrot/QuickChick + + unicoq_CI_REF="evar-inst-list" + unicoq_CI_GITURL=https://github.com/ppedrot/unicoq + +fi 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/dev/top_printers.ml b/dev/top_printers.ml index 542893ad0b..00050a89e1 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -287,7 +287,7 @@ let constr_display csr = "LetIn("^(name_display na)^","^(term_display b)^"," ^(term_display t)^","^(term_display c)^")" | App (c,l) -> "App("^(term_display c)^","^(array_display l)^")\n" - | Evar (e,l) -> "Evar("^(Pp.string_of_ppcmds (Evar.print e))^","^(array_display l)^")" + | Evar (e,l) -> "Evar("^(Pp.string_of_ppcmds (Evar.print e))^","^(array_display (Array.of_list l))^")" | Const (c,u) -> "Const("^(Constant.to_string c)^","^(universes_display u)^")" | Ind ((sp,i),u) -> "MutInd("^(MutInd.to_string sp)^","^(string_of_int i)^","^(universes_display u)^")" @@ -383,7 +383,7 @@ let print_pure_constr csr = Array.iter (fun x -> print_space (); box_display x) l; print_string ")" | Evar (e,l) -> print_string "Evar#"; print_int (Evar.repr e); print_string "{"; - Array.iter (fun x -> print_space (); box_display x) l; + List.iter (fun x -> print_space (); box_display x) l; print_string"}" | Const (c,u) -> print_string "Cons("; sp_con_display c; diff --git a/doc/changelog/04-tactics/11883-fix-autounfold.rst b/doc/changelog/04-tactics/11883-fix-autounfold.rst new file mode 100644 index 0000000000..83ff177380 --- /dev/null +++ b/doc/changelog/04-tactics/11883-fix-autounfold.rst @@ -0,0 +1,13 @@ +- **Fixed:** + The behavior of :tacn:`autounfold` no longer depends on the names of terms and modules + (`#11883 <https://github.com/coq/coq/pull/11883>`_, + fixes `#7812 <https://github.com/coq/coq/issues/7812>`_, + by Attila Gáspár). +- **Changed:** + `at` clauses can no longer be used with :tacn:`autounfold`. Since they had no effect, it is safe to remove them + (`#11883 <https://github.com/coq/coq/pull/11883>`_, + by Attila Gáspár). +- **Changed:** + :tacn:`autounfold` no longer fails when the :cmd:`Opaque` command is used on constants in the hint databases + (`#11883 <https://github.com/coq/coq/pull/11883>`_, + by Attila Gáspár). 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/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst b/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst new file mode 100644 index 0000000000..7af2b4d97b --- /dev/null +++ b/doc/changelog/04-tactics/12116-master+fix12045-missing-reduction-in-using-ind-scheme.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Anomaly with induction schemes whose conclusion is not normalized + (`#12116 <https://github.com/coq/coq/pull/12116>`_, + by Hugo Herbelin; fixes + `#12045 <https://github.com/coq/coq/pull/12045>`_) 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/08-tools/12126-adjust-timed-name.rst b/doc/changelog/08-tools/12126-adjust-timed-name.rst new file mode 100644 index 0000000000..c305b384d9 --- /dev/null +++ b/doc/changelog/08-tools/12126-adjust-timed-name.rst @@ -0,0 +1,8 @@ +- **Changed:** + The output of ``make TIMED=1`` (and therefore the timing targets + such as ``print-pretty-timed`` and ``print-pretty-timed-diff``) now + displays the full name of the output file being built, rather than + the stem of the rule (which was usually the filename without the + extension, but in general could be anything for user-defined rules + involving ``%``) (`#12126 + <https://github.com/coq/coq/pull/12126>`_, by Jason Gross). diff --git a/doc/changelog/09-coqide/12060-ide-disable-csd.rst b/doc/changelog/09-coqide/12060-ide-disable-csd.rst new file mode 100644 index 0000000000..b61ab26007 --- /dev/null +++ b/doc/changelog/09-coqide/12060-ide-disable-csd.rst @@ -0,0 +1,6 @@ +- **Changed:** + CoqIDE now uses native window frames by default on Windows. + The GTK window frames can be restored by setting the `GTK_CSD` environment variable to `1` + (`#12060 <https://github.com/coq/coq/pull/12060>`_, + fixes `#11080 <https://github.com/coq/coq/issues/11080>`_, + by Attila Gáspár). diff --git a/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst b/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst index a17e9956b9..6b1148a9a8 100644 --- a/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst +++ b/doc/changelog/09-coqide/12106-master+coqide-style-apply-all-windows.rst @@ -1,5 +1,5 @@ - **Fixed:** - Highlighting style and language settings consistently apply to all three buffers of CoqIDE + Highlighting style consistently applied to all three buffers of CoqIDE (`#12106 <https://github.com/coq/coq/pull/12106>`_, by Hugo Herbelin; fixes `#11506 <https://github.com/coq/coq/pull/11506>`_). diff --git a/doc/changelog/10-standard-library/12014-ollibs-vector.rst b/doc/changelog/10-standard-library/12014-ollibs-vector.rst new file mode 100644 index 0000000000..87625dd23b --- /dev/null +++ b/doc/changelog/10-standard-library/12014-ollibs-vector.rst @@ -0,0 +1,10 @@ +- **Added:** + Properties of some operations on vectors: + + - ``nth_order``: ``nth_order_hd``, ``nth_order_tl``, ``nth_order_ext`` + - ``replace``: ``nth_order_replace_eq``, ``nth_order_replace_neq``, ``replace_id``, ``replace_replace_eq``, ``replace_replace_neq`` + - ``map``: ``map_id``, ``map_map``, ``map_ext_in``, ``map_ext`` + - ``Forall`` and ``Forall2``: ``Forall_impl``, ``Forall_forall``, ``Forall_nth_order``, ``Forall2_nth_order`` + + (`#12014 <https://github.com/coq/coq/pull/12014>`_, + by Olivier Laurent). 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/12073-split-nsatz.rst b/doc/changelog/10-standard-library/12073-split-nsatz.rst new file mode 100644 index 0000000000..bc3c24e441 --- /dev/null +++ b/doc/changelog/10-standard-library/12073-split-nsatz.rst @@ -0,0 +1,11 @@ +- **Changed:** + It is now possible to import the :g:`nsatz` machinery without + transitively depending on the axioms of the real numbers nor of + classical logic by loading ``Coq.nsatz.NsatzTactic`` rather than + ``Coq.nsatz.Nsatz``. Note that some constants have changed kernel + names, living in ``Coq.nsatz.NsatzTactic`` rather than + ``Coq.nsatz.Nsatz``; this might cause minor incompatibilities that + can be fixed by actually running :g:`Import Nsatz` rather than + relying on absolute names (fixes `#5445 + <https://github.com/coq/coq/issues/5445>`_, `#12073 + <https://github.com/coq/coq/pull/12073>`_, by Jason Gross). 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; -} @@ -23,7 +23,14 @@ (targets refman-html) (alias refman-html) (package coq-doc) - (deps (alias refman-deps)) + ; Cannot use this deps alias because of ocaml/dune#3415 + ; (deps (alias refman-deps)) + (deps + (package coq) + (source_tree sphinx) + (source_tree tools/coqrst) + unreleased.rst + (env_var SPHINXWARNOPT)) (action (run env COQLIB=%{project_root} sphinx-build %{env:SPHINXWARNOPT=-W} -b html sphinx %{targets}))) @@ -31,7 +38,14 @@ (targets refman-pdf) (alias refman-pdf) (package coq-doc) - (deps (alias refman-deps)) + ; Cannot use this deps alias because of ocaml/dune#3415 + ; (deps (alias refman-deps)) + (deps + (package coq) + (source_tree sphinx) + (source_tree tools/coqrst) + unreleased.rst + (env_var SPHINXWARNOPT)) (action (progn (run env COQLIB=%{project_root} sphinx-build %{env:SPHINXWARNOPT=-W} -b latex sphinx %{targets}) diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index 082ea4691b..e1b1ee8e8d 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -1,4 +1,4 @@ -.. _omega: +.. _omega_chapter: Omega: a solver for quantifier-free problems in Presburger Arithmetic ===================================================================== @@ -28,6 +28,7 @@ Description of ``omega`` ------------------------ .. tacn:: omega + :name: omega .. deprecated:: 8.12 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/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index a08495badd..2958d866ac 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -227,7 +227,7 @@ constraints by prefixing the level names with symbols. Because inductive subtypings are only produced by comparing inductives to themselves with universes changed, they amount to variance information: each universe is either invariant, covariant or -irrelevant (there are no contravariant subtypings in Coq), +irrelevant (there are no contravariant subtypings in |Coq|), respectively represented by the symbols `=`, `+` and `*`. Here we see that :g:`list` binds an irrelevant universe, so any two @@ -426,6 +426,19 @@ mode, introduced universe names can be referred to in terms. Note that local universe names shadow global universe names. During a proof, one can use :cmd:`Show Universes` to display the current context of universes. +It is possible to provide only some universe levels and let |Coq| infer the others +by adding a :g:`+` in the list of bound universe levels: + +.. coqtop:: all + + Fail Definition foobar@{u} : Type@{u} := Type. + Definition foobar@{u +} : Type@{u} := Type. + Set Printing Universes. + Print foobar. + +This can be used to find which universes need to be explicitly bound in a given +definition. + Definitions can also be instantiated explicitly, giving their full instance: diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index c55c1f644c..88ca0e63d8 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -55,7 +55,8 @@ __ 811Reals_ Additionally, while the :tacn:`omega` tactic is not yet deprecated in this version of Coq, it should soon be the case and we already recommend users to switch to :tacn:`lia` in new proof scripts (see -also the warning message in the :ref:`corresponding chapter <omega>`). +also the warning message in the :ref:`corresponding chapter +<omega_chapter>`). The ``dev/doc/critical-bugs`` file documents the known critical bugs of |Coq| and affected releases. See the `Changes in 8.11+beta1`_ @@ -481,10 +482,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/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 0f255e4e64..4e8a2b0879 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -100,19 +100,6 @@ processed color, though their preceding proofs have the processed color. Notice that for all these buttons, except for the "gears" button, their operations are also available in the menu, where their keyboard shortcuts are given. -Proof folding ------------------- - -As your script grows bigger and bigger, it might be useful to hide the -proofs of your theorems and lemmas. - -This feature is toggled via the Hide entry of the Navigation menu. The -proof shall be enclosed between ``Proof.`` and ``Qed.``, both with their final -dots. The proof that shall be hidden or revealed is the first one -whose beginning statement (such as ``Theorem``) precedes the insertion -cursor. - - Vernacular commands, templates ----------------------------------- diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 921c7bbbf7..bc77e2e58c 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -245,9 +245,9 @@ file timing data: COQDEP Fast.v COQDEP Slow.v COQC Slow.v - Slow (user: 0.34 mem: 395448 ko) + Slow.vo (user: 0.34 mem: 395448 ko) COQC Fast.v - Fast (user: 0.01 mem: 45184 ko) + Fast.vo (user: 0.01 mem: 45184 ko) + ``pretty-timed`` this target stores the output of ``make TIMED=1`` into @@ -280,15 +280,15 @@ file timing data: COQDEP Fast.v COQDEP Slow.v COQC Slow.v - Slow (user: 0.36 mem: 393912 ko) + Slow.vo (user: 0.36 mem: 393912 ko) COQC Fast.v - Fast (user: 0.05 mem: 45992 ko) + Fast.vo (user: 0.05 mem: 45992 ko) Time | File Name -------------------- 0m00.41s | Total -------------------- - 0m00.36s | Slow - 0m00.05s | Fast + 0m00.36s | Slow.vo + 0m00.05s | Fast.vo + ``print-pretty-timed-diff`` @@ -338,8 +338,8 @@ file timing data: -------------------------------------------------------- 0m00.39s | Total | 0m00.35s || +0m00.03s | +11.42% -------------------------------------------------------- - 0m00.37s | Slow | 0m00.01s || +0m00.36s | +3600.00% - 0m00.02s | Fast | 0m00.34s || -0m00.32s | -94.11% + 0m00.37s | Slow.vo | 0m00.01s || +0m00.36s | +3600.00% + 0m00.02s | Fast.vo | 0m00.34s || -0m00.32s | -94.11% The following targets and ``Makefile`` variables allow collection of per- diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index b5d1e8bffd..28c5359a04 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -1624,9 +1624,15 @@ previous :token:`i_item` have been performed. The second entry in the :token:`i_view` grammar rule, ``/ltac:(`` :token:`tactic` ``)``, executes :token:`tactic`. -Notations can be used to name tactics, for example:: +Notations can be used to name tactics, for example - Notation myop := (ltac:(some ltac code)) : ssripat_scope. +.. coqtop:: none + + Tactic Notation "my" "ltac" "code" := idtac. + +.. coqtop:: in warn + + Notation "'myop'" := (ltac:(my ltac code)) : ssripat_scope. lets one write just ``/myop`` in the intro pattern. Note the scope annotation: views are interpreted opening the ``ssripat`` scope. diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 06186d4f08..8989dd29ab 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -1875,6 +1875,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) Lemma induction_test : forall n:nat, n = n -> n <= n. intros n H. induction n. + exact (le_n 0). .. exn:: Not an inductive product. :undocumented: @@ -2076,7 +2077,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 +2105,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 +2612,8 @@ and an explanation of the underlying technique. assumption. Qed. +.. seealso:: :tacn:`functional inversion` + .. tacn:: fix @ident @num :name: fix @@ -3945,10 +3887,10 @@ At Coq startup, only the core database is nonempty and can be used. :arith: This database contains all lemmas about Peano’s arithmetic proved in the directories Init and Arith. -:zarith: contains lemmas about binary signed integers from the directories - theories/ZArith. When required, the module Omega also extends the - database zarith with a high-cost hint that calls ``omega`` on equations - and inequalities in ``nat`` or ``Z``. +:zarith: contains lemmas about binary signed integers from the + directories theories/ZArith. The database also contains + high-cost hints that call :tacn:`lia` on equations and + inequalities in ``nat`` or ``Z``. :bool: contains lemmas about booleans, mostly from directory theories/Bool. @@ -4539,42 +4481,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 ----------------- @@ -4631,18 +4537,6 @@ Automating The goal is not of the form :g:`t = u`. Especially note that :tacn:`btauto` doesn't introduce variables into the context on its own. -.. tacn:: omega - :name: omega - - The tactic :tacn:`omega`, due to Pierre Crégut, is an automatic decision - procedure for Presburger arithmetic. It solves quantifier-free - formulas built with `~`, `\\/`, `/\\`, `->` on top of equalities, - inequalities and disequalities on both the type :g:`nat` of natural numbers - and :g:`Z` of binary integers. This tactic must be loaded by the command - ``Require Import Omega``. See the additional documentation about omega - (see Chapter :ref:`omega`). - - .. tacn:: ring :name: ring diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index f921e65955..3d69126b2d 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -91,9 +91,15 @@ capital letter. This command supports the :attr:`local`, :attr:`global` and :attr:`export` attributes. They are described :ref:`here <set_unset_scope_qualifiers>`. - .. warn:: There is no option @setting_name. + .. warn:: There is no flag or option with this name: "@setting_name". - This message also appears for unknown flags. + This warning message can be raised by :cmd:`Set` and + :cmd:`Unset` when :n:`@setting_name` is unknown. It is a + warning rather than an error because this helps library authors + produce Coq code that is compatible with several Coq versions. + To preserve the same behavior, they may need to set some + compatibility flags or options that did not exist in previous + Coq versions. .. cmd:: Unset @setting_name :name: Unset @@ -119,6 +125,20 @@ capital letter. whether the table contains each specified value, otherise this is equivalent to :cmd:`Print Table`. The `for` clause is not valid for flags and options. + .. exn:: There is no flag, option or table with this name: "@setting_name". + + This error message is raised when calling the :cmd:`Test` + command (without the `for` clause), or the :cmd:`Print Table` + command, for an unknown :n:`@setting_name`. + + .. exn:: There is no qualid-valued table with this name: "@setting_name". + There is no string-valued table with this name: "@setting_name". + + These error messages are raised when calling the :cmd:`Add` or + :cmd:`Remove` commands, or the :cmd:`Test` command with the + `for` clause, if :n:`@setting_name` is unknown or does not have + the right type. + .. cmd:: Print Options Prints the current value of all flags and options, and the names of all tables. @@ -1077,6 +1097,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/hidden-files b/doc/stdlib/hidden-files index 65c88ed8d5..3af16cb731 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -53,6 +53,7 @@ theories/micromega/ZifyComparison.v theories/micromega/ZifyClasses.v theories/micromega/ZifyPow.v theories/micromega/Zify.v +theories/nsatz/NsatzTactic.v theories/nsatz/Nsatz.v theories/omega/Omega.v theories/omega/OmegaLemmas.v 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/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 6d33b44470..6111eaa160 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -919,14 +919,14 @@ command: [ | DELETE "Unset" option_table | REPLACE "Set" option_table option_setting | WITH OPT "Export" "Set" option_table (* set flag *) -| REPLACE "Test" option_table "for" LIST1 option_ref_value -| WITH "Test" option_table OPT ( "for" LIST1 option_ref_value ) +| REPLACE "Test" option_table "for" LIST1 table_value +| WITH "Test" option_table OPT ( "for" LIST1 table_value ) | DELETE "Test" option_table (* hide the fact that table names are limited to 2 IDENTs *) -| REPLACE "Add" IDENT IDENT LIST1 option_ref_value -| WITH "Add" option_table LIST1 option_ref_value -| DELETE "Add" IDENT LIST1 option_ref_value +| REPLACE "Add" IDENT IDENT LIST1 table_value +| WITH "Add" option_table LIST1 table_value +| DELETE "Add" IDENT LIST1 table_value | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident | DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident @@ -982,9 +982,9 @@ command: [ | DELETE "Preterm" (* hide the fact that table names are limited to 2 IDENTs *) -| REPLACE "Remove" IDENT IDENT LIST1 option_ref_value -| WITH "Remove" option_table LIST1 option_ref_value -| DELETE "Remove" IDENT LIST1 option_ref_value +| REPLACE "Remove" IDENT IDENT LIST1 table_value +| WITH "Remove" option_table LIST1 table_value +| DELETE "Remove" IDENT LIST1 table_value | DELETE "Restore" "State" IDENT | DELETE "Restore" "State" ne_string | "Restore" "State" [ IDENT | ne_string ] @@ -1613,7 +1613,7 @@ SPLICE: [ | constructor_type | record_binder | at_level_opt -| option_ref_value +| table_value | positive_search_mark | in_or_out_modules | option_setting diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 04c20a7203..4274dccb40 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -524,12 +524,12 @@ command: [ | "Set" option_table option_setting | "Unset" option_table | "Print" "Table" option_table -| "Add" IDENT IDENT LIST1 option_ref_value -| "Add" IDENT LIST1 option_ref_value -| "Test" option_table "for" LIST1 option_ref_value +| "Add" IDENT IDENT LIST1 table_value +| "Add" IDENT LIST1 table_value +| "Test" option_table "for" LIST1 table_value | "Test" option_table -| "Remove" IDENT IDENT LIST1 option_ref_value -| "Remove" IDENT LIST1 option_ref_value +| "Remove" IDENT IDENT LIST1 table_value +| "Remove" IDENT LIST1 table_value | "Write" "State" IDENT | "Write" "State" ne_string | "Restore" "State" IDENT @@ -1318,7 +1318,7 @@ option_setting: [ | STRING ] -option_ref_value: [ +table_value: [ | global | STRING ] diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 4508633858..ca681e58f8 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -355,7 +355,7 @@ let iter_with_full_binders sigma g f n c = | Lambda (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c | LetIn (na,b,t,c) -> f n b; f n t; f (g (LocalDef (na, b, t)) n) c | App (c,l) -> f n c; Array.Fun1.iter f n l - | Evar (_,l) -> Array.Fun1.iter f n l + | Evar (_,l) -> List.iter (fun c -> f n c) l | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl | Proj (p,c) -> f n c | Fix (_,(lna,tl,bl)) -> @@ -717,7 +717,7 @@ let val_of_named_context e = val_of_named_context (cast_named_context unsafe_eq let named_context_of_val e = cast_named_context (sym unsafe_eq) (named_context_of_val e) let of_existential : Constr.existential -> existential = - let gen : type a b. (a,b) eq -> 'c * b array -> 'c * a array = fun Refl x -> x in + let gen : type a b. (a,b) eq -> 'c * b list -> 'c * a list = fun Refl x -> x in gen unsafe_eq let lookup_rel i e = cast_rel_decl (sym unsafe_eq) (lookup_rel i e) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index fdcdfe11f4..5fcadfcef7 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -200,7 +200,7 @@ let make_pure_subst evi args = match args with | a::rest -> (rest, (NamedDecl.get_id decl, a)::l) | _ -> anomaly (Pp.str "Instance does not match its signature.")) - (evar_filtered_context evi) (Array.rev_to_list args,[])) + (evar_filtered_context evi) (List.rev args,[])) (*------------------------------------* * functional operations on evar sets * @@ -448,7 +448,7 @@ let new_evar_instance ?src ?filter ?abstract_arguments ?candidates ?naming ?type assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); let (evd, newevk) = new_pure_evar sign evd ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_candidate ?principal typ in - evd, mkEvar (newevk,Array.of_list instance) + evd, mkEvar (newevk, instance) let new_evar_from_context ?src ?filter ?candidates ?naming ?typeclass_candidate ?principal sign evd typ = let instance = List.map (NamedDecl.get_id %> EConstr.mkVar) (named_context_of_val sign) in @@ -506,7 +506,7 @@ let generalize_evar_over_rels sigma (ev,args) = List.fold_left2 (fun (c,inst as x) a d -> if isRel sigma a then (mkNamedProd_or_LetIn d c,a::inst) else x) - (evi.evar_concl,[]) (Array.to_list args) sign + (evi.evar_concl,[]) args sign (************************************) (* Removing a dependency in an evar *) @@ -594,7 +594,7 @@ let rec check_and_clear_in_constr env evdref err ids global c = (* No dependency at all, we can keep this ev's context hyp *) (ri, true::filter) with Depends id -> (Id.Map.add (NamedDecl.get_id h) id ri, false::filter)) - ctxt (Array.to_list l) (Id.Map.empty,[]) in + ctxt l (Id.Map.empty,[]) in (* Check if some rid to clear in the context of ev has dependencies in the type of ev and adjust the source of the dependency *) let _nconcl = @@ -736,7 +736,7 @@ let undefined_evars_of_term evd t = match EConstr.kind evd c with | Evar (n, l) -> let acc = Evar.Set.add n acc in - Array.fold_left evrec acc l + List.fold_left evrec acc l | _ -> EConstr.fold evd evrec acc c in evrec Evar.Set.empty t diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 1dec63aaf0..b5c7ccb283 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -88,7 +88,7 @@ val new_evar_instance : named_context_val -> evar_map -> types -> constr list -> evar_map * constr -val make_pure_subst : evar_info -> 'a array -> (Id.t * 'a) list +val make_pure_subst : evar_info -> 'a list -> (Id.t * 'a) list val safe_evar_value : evar_map -> Constr.existential -> Constr.constr option diff --git a/engine/evd.ml b/engine/evd.ml index 65fe261ff4..5642145f6d 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -233,32 +233,27 @@ exception NotInstantiatedEvar (* Note: let-in contributes to the instance *) let evar_instance_array test_id info args = - let len = Array.length args in - let rec instrec filter ctxt i = match filter, ctxt with - | [], [] -> - if Int.equal i len then [] - else instance_mismatch () - | false :: filter, _ :: ctxt -> - instrec filter ctxt i - | true :: filter, d :: ctxt -> - if i < len then - let c = Array.unsafe_get args i in - if test_id d c then instrec filter ctxt (succ i) - else (NamedDecl.get_id d, c) :: instrec filter ctxt (succ i) - else instance_mismatch () + let rec instrec filter ctxt args = match filter, ctxt, args with + | [], [], [] -> [] + | false :: filter, _ :: ctxt, args -> + instrec filter ctxt args + | true :: filter, d :: ctxt, c :: args -> + if test_id d c then instrec filter ctxt args + else (NamedDecl.get_id d, c) :: instrec filter ctxt args | _ -> instance_mismatch () in match Filter.repr (evar_filter info) with | None -> - let map i d = - if (i < len) then - let c = Array.unsafe_get args i in - if test_id d c then None else Some (NamedDecl.get_id d, c) - else instance_mismatch () + let rec instance ctxt args = match ctxt, args with + | [], [] -> [] + | d :: ctxt, c :: args -> + if test_id d c then instance ctxt args + else (NamedDecl.get_id d, c) :: instance ctxt args + | _ -> instance_mismatch () in - List.map_filter_i map (evar_context info) + instance (evar_context info) args | Some filter -> - instrec filter (evar_context info) 0 + instrec filter (evar_context info) args let make_evar_instance_array info args = evar_instance_array (NamedDecl.get_id %> isVarId) info args @@ -794,7 +789,7 @@ let restrict evk filter ?candidates ?src evd = | _ -> Evar.Set.add evk evd.last_mods in let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in let ctxt = Filter.filter_list filter (evar_context evar_info) in - let id_inst = Array.map_of_list (NamedDecl.get_id %> mkVar) ctxt in + let id_inst = List.map (NamedDecl.get_id %> mkVar) ctxt in let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in let evar_flags = declare_restricted_evar evd.evar_flags evk evk' in @@ -1405,7 +1400,7 @@ let evars_of_term evd c = let rec evrec acc c = let c = MiniEConstr.whd_evar evd c in match kind c with - | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) + | Evar (n, l) -> Evar.Set.add n (List.fold_left evrec acc l) | _ -> Constr.fold evrec acc c in evrec Evar.Set.empty c @@ -1413,7 +1408,7 @@ let evars_of_term evd c = let evar_nodes_of_term c = let rec evrec acc c = match kind c with - | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) + | Evar (n, l) -> Evar.Set.add n (List.fold_left evrec acc l) | _ -> Constr.fold evrec acc c in evrec Evar.Set.empty c diff --git a/engine/evd.mli b/engine/evd.mli index bbdb63a467..c6c4a71b22 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -247,9 +247,9 @@ val existential_opt_value : evar_map -> econstr pexistential -> econstr option val existential_opt_value0 : evar_map -> existential -> constr option val evar_instance_array : (Constr.named_declaration -> 'a -> bool) -> evar_info -> - 'a array -> (Id.t * 'a) list + 'a list -> (Id.t * 'a) list -val instantiate_evar_array : evar_info -> econstr -> econstr array -> econstr +val instantiate_evar_array : evar_info -> econstr -> econstr list -> econstr val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> evar_map -> evar_map -> evar_map diff --git a/engine/termops.ml b/engine/termops.ml index 16f2a87c1e..6d779e6a35 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -636,8 +636,8 @@ let map_constr_with_binders_left_to_right sigma g f l c = if b' == b then c else mkProj (p, b') | Evar (e,al) -> - let al' = Array.map_left (f l) al in - if Array.for_all2 (==) al' al then c + let al' = List.map_left (f l) al in + if List.for_all2 (==) al' al then c else mkEvar (e, al') | Case (ci,p,b,bl) -> (* In v8 concrete syntax, predicate is after the term to match! *) @@ -707,8 +707,8 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let c' = f l c in if c' == c then cstr else mkProj (p, c') | Evar (e,al) -> - let al' = Array.map (f l) al in - if Array.for_all2 (==) al al' then cstr else mkEvar (e, al') + let al' = List.map (f l) al in + if List.for_all2 (==) al al' then cstr else mkEvar (e, al') | Case (ci,p,c,bl) when userview -> let p' = map_return_predicate_with_full_binders sigma g f l ci p in let c' = f l c in 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/engine/univSubst.ml b/engine/univSubst.ml index 6000650ad9..a691239ee2 100644 --- a/engine/univSubst.ml +++ b/engine/univSubst.ml @@ -131,7 +131,7 @@ let nf_evars_and_universes_opt_subst f subst = let rec aux c = match kind c with | Evar (evk, args) -> - let args = Array.map aux args in + let args = List.map aux args in (match try f (evk, args) with Not_found -> None with | None -> mkEvar (evk, args) | Some c -> aux c) diff --git a/ide/coqide.ml b/ide/coqide.ml index 54ef8c7a8a..ab2a17798e 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -1301,10 +1301,7 @@ let build_ui () = in let refresh_language lang = let lang = lang_manager#language lang in - let iter_session v = - v.script#source_buffer#set_language lang; - v.proof#source_buffer#set_language lang; - v.messages#default_route#source_buffer#set_language lang in + let iter_session v = v.script#source_buffer#set_language lang in List.iter iter_session notebook#pages in let refresh_toolbar b = diff --git a/ide/coqide_WIN32.ml.in b/ide/coqide_WIN32.ml.in index 2d3964f210..be8aab9e49 100644 --- a/ide/coqide_WIN32.ml.in +++ b/ide/coqide_WIN32.ml.in @@ -44,6 +44,7 @@ let () = Coq.gio_channel_of_descr_socket := Glib.Io.channel_of_descr_socket; set_win32_path (); Coq.interrupter := win32_interrupt; - reroute_stdout_stderr () + reroute_stdout_stderr (); + try ignore (Unix.getenv "GTK_CSD") with Not_found -> Unix.putenv "GTK_CSD" "0" let init () = () diff --git a/ide/session.ml b/ide/session.ml index b16af9c317..09391b7f50 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -151,7 +151,7 @@ let set_buffer_handlers else if it#has_tag Tags.Script.processed then Some old else if it#has_tag Tags.Script.error_bg then aux it it#backward_char else None in - aux it it in + aux it it#copy in let insert_cb it s = if String.length s = 0 then () else begin Minilib.log ("insert_cb " ^ string_of_int it#offset); let text_mark = add_mark it in diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 9d97b01a7a..6e22172d05 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -46,7 +46,6 @@ let message_view () : message_view = let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true ~tag_table:Tags.Message.table - ?language:(lang_manager#language source_language#get) ?style_scheme:(style_manager#style_scheme source_style#get) () in let mark = buffer#create_mark ~left_gravity:false buffer#start_iter in diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index b8ed3436ce..1de63953af 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -197,7 +197,6 @@ let proof_view () = let buffer = GSourceView3.source_buffer ~highlight_matching_brackets:true ~tag_table:Tags.Proof.table - ?language:(lang_manager#language source_language#get) ?style_scheme:(style_manager#style_scheme source_style#get) () in let text_buffer = new GText.buffer buffer#as_buffer in diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 7a14ca3e48..a37bac3275 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -282,9 +282,9 @@ let insert_pat_alias ?loc p = function | Anonymous -> p | Name _ as na -> CAst.make ?loc @@ CPatAlias (p,(CAst.make ?loc na)) -let rec insert_coercion ?loc l c = match l with +let rec insert_entry_coercion ?loc l c = match l with | [] -> c - | (inscope,ntn)::l -> CAst.make ?loc @@ CNotation (Some inscope,ntn,([insert_coercion ?loc l c],[],[],[])) + | (inscope,ntn)::l -> CAst.make ?loc @@ CNotation (Some inscope,ntn,([insert_entry_coercion ?loc l c],[],[],[])) let rec insert_pat_coercion ?loc l c = match l with | [] -> c @@ -453,7 +453,8 @@ let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = with No_match -> let loc = pat.CAst.loc in match DAst.get pat with - | PatVar (Name id) when entry_has_ident custom -> CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) + | PatVar (Name id) when entry_has_global custom || entry_has_ident custom -> + CAst.make ?loc (CPatAtom (Some (qualid_of_ident ?loc id))) | pat -> match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match @@ -615,6 +616,10 @@ let is_projection nargs r = let is_hole = function CHole _ | CEvar _ -> true | _ -> false +let isCRef_no_univ = function + | CRef (_,None) -> true + | _ -> false + let is_significant_implicit a = not (is_hole (a.CAst.v)) @@ -849,7 +854,7 @@ let extern_possible_prim_token (custom,scopes) r = | Some coercion -> match availability_of_prim_token n sc scopes with | None -> raise No_match - | Some key -> insert_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) + | Some key -> insert_entry_coercion coercion (insert_delimiters (CAst.make ?loc:(loc_of_glob_constr r) @@ CPrim n) key) let filter_enough_applied nargs l = match nargs with @@ -931,7 +936,8 @@ let rec extern inctx ?impargs scopes vars r = match DAst.get r with | GRef (ref,us) when entry_has_global (fst scopes) -> CAst.make ?loc (extern_ref vars ref us) - | GVar id when entry_has_ident (fst scopes) -> CAst.make ?loc (extern_var ?loc id) + | GVar id when entry_has_global (fst scopes) || entry_has_ident (fst scopes) -> + CAst.make ?loc (extern_var ?loc id) | c -> @@ -1081,7 +1087,7 @@ let rec extern inctx ?impargs scopes vars r = | GFloat f -> extern_float f (snd scopes) - in insert_coercion coercion (CAst.make ?loc c) + in insert_entry_coercion coercion (CAst.make ?loc c) and extern_typ ?impargs (subentry,(_,scopes)) = extern true ?impargs (subentry,(Notation.current_type_scope_name (),scopes)) @@ -1279,14 +1285,11 @@ and extern_notation (custom,scopes as allscopes) vars t rules = pi3 (extern_local_binder (subentry,(scopt,scl@scopes')) vars bl)) binderlists in let c = make_notation loc specific_ntn (l,ll,bl,bll) in - let c = insert_coercion coercion (insert_delimiters c key) in + let c = insert_entry_coercion coercion (insert_delimiters c key) in let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in CAst.make ?loc @@ extern_applied_notation nallargs argsimpls c args) | SynDefRule kn -> - match availability_of_entry_coercion custom InConstrEntrySomeLevel with - | None -> raise No_match - | Some coercion -> let l = List.map (fun (c,(subentry,(scopt,scl))) -> extern true (subentry,(scopt,scl@snd scopes)) vars c) @@ -1296,7 +1299,10 @@ and extern_notation (custom,scopes as allscopes) vars t rules = let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in let c = CAst.make ?loc @@ extern_applied_syntactic_definition nallargs argsimpls (a,cf) l args in - insert_coercion coercion c + if isCRef_no_univ c.CAst.v && entry_has_global custom then c + else match availability_of_entry_coercion custom InConstrEntrySomeLevel with + | None -> raise No_match + | Some coercion -> insert_entry_coercion coercion c with No_match -> extern_notation allscopes vars t rules diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index c31cdae6f5..de02882370 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -613,7 +613,7 @@ let rec to_constr lfts v = subst_constr subs f) | FEvar ((ev,args),env) -> let subs = comp_subs lfts env in - mkEvar(ev,Array.map (fun a -> subst_constr subs a) args) + mkEvar(ev,List.map (fun a -> subst_constr subs a) args) | FLIFT (k,a) -> to_constr (el_shft k lfts) a | FInt i -> @@ -1408,7 +1408,7 @@ and norm_head info tab m = Array.Fun1.map mk_clos (subs_liftn (Array.length na) e) bds in mkFix(n,(na, CArray.map (kl info tab) ftys, CArray.map (kl info tab) fbds)) | FEvar((i,args),env) -> - mkEvar(i, Array.map (fun a -> kl info tab (mk_clos env a)) args) + mkEvar(i, List.map (fun a -> kl info tab (mk_clos env a)) args) | FProj (p,c) -> mkProj (p, kl info tab c) | FLOCKED | FRel _ | FAtom _ | FFlex _ | FInd _ | FConstruct _ diff --git a/kernel/clambda.ml b/kernel/clambda.ml index 8c7aa6b17a..65de52c0f6 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -670,7 +670,7 @@ let rec lambda_of_constr env c = match Constr.kind c with | Meta _ -> raise (Invalid_argument "Cbytegen.lambda_of_constr: Meta") | Evar (evk, args) -> - let args = lambda_of_args env 0 args in + let args = Array.map_of_list (fun c -> lambda_of_constr env c) args in Levar (evk, args) | Cast (c, _, _) -> lambda_of_constr env c @@ -799,9 +799,6 @@ and lambda_of_args env start args = (fun i -> lambda_of_constr env args.(start + i)) else empty_args - - - (*********************************) let dump_lambda = ref false diff --git a/kernel/constr.ml b/kernel/constr.ml index ade03fdf93..703e3616a0 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -71,7 +71,7 @@ type case_info = (* [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) -type 'constr pexistential = existential_key * 'constr array +type 'constr pexistential = existential_key * 'constr list type ('constr, 'types) prec_declaration = Name.t binder_annot array * 'types array * 'constr array type ('constr, 'types) pfixpoint = @@ -110,7 +110,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = type t = (t, t, Sorts.t, Instance.t) kind_of_term type constr = t -type existential = existential_key * constr array +type existential = existential_key * constr list type types = constr @@ -470,7 +470,7 @@ let fold f acc c = match kind c with | LetIn (_,b,t,c) -> f (f (f acc b) t) c | App (c,l) -> Array.fold_left f (f acc c) l | Proj (_p,c) -> f acc c - | Evar (_,l) -> Array.fold_left f acc l + | Evar (_,l) -> List.fold_left f acc l | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | Fix (_,(_lna,tl,bl)) -> Array.fold_left2 (fun acc t b -> f (f acc t) b) acc tl bl @@ -490,7 +490,7 @@ let iter f c = match kind c with | LetIn (_,b,t,c) -> f b; f t; f c | App (c,l) -> f c; Array.iter f l | Proj (_p,c) -> f c - | Evar (_,l) -> Array.iter f l + | Evar (_,l) -> List.iter f l | Case (_,p,c,bl) -> f p; f c; Array.iter f bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl @@ -509,7 +509,7 @@ let iter_with_binders g f n c = match kind c with | Lambda (_,t,c) -> f n t; f (g n) c | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c | App (c,l) -> f n c; Array.Fun1.iter f n l - | Evar (_,l) -> Array.Fun1.iter f n l + | Evar (_,l) -> List.iter (fun c -> f n c) l | Case (_,p,c,bl) -> f n p; f n c; Array.Fun1.iter f n bl | Proj (_p,c) -> f n c | Fix (_,(_,tl,bl)) -> @@ -536,7 +536,7 @@ let fold_constr_with_binders g f n acc c = | LetIn (_na,b,t,c) -> f (g n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_p,c) -> f n acc c - | Evar (_,l) -> Array.fold_left (f n) acc l + | Evar (_,l) -> List.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(_,tl,bl)) -> let n' = iterate g (Array.length tl) n in @@ -657,7 +657,7 @@ let map_gen userview f c = match kind c with if t' == t then c else mkProj (p, t') | Evar (e,l) -> - let l' = Array.Smart.map f l in + let l' = List.Smart.map f l in if l'==l then c else mkEvar (e, l') | Case (ci,p,b,bl) when userview -> @@ -722,7 +722,8 @@ let fold_map f accu c = match kind c with if t' == t then accu, c else accu, mkProj (p, t') | Evar (e,l) -> - let accu, l' = Array.Smart.fold_left_map f accu l in + (* Doesn't matter, we should not hashcons evars anyways *) + let accu, l' = List.fold_left_map f accu l in if l'==l then accu, c else accu, mkEvar (e, l') | Case (ci,p,b,bl) -> @@ -782,7 +783,7 @@ let map_with_binders g f l c0 = match kind c0 with if t' == t then c0 else mkProj (p, t') | Evar (e, al) -> - let al' = Array.Fun1.Smart.map f l al in + let al' = List.Smart.map (fun c -> f l c) al in if al' == al then c0 else mkEvar (e, al') | Case (ci, p, c, bl) -> @@ -834,7 +835,7 @@ let fold_with_full_binders g f n acc c = | LetIn (na,b,t,c) -> f (g (LocalDef (na,b,t)) n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (_,c) -> f n acc c - | Evar (_,l) -> Array.fold_left (f n) acc l + | Evar (_,l) -> List.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> let n' = CArray.fold_left2_i (fun i c n t -> g (LocalAssum (n,lift i t)) c) n lna tl in @@ -880,7 +881,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t Int.equal len (Array.length l2) && leq (nargs+len) c1 c2 && Array.equal_norefl (eq 0) l1 l2 | Proj (p1,c1), Proj (p2,c2) -> Projection.equal p1 p2 && eq 0 c1 c2 - | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal (eq 0) l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && List.equal (eq 0) l1 l2 | Const (c1,u1), Const (c2,u2) -> (* The args length currently isn't used but may as well pass it. *) Constant.equal c1 c2 && leq_universes (GlobRef.ConstRef c1) nargs u1 u2 @@ -1039,7 +1040,7 @@ let constr_ord_int f t1 t2 = | Meta m1, Meta m2 -> Int.compare m1 m2 | Meta _, _ -> -1 | _, Meta _ -> 1 | Evar (e1,l1), Evar (e2,l2) -> - (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 + (Evar.compare =? (List.compare f)) e1 e2 l1 l2 | Evar _, _ -> -1 | _, Evar _ -> 1 | Sort s1, Sort s2 -> Sorts.compare s1 s2 | Sort _, _ -> -1 | _, Sort _ -> 1 @@ -1141,7 +1142,7 @@ let hasheq t1 t2 = n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2 | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2 | Proj (p1,c1), Proj(p2,c2) -> p1 == p2 && c1 == c2 - | Evar (e1,l1), Evar (e2,l2) -> e1 == e2 && array_eqeq l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> e1 == e2 && List.equal (==) l1 l2 | Const (c1,u1), Const (c2,u2) -> c1 == c2 && u1 == u2 | Ind (ind1,u1), Ind (ind2,u2) -> ind1 == ind2 && u1 == u2 | Construct (cstr1,u1), Construct (cstr2,u2) -> cstr1 == cstr2 && u1 == u2 @@ -1221,7 +1222,7 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let l, hl = hash_term_array l in (App (c,l), combinesmall 7 (combine hl hc)) | Evar (e,l) -> - let l, hl = hash_term_array l in + let l, hl = hash_list_array l in (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) | Const (c,u) -> let c' = sh_con c in @@ -1289,6 +1290,14 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = let h = !accu land 0x3FFFFFFF in (HashsetTermArray.repr h t term_array_table, h) + and hash_list_array l = + let fold accu c = + let c, h = sh_rec c in + (combine accu h, c) + in + let h, l = List.fold_left_map fold 0 l in + (l, h land 0x3FFFFFFF) + in (* Make sure our statically allocated Rels (1 to 16) are considered as canonical, and hence hash-consed to themselves *) @@ -1316,7 +1325,7 @@ let rec hash t = | App (c,l) -> combinesmall 7 (combine (hash_term_array l) (hash c)) | Evar (e,l) -> - combinesmall 8 (combine (Evar.hash e) (hash_term_array l)) + combinesmall 8 (combine (Evar.hash e) (hash_term_list l)) | Const (c,u) -> combinesmall 9 (combine (Constant.hash c) (Instance.hash u)) | Ind (ind,u) -> @@ -1339,6 +1348,9 @@ let rec hash t = and hash_term_array t = Array.fold_left (fun acc t -> combine acc (hash t)) 0 t +and hash_term_list t = + List.fold_left (fun acc t -> combine (hash t) acc) 0 t + module CaseinfoHash = struct type t = case_info @@ -1458,7 +1470,7 @@ let rec debug_print c = prlist_with_sep spc debug_print (Array.to_list l) ++ str")") | Evar (e,l) -> hov 1 (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++ - prlist_with_sep spc debug_print (Array.to_list l) ++str"}") + prlist_with_sep spc debug_print l ++str"}") | Const (c,u) -> str"Cst(" ++ pr_puniverses (Constant.debug_print c) u ++ str")" | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (MutInd.print sp ++ str"," ++ int i) u ++ str")" | Construct (((sp,i),j),u) -> diff --git a/kernel/constr.mli b/kernel/constr.mli index 16919b705a..00051d7551 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -83,7 +83,7 @@ val mkFloat : Float64.t -> constr val mkMeta : metavariable -> constr (** Constructs an existential variable *) -type existential = Evar.t * constr array +type existential = Evar.t * constr list val mkEvar : existential -> constr (** Construct a sort *) @@ -203,9 +203,9 @@ val mkCoFix : cofixpoint -> constr (** {6 Concrete type for making pattern-matching. } *) -(** [constr array] is an instance matching definitional [named_context] in +(** [constr list] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) -type 'constr pexistential = Evar.t * 'constr array +type 'constr pexistential = Evar.t * 'constr list type ('constr, 'types, 'sort, 'univs) kind_of_term = | Rel of int (** Gallina-variable introduced by [forall], [fun], [let-in], [fix], or [cofix]. *) 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/inferCumulativity.ml b/kernel/inferCumulativity.ml index f987164d52..662ad550b8 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -99,7 +99,7 @@ let rec infer_fterm cv_pb infos variances hd stk = end | FEvar ((_,args),e) -> let variances = infer_stack infos variances stk in - infer_vect infos variances (Array.map (mk_clos e) args) + infer_list infos variances (List.map (mk_clos e) args) | FRel _ -> infer_stack infos variances stk | FInt _ -> infer_stack infos variances stk | FFloat _ -> infer_stack infos variances stk @@ -168,6 +168,9 @@ and infer_stack infos variances (stk:CClosure.stack) = and infer_vect infos variances v = Array.fold_left (fun variances c -> infer_fterm CONV infos variances c []) variances v +and infer_list infos variances v = + List.fold_left (fun variances c -> infer_fterm CONV infos variances c []) variances v + let infer_term cv_pb env variances c = let open CClosure in let infos = (create_clos_infos all env, create_tab ()) in diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index aa513c1536..317141e324 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -405,7 +405,7 @@ let rec map_kn f f' c = if (ct'== ct && l'==l) then c else mkApp (ct',l') | Evar (e,l) -> - let l' = Array.Smart.map func l in + let l' = List.Smart.map func l in if (l'==l) then c else mkEvar (e,l') | Fix (ln,(lna,tl,bl)) -> diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 9ed0f6f411..02ee501f5f 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -474,7 +474,7 @@ let rec lambda_of_constr cache env sigma c = | Evar (evk,args as ev) -> (match evar_value sigma ev with | None -> - let args = Array.map (lambda_of_constr cache env sigma) args in + let args = Array.map_of_list (fun c -> lambda_of_constr cache env sigma c) args in Levar(evk, args) | Some t -> lambda_of_constr cache env sigma t) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 7574d7b21e..4ff90dd70d 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -367,9 +367,9 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let el1 = el_stack lft1 v1 in let el2 = el_stack lft2 v2 in let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in - convert_vect l2r infos el1 el2 - (Array.map (mk_clos env1) args1) - (Array.map (mk_clos env2) args2) cuniv + convert_list l2r infos el1 el2 + (List.map (mk_clos env1) args1) + (List.map (mk_clos env2) args2) cuniv else raise NotConvertible (* 2 index known to be bound to no constant *) @@ -702,6 +702,13 @@ and convert_branches l2r infos ci e1 e2 lft1 lft2 br1 br2 cuniv = in Array.fold_right3 fold ci.ci_cstr_nargs br1 br2 cuniv +and convert_list l2r infos lft1 lft2 v1 v2 cuniv = match v1, v2 with +| [], [] -> cuniv +| c1 :: v1, c2 :: v2 -> + let cuniv = ccnv CONV l2r infos lft1 lft2 c1 c2 cuniv in + convert_list l2r infos lft1 lft2 v1 v2 cuniv +| _, _ -> raise NotConvertible + let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = CClosure.RedFlags.red_add_transparent betaiotazeta trans in let infos = create_clos_infos ~evars reds env in 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/lib/lib.mllib b/lib/lib.mllib index 2db59712b9..4e08e87084 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -14,6 +14,7 @@ CWarnings AcyclicGraph Rtree System +ObjFile Explore CProfile Future diff --git a/lib/objFile.ml b/lib/objFile.ml new file mode 100644 index 0000000000..96db51a010 --- /dev/null +++ b/lib/objFile.ml @@ -0,0 +1,229 @@ +(************************************************************************) +(* * 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 Pp +open System + +let magic_number = 0x436F7121l (* "Coq!" *) + +let error_corrupted file s = + CErrors.user_err ~hdr:"System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") + +let open_trapping_failure name = + try open_out_bin name + with e when CErrors.noncritical e -> + CErrors.user_err ~hdr:"System.open" (str "Can't open " ++ str name) + +(* + +int32: big-endian, 4 bytes +int64: big-endian, 8 bytes + +-- string -- +int32 | length of the next field +data | + +-- segment summary -- +string | name +int64 | absolute position +int64 | length (without hash) +hash | MD5 (16 bytes) + +-- segment -- +... | binary data +hash | MD5 (16 bytes) + +-- summary -- +int32 | number of segment summaries +s1 | +... | segment summaries +sn | + +-- vo -- +int32 | magic number +int32 | Coq version +int64 | absolute position of the summary +... | segments +summary | + +*) + +type segment = { + name : string; + pos : int64; + len : int64; + hash : Digest.t; +} + +type in_handle = { + in_filename : string; + in_channel : in_channel; + in_segments : segment CString.Map.t; +} + +type out_handle = { + out_filename : string; + out_channel : out_channel; + mutable out_segments : segment CString.Map.t; +} + +let input_int32 ch = + let accu = ref 0l in + for _i = 0 to 3 do + let c = input_byte ch in + accu := Int32.add (Int32.shift_left !accu 8) (Int32.of_int c) + done; + !accu + +let input_int64 ch = + let accu = ref 0L in + for _i = 0 to 7 do + let c = input_byte ch in + accu := Int64.add (Int64.shift_left !accu 8) (Int64.of_int c) + done; + !accu + +let output_int32 ch n = + for i = 0 to 3 do + output_byte ch (Int32.to_int (Int32.shift_right_logical n (24 - 8 * i))) + done + +let output_int64 ch n = + for i = 0 to 7 do + output_byte ch (Int64.to_int (Int64.shift_right_logical n (56 - 8 * i))) + done + +let input_segment_summary ch = + let nlen = input_int32 ch in + let name = really_input_string ch (Int32.to_int nlen) in + let pos = input_int64 ch in + let len = input_int64 ch in + let hash = Digest.input ch in + { name; pos; len; hash } + +let output_segment_summary ch seg = + let nlen = Int32.of_int (String.length seg.name) in + let () = output_int32 ch nlen in + let () = output_string ch seg.name in + let () = output_int64 ch seg.pos in + let () = output_int64 ch seg.len in + let () = Digest.output ch seg.hash in + () + +let rec input_segment_summaries ch n accu = + if Int32.equal n 0l then accu + else + let s = input_segment_summary ch in + let accu = CString.Map.add s.name s accu in + input_segment_summaries ch (Int32.pred n) accu + +let marshal_in_segment (type a) h ~segment : a * Digest.t = + let { in_channel = ch } = h in + let s = CString.Map.find segment h.in_segments in + let () = LargeFile.seek_in ch s.pos in + let (v : a) = marshal_in h.in_filename ch in + let () = assert (Int64.equal (LargeFile.pos_in ch) (Int64.add s.pos s.len)) in + let h = Digest.input ch in + let () = assert (String.equal h s.hash) in + (v, s.hash) + +let marshal_out_segment h ~segment v = + let { out_channel = ch } = h in + let () = assert (not (CString.Map.mem segment h.out_segments)) in + let pos = LargeFile.pos_out ch in + let () = Marshal.to_channel ch v [] in + let () = flush ch in + let pos' = LargeFile.pos_out ch in + let len = Int64.sub pos' pos in + let hash = + let in_ch = open_in_bin h.out_filename in + let () = LargeFile.seek_in in_ch pos in + let digest = Digest.channel in_ch (Int64.to_int len) in + let () = close_in in_ch in + digest + in + let () = Digest.output ch hash in + let s = { name = segment; pos; len; hash } in + let () = h.out_segments <- CString.Map.add segment s h.out_segments in + () + +let marshal_out_binary h ~segment = + let { out_channel = ch } = h in + let () = assert (not (CString.Map.mem segment h.out_segments)) in + let pos = LargeFile.pos_out ch in + let finish () = + let () = flush ch in + let pos' = LargeFile.pos_out ch in + let len = Int64.sub pos' pos in + let hash = + let in_ch = open_in_bin h.out_filename in + let () = LargeFile.seek_in in_ch pos in + let digest = Digest.channel in_ch (Int64.to_int len) in + let () = close_in in_ch in + digest + in + let () = Digest.output ch hash in + let s = { name = segment; pos; len; hash } in + h.out_segments <- CString.Map.add segment s h.out_segments + in + ch, finish + +let open_in ~file = + try + let ch = open_in_bin file in + let magic = input_int32 ch in + let version = input_int32 ch in + let () = + if not (Int32.equal magic magic_number) then + let e = { filename = file; actual = version; expected = magic_number } in + raise (Bad_magic_number e) + in + let () = + let expected = Coq_config.vo_version in + if not (Int32.equal version expected) then + let e = { filename = file; actual = version; expected } in + raise (Bad_version_number e) + in + let summary_pos = input_int64 ch in + let () = LargeFile.seek_in ch summary_pos in + let nsum = input_int32 ch in + let seg = input_segment_summaries ch nsum CString.Map.empty in + { in_filename = file; in_channel = ch; in_segments = seg } + with + | End_of_file -> error_corrupted file "premature end of file" + | Failure s | Sys_error s -> error_corrupted file s + +let close_in ch = + close_in ch.in_channel + +let get_segment ch ~segment = + CString.Map.find segment ch.in_segments + +let segments ch = ch.in_segments + +let open_out ~file = + let ch = open_trapping_failure file in + let () = output_int32 ch magic_number in + let () = output_int32 ch Coq_config.vo_version in + let () = output_int64 ch 0L (* placeholder *) in + { out_channel = ch; out_segments = CString.Map.empty; out_filename = file } + +let close_out { out_channel = ch; out_segments = seg } = + let () = flush ch in + let pos = LargeFile.pos_out ch in + (* Write the segment summary *) + let () = output_int32 ch (Int32.of_int (CString.Map.cardinal seg)) in + let iter _ s = output_segment_summary ch s in + let () = CString.Map.iter iter seg in + (* Overwrite the position place holder *) + let () = LargeFile.seek_out ch 8L in + let () = output_int64 ch pos in + let () = flush ch in + close_out ch diff --git a/lib/objFile.mli b/lib/objFile.mli new file mode 100644 index 0000000000..b15b04ee54 --- /dev/null +++ b/lib/objFile.mli @@ -0,0 +1,37 @@ +(************************************************************************) +(* * 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 magic_number : int32 + +type segment = { + name : string; + pos : int64; + len : int64; + hash : Digest.t; +} + +type in_handle +type out_handle + +val open_in : file:string -> in_handle +val close_in : in_handle -> unit +val marshal_in_segment : in_handle -> segment:string -> 'a * Digest.t +val get_segment : in_handle -> segment:string -> segment +val segments : in_handle -> segment CString.Map.t + +val open_out : file:string -> out_handle +val close_out : out_handle -> unit +val marshal_out_segment : out_handle -> segment:string -> 'a -> unit +val marshal_out_binary : out_handle -> segment:string -> out_channel * (unit -> unit) +(** [marshal_out_binary oh segment] is a low level, stateful, API returning + [oc, stop]. Once called no other API can be used on the same [oh] and only + [Stdlib.output_*] APIs should be used on [oc]. [stop ()] must be invoked in + order to signal that all data was written to [oc] (which should not be used + afterwards). Only after calling [stop] the other API can be used on [oh]. *) diff --git a/lib/system.ml b/lib/system.ml index d7f5fa26ab..4e98651d6e 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -182,36 +182,9 @@ let marshal_in filename ch = | End_of_file -> error_corrupted filename "premature end of file" | Failure s -> error_corrupted filename s -let digest_out = Digest.output -let digest_in filename ch = - try Digest.input ch - with - | End_of_file -> error_corrupted filename "premature end of file" - | Failure s -> error_corrupted filename s - -let marshal_out_segment f ch v = - let start = pos_out ch in - output_binary_int ch 0; (* dummy value for stop *) - marshal_out ch v; - let stop = pos_out ch in - seek_out ch start; - output_binary_int ch stop; - seek_out ch stop; - digest_out ch (Digest.file f) - -let marshal_in_segment f ch = - let stop = (input_binary_int f ch : int) in - let v = marshal_in f ch in - let digest = digest_in f ch in - v, stop, digest - -let skip_in_segment f ch = - let stop = (input_binary_int f ch : int) in - seek_in ch stop; - stop, digest_in f ch - -type magic_number_error = {filename: string; actual: int; expected: int} +type magic_number_error = {filename: string; actual: int32; expected: int32} exception Bad_magic_number of magic_number_error +exception Bad_version_number of magic_number_error let raw_extern_state magic filename = let channel = open_trapping_failure filename in @@ -225,8 +198,8 @@ let raw_intern_state magic filename = if not (Int.equal actual_magic magic) then raise (Bad_magic_number { filename=filename; - actual=actual_magic; - expected=magic}); + actual=Int32.of_int actual_magic; + expected=Int32.of_int magic}); channel with | End_of_file -> error_corrupted filename "premature end of file" @@ -256,10 +229,14 @@ let intern_state magic filename = let with_magic_number_check f a = try f a - with Bad_magic_number {filename=fname;actual=actual;expected=expected} -> + with + | Bad_magic_number {filename=fname; _} -> + CErrors.user_err ~hdr:"with_magic_number_check" + (str"File " ++ str fname ++ strbrk" is corrupted.") + | Bad_version_number {filename=fname;actual=actual;expected=expected} -> CErrors.user_err ~hdr:"with_magic_number_check" - (str"File " ++ str fname ++ strbrk" has bad magic number " ++ - int actual ++ str" (expected " ++ int expected ++ str")." ++ + (str"File " ++ str fname ++ strbrk" has bad version number " ++ + (str @@ Int32.to_string actual) ++ str" (expected " ++ (str @@ Int32.to_string expected) ++ str")." ++ spc () ++ strbrk "It is corrupted or was compiled with another version of Coq.") diff --git a/lib/system.mli b/lib/system.mli index 00701379bd..4a8c35b6ea 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -68,8 +68,9 @@ val file_exists_respecting_case : string -> string -> bool when the check fails, with the full file name and expected/observed magic numbers. *) -type magic_number_error = {filename: string; actual: int; expected: int} +type magic_number_error = {filename: string; actual: int32; expected: int32} exception Bad_magic_number of magic_number_error +exception Bad_version_number of magic_number_error val raw_extern_state : int -> string -> out_channel @@ -87,15 +88,6 @@ val with_magic_number_check : ('a -> 'b) -> 'a -> 'b val marshal_out : out_channel -> 'a -> unit val marshal_in : string -> in_channel -> 'a -(** Clones of Digest.output and Digest.input (with nice error message) *) - -val digest_out : out_channel -> Digest.t -> unit -val digest_in : string -> in_channel -> Digest.t - -val marshal_out_segment : string -> out_channel -> 'a -> unit -val marshal_in_segment : string -> in_channel -> 'a * int * Digest.t -val skip_in_segment : string -> in_channel -> int * Digest.t - (** {6 Time stamps.} *) type time 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/library/goptions.ml b/library/goptions.ml index 1418407533..666ba8ee2e 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -24,6 +24,10 @@ type option_value = | StringValue of string | StringOptValue of string option +type table_value = + | StringRefValue of string + | QualidRefValue of qualid + (** Summary of an option status *) type option_state = { opt_depr : bool; @@ -35,8 +39,13 @@ type option_state = { let nickname table = String.concat " " table +let error_no_table_of_this_type ~kind key = + user_err ~hdr:"Goptions" + (str ("There is no " ^ kind ^ "-valued table with this name: \"" ^ nickname key ^ "\".")) + let error_undeclared_key key = - user_err ~hdr:"Goptions" (str (nickname key) ++ str ": no table or option of this type") + user_err ~hdr:"Goptions" + (str ("There is no flag, option or table with this name: \"" ^ nickname key ^ "\".")) (****************************************************************************) (* 1- Tables *) @@ -184,6 +193,23 @@ end module MakeRefTable = functor (A : RefConvertArg) -> MakeTable (RefConvert(A)) +type iter_table_aux = { aux : 'a. 'a table_of_A -> Environ.env -> 'a -> unit } + +let iter_table f key lv = + let aux = function + | StringRefValue s -> + begin + try f.aux (get_string_table key) (Global.env()) s + with Not_found -> error_no_table_of_this_type ~kind:"string" key + end + | QualidRefValue locqid -> + begin + try f.aux (get_ref_table key) (Global.env()) locqid + with Not_found -> error_no_table_of_this_type ~kind:"qualid" key + end + in + List.iter aux lv + (****************************************************************************) (* 2- Flags. *) @@ -387,9 +413,10 @@ let declare_interpreted_string_option_and_ref ~depr ~key ~(value:'a) from_string (* Setting values of options *) let warn_unknown_option = - CWarnings.create ~name:"unknown-option" ~category:"option" - (fun key -> strbrk "There is no option " ++ - str (nickname key) ++ str ".") + CWarnings.create + ~name:"unknown-option" ~category:"option" + (fun key -> strbrk "There is no flag or option with this name: \"" ++ + str (nickname key) ++ str "\".") let set_option_value ?(locality = OptDefault) check_and_cast key v = let opt = try Some (get_option key) with Not_found -> None in diff --git a/library/goptions.mli b/library/goptions.mli index 336cae420c..150954cbac 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -187,6 +187,10 @@ type option_value = | StringValue of string | StringOptValue of string option +type table_value = + | StringRefValue of string + | QualidRefValue of qualid + val set_option_value : ?locality:option_locality -> ('a -> option_value -> option_value) -> option_name -> 'a -> unit (** [set_option_value ?locality f name v] sets [name] to the result of @@ -204,4 +208,7 @@ type option_state = { val get_tables : unit -> option_state OptionMap.t val print_tables : unit -> Pp.t +type iter_table_aux = { aux : 'a. 'a table_of_A -> Environ.env -> 'a -> unit } +val iter_table : iter_table_aux -> option_name -> table_value list -> unit + val error_undeclared_key : option_name -> 'a 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/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 35e131020b..f002bbc57a 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1559,7 +1559,7 @@ let assert_replacing id newt tac = if Id.equal n id then ev' else mkVar n in let (e, _) = destEvar sigma ev in - (sigma, mkEvar (e, Array.map_of_list map nc)) + (sigma, mkEvar (e, List.map map nc)) end end in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) 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/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index e0b083a70a..134a9e4b36 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -537,7 +537,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = let rec put evlist c = match Constr.kind c with | Evar (k, a) -> if List.mem_assoc k evlist || Evd.mem sigma0 k || List.mem k rigid then evlist else - let n = max 0 (Array.length a - nenv) in + let n = max 0 (List.length a - nenv) in let t = abs_evar n k in (k, (n, t)) :: put evlist t | _ -> Constr.fold put evlist c in let evlist = put [] c0 in @@ -549,6 +549,7 @@ let pf_abs_evars2 gl rigid (sigma, c0) = | Evar (ev, a) -> let j, n = lookup ev i evlist in if j = 0 then Constr.map (get i) c else if n = 0 then mkRel j else + let a = Array.of_list a in mkApp (mkRel j, Array.init n (fun k -> get i a.(n - 1 - k))) | _ -> Constr.map_with_binders ((+) 1) get i c in let rec loop c i = function @@ -598,7 +599,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = let rec put evlist c = match Constr.kind c with | Evar (k, a) -> if List.mem_assoc k evlist || Evd.mem sigma0 k then evlist else - let n = max 0 (Array.length a - nenv) in + let n = max 0 (List.length a - nenv) in let k_ty = Retyping.get_sort_family_of (pf_env gl) sigma (Evd.evar_concl (Evd.find sigma k)) in @@ -636,6 +637,7 @@ let pf_abs_evars_pirrel gl (sigma, c0) = | Evar (ev, a) -> let j, n = lookup ev i evlist in if j = 0 then Constr.map (get evlist i) c else if n = 0 then mkRel j else + let a = Array.of_list a in mkApp (mkRel j, Array.init n (fun k -> get evlist i a.(n - 1 - k))) | _ -> Constr.map_with_binders ((+) 1) (get evlist) i c in let rec app extra_args i c = match decompose_app c with diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 1c776398e7..d5a781e472 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -263,7 +263,7 @@ let nf_open_term sigma0 ise c = let rec nf c' = match kind c' with | Evar ex -> begin try nf (existential_value0 s ex) with _ -> - let k, a = ex in let a' = Array.map nf a in + let k, a = ex in let a' = List.map nf a in if not (Evd.mem !s' k) then s' := Evd.add !s' k (Evarutil.nf_evar_info s (Evd.find s k)); mkEvar (k, a') @@ -307,7 +307,7 @@ let pf_unify_HO gl t1 t2 = (* This is what the definition of iter_constr should be... *) let iter_constr_LR f c = match kind c with - | Evar (k, a) -> Array.iter f a + | Evar (k, a) -> List.iter f a | Cast (cc, _, t) -> f cc; f t | Prod (_, t, b) | Lambda (_, t, b) -> f t; f b | LetIn (_, v, t, b) -> f v; f t; f b @@ -387,7 +387,7 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = with NotInstantiatedEvar -> if Evd.mem sigma0 k then map put c else let evi = Evd.find !sigma k in - let dc = List.firstn (max 0 (Array.length a - nenv)) (evar_filtered_context evi) in + let dc = List.firstn (max 0 (List.length a - nenv)) (evar_filtered_context evi) in let abs_dc (d, c) = function | Context.Named.Declaration.LocalDef (x, b, t) -> d, mkNamedLetIn x (put b) (put t) c @@ -601,7 +601,8 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = | KpatFixed | KpatConst -> ise | KpatEvar _ -> let _, pka = destEvar u.up_f and _, ka = destEvar f in - unif_HO_args env ise pka 0 ka + let fold ise pk k = unif_HO env ise (EConstr.of_constr pk) (EConstr.of_constr k) in + List.fold_left2 fold ise pka ka | KpatLet -> let x, v, t, b = destLetIn f in let _, pv, _, pb = destLetIn u.up_f in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index f816599a17..b39ec37cd1 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -446,7 +446,7 @@ let rec norm_head info env t stack = Some c -> norm_head info env c stack | None -> let e, xs = ev in - let xs' = Array.map (apply_env env) xs in + let xs' = List.map (apply_env env) xs in (VAL(0, mkEvar (e,xs')), stack)) (* non-neutral cases *) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index f85635528d..25aa8915ba 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -404,7 +404,7 @@ let matches_core env sigma allow_bound_rels Array.fold_left2 (fun subst na1 na2 -> add_binders na1 na2 binding_vars subst) subst lna1 lna2 | PEvar (c1,args1), Evar (c2,args2) when Evar.equal c1 c2 -> - Array.fold_left2 (sorec ctx env) subst args1 args2 + List.fold_left2 (sorec ctx env) subst args1 args2 | PInt i1, Int i2 when Uint63.equal i1 i2 -> subst | PFloat f1, Float f2 when Float64.equal f1 f2 -> subst | (PRef _ | PVar _ | PRel _ | PApp _ | PProj _ | PLambda _ diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 857918c928..ff278baf9f 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -790,7 +790,7 @@ and detype_r d flags avoid env sigma t = id,l with Not_found -> Id.of_string ("X" ^ string_of_int (Evar.repr evk)), - (Array.map_to_list (fun c -> (Id.of_string "__",c)) cl) + (List.map (fun c -> (Id.of_string "__",c)) cl) in GEvar (id, List.map (on_snd (detype d flags avoid env sigma)) l) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3d887e1a95..f1506f5f59 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -195,7 +195,7 @@ let occur_rigidly flags env evd (evk,_) t = | Evar (evk',l as ev) -> if Evar.equal evk evk' then Rigid true else if is_frozen flags ev then - Rigid (Array.exists (fun x -> rigid_normal_occ (aux x)) l) + Rigid (List.exists (fun x -> rigid_normal_occ (aux x)) l) else Reducible | Cast (p, _, _) -> aux p | Lambda (na, t, b) -> aux b @@ -351,6 +351,14 @@ let ise_array2 evd f v1 v2 = if Int.equal lv1 (Array.length v2) then allrec evd (pred lv1) else UnifFailure (evd,NotSameArgSize) +let rec ise_inst2 evd f l1 l2 = match l1, l2 with +| [], [] -> Success evd +| [], (_ :: _) | (_ :: _), [] -> assert false +| c1 :: l1, c2 :: l2 -> + match ise_inst2 evd f l1 l2 with + | Success evd' -> f evd' c1 c2 + | UnifFailure _ as x -> x + (* Applicative node of stack are read from the outermost to the innermost but are unified the other way. *) let rec ise_app_stack2 env f evd sk1 sk2 = @@ -1019,7 +1027,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty if Evar.equal sp1 sp2 then match ise_stack2 false env evd (evar_conv_x flags) sk1 sk2 with |None, Success i' -> - ise_array2 i' (fun i' -> evar_conv_x flags env i' CONV) al1 al2 + ise_inst2 i' (fun i' -> evar_conv_x flags env i' CONV) al1 al2 |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (evd,NotSameArgSize) else UnifFailure (evd,NotSameHead) @@ -1241,6 +1249,7 @@ let filter_possible_projections evd c ty ctxt args = (* Since args in the types will be replaced by holes, we count the fv of args to have a well-typed filter; don't know how necessary it is however to have a well-typed filter here *) + let args = Array.of_list args in let fv1 = free_rels evd (mkApp (c,args)) (* Hack: locally untyped *) in let fv2 = collect_vars evd (mkApp (c,args)) in let len = Array.length args in @@ -1309,8 +1318,8 @@ let thin_evars env sigma sign c = match kind !sigma t with | Evar (ev, args) -> let evi = Evd.find_undefined !sigma ev in - let filter = Array.map (fun c -> Id.Set.subset (collect_vars !sigma c) ctx) args in - let filter = Filter.make (Array.to_list filter) in + let filter = List.map (fun c -> Id.Set.subset (collect_vars !sigma c) ctx) args in + let filter = Filter.make filter in let candidates = Option.map (List.map EConstr.of_constr) (evar_candidates evi) in let evd, ev = restrict_evar !sigma ev filter candidates in sigma := evd; whd_evar !sigma t @@ -1336,9 +1345,9 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = if debug_ho_unification () then (Feedback.msg_debug Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs); Feedback.msg_debug Pp.(str"env evars: " ++ Termops.Internal.print_env env_evar)); - let args = Array.map (nf_evar evd) args in + let args = List.map (nf_evar evd) args in let vars = List.map NamedDecl.get_id ctxt in - let argsubst = List.map2 (fun id c -> (id, c)) vars (Array.to_list args) in + let argsubst = List.map2 (fun id c -> (id, c)) vars args in let instance = List.map mkVar vars in let rhs = nf_evar evd rhs in if not (noccur_evar env_rhs evd evk rhs) then raise (TypingFailed evd); @@ -1416,7 +1425,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = set_holes env_rhs' evd rhs' subst | [] -> evd, rhs in - let subst = make_subst (ctxt,Array.to_list args,argoccs) in + let subst = make_subst (ctxt,args,argoccs) in let evd, rhs' = set_holes env_rhs evd rhs subst in let rhs' = nf_evar evd rhs' in @@ -1533,7 +1542,7 @@ let default_evar_selection flags evd (ev,args) = in spec :: aux args abs | l, [] -> List.map (fun _ -> default_occurrence_selection) l | [], _ :: _ -> assert false - in aux (Array.to_list args) evi.evar_abstract_arguments + in aux args evi.evar_abstract_arguments let second_order_matching_with_args flags env evd with_ho pbty ev l t = if with_ho then diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 50187d82cc..71edcaa231 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -113,7 +113,7 @@ let define_evar_as_product env evd (evk,args) = (* Quick way to compute the instantiation of evk with args *) let na,dom,rng = destProd evd prod in let evdom = mkEvar (fst (destEvar evd dom), args) in - let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evrngargs = mkRel 1 :: List.map (lift 1) args in let evrng = mkEvar (fst (destEvar evd rng), evrngargs) in evd, mkProd (na, evdom, evrng) @@ -152,7 +152,7 @@ let define_evar_as_lambda env evd (evk,args) = let evd,lam = define_pure_evar_as_lambda env evd evk in (* Quick way to compute the instantiation of evk with args *) let na,dom,body = destLambda evd lam in - let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in + let evbodyargs = mkRel 1 :: List.map (lift 1) args in let evbody = mkEvar (fst (destEvar evd body), evbodyargs) in evd, mkLambda (na, dom, evbody) @@ -163,7 +163,7 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function let evd,lam = define_pure_evar_as_lambda env evd evk in let _,_,body = destLambda evd lam in let evk = fst (destEvar evd body) in - evar_absorb_arguments env evd (evk, Array.cons a args) l + evar_absorb_arguments env evd (evk, a :: args) l (* Refining an evar to a sort *) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index e475e4c52b..34684e4a34 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -217,7 +217,7 @@ type 'a update = | NoUpdate open Context.Named.Declaration -let inst_of_vars sign = Array.map_of_list (get_id %> mkVar) sign +let inst_of_vars sign = List.map (get_id %> mkVar) sign let restrict_evar_key evd evk filter candidates = match filter, candidates with @@ -247,7 +247,7 @@ let restrict_applied_evar evd (evk,argsv) filter candidates = | Some filter -> let evi = Evd.find evd evk in let subfilter = Filter.compose (evar_filter evi) filter in - Filter.filter_array subfilter argsv in + Filter.filter_list subfilter argsv in evd,(newevk,newargsv) (* Restrict an evar in the current evar_map *) @@ -258,7 +258,7 @@ let restrict_evar evd evk filter candidates = let restrict_instance evd evk filter argsv = match filter with None -> argsv | Some filter -> let evi = Evd.find evd evk in - Filter.filter_array (Filter.compose (evar_filter evi) filter) argsv + Filter.filter_list (Filter.compose (evar_filter evi) filter) argsv open Context.Rel.Declaration let noccur_evar env evd evk c = @@ -269,7 +269,7 @@ let noccur_evar env evd evk c = if Evar.equal evk evk' then raise Occur else (if check_types then occur_rec false acc (existential_type evd ev'); - Array.iter (occur_rec check_types acc) args') + List.iter (occur_rec check_types acc) args') | Rel i when i > k -> if not (Int.Set.mem (i-k) !cache) then let decl = Environ.lookup_rel i env in @@ -552,17 +552,13 @@ let get_actual_deps env evd aliases l t = open Context.Named.Declaration let remove_instance_local_defs evd evk args = let evi = Evd.find evd evk in - let len = Array.length args in - let rec aux sign i = match sign with - | [] -> - let () = assert (i = len) in [] - | LocalAssum _ :: sign -> - let () = assert (i < len) in - (Array.unsafe_get args i) :: aux sign (succ i) - | LocalDef _ :: sign -> - aux sign (succ i) + let rec aux sign args = match sign, args with + | [], [] -> [] + | LocalAssum _ :: sign, c :: args -> c :: aux sign args + | LocalDef _ :: sign, _ :: args -> aux sign args + | _ -> assert false in - aux (evar_filtered_context evi) 0 + aux (evar_filtered_context evi) args (* Check if an applied evar "?X[args] l" is a Miller's pattern *) @@ -688,7 +684,7 @@ let make_projectable_subst aliases sigma evi args = let all = Int.Map.add i [a, id] all in (rest,all,cstrs,revmap)) | _ -> anomaly (Pp.str "Instance does not match its signature.")) 0 - sign (Array.rev_to_list args,Int.Map.empty,Constrmap.empty,Id.Map.empty) in + sign (List.rev args,Int.Map.empty,Constrmap.empty,Id.Map.empty) in (full_subst,cstr_subst) (*------------------------------------* @@ -765,7 +761,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = (mkRel 1)::(List.map (lift 1) inst_in_sign), push_rel d env,evd,Id.Set.add id.binder_name avoid)) rel_sign - (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,avoid) + (sign1,filter1,args1,inst_in_sign,env1,evd,avoid) in let evd,ev2ty_in_sign = let s = Retyping.get_sort_of env evd ty_in_env in @@ -775,11 +771,12 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = ty_t_in_sign sign2 filter2 inst2_in_env in let (evd, ev2_in_sign) = new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in - let ev2_in_env = (fst (destEvar evd ev2_in_sign), Array.of_list inst2_in_env) in + let ev2_in_env = (fst (destEvar evd ev2_in_sign), inst2_in_env) in (evd, ev2_in_sign, ev2_in_env) let restrict_upon_filter evd evk p args = let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in + let args = Array.of_list args in let len = Array.length args in Filter.restrict_upon oldfullfilter len (fun i -> p (Array.unsafe_get args i)) @@ -1034,7 +1031,7 @@ let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' = let p = invert_arg fullenv evd aliases k evk subst arg in extract_unique_projection p in - Array.map invert args' + List.map invert args' (* Redefines an evar with a smaller context (i.e. it may depend on less * variables) such that c becomes closed. @@ -1390,9 +1387,9 @@ let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 = try evdref := Evd.add_universe_constraints !evdref cstr; true with UniversesDiffer -> false in - if Array.equal eq_constr argsv1 argsv2 then !evdref else + if List.equal eq_constr argsv1 argsv2 then !evdref else (* Filter and restrict if needed *) - let args = Array.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in + let args = List.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in let untypedfilter = restrict_upon_filter evd evk (fun (a1,a2) -> unify flags TermUnification env evd Reduction.CONV a1 a2) args in @@ -1452,7 +1449,7 @@ let occur_evar_upto_types sigma n c = | Evar (sp,_) when Evar.equal sp n -> raise Occur | Evar (sp,args as e) -> if Evar.Set.mem sp !seen then - Array.iter occur_rec args + List.iter occur_rec args else ( seen := Evar.Set.add sp !seen; Option.iter occur_rec (existential_opt_value0 sigma e); @@ -1570,7 +1567,7 @@ let rec invert_definition unify flags choose imitate_defs (* Evar/Evar problem (but left evar is virtual) *) let aliases = lift_aliases k aliases in (try - let ev = (evk,Array.map (lift k) argsv) in + let ev = (evk,List.map (lift k) argsv) in let evd,body = project_evar_on_evar false unify flags env' !evdref aliases k None ev' ev in evdref := evd; body @@ -1648,7 +1645,7 @@ let rec invert_definition unify flags choose imitate_defs | [], [] -> true | _ -> false in - is_id_subst filter_ctxt (Array.to_list argsv) && + is_id_subst filter_ctxt argsv && closed0 evd rhs && Id.Set.subset (collect_vars evd rhs) !names in diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 0a1b731e6b..3fb80432ad 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -99,7 +99,7 @@ val refresh_universes : env -> evar_map -> types -> evar_map * types val solve_refl : ?can_drop:bool -> conversion_check -> unify_flags -> env -> evar_map -> - bool option -> Evar.t -> constr array -> constr array -> evar_map + bool option -> Evar.t -> constr list -> constr list -> evar_map val solve_evar_evar : ?force:bool -> (env -> evar_map -> bool option -> existential -> constr -> evar_map) -> @@ -128,7 +128,7 @@ val check_evar_instance : unifier -> unify_flags -> env -> evar_map -> Evar.t -> constr -> evar_map val remove_instance_local_defs : - evar_map -> Evar.t -> 'a array -> 'a list + evar_map -> Evar.t -> 'a list -> 'a list val get_type_of_refresh : ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * types diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 34498458a4..d672ddc906 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -423,8 +423,8 @@ and nf_evar env sigma evk args = let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in let ty = EConstr.to_constr ~abort_on_undefined_evars:false sigma @@ Evd.evar_concl evi in if List.is_empty hyps then begin - assert (Int.equal (Array.length args) 0); - mkEvar (evk, [||]), ty + assert (Array.is_empty args); + mkEvar (evk, []), ty end else (* Let-bound arguments are present in the evar arguments but not @@ -436,7 +436,7 @@ and nf_evar env sigma evk args = (* nf_args takes arguments in the reverse order but produces them in the correct one, so we have to reverse them again for the evar node *) - mkEvar (evk, Array.rev_of_list args), ty + mkEvar (evk, List.rev args), ty let evars_of_evar_map sigma = { Nativelambda.evars_val = Evd.existential_opt_value0 sigma; diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index 3f2e690da5..1dfb8b2cd1 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -24,7 +24,7 @@ type case_info_pattern = type constr_pattern = | PRef of GlobRef.t | PVar of Id.t - | PEvar of Evar.t * constr_pattern array + | PEvar of constr_pattern Constr.pexistential | PRel of int | PApp of constr_pattern * constr_pattern array | PSoApp of patvar * constr_pattern list diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index b8635d03b7..6d30e0338e 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -31,7 +31,7 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with | PRef r1, PRef r2 -> GlobRef.equal r1 r2 | PVar v1, PVar v2 -> Id.equal v1 v2 | PEvar (ev1, ctx1), PEvar (ev2, ctx2) -> - Evar.equal ev1 ev2 && Array.equal constr_pattern_eq ctx1 ctx2 + Evar.equal ev1 ev2 && List.equal constr_pattern_eq ctx1 ctx2 | PRel i1, PRel i2 -> Int.equal i1 i2 | PApp (t1, arg1), PApp (t2, arg2) -> @@ -115,7 +115,7 @@ let rec occurn_pattern n = function (occurn_pattern n c) || (List.exists (fun (_,_,p) -> occurn_pattern n p) br) | PMeta _ | PSoApp _ -> true - | PEvar (_,args) -> Array.exists (occurn_pattern n) args + | PEvar (_,args) -> List.exists (occurn_pattern n) args | PVar _ | PRef _ | PSort _ | PInt _ | PFloat _ -> false | PFix (_,(_,tl,bl)) -> Array.exists (occurn_pattern n) tl || Array.exists (occurn_pattern (n+Array.length tl)) bl @@ -190,7 +190,7 @@ let pattern_of_constr env sigma t = (* These are the two evar kinds used for existing goals *) (* see Proofview.mark_in_evm *) if Evd.is_defined sigma evk then pattern_of_constr env (Evd.existential_value0 sigma ev) - else PEvar (evk,Array.map (pattern_of_constr env) ctxt) + else PEvar (evk,List.map (pattern_of_constr env) ctxt) | Evar_kinds.MatchingVar (Evar_kinds.SecondOrderPatVar ido) -> assert false | _ -> PMeta None) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 940150b15a..f7e3d651ff 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -607,7 +607,7 @@ let pretype_instance self ~program_mode ~poly resolve_tc env sigma loc hyps evk ((id,c)::subst, update, sigma) in let subst,inst,sigma = List.fold_right f hyps ([],update,sigma) in check_instance loc subst inst; - sigma, Array.map_of_list snd subst + sigma, List.map snd subst module Default = struct diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 70605d58ab..2c717b8774 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -86,7 +86,7 @@ let evaluable_reference_eq sigma r1 r2 = match r1, r2 with | EvalVar id1, EvalVar id2 -> Id.equal id1 id2 | EvalRel i1, EvalRel i2 -> Int.equal i1 i2 | EvalEvar (e1, ctx1), EvalEvar (e2, ctx2) -> - Evar.equal e1 e2 && Array.equal (EConstr.eq_constr sigma) ctx1 ctx2 + Evar.equal e1 e2 && List.equal (EConstr.eq_constr sigma) ctx1 ctx2 | _ -> false let mkEvalRef ref u = @@ -408,7 +408,7 @@ let substl_with_function subst sigma constr = let (sigma, evk) = Evarutil.new_pure_evar venv sigma dummy in evd := sigma; minargs := Evar.Map.add evk min !minargs; - Vars.lift k (mkEvar (evk, [|fx;ref|])) + Vars.lift k (mkEvar (evk, [fx; ref])) | (fx, None) -> Vars.lift k fx else mkRel (i - Array.length v) | _ -> @@ -455,7 +455,7 @@ let substl_checking_arity env subst sigma c = (* we propagate the constraints: solved problems are substituted; the other ones are replaced by the function symbol *) let rec nf_fix c = match EConstr.kind sigma c with - | Evar (i,[|fx;f|]) when Evar.Map.mem i minargs -> + | Evar (i,[fx;f]) when Evar.Map.mem i minargs -> (* FIXME: find a less hackish way of doing this *) begin match EConstr.kind sigma' c with | Evar _ -> f diff --git a/pretyping/unification.ml b/pretyping/unification.ml index e168f6d1b6..f5aaac315a 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -76,7 +76,7 @@ let occur_meta_or_undefined_evar evd c = | Evar (ev,args) -> (match evar_body (Evd.find evd ev) with | Evar_defined c -> - occrec (EConstr.Unsafe.to_constr c); Array.iter occrec args + occrec (EConstr.Unsafe.to_constr c); List.iter occrec args | Evar_empty -> raise Occur) | _ -> Constr.iter occrec c in try occrec c; false with Occur | Not_found -> true @@ -138,9 +138,9 @@ let abstract_list_all env evd typ c l = error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in evd,(p,typp) -let set_occurrences_of_last_arg args = +let set_occurrences_of_last_arg n = Evarconv.AtOccurrences AllOccurrences :: - List.tl (Array.map_to_list (fun _ -> Evarconv.Unspecified Abstraction.Abstract) args) + List.tl (List.init n (fun _ -> Evarconv.Unspecified Abstraction.Abstract)) let occurrence_test _ _ _ env sigma _ c1 c2 = match EConstr.eq_constr_universes env sigma c1 c2 with @@ -153,7 +153,8 @@ let abstract_list_all_with_dependencies env evd typ c l = let (evd, ev) = new_evar env evd typ in let evd,ev' = evar_absorb_arguments env evd (destEvar evd ev) l in let n = List.length l in - let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in + let () = assert (n <= List.length (snd ev')) in + let argoccs = set_occurrences_of_last_arg n in let evd,b = Evarconv.second_order_matching (Evarconv.default_flags_of TransparentState.empty) @@ -623,7 +624,7 @@ let subst_defined_metas_evars sigma (bl,el) c = substrec (EConstr.Unsafe.to_constr (pi2 (List.find select bl))) | Evar (evk,args) -> let eq c1 c2 = Constr.equal c1 (EConstr.Unsafe.to_constr c2) in - let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.for_all2 eq args args' in + let select (_,(evk',args'),_) = Evar.equal evk evk' && List.for_all2 eq args args' in (try substrec (EConstr.Unsafe.to_constr (pi3 (List.find select el))) with Not_found -> Constr.map substrec c) | _ -> Constr.map substrec c diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index d4da93cc5b..37c34d55cf 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -205,7 +205,7 @@ and nf_evar env sigma evk stk = let hyps = Environ.named_context_of_val (Evd.evar_filtered_hyps evi) in let concl = EConstr.to_constr ~abort_on_undefined_evars:false sigma @@ Evd.evar_concl evi in if List.is_empty hyps then - nf_stk env sigma (mkEvar (evk, [||])) concl stk + nf_stk env sigma (mkEvar (evk, [])) concl stk else match stk with | Zapp args :: stk -> (* We assume that there is no consecutive Zapp nodes in a VM stack. Is that @@ -217,6 +217,7 @@ and nf_evar env sigma evk stk = let t = List.fold_left fold concl hyps in let t, args = nf_args env sigma args t in let inst, args = Array.chop (List.length hyps) args in + let inst = Array.to_list inst in let c = mkApp (mkEvar (evk, inst), args) in nf_stk env sigma c t stk | _ -> 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/proofs/goal.ml b/proofs/goal.ml index b1f8fd3e97..53d3047bc7 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -69,7 +69,7 @@ module V82 = struct let (evars, evk) = Evarutil.new_pure_evar_full evars ~typeclass_candidate:false evi in let evars = Evd.restore_future_goals evars prev_future_goals in let ctxt = Environ.named_context_of_val hyps in - let inst = Array.map_of_list (NamedDecl.get_id %> EConstr.mkVar) ctxt in + let inst = List.map (NamedDecl.get_id %> EConstr.mkVar) ctxt in let ev = EConstr.mkEvar (evk,inst) in (evk, ev, evars) 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/class_tactics.ml b/tactics/class_tactics.ml index 57eab7ddf8..a51fc8b347 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1188,7 +1188,7 @@ let resolve_one_typeclass env ?(sigma=Evd.from_env env) gl unique = with Refiner.FailError _ -> raise Not_found in let evd = sig_sig gls' in - let t' = mkEvar (ev, Array.of_list subst) in + let t' = mkEvar (ev, subst) in let term = Evarutil.nf_evar evd t' in term, evd end in 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/eauto.ml b/tactics/eauto.ml index a89e5ef19a..28b5ed5811 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -430,29 +430,39 @@ let make_dimension n = function | None -> (true,make_depth n) | Some d -> (false,d) +let autounfolds ids csts gl cls = + let hyps = Tacmach.New.pf_ids_of_hyps gl in + let env = Tacmach.New.pf_env gl in + let ids = List.filter (fun id -> List.mem id hyps && Tacred.is_evaluable env (EvalVarRef id)) ids in + let csts = List.filter (fun cst -> Tacred.is_evaluable env (EvalConstRef cst)) csts in + let flags = + List.fold_left (fun flags cst -> CClosure.RedFlags.(red_add flags (fCONST cst))) + (List.fold_left (fun flags id -> CClosure.RedFlags.(red_add flags (fVAR id))) + CClosure.betaiotazeta ids) csts + in reduct_option ~check:false (Reductionops.clos_norm_flags flags, DEFAULTcast) cls + let cons a l = a :: l -let autounfolds db occs cls gl = - let unfolds = List.concat (List.map (fun dbname -> - let db = try searchtable_map dbname - with Not_found -> user_err ~hdr:"autounfold" (str "Unknown database " ++ str dbname) - in - let (ids, csts) = Hint_db.unfolds db in - let hyps = pf_ids_of_hyps gl in - let ids = Id.Set.filter (fun id -> List.mem id hyps) ids in - Cset.fold (fun cst -> cons (AllOccurrences, EvalConstRef cst)) csts - (Id.Set.fold (fun id -> cons (AllOccurrences, EvalVarRef id)) ids [])) db) - in Proofview.V82.of_tactic (unfold_option unfolds cls) gl +exception UnknownDatabase of string let autounfold db cls = - Proofview.V82.tactic begin fun gl -> - let cls = concrete_clause_of (fun () -> pf_ids_of_hyps gl) cls in - let tac = autounfolds db in - tclMAP (function - | OnHyp (id,occs,where) -> tac occs (Some (id,where)) - | OnConcl occs -> tac occs None) - cls gl - end + if not (Locusops.clause_with_generic_occurrences cls) then + user_err ~hdr:"autounfold" (str "\"at\" clause not supported"); + match List.fold_left (fun (ids, csts) dbname -> + let db = try searchtable_map dbname + with Not_found -> raise (UnknownDatabase dbname) + in + let (db_ids, db_csts) = Hint_db.unfolds db in + (Id.Set.fold cons db_ids ids, Cset.fold cons db_csts csts)) ([], []) db + with + | (ids, csts) -> Proofview.Goal.enter begin fun gl -> + let cls = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in + let tac = autounfolds ids csts gl in + Tacticals.New.tclMAP (function + | OnHyp (id, _, where) -> tac (Some (id, where)) + | OnConcl _ -> tac None) cls + end + | exception UnknownDatabase dbname -> Tacticals.New.tclZEROMSG (str "Unknown database " ++ str dbname) let autounfold_tac db cls = Proofview.tclUNIT () >>= fun () -> 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.ml b/tactics/tactics.ml index c79aca3d3c..0df4f5b207 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2763,8 +2763,8 @@ let pose_tac na c = let id = make_annot id Sorts.Relevant in let nhyps = EConstr.push_named_context_val (NamedDecl.LocalDef (id, c, t)) hyps in let (sigma, ev) = Evarutil.new_pure_evar nhyps sigma concl in - let inst = Array.map_of_list (fun d -> mkVar (get_id d)) (named_context env) in - let body = mkEvar (ev, Array.append [|mkRel 1|] inst) in + let inst = List.map (fun d -> mkVar (get_id d)) (named_context env) in + let body = mkEvar (ev, mkRel 1 :: inst) in (sigma, mkLetIn (map_annot Name.mk_name id, c, t, body)) end end @@ -4499,7 +4499,7 @@ let check_expected_type env sigma (elimc,bl) elimt = if n == 0 then error "Scheme cannot be applied."; let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in let sigma = solve_evar_clause env sigma true cl bl in - let (_,u,_) = destProd sigma cl.cl_concl in + let (_,u,_) = destProd sigma (whd_all env sigma cl.cl_concl) in fun t -> match Evarconv.unify_leq_delay env sigma t u with | _sigma -> true | exception Evarconv.UnableToUnify _ -> false 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/Makefile b/test-suite/Makefile index 954a922c8c..dece21885c 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -62,6 +62,10 @@ coqtopbyte := $(BIN)coqtop.byte -q coqc_interactive := $(coqc) -test-mode -async-proofs-cache force coqdep := $(BIN)coqdep +# This is the convention for coq_makefile +OPT=-$(BEST) +export OPT + VERBOSE?= SHOW := $(if $(VERBOSE),@true,@echo) HIDE := $(if $(VERBOSE),,@) 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_12045.v b/test-suite/bugs/closed/bug_12045.v new file mode 100644 index 0000000000..4e416778a9 --- /dev/null +++ b/test-suite/bugs/closed/bug_12045.v @@ -0,0 +1,19 @@ +(* Check enough reduction happens in the conclusion of an induction scheme *) + +Lemma foo : + forall (P : nat -> Prop), + (forall n, P (S n)) -> + forall n, + (fun e => + IsSucc e -> + P e) n. +Proof. +Admitted. + +Theorem bar : forall n, + IsSucc n -> + True. +Proof. + intros. + Fail induction n using foo. (* was an anomaly *) +Admitted. 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_5359.v b/test-suite/bugs/closed/bug_5359.v index 1f202e4396..36f2ec5891 100644 --- a/test-suite/bugs/closed/bug_5359.v +++ b/test-suite/bugs/closed/bug_5359.v @@ -90,7 +90,7 @@ Goal False. (Ring_polynom.PEX Z 2))) (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) (Ring_polynom.PEX Z 3)))) :: nil)%list ) in - Nsatz.nsatz_compute + NsatzTactic.nsatz_compute (@cons _ (@Ring_polynom.PEc _ sugar) (@cons _ (@Ring_polynom.PEc _ nparams) (@cons _ (@Ring_polynom.PEpow _ reified_goal power) reified_givens))). let sugar := constr:( 0%Z ) in @@ -214,6 +214,6 @@ Goal False. (Ring_polynom.PEX Z 2))) (Ring_polynom.PEmul (Ring_polynom.PEX Z 3) (Ring_polynom.PEX Z 3)))) :: nil)%list ) in - Nsatz.nsatz_compute + NsatzTactic.nsatz_compute (@cons _ (@Ring_polynom.PEc _ sugar) (@cons _ (@Ring_polynom.PEc _ nparams) (@cons _ (@Ring_polynom.PEpow _ reified_goal power) reified_givens))). Abort. diff --git a/test-suite/bugs/closed/bug_5445.v b/test-suite/bugs/closed/bug_5445.v new file mode 100644 index 0000000000..deaf174661 --- /dev/null +++ b/test-suite/bugs/closed/bug_5445.v @@ -0,0 +1,11 @@ +Require Import Coq.nsatz.NsatzTactic. +(** Ensure that loading the nsatz tactic doesn't load the reals *) +Fail Module M := Coq.Reals.Rdefinitions. +(** Ensure that loading the nsatz tactic doesn't load classic *) +Fail Check Coq.Logic.Classical_Prop.classic. +(** Ensure that this test-case hasn't messed up about the location of the reals / how to check for them *) +Require Coq.Reals.Rdefinitions. +Module M := Coq.Reals.Rdefinitions. +(** Ensure that this test-case hasn't messed up about the location of classic / how to check for it *) +Require Coq.Logic.Classical_Prop. +Check Coq.Logic.Classical_Prop.classic. 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/test-suite/bugs/closed/bug_7812.v b/test-suite/bugs/closed/bug_7812.v new file mode 100644 index 0000000000..a714eea81d --- /dev/null +++ b/test-suite/bugs/closed/bug_7812.v @@ -0,0 +1,30 @@ +Module Foo. + Definition binary A := A -> A -> Prop. + + Definition inter A (R1 R2 : binary A): binary A := + fun (x y:A) => R1 x y /\ R2 x y. +End Foo. + +Module Simple_sparse_proof. + Parameter node : Type. + Parameter graph : Type. + Parameter has_edge : graph -> node -> node -> Prop. + Implicit Types x y z : node. + Implicit Types G : graph. + + Parameter mem : forall A, A -> list A -> Prop. + Hypothesis mem_nil : forall x, mem node x nil = False. + + Definition notin (l: list node): node -> node -> Prop := + fun x y => ~ mem node x l /\ ~ mem node y l. + + Definition edge_notin G l : node -> node -> Prop := + Foo.inter node (has_edge G) (notin l). + + Hint Unfold Foo.inter notin edge_notin : rel_crush. + + Lemma edge_notin_nil G : forall x y, edge_notin G nil x y <-> has_edge G x y. + Proof. + intros. autounfold with rel_crush. rewrite !mem_nil. tauto. + Qed. +End Simple_sparse_proof. diff --git a/test-suite/complexity/ConstructiveCauchyRealsPerformance.v b/test-suite/complexity/ConstructiveCauchyRealsPerformance.v new file mode 100644 index 0000000000..c901334da9 --- /dev/null +++ b/test-suite/complexity/ConstructiveCauchyRealsPerformance.v @@ -0,0 +1,149 @@ +(* Here we give some functions that compute non-rational reals, + to measure the computation speed. *) +(* Expected time < 5.00s *) + +Require Import QArith Qabs. +Require Import ConstructiveCauchyRealsMult. + +Local Open Scope CReal_scope. + +Definition approx_sqrt_Q (q : Q) (n : positive) : Q + := let (k,j) := q in + match k with + | Z0 => 0 + | Z.pos i => Z.pos (Pos.sqrt (i*j*n*n)) # (j*n) + | Z.neg i => 0 (* unused *) + end. + +(* Approximation of the square root from below, + improves the convergence modulus. *) +Lemma approx_sqrt_Q_le_below : forall (q : Q) (n : positive), + Qle 0 q -> Qle (approx_sqrt_Q q n * approx_sqrt_Q q n) q. +Proof. + intros. destruct q as [k j]. unfold approx_sqrt_Q. + destruct k as [|i|i]. apply Z.le_refl. + pose proof (Pos.sqrt_spec (i * j * n * n)). simpl in H0. + destruct H0 as [H0 _]. + unfold Qle, Qmult, Qnum, Qden. + rewrite <- Pos2Z.inj_mul, <- Pos2Z.inj_mul, <- Pos2Z.inj_mul. + apply Pos2Z.pos_le_pos. rewrite (Pos.mul_comm i (j * n * (j * n))). + rewrite <- (Pos.mul_comm j), <- (Pos.mul_assoc j), <- (Pos.mul_assoc j). + apply Pos.mul_le_mono_l. + apply (Pos.le_trans _ _ _ H0). + rewrite <- (Pos.mul_comm n), <- (Pos.mul_assoc n). + apply Pos.mul_le_mono_l. + rewrite (Pos.mul_comm i j), <- Pos.mul_assoc, <- Pos.mul_assoc. + apply Pos.mul_le_mono_l. rewrite Pos.mul_comm. apply Pos.le_refl. + exfalso. unfold Qle, Z.le in H; simpl in H. exact (H eq_refl). +Qed. + +Require Import Lia. + +Lemma approx_sqrt_Q_le_below_lia : forall (q : Q) (n : positive), + (0 <= q)%Q -> (approx_sqrt_Q q n * approx_sqrt_Q q n <= q)%Q. +Proof. + intros. destruct q as [k j]. unfold approx_sqrt_Q. + destruct k as [|i|i]. + - apply Z.le_refl. + - unfold Qle, Qmult, Qnum, Qden. + pose proof (Pos.sqrt_spec (i * j * n * n)) as Hsqrt; simpl in Hsqrt. + destruct Hsqrt as [Hsqrt _]; apply (Pos.mul_le_mono_l j) in Hsqrt. + lia. + - unfold Qle, Qnum, Qden in H; lia. +Qed. + +Print Assumptions approx_sqrt_Q_le_below_lia. + +Lemma approx_sqrt_Q_lt_above : forall (q : Q) (n : positive), + Qle 0 q -> Qlt q ((approx_sqrt_Q q n + (1#n)) * (approx_sqrt_Q q n + (1#n))). +Proof. + intros. destruct q as [k j]. unfold approx_sqrt_Q. + destruct k as [|i|i]. reflexivity. + 2: exfalso; unfold Qle, Z.le in H; simpl in H; exact (H eq_refl). + pose proof (Pos.sqrt_spec (i * j * n * n)). simpl in H0. + destruct H0 as [_ H0]. + apply (Qlt_le_trans + _ (((Z.pos ((Pos.sqrt (i * j * n * n)) + 1) # j * n)) + * ((Z.pos ((Pos.sqrt (i * j * n * n)) + 1) # j * n)))). + unfold Qlt, Qmult, Qnum, Qden. + rewrite <- Pos2Z.inj_mul, <- Pos2Z.inj_mul, <- Pos2Z.inj_mul. + apply Pos2Z.pos_lt_pos. + rewrite Pos.mul_comm, <- Pos.mul_assoc, <- Pos.mul_assoc, Pos.mul_comm. + apply Pos.mul_lt_mono_r. rewrite Pplus_one_succ_r in H0. + refine (Pos.le_lt_trans _ _ _ _ H0). rewrite Pos.mul_comm. + apply Pos.mul_le_mono_r. + rewrite <- Pos.mul_assoc, (Pos.mul_comm i), <- Pos.mul_assoc. + apply Pos.mul_le_mono_l. rewrite Pos.mul_comm. apply Pos.le_refl. + setoid_replace (1#n)%Q with (Z.pos j#j*n)%Q. 2: reflexivity. + rewrite Qinv_plus_distr. + unfold Qle, Qmult, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. + discriminate. apply Z.mul_le_mono_nonneg. + discriminate. 2: discriminate. + rewrite Pos2Z.inj_add. apply Z.add_le_mono_l. + apply Pos2Z.pos_le_pos. destruct j; discriminate. + rewrite Pos2Z.inj_add. apply Z.add_le_mono_l. + apply Pos2Z.pos_le_pos. destruct j; discriminate. +Qed. + +Lemma approx_sqrt_Q_pos : forall (q : Q) (n : positive), + Qle 0 q -> Qle 0 (approx_sqrt_Q q n). +Proof. + intros. unfold approx_sqrt_Q. destruct q, Qnum. + apply Qle_refl. discriminate. apply Qle_refl. +Qed. + +Lemma Qsqrt_lt : forall q r :Q, + (0 <= r -> q*q < r*r -> q < r)%Q. +Proof. + intros. destruct (Q_dec q r). destruct s. exact q0. + - exfalso. apply (Qlt_not_le _ _ H0). apply (Qle_trans _ (q * r)). + apply Qmult_le_compat_r. apply Qlt_le_weak, q0. exact H. + rewrite Qmult_comm. + apply Qmult_le_compat_r. apply Qlt_le_weak, q0. + apply (Qle_trans _ r _ H). apply Qlt_le_weak, q0. + - exfalso. rewrite q0 in H0. exact (Qlt_irrefl _ H0). +Qed. + +Lemma approx_sqrt_Q_cauchy : + forall q:Q, QCauchySeq (approx_sqrt_Q q) id. +Proof. + intro q. destruct q as [k j]. destruct k. + - intros n a b H H0. reflexivity. + - assert (forall n a b, Pos.le n b -> + (approx_sqrt_Q (Z.pos p # j) a - approx_sqrt_Q (Z.pos p # j) b + < 1 # n)%Q). + { intros. rewrite <- (Qplus_lt_r _ _ (approx_sqrt_Q (Z.pos p # j) b)). + ring_simplify. apply Qsqrt_lt. + apply (Qle_trans _ (0+(1#n))). rewrite Qplus_0_l. discriminate. + apply Qplus_le_l. apply approx_sqrt_Q_pos. discriminate. + apply (Qle_lt_trans _ (Z.pos p # j)). + apply approx_sqrt_Q_le_below. discriminate. + apply (Qlt_le_trans _ ((approx_sqrt_Q (Z.pos p # j) b + (1 # b)) * + (approx_sqrt_Q (Z.pos p # j) b + (1 # b)))). + apply approx_sqrt_Q_lt_above. discriminate. + apply (Qle_trans _ ((approx_sqrt_Q (Z.pos p # j) b + (1 # n)) * + (approx_sqrt_Q (Z.pos p # j) b + (1 # b)))). + apply Qmult_le_r. + apply (Qlt_le_trans _ (0+(1#b))). rewrite Qplus_0_l. reflexivity. + apply Qplus_le_l. apply approx_sqrt_Q_pos. discriminate. + apply Qplus_le_r. unfold Qle; simpl. + apply Pos2Z.pos_le_pos, H. + apply Qmult_le_l. + apply (Qlt_le_trans _ (0+(1#n))). rewrite Qplus_0_l. reflexivity. + apply Qplus_le_l. apply approx_sqrt_Q_pos. discriminate. + apply Qplus_le_r. unfold Qle; simpl. + apply Pos2Z.pos_le_pos, H. } + intros n a b H0 H1. apply Qabs_case. + intros. apply H, H1. + intros. + setoid_replace (- (approx_sqrt_Q (Z.pos p # j) a - approx_sqrt_Q (Z.pos p # j) b))%Q + with (approx_sqrt_Q (Z.pos p # j) b - approx_sqrt_Q (Z.pos p # j) a)%Q. + 2: ring. apply H, H0. + - intros n a b H H0. reflexivity. +Qed. + +Definition CReal_sqrt_Q (q : Q) : CReal + := exist _ (approx_sqrt_Q q) (approx_sqrt_Q_cauchy q). + + +Time Eval vm_compute in (proj1_sig (CReal_sqrt_Q 2) (10 ^ 400)%positive). diff --git a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired index 4381160a4e..ebe44f3548 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-after.log.desired @@ -1,5 +1,5 @@ COQDEP VFILES COQC Slow.v -Slow (real: 0.04, user: 0.02, sys: 0.01, mem: 45512 ko) +Slow.vo (real: 0.04, user: 0.02, sys: 0.01, mem: 45512 ko) COQC Fast.v -Fast (real: 0.41, user: 0.37, sys: 0.04, mem: 395200 ko) +Fast.vo (real: 0.41, user: 0.37, sys: 0.04, mem: 395200 ko) diff --git a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired index e6af909268..bf17a3e95c 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-before.log.desired @@ -1,5 +1,5 @@ COQDEP VFILES COQC Slow.v -Slow (real: 0.40, user: 0.35, sys: 0.04, mem: 394968 ko) +Slow.vo (real: 0.40, user: 0.35, sys: 0.04, mem: 394968 ko) COQC Fast.v -Fast (real: 0.04, user: 0.03, sys: 0.00, mem: 46564 ko) +Fast.vo (real: 0.04, user: 0.03, sys: 0.00, mem: 46564 ko) diff --git a/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired b/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired index 72c520218c..c8f35dc1e4 100644 --- a/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired +++ b/test-suite/coq-makefile/timing/after/time-of-build-both.log.desired @@ -2,5 +2,5 @@ After | File Name | Before || Change | % Change -------------------------------------------------------- 0m00.34s | Total | 0m00.49s || -0m00.14s | -30.61% -------------------------------------------------------- -0m00.32s | Fast | 0m00.02s || +0m00.30s | +1500.00% -0m00.02s | Slow | 0m00.47s || -0m00.44s | -95.74%
\ No newline at end of file +0m00.32s | Fast.vo | 0m00.02s || +0m00.30s | +1500.00% +0m00.02s | Slow.vo | 0m00.47s || -0m00.44s | -95.74%
\ No newline at end of file diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index e121b5e86c..f48eaac4c9 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -14,6 +14,10 @@ Entry constr:myconstr is : nat [<< # 0 >>] : option nat +[b + c] + : nat +fun a : nat => [a + a] + : nat -> nat [1 {f 1}] : Expr fun (x : nat) (y z : Expr) => [1 + y z + {f x}] @@ -81,18 +85,18 @@ fun x : nat => [x] : nat -> nat ∀ x : nat, x = x : Prop -File "stdin", line 219, characters 0-160: +File "stdin", line 226, characters 0-160: Warning: Notation "∀ _ .. _ , _" was already defined with a different format in scope type_scope. [notation-incompatible-format,parsing] ∀x : nat,x = x : Prop -File "stdin", line 232, characters 0-60: +File "stdin", line 239, characters 0-60: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 236, characters 0-64: +File "stdin", line 243, characters 0-64: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 241, characters 0-62: +File "stdin", line 248, characters 0-62: Warning: Lonely notation "_ %%%% _" was already defined with a different format. [notation-incompatible-format,parsing] 3 %% 4 @@ -101,9 +105,9 @@ format. [notation-incompatible-format,parsing] : nat 3 %% 4 : nat -File "stdin", line 269, characters 0-61: +File "stdin", line 276, characters 0-61: Warning: The format modifier is irrelevant for only parsing rules. [irrelevant-format-only-parsing,parsing] -File "stdin", line 273, characters 0-63: +File "stdin", line 280, characters 0-63: Warning: The only parsing modifier has no effect in Reserved Notation. [irrelevant-reserved-notation-only-parsing,parsing] diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 1cf0d919b1..4d4b37a8b2 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -22,6 +22,13 @@ Notation "<< x >>" := x (in custom myconstr at level 3, x custom anotherconstr a Notation "# x" := (Some x) (in custom anotherconstr at level 8, x constr at level 9). Check [ << # 0 >> ]. +(* Now check with global *) + +Axiom c : nat. +Notation "x" := x (in custom myconstr at level 0, x global). +Check [ b + c ]. +Check fun a => [ a + a ]. + End A. Module B. diff --git a/test-suite/output/undeclared_key.out b/test-suite/output/undeclared_key.out new file mode 100644 index 0000000000..ed768751fc --- /dev/null +++ b/test-suite/output/undeclared_key.out @@ -0,0 +1,13 @@ +The command has indeed failed with message: +There is no flag, option or table with this name: "Search Blacklists". +The command has indeed failed with message: +There is no qualid-valued table with this name: "Search Blacklist". +File "stdin", line 3, characters 0-22: +Warning: There is no flag or option with this name: "Search Blacklists". +[unknown-option,option] +The command has indeed failed with message: +There is no string-valued table with this name: "Search Blacklists". +The command has indeed failed with message: +There is no qualid-valued table with this name: "Search Blacklist". +The command has indeed failed with message: +There is no qualid-valued table with this name: "Search Blacklist". diff --git a/test-suite/output/undeclared_key.v b/test-suite/output/undeclared_key.v new file mode 100644 index 0000000000..4134bc8bfa --- /dev/null +++ b/test-suite/output/undeclared_key.v @@ -0,0 +1,6 @@ +Fail Test Search Blacklists. +Fail Test Search Blacklist for foo. +Set Search Blacklists. +Fail Remove Search Blacklists "bar" foo. +Fail Remove Search Blacklist "bar" foo. +Fail Add Search Blacklist "bar" foo. 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/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index 466e2bf994..443931e5bb 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -15,7 +15,7 @@ *) Require Fin. -Require Import VectorDef. +Require Import VectorDef PeanoNat Eqdep_dec. Import VectorNotations. Definition cons_inj {A} {a1 a2} {n} {v1 v2 : t A n} @@ -32,6 +32,8 @@ Defined. (** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all is true for the one that use [lt] *) +(** ** Properties of [nth] and [nth_order] *) + Lemma eq_nth_iff A n (v1 v2: t A n): (forall p1 p2, p1 = p2 -> v1 [@ p1 ] = v2 [@ p2 ]) <-> v1 = v2. Proof. @@ -44,12 +46,35 @@ split. - intros; now f_equal. Qed. +Lemma nth_order_hd A: forall n (v : t A (S n)) (H : 0 < S n), + nth_order v H = hd v. +Proof. intros; now rewrite (eta v). Qed. + +Lemma nth_order_tl A: forall n k (v : t A (S n)) (H : k < n) (HS : S k < S n), + nth_order (tl v) H = nth_order v HS. +Proof. +induction n; intros. +- inversion H. +- rewrite (eta v). + unfold nth_order; simpl. + now rewrite (Fin.of_nat_ext H (Lt.lt_S_n _ _ HS)). +Qed. + Lemma nth_order_last A: forall n (v: t A (S n)) (H: n < S n), nth_order v H = last v. Proof. unfold nth_order; refine (@rectS _ _ _ _); now simpl. Qed. +Lemma nth_order_ext A: forall n k (v : t A n) (H1 H2 : k < n), + nth_order v H1 = nth_order v H2. +Proof. +intros; unfold nth_order. +now rewrite (Fin.of_nat_ext H1 H2). +Qed. + +(** ** Properties of [shiftin] and [shiftrepeat] *) + Lemma shiftin_nth A a n (v: t A n) k1 k2 (eq: k1 = k2): nth (shiftin a v) (Fin.L_R 1 k1) = nth v k2. Proof. @@ -82,11 +107,99 @@ Proof. refine (@rectS _ _ _ _); now simpl. Qed. +(** ** Properties of [replace] *) + +Lemma nth_order_replace_eq A: forall n k (v : t A n) a (H1 : k < n) (H2 : k < n), + nth_order (replace v (Fin.of_nat_lt H2) a) H1 = a. +Proof. +intros n k; revert n; induction k; intros; + (destruct n; [ inversion H1 | subst ]). +- now rewrite nth_order_hd, (eta v). +- rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) H1)), (eta v). + apply IHk. +Qed. + +Lemma nth_order_replace_neq A: forall n k1 k2, k1 <> k2 -> + forall (v : t A n) a (H1 : k1 < n) (H2 : k2 < n), + nth_order (replace v (Fin.of_nat_lt H2) a) H1 = nth_order v H1. +Proof. +intros n k1; revert n; induction k1; intros; + (destruct n ; [ inversion H1 | subst ]). +- rewrite 2 nth_order_hd. + destruct k2; intuition. + now rewrite 2 (eta v). +- rewrite <- 2 (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) H1)), (eta v). + destruct k2; auto. + apply IHk1. + intros Hk; apply H; now subst. +Qed. + +Lemma replace_id A: forall n p (v : t A n), + replace v p (nth v p) = v. +Proof. +induction p; intros; rewrite 2 (eta v); simpl; auto. +now rewrite IHp. +Qed. + +Lemma replace_replace_eq A: forall n p (v : t A n) a b, + replace (replace v p a) p b = replace v p b. +Proof. +intros. +induction p; rewrite 2 (eta v); simpl; auto. +now rewrite IHp. +Qed. + +Lemma replace_replace_neq A: forall n p1 p2 (v : t A n) a b, p1 <> p2 -> + replace (replace v p1 a) p2 b = replace (replace v p2 b) p1 a. +Proof. +apply (Fin.rect2 (fun n p1 p2 => forall v a b, + p1 <> p2 -> replace (replace v p1 a) p2 b = replace (replace v p2 b) p1 a)). +- intros n v a b Hneq. + now contradiction Hneq. +- intros n p2 v; revert n v p2. + refine (@rectS _ _ _ _); auto. +- intros n p1 v; revert n v p1. + refine (@rectS _ _ _ _); auto. +- intros n p1 p2 IH v; revert n v p1 p2 IH. + refine (@rectS _ _ _ _); simpl; do 6 intro; [ | do 3 intro ]; intro Hneq; + f_equal; apply IH; intros Heq; apply Hneq; now subst. +Qed. + +(** ** Properties of [const] *) + Lemma const_nth A (a: A) n (p: Fin.t n): (const a n)[@ p] = a. Proof. now induction p. Qed. +(** ** Properties of [map] *) + +Lemma map_id A: forall n (v : t A n), + map (fun x => x) v = v. +Proof. +induction v; simpl; [ | rewrite IHv ]; auto. +Qed. + +Lemma map_map A B C: forall (f:A->B) (g:B->C) n (v : t A n), + map g (map f v) = map (fun x => g (f x)) v. +Proof. +induction v; simpl; [ | rewrite IHv ]; auto. +Qed. + +Lemma map_ext_in A B: forall (f g:A->B) n (v : t A n), + (forall a, In a v -> f a = g a) -> map f v = map g v. +Proof. +induction v; simpl; auto. +intros; rewrite H by constructor; rewrite IHv; intuition. +apply H; now constructor. +Qed. + +Lemma map_ext A B: forall (f g:A->B), (forall a, f a = g a) -> + forall n (v : t A n), map f v = map g v. +Proof. +intros; apply map_ext_in; auto. +Qed. + Lemma nth_map {A B} (f: A -> B) {n} v (p1 p2: Fin.t n) (eq: p1 = p2): (map f v) [@ p1] = f (v [@ p2]). Proof. @@ -105,6 +218,8 @@ refine (@rect2 _ _ _ _ _); simpl. now simpl. Qed. +(** ** Properties of [fold_left] *) + Lemma fold_left_right_assoc_eq {A B} {f: A -> B -> A} (assoc: forall a b c, f (f a b) c = f (f a c) b) {n} (v: t B n): forall a, fold_left f a v = fold_right (fun x y => f y x) v a. @@ -118,6 +233,8 @@ assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). + simpl. intros; now rewrite<- (IHv). Qed. +(** ** Properties of [to_list] *) + Lemma to_list_of_list_opp {A} (l: list A): to_list (of_list l) = l. Proof. induction l. @@ -125,6 +242,8 @@ induction l. - unfold to_list; simpl. now f_equal. Qed. +(** ** Properties of [take] *) + Lemma take_O : forall {A} {n} le (v:t A n), take 0 le v = []. Proof. reflexivity. @@ -153,10 +272,14 @@ Proof. - destruct v. inversion le. simpl. apply f_equal. apply IHp. Qed. +(** ** Properties of [uncons] and [splitat] *) + Lemma uncons_cons {A} : forall {n : nat} (a : A) (v : t A n), uncons (a::v) = (a,v). Proof. reflexivity. Qed. +(* [append] *) + Lemma append_comm_cons {A} : forall {n m : nat} (v : t A n) (w : t A m) (a : A), a :: (v ++ w) = (a :: v) ++ w. Proof. reflexivity. Qed. @@ -187,3 +310,80 @@ Proof with auto. f_equal... apply IHv... Qed. + +(** ** Properties of [Forall] and [Forall2] *) + +Lemma Forall_impl A: forall (P Q : A -> Prop), (forall a, P a -> Q a) -> + forall n (v : t A n), Forall P v -> Forall Q v. +Proof. +induction v; intros HP; constructor; inversion HP as [| ? ? ? ? ? Heq1 [Heq2 He]]; + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He; subst; intuition. +Qed. + +Lemma Forall_forall A: forall P n (v : t A n), + Forall P v <-> forall a, In a v -> P a. +Proof. +intros P n v; split. +- intros HP a Hin. + revert HP; induction Hin; intros HP; + inversion HP as [| ? ? ? ? ? Heq1 [Heq2 He]]; subst; auto. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He; subst; auto. +- induction v; intros Hin; constructor. + + apply Hin; constructor. + + apply IHv; intros a Ha. + apply Hin; now constructor. +Qed. + +Lemma Forall_nth_order A: forall P n (v : t A n), + Forall P v <-> forall i (Hi : i < n), P (nth_order v Hi). +Proof. +split; induction n. +- intros HF i Hi; inversion Hi. +- intros HF i Hi. + rewrite (eta v). + rewrite (eta v) in HF. + inversion HF as [| ? ? ? ? ? Heq1 [Heq2 He]]; subst. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He ; subst. + destruct i. + + now rewrite nth_order_hd. + + rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) Hi) Hi). + now apply IHn. +- intros HP; apply case0; constructor. +- intros HP. + rewrite (eta v) in HP. + rewrite (eta v); constructor. + + specialize HP with 0 (Nat.lt_0_succ n). + now rewrite nth_order_hd in HP. + + apply IHn; intros. + specialize HP with (S i) (proj1 (Nat.succ_lt_mono _ _) Hi). + now rewrite <- (nth_order_tl _ _ _ _ Hi) in HP. +Qed. + +Lemma Forall2_nth_order A: forall P n (v1 v2 : t A n), + Forall2 P v1 v2 + <-> forall i (Hi1 : i < n) (Hi2 : i < n), P (nth_order v1 Hi1) (nth_order v2 Hi2). +Proof. +split; induction n. +- intros HF i Hi1 Hi2; inversion Hi1. +- intros HF i Hi1 Hi2. + rewrite (eta v1), (eta v2). + rewrite (eta v1), (eta v2) in HF. + inversion HF as [| ? ? ? ? ? ? ? Heq [Heq1 He1] [Heq2 He2]]. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He1. + apply (inj_pair2_eq_dec _ Nat.eq_dec) in He2; subst. + destruct i. + + now rewrite nth_order_hd. + + rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) Hi1) Hi1). + rewrite <- (nth_order_tl _ _ _ _ (proj2 (Nat.succ_lt_mono _ _) Hi2) Hi2). + now apply IHn. +- intros _; revert v1; apply case0; revert v2; apply case0; constructor. +- intros HP. + rewrite (eta v1), (eta v2) in HP. + rewrite (eta v1), (eta v2); constructor. + + specialize HP with 0 (Nat.lt_0_succ _) (Nat.lt_0_succ _). + now rewrite nth_order_hd in HP. + + apply IHn; intros. + specialize HP with (S i) (proj1 (Nat.succ_lt_mono _ _) Hi1) + (proj1 (Nat.succ_lt_mono _ _) Hi2). + now rewrite <- (nth_order_tl _ _ _ _ Hi1), <- (nth_order_tl _ _ _ _ Hi2) in HP. +Qed. 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/theories/nsatz/Nsatz.v b/theories/nsatz/Nsatz.v index 93b84f3a02..70180f47c7 100644 --- a/theories/nsatz/Nsatz.v +++ b/theories/nsatz/Nsatz.v @@ -9,9 +9,9 @@ (************************************************************************) (* - Tactic nsatz: proofs of polynomials equalities in an integral domain + Tactic nsatz: proofs of polynomials equalities in an integral domain (commutative ring without zero divisor). - + Examples: see test-suite/success/Nsatz.v Reification is done using type classes, defined in Ncring_tac.v @@ -33,416 +33,9 @@ Require Import DiscrR. Require Import ZArith. Require Import Lia. -Declare ML Module "nsatz_plugin". - -Section nsatz1. - -Context {R:Type}`{Rid:Integral_domain R}. - -Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y. -intros x y H; setoid_replace x with ((x - y) + y); simpl; - [setoid_rewrite H | idtac]; simpl. cring. cring. -Qed. - -Lemma psos_r1: forall x y, x == y -> x - y == 0. -intros x y H; simpl; setoid_rewrite H; simpl; cring. -Qed. - -Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0). -intros. -intro; apply H. -simpl; setoid_replace x with ((x - y) + y). simpl. -setoid_rewrite H0. -simpl; cring. -simpl. simpl; cring. -Qed. - -(* adpatation du code de Benjamin aux setoides *) -Export Ring_polynom. -Export InitialRing. - -Definition PolZ := Pol Z. -Definition PEZ := PExpr Z. - -Definition P0Z : PolZ := P0 (C:=Z) 0%Z. - -Definition PolZadd : PolZ -> PolZ -> PolZ := - @Padd Z 0%Z Z.add Zeq_bool. - -Definition PolZmul : PolZ -> PolZ -> PolZ := - @Pmul Z 0%Z 1%Z Z.add Z.mul Zeq_bool. - -Definition PolZeq := @Peq Z Zeq_bool. - -Definition norm := - @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool. - -Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := - match la, lp with - | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) - | _, _ => P0Z - end. - -Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := - match lla with - | List.nil => lp - | la::lla => compute_list lla ((mult_l la lp)::lp) - end. - -Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := - let (lla, lq) := certif in - let lp := List.map norm lpe in - PolZeq (norm qe) (mult_l lq (compute_list lla lp)). - - -(* Correction *) -Definition PhiR : list R -> PolZ -> R := - (Pphi ring0 add mul - (InitialRing.gen_phiZ ring0 ring1 add mul opp)). - -Definition PEevalR : list R -> PEZ -> R := - PEeval ring0 ring1 add mul sub opp - (gen_phiZ ring0 ring1 add mul opp) - N.to_nat pow. - -Lemma P0Z_correct : forall l, PhiR l P0Z = 0. -Proof. trivial. Qed. - -Lemma Rext: ring_eq_ext add mul opp _==_. -Proof. -constructor; solve_proper. -Qed. - -Lemma Rset : Setoid_Theory R _==_. -apply ring_setoid. -Qed. - -Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_. -apply mk_rt. -apply ring_add_0_l. -apply ring_add_comm. -apply ring_add_assoc. -apply ring_mul_1_l. -apply cring_mul_comm. -apply ring_mul_assoc. -apply ring_distr_l. -apply ring_sub_def. -apply ring_opp_def. -Defined. - -Lemma PolZadd_correct : forall P' P l, - PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')). -Proof. -unfold PolZadd, PhiR. intros. simpl. - refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) _ _ _). -Qed. - -Lemma PolZmul_correct : forall P P' l, - PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')). -Proof. -unfold PolZmul, PhiR. intros. - refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) _ _ _). -Qed. - -Lemma R_power_theory - : Ring_theory.power_theory ring1 mul _==_ N.to_nat pow. -apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id. -reflexivity. Qed. - -Lemma norm_correct : - forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe). -Proof. - intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory) - (gen_phiZ_morph Rset Rext Rtheory) R_power_theory). -Qed. - -Lemma PolZeq_correct : forall P P' l, - PolZeq P P' = true -> - PhiR l P == PhiR l P'. -Proof. - intros;apply - (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial. -Qed. - -Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := - match l with - | List.nil => True - | a::l => Interp a == 0 /\ Cond0 A Interp l - end. - -Lemma mult_l_correct : forall l la lp, - Cond0 PolZ (PhiR l) lp -> - PhiR l (mult_l la lp) == 0. -Proof. - induction la;simpl;intros. cring. - destruct lp;trivial. simpl. cring. - simpl in H;destruct H. - rewrite PolZadd_correct. - simpl. rewrite PolZmul_correct. simpl. rewrite H. - rewrite IHla. cring. trivial. -Qed. - -Lemma compute_list_correct : forall l lla lp, - Cond0 PolZ (PhiR l) lp -> - Cond0 PolZ (PhiR l) (compute_list lla lp). -Proof. - induction lla;simpl;intros;trivial. - apply IHlla;simpl;split;trivial. - apply mult_l_correct;trivial. -Qed. - -Lemma check_correct : - forall l lpe qe certif, - check lpe qe certif = true -> - Cond0 PEZ (PEevalR l) lpe -> - PEevalR l qe == 0. -Proof. - unfold check;intros l lpe qe (lla, lq) H2 H1. - apply PolZeq_correct with (l:=l) in H2. - rewrite norm_correct, H2. - apply mult_l_correct. - apply compute_list_correct. - clear H2 lq lla qe;induction lpe;simpl;trivial. - simpl in H1;destruct H1. - rewrite <- norm_correct;auto. -Qed. - -(* fin *) - -Definition R2:= 1 + 1. - -Fixpoint IPR p {struct p}: R := - match p with - xH => ring1 - | xO xH => 1+1 - | xO p1 => R2*(IPR p1) - | xI xH => 1+(1+1) - | xI p1 => 1+(R2*(IPR p1)) - end. - -Definition IZR1 z := - match z with Z0 => 0 - | Zpos p => IPR p - | Zneg p => -(IPR p) - end. - -Fixpoint interpret3 t fv {struct t}: R := - match t with - | (PEadd t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 + v2) - | (PEmul t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 * v2) - | (PEsub t1 t2) => - let v1 := interpret3 t1 fv in - let v2 := interpret3 t2 fv in (v1 - v2) - | (PEopp t1) => - let v1 := interpret3 t1 fv in (-v1) - | (PEpow t1 t2) => - let v1 := interpret3 t1 fv in pow v1 (N.to_nat t2) - | (PEc t1) => (IZR1 t1) - | PEO => 0 - | PEI => 1 - | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0 - end. - - -End nsatz1. - -Ltac equality_to_goal H x y:= - (* eliminate trivial hypotheses, but it takes time!: - let h := fresh "nH" in - (assert (h:equality x y); - [solve [cring] | clear H; clear h]) - || *) try (generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H) -. - -Ltac equalities_to_goal := - lazymatch goal with - | H: (_ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y - | H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y -(* extension possible :-) *) - | H: (?x == ?y) |- _ => equality_to_goal H x y - end. - -(* lp est incluse dans fv. La met en tete. *) - -Ltac parametres_en_tete fv lp := - match fv with - | (@nil _) => lp - | (@cons _ ?x ?fv1) => - let res := AddFvTail x lp in - parametres_en_tete fv1 res - end. - -Ltac append1 a l := - match l with - | (@nil _) => constr:(cons a l) - | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') - end. - -Ltac rev l := - match l with - |(@nil _) => l - | (cons ?x ?l) => let l' := rev l in append1 x l' - end. - -Ltac nsatz_call_n info nparam p rr lp kont := -(* idtac "Trying power: " rr;*) - let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in -(* idtac "calcul...";*) - nsatz_compute ll; -(* idtac "done";*) - match goal with - | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => - intros _; - let lci := fresh "lci" in - set (lci:=lci0); - let lq := fresh "lq" in - set (lq:=lq0); - kont c rr lq lci - end. - -Ltac nsatz_call radicalmax info nparam p lp kont := - let rec try_n n := - lazymatch n with - | 0%N => fail - | _ => - (let r := eval compute in (N.sub radicalmax (N.pred n)) in - nsatz_call_n info nparam p r lp kont) || - let n' := eval compute in (N.pred n) in try_n n' - end in - try_n radicalmax. - - -Ltac lterm_goal g := - match g with - ?b1 == ?b2 => constr:(b1::b2::nil) - | ?b1 == ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) - end. - -Ltac reify_goal l le lb:= - match le with - nil => idtac - | ?e::?le1 => - match lb with - ?b::?lb1 => (* idtac "b="; idtac b;*) - let x := fresh "B" in - set (x:= b) at 1; - change x with (interpret3 e l); - clear x; - reify_goal l le1 lb1 - end - end. - -Ltac get_lpol g := - match g with - (interpret3 ?p _) == _ => constr:(p::nil) - | (interpret3 ?p _) == _ -> ?g => - let l := get_lpol g in constr:(p::l) - end. - -Ltac nsatz_generic radicalmax info lparam lvar := - let nparam := eval compute in (Z.of_nat (List.length lparam)) in - match goal with - |- ?g => let lb := lterm_goal g in - match (match lvar with - |(@nil _) => - match lparam with - |(@nil _) => - let r := eval red in (list_reifyl (lterm:=lb)) in r - |_ => - match eval red in (list_reifyl (lterm:=lb)) with - |(?fv, ?le) => - let fv := parametres_en_tete fv lparam in - (* we reify a second time, with the good order - for variables *) - let r := eval red in - (list_reifyl (lterm:=lb) (lvar:=fv)) in r - end - end - |_ => - let fv := parametres_en_tete lvar lparam in - let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r - end) with - |(?fv, ?le) => - reify_goal fv le lb ; - match goal with - |- ?g => - let lp := get_lpol g in - let lpol := eval compute in (List.rev lp) in - intros; - - let SplitPolyList kont := - match lpol with - | ?p2::?lp2 => kont p2 lp2 - | _ => idtac "polynomial not in the ideal" - end in - - SplitPolyList ltac:(fun p lp => - let p21 := fresh "p21" in - let lp21 := fresh "lp21" in - set (p21:=p) ; - set (lp21:=lp); -(* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *) - nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => - let q := fresh "q" in - set (q := PEmul c (PEpow p21 r)); - let Hg := fresh "Hg" in - assert (Hg:check lp21 q (lci,lq) = true); - [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" - | let Hg2 := fresh "Hg" in - assert (Hg2: (interpret3 q fv) == 0); - [ (*simpl*) idtac; - generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg); - let cc := fresh "H" in - (*simpl*) idtac; intro cc; apply cc; clear cc; - (*simpl*) idtac; - repeat (split;[assumption|idtac]); exact I - | (*simpl in Hg2;*) (*simpl*) idtac; - apply Rintegral_domain_pow with (interpret3 c fv) (N.to_nat r); - (*simpl*) idtac; - try apply integral_domain_one_zero; - try apply integral_domain_minus_one_zero; - try trivial; - try exact integral_domain_one_zero; - try exact integral_domain_minus_one_zero - || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation, - one, one_notation, multiplication, mul_notation, zero, zero_notation; - discrR || lia ]) - || ((*simpl*) idtac) || idtac "could not prove discrimination result" - ] - ] -) -) -end end end . - -Ltac nsatz_default:= - intros; - try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); - match goal with |- (@equality ?r _ _ _) => - repeat equalities_to_goal; - nsatz_generic 6%N 1%Z (@nil r) (@nil r) - end. - -Tactic Notation "nsatz" := nsatz_default. - -Tactic Notation "nsatz" "with" - "radicalmax" ":=" constr(radicalmax) - "strategy" ":=" constr(info) - "parameters" ":=" constr(lparam) - "variables" ":=" constr(lvar):= - intros; - try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); - match goal with |- (@equality ?r _ _ _) => - repeat equalities_to_goal; - nsatz_generic radicalmax info lparam lvar - end. +Require Export NsatzTactic. +(** Make use of [discrR] in [nsatz] *) +Ltac nsatz_internal_discrR ::= discrR. (* Real numbers *) Require Import Reals. @@ -462,7 +55,7 @@ try (try apply Rsth; intros; try rewrite H; try rewrite H0; reflexivity)). exact Rplus_0_l. exact Rplus_comm. symmetry. apply Rplus_assoc. exact Rmult_1_l. exact Rmult_1_r. symmetry. apply Rmult_assoc. - exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. + exact Rmult_plus_distr_r. intros; apply Rmult_plus_distr_l. exact Rplus_opp_r. Defined. @@ -479,8 +72,8 @@ Qed. Instance Rcri: (Cring (Rr:=Rri)). red. exact Rmult_comm. Defined. -Instance Rdi : (Integral_domain (Rcr:=Rcri)). -constructor. +Instance Rdi : (Integral_domain (Rcr:=Rcri)). +constructor. exact Rmult_integral. exact R_one_zero. Defined. (* Rational numbers *) @@ -491,14 +84,14 @@ Defined. Instance Qri : (Ring (Ro:=Qops)). constructor. -try apply Q_Setoid. -apply Qplus_comp. -apply Qmult_comp. -apply Qminus_comp. +try apply Q_Setoid. +apply Qplus_comp. +apply Qmult_comp. +apply Qminus_comp. apply Qopp_comp. exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. - apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. + apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. reflexivity. exact Qplus_opp_r. Defined. @@ -508,8 +101,8 @@ Proof. unfold Qeq. simpl. lia. Qed. Instance Qcri: (Cring (Rr:=Qri)). red. exact Qmult_comm. Defined. -Instance Qdi : (Integral_domain (Rcr:=Qcri)). -constructor. +Instance Qdi : (Integral_domain (Rcr:=Qcri)). +constructor. exact Qmult_integral. exact Q_one_zero. Defined. (* Integers *) @@ -519,7 +112,6 @@ Proof. lia. Qed. Instance Zcri: (Cring (Rr:=Zr)). red. exact Z.mul_comm. Defined. -Instance Zdi : (Integral_domain (Rcr:=Zcri)). -constructor. +Instance Zdi : (Integral_domain (Rcr:=Zcri)). +constructor. exact Zmult_integral. exact Z_one_zero. Defined. - diff --git a/theories/nsatz/NsatzTactic.v b/theories/nsatz/NsatzTactic.v new file mode 100644 index 0000000000..db7dab2c46 --- /dev/null +++ b/theories/nsatz/NsatzTactic.v @@ -0,0 +1,449 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* + Tactic nsatz: proofs of polynomials equalities in an integral domain +(commutative ring without zero divisor). + +Examples: see test-suite/success/Nsatz.v + +Reification is done using type classes, defined in Ncring_tac.v + +*) + +Require Import List. +Require Import Setoid. +Require Import BinPos. +Require Import BinList. +Require Import Znumtheory. +Require Export Morphisms Setoid Bool. +Require Export Algebra_syntax. +Require Export Ncring. +Require Export Ncring_initial. +Require Export Ncring_tac. +Require Export Integral_domain. +Require Import ZArith. +Require Import Lia. + +Declare ML Module "nsatz_plugin". + +Section nsatz1. + +Context {R:Type}`{Rid:Integral_domain R}. + +Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y. +intros x y H; setoid_replace x with ((x - y) + y); simpl; + [setoid_rewrite H | idtac]; simpl. cring. cring. +Qed. + +Lemma psos_r1: forall x y, x == y -> x - y == 0. +intros x y H; simpl; setoid_rewrite H; simpl; cring. +Qed. + +Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0). +intros. +intro; apply H. +simpl; setoid_replace x with ((x - y) + y). simpl. +setoid_rewrite H0. +simpl; cring. +simpl. simpl; cring. +Qed. + +(* adpatation du code de Benjamin aux setoides *) +Export Ring_polynom. +Export InitialRing. + +Definition PolZ := Pol Z. +Definition PEZ := PExpr Z. + +Definition P0Z : PolZ := P0 (C:=Z) 0%Z. + +Definition PolZadd : PolZ -> PolZ -> PolZ := + @Padd Z 0%Z Z.add Zeq_bool. + +Definition PolZmul : PolZ -> PolZ -> PolZ := + @Pmul Z 0%Z 1%Z Z.add Z.mul Zeq_bool. + +Definition PolZeq := @Peq Z Zeq_bool. + +Definition norm := + @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool. + +Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ := + match la, lp with + | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp) + | _, _ => P0Z + end. + +Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) := + match lla with + | List.nil => lp + | la::lla => compute_list lla ((mult_l la lp)::lp) + end. + +Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) := + let (lla, lq) := certif in + let lp := List.map norm lpe in + PolZeq (norm qe) (mult_l lq (compute_list lla lp)). + + +(* Correction *) +Definition PhiR : list R -> PolZ -> R := + (Pphi ring0 add mul + (InitialRing.gen_phiZ ring0 ring1 add mul opp)). + +Definition PEevalR : list R -> PEZ -> R := + PEeval ring0 ring1 add mul sub opp + (gen_phiZ ring0 ring1 add mul opp) + N.to_nat pow. + +Lemma P0Z_correct : forall l, PhiR l P0Z = 0. +Proof. trivial. Qed. + +Lemma Rext: ring_eq_ext add mul opp _==_. +Proof. +constructor; solve_proper. +Qed. + +Lemma Rset : Setoid_Theory R _==_. +apply ring_setoid. +Qed. + +Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_. +apply mk_rt. +apply ring_add_0_l. +apply ring_add_comm. +apply ring_add_assoc. +apply ring_mul_1_l. +apply cring_mul_comm. +apply ring_mul_assoc. +apply ring_distr_l. +apply ring_sub_def. +apply ring_opp_def. +Defined. + +Lemma PolZadd_correct : forall P' P l, + PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')). +Proof. +unfold PolZadd, PhiR. intros. simpl. + refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory) + (gen_phiZ_morph Rset Rext Rtheory) _ _ _). +Qed. + +Lemma PolZmul_correct : forall P P' l, + PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')). +Proof. +unfold PolZmul, PhiR. intros. + refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory) + (gen_phiZ_morph Rset Rext Rtheory) _ _ _). +Qed. + +Lemma R_power_theory + : Ring_theory.power_theory ring1 mul _==_ N.to_nat pow. +apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id. +reflexivity. Qed. + +Lemma norm_correct : + forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe). +Proof. + intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory) + (gen_phiZ_morph Rset Rext Rtheory) R_power_theory). +Qed. + +Lemma PolZeq_correct : forall P P' l, + PolZeq P P' = true -> + PhiR l P == PhiR l P'. +Proof. + intros;apply + (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial. +Qed. + +Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop := + match l with + | List.nil => True + | a::l => Interp a == 0 /\ Cond0 A Interp l + end. + +Lemma mult_l_correct : forall l la lp, + Cond0 PolZ (PhiR l) lp -> + PhiR l (mult_l la lp) == 0. +Proof. + induction la;simpl;intros. cring. + destruct lp;trivial. simpl. cring. + simpl in H;destruct H. + rewrite PolZadd_correct. + simpl. rewrite PolZmul_correct. simpl. rewrite H. + rewrite IHla. cring. trivial. +Qed. + +Lemma compute_list_correct : forall l lla lp, + Cond0 PolZ (PhiR l) lp -> + Cond0 PolZ (PhiR l) (compute_list lla lp). +Proof. + induction lla;simpl;intros;trivial. + apply IHlla;simpl;split;trivial. + apply mult_l_correct;trivial. +Qed. + +Lemma check_correct : + forall l lpe qe certif, + check lpe qe certif = true -> + Cond0 PEZ (PEevalR l) lpe -> + PEevalR l qe == 0. +Proof. + unfold check;intros l lpe qe (lla, lq) H2 H1. + apply PolZeq_correct with (l:=l) in H2. + rewrite norm_correct, H2. + apply mult_l_correct. + apply compute_list_correct. + clear H2 lq lla qe;induction lpe;simpl;trivial. + simpl in H1;destruct H1. + rewrite <- norm_correct;auto. +Qed. + +(* fin *) + +Definition R2:= 1 + 1. + +Fixpoint IPR p {struct p}: R := + match p with + xH => ring1 + | xO xH => 1+1 + | xO p1 => R2*(IPR p1) + | xI xH => 1+(1+1) + | xI p1 => 1+(R2*(IPR p1)) + end. + +Definition IZR1 z := + match z with Z0 => 0 + | Zpos p => IPR p + | Zneg p => -(IPR p) + end. + +Fixpoint interpret3 t fv {struct t}: R := + match t with + | (PEadd t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 + v2) + | (PEmul t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 * v2) + | (PEsub t1 t2) => + let v1 := interpret3 t1 fv in + let v2 := interpret3 t2 fv in (v1 - v2) + | (PEopp t1) => + let v1 := interpret3 t1 fv in (-v1) + | (PEpow t1 t2) => + let v1 := interpret3 t1 fv in pow v1 (N.to_nat t2) + | (PEc t1) => (IZR1 t1) + | PEO => 0 + | PEI => 1 + | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0 + end. + + +End nsatz1. + +Ltac equality_to_goal H x y:= + (* eliminate trivial hypotheses, but it takes time!: + let h := fresh "nH" in + (assert (h:equality x y); + [solve [cring] | clear H; clear h]) + || *) try (generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H) +. + +Ltac equalities_to_goal := + lazymatch goal with + | H: (_ ?x ?y) |- _ => equality_to_goal H x y + | H: (_ _ ?x ?y) |- _ => equality_to_goal H x y + | H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y + | H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y +(* extension possible :-) *) + | H: (?x == ?y) |- _ => equality_to_goal H x y + end. + +(* lp est incluse dans fv. La met en tete. *) + +Ltac parametres_en_tete fv lp := + match fv with + | (@nil _) => lp + | (@cons _ ?x ?fv1) => + let res := AddFvTail x lp in + parametres_en_tete fv1 res + end. + +Ltac append1 a l := + match l with + | (@nil _) => constr:(cons a l) + | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l') + end. + +Ltac rev l := + match l with + |(@nil _) => l + | (cons ?x ?l) => let l' := rev l in append1 x l' + end. + +Ltac nsatz_call_n info nparam p rr lp kont := +(* idtac "Trying power: " rr;*) + let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in +(* idtac "calcul...";*) + nsatz_compute ll; +(* idtac "done";*) + match goal with + | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => + intros _; + let lci := fresh "lci" in + set (lci:=lci0); + let lq := fresh "lq" in + set (lq:=lq0); + kont c rr lq lci + end. + +Ltac nsatz_call radicalmax info nparam p lp kont := + let rec try_n n := + lazymatch n with + | 0%N => fail + | _ => + (let r := eval compute in (N.sub radicalmax (N.pred n)) in + nsatz_call_n info nparam p r lp kont) || + let n' := eval compute in (N.pred n) in try_n n' + end in + try_n radicalmax. + + +Ltac lterm_goal g := + match g with + ?b1 == ?b2 => constr:(b1::b2::nil) + | ?b1 == ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l) + end. + +Ltac reify_goal l le lb:= + match le with + nil => idtac + | ?e::?le1 => + match lb with + ?b::?lb1 => (* idtac "b="; idtac b;*) + let x := fresh "B" in + set (x:= b) at 1; + change x with (interpret3 e l); + clear x; + reify_goal l le1 lb1 + end + end. + +Ltac get_lpol g := + match g with + (interpret3 ?p _) == _ => constr:(p::nil) + | (interpret3 ?p _) == _ -> ?g => + let l := get_lpol g in constr:(p::l) + end. + +(** We only make use of [discrR] if [nsatz] support for reals is + loaded. To do this, we redefine this tactic in Nsatz.v to make + use of real discrimination. *) +Ltac nsatz_internal_discrR := idtac. + +Ltac nsatz_generic radicalmax info lparam lvar := + let nparam := eval compute in (Z.of_nat (List.length lparam)) in + match goal with + |- ?g => let lb := lterm_goal g in + match (match lvar with + |(@nil _) => + match lparam with + |(@nil _) => + let r := eval red in (list_reifyl (lterm:=lb)) in r + |_ => + match eval red in (list_reifyl (lterm:=lb)) with + |(?fv, ?le) => + let fv := parametres_en_tete fv lparam in + (* we reify a second time, with the good order + for variables *) + let r := eval red in + (list_reifyl (lterm:=lb) (lvar:=fv)) in r + end + end + |_ => + let fv := parametres_en_tete lvar lparam in + let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r + end) with + |(?fv, ?le) => + reify_goal fv le lb ; + match goal with + |- ?g => + let lp := get_lpol g in + let lpol := eval compute in (List.rev lp) in + intros; + + let SplitPolyList kont := + match lpol with + | ?p2::?lp2 => kont p2 lp2 + | _ => idtac "polynomial not in the ideal" + end in + + SplitPolyList ltac:(fun p lp => + let p21 := fresh "p21" in + let lp21 := fresh "lp21" in + set (p21:=p) ; + set (lp21:=lp); +(* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *) + nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => + let q := fresh "q" in + set (q := PEmul c (PEpow p21 r)); + let Hg := fresh "Hg" in + assert (Hg:check lp21 q (lci,lq) = true); + [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate" + | let Hg2 := fresh "Hg" in + assert (Hg2: (interpret3 q fv) == 0); + [ (*simpl*) idtac; + generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg); + let cc := fresh "H" in + (*simpl*) idtac; intro cc; apply cc; clear cc; + (*simpl*) idtac; + repeat (split;[assumption|idtac]); exact I + | (*simpl in Hg2;*) (*simpl*) idtac; + apply Rintegral_domain_pow with (interpret3 c fv) (N.to_nat r); + (*simpl*) idtac; + try apply integral_domain_one_zero; + try apply integral_domain_minus_one_zero; + try trivial; + try exact integral_domain_one_zero; + try exact integral_domain_minus_one_zero + || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation, + one, one_notation, multiplication, mul_notation, zero, zero_notation; + nsatz_internal_discrR || lia ]) + || ((*simpl*) idtac) || idtac "could not prove discrimination result" + ] + ] +) +) +end end end . + +Ltac nsatz_default:= + intros; + try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); + match goal with |- (@equality ?r _ _ _) => + repeat equalities_to_goal; + nsatz_generic 6%N 1%Z (@nil r) (@nil r) + end. + +Tactic Notation "nsatz" := nsatz_default. + +Tactic Notation "nsatz" "with" + "radicalmax" ":=" constr(radicalmax) + "strategy" ":=" constr(info) + "parameters" ":=" constr(lparam) + "variables" ":=" constr(lvar):= + intros; + try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _); + match goal with |- (@equality ?r _ _ _) => + repeat equalities_to_goal; + nsatz_generic radicalmax info lparam lvar + end. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 0202b3136b..745bbb7e55 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -66,7 +66,7 @@ VERBOSE ?= TIMED?= TIMECMD?= # Use command time on linux, gtime on Mac OS -TIMEFMT?="$* (real: %e, user: %U, sys: %S, mem: %M ko)" +TIMEFMT?="$@ (real: %e, user: %U, sys: %S, mem: %M ko)" ifneq (,$(TIMED)) ifeq (0,$(shell command time -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=command time -f $(TIMEFMT) 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/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 2102cd1172..e77040a8db 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -375,7 +375,7 @@ let () = define1 "constr_kind" constr begin fun c -> | Evar (evk, args) -> v_blk 3 [| Value.of_int (Evar.repr evk); - Value.of_array Value.of_constr args; + Value.of_array Value.of_constr (Array.of_list args); |] | Sort s -> v_blk 4 [|Value.of_ext Value.val_sort s|] @@ -469,7 +469,7 @@ let () = define1 "constr_make" valexpr begin fun knd -> | (3, [|evk; args|]) -> let evk = Evar.unsafe_of_int (Value.to_int evk) in let args = Value.to_array Value.to_constr args in - EConstr.mkEvar (evk, args) + EConstr.mkEvar (evk, Array.to_list args) | (4, [|s|]) -> let s = Value.to_ext Value.val_sort s in EConstr.mkSort (EConstr.Unsafe.to_sorts s) @@ -603,7 +603,7 @@ let () = define3 "constr_in_context" ident constr closure begin fun id t c -> thaw c >>= fun _ -> Proofview.Unsafe.tclSETGOALS [Proofview.with_empty_state (Proofview.Goal.goal gl)] >>= fun () -> let args = List.map (fun d -> EConstr.mkVar (get_id d)) (EConstr.named_context env) in - let args = Array.of_list (EConstr.mkRel 1 :: args) in + let args = EConstr.mkRel 1 :: args in let ans = EConstr.mkEvar (evk, args) in let ans = EConstr.mkLambda (Context.make_annot (Name id) Sorts.Relevant, t, ans) in return (Value.of_constr ans) 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/declareDef.ml b/vernac/declareDef.ml index 601e7e060c..1809c2bc91 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -112,7 +112,7 @@ let declare_mutually_recursive ~opaque ~scope ~kind ~poly ~uctx ~udecl ~ntns ~re declare_entry ~name ~scope ~kind ~impargs ~uctx entry) fixitems fixdecls in - let isfix = Option.is_empty possible_indexes in + let isfix = Option.has_some possible_indexes in let fixnames = List.map (fun { Recthm.name } -> name) fixitems in Declare.recursive_message isfix indexes fixnames; List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; 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/g_vernac.mlg b/vernac/g_vernac.mlg index 08ba49f92b..13145d3757 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -938,23 +938,23 @@ GRAMMAR EXTEND Gram | IDENT "Print"; IDENT "Table"; table = option_table -> { VernacPrintOption table } - | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 option_ref_value + | IDENT "Add"; table = IDENT; field = IDENT; v = LIST1 table_value -> { VernacAddOption ([table;field], v) } (* A global value below will be hidden by a field above! *) (* In fact, we give priority to secondary tables *) (* No syntax for tertiary tables due to conflict *) (* (but they are unused anyway) *) - | IDENT "Add"; table = IDENT; v = LIST1 option_ref_value -> + | IDENT "Add"; table = IDENT; v = LIST1 table_value -> { VernacAddOption ([table], v) } - | IDENT "Test"; table = option_table; "for"; v = LIST1 option_ref_value + | IDENT "Test"; table = option_table; "for"; v = LIST1 table_value -> { VernacMemOption (table, v) } | IDENT "Test"; table = option_table -> { VernacPrintOption table } - | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 option_ref_value + | IDENT "Remove"; table = IDENT; field = IDENT; v= LIST1 table_value -> { VernacRemoveOption ([table;field], v) } - | IDENT "Remove"; table = IDENT; v = LIST1 option_ref_value -> + | IDENT "Remove"; table = IDENT; v = LIST1 table_value -> { VernacRemoveOption ([table], v) } ]] ; query_command: (* TODO: rapprocher Eval et Check *) @@ -1047,9 +1047,9 @@ GRAMMAR EXTEND Gram | n = integer -> { OptionSetInt n } | s = STRING -> { OptionSetString s } ] ] ; - option_ref_value: - [ [ id = global -> { QualidRefValue id } - | s = STRING -> { StringRefValue s } ] ] + table_value: + [ [ id = global -> { Goptions.QualidRefValue id } + | s = STRING -> { Goptions.StringRefValue s } ] ] ; option_table: [ [ fl = LIST1 [ x = IDENT -> { x } ] -> { fl } ]] diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 5555a2c68e..fddc84b398 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -57,16 +57,16 @@ let contract3 env sigma a b c = match contract env sigma [a;b;c] with let contract4 env sigma a b c d = match contract env sigma [a;b;c;d] with | env, [a;b;c;d] -> (env,a,b,c),d | _ -> assert false -let contract1_vect env sigma a v = - match contract env sigma (a :: Array.to_list v) with - | env, a::l -> env,a,Array.of_list l +let contract1 env sigma a v = + match contract env sigma (a :: v) with + | env, a::l -> env,a,l | _ -> assert false let rec contract3' env sigma a b c = function | OccurCheck (evk,d) -> let x,d = contract4 env sigma a b c d in x,OccurCheck(evk, d) | NotClean ((evk,args),env',d) -> - let env',d,args = contract1_vect env' sigma d args in + let env',d,args = contract1 env' sigma d args in contract3 env sigma a b c,NotClean((evk,args),env',d) | ConversionFailed (env',t1,t2) -> let (env',t1,t2) = contract2 env' sigma t1 t2 in @@ -299,9 +299,9 @@ let explain_unification_error env sigma p1 p2 = function [str "cannot instantiate " ++ quote (pr_existential_key sigma evk) ++ strbrk " because " ++ pr_leconstr_env env sigma c ++ strbrk " is not in its scope" ++ - (if Array.is_empty args then mt() else + (if List.is_empty args then mt() else strbrk ": available arguments are " ++ - pr_sequence (pr_leconstr_env env sigma) (List.rev (Array.to_list args)))] + pr_sequence (pr_leconstr_env env sigma) (List.rev args))] | NotSameArgSize | NotSameHead | NoCanonicalStructure -> (* Error speaks from itself *) [] | ConversionFailed (env,t1,t2) -> 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/library.ml b/vernac/library.ml index 01f5101764..35b2a18871 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -20,11 +20,11 @@ open Libobject (*s Low-level interning/externing of libraries to files *) let raw_extern_library f = - System.raw_extern_state Coq_config.vo_magic_number f + ObjFile.open_out ~file:f let raw_intern_library f = System.with_magic_number_check - (System.raw_intern_state Coq_config.vo_magic_number) f + (fun file -> ObjFile.open_in ~file) f (************************************************************************) (** Serialized objects loaded on-the-fly *) @@ -35,7 +35,7 @@ module Delayed : sig type 'a delayed -val in_delayed : string -> in_channel -> 'a delayed * Digest.t +val in_delayed : string -> ObjFile.in_handle -> segment:string -> 'a delayed * Digest.t val fetch_delayed : 'a delayed -> 'a end = @@ -43,14 +43,14 @@ struct type 'a delayed = { del_file : string; - del_off : int; + del_off : int64; del_digest : Digest.t; } -let in_delayed f ch = - let pos = pos_in ch in - let _, digest = System.skip_in_segment f ch in - ({ del_file = f; del_digest = digest; del_off = pos; }, digest) +let in_delayed f ch ~segment = + let seg = ObjFile.get_segment ch ~segment in + let digest = seg.ObjFile.hash in + { del_file = f; del_digest = digest; del_off = seg.ObjFile.pos; }, digest (** Fetching a table of opaque terms at position [pos] in file [f], expecting to find first a copy of [digest]. *) @@ -58,10 +58,10 @@ let in_delayed f ch = let fetch_delayed del = let { del_digest = digest; del_file = f; del_off = pos; } = del in try - let ch = raw_intern_library f in - let () = seek_in ch pos in - let obj, _, digest' = System.marshal_in_segment f ch in - let () = close_in ch in + let ch = open_in_bin f in + let () = LargeFile.seek_in ch pos in + let obj = System.marshal_in f ch in + let digest' = Digest.input ch in if not (String.equal digest digest') then raise (Faulty f); obj with e when CErrors.noncritical e -> raise (Faulty f) @@ -242,12 +242,11 @@ let mk_summary m = { let intern_from_file f = let ch = raw_intern_library f in - let (lsd : seg_sum), _, digest_lsd = System.marshal_in_segment f ch in - let ((lmd : seg_lib delayed), digest_lmd) = in_delayed f ch in - let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in - let _ = System.skip_in_segment f ch in - let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch in - close_in ch; + let (lsd : seg_sum), digest_lsd = ObjFile.marshal_in_segment ch ~segment:"summary" in + let ((lmd : seg_lib delayed), digest_lmd) = in_delayed f ch ~segment:"library" in + let (univs : seg_univ option), digest_u = ObjFile.marshal_in_segment ch ~segment:"universes" in + let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch ~segment:"opaques" in + ObjFile.close_in ch; register_library_filename lsd.md_name f; add_opaque_table lsd.md_name (ToFetch del_opaque); let open Safe_typing in @@ -297,7 +296,7 @@ let rec_intern_library ~lib_resolver libs (dir, f) = let native_name_from_filename f = let ch = raw_intern_library f in - let (lmd : seg_sum), pos, digest_lmd = System.marshal_in_segment f ch in + let (lmd : seg_sum), digest_lmd = ObjFile.marshal_in_segment ch ~segment:"summary" in Nativecode.mod_uid_of_dirpath lmd.md_name (**********************************************************************) @@ -392,12 +391,12 @@ let require_library_from_dirpath ~lib_resolver modrefl export = let load_library_todo f = let ch = raw_intern_library f in - let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in - let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in - let (s2 : seg_univ option), _, _ = System.marshal_in_segment f ch in - let tasks, _, _ = System.marshal_in_segment f ch in - let (s4 : seg_proofs), _, _ = System.marshal_in_segment f ch in - close_in ch; + let (s0 : seg_sum), _ = ObjFile.marshal_in_segment ch ~segment:"summary" in + let (s1 : seg_lib), _ = ObjFile.marshal_in_segment ch ~segment:"library" in + let (s2 : seg_univ option), _ = ObjFile.marshal_in_segment ch ~segment:"universes" in + let tasks, _ = ObjFile.marshal_in_segment ch ~segment:"tasks" in + let (s4 : seg_proofs), _ = ObjFile.marshal_in_segment ch ~segment:"opaques" in + ObjFile.close_in ch; if tasks = None then user_err ~hdr:"restart" (str"not a .vio file"); if s2 = None then user_err ~hdr:"restart" (str"not a .vio file"); if snd (Option.get s2) then user_err ~hdr:"restart" (str"not a .vio file"); @@ -433,15 +432,15 @@ let error_recursively_dependent_library dir = let save_library_base f sum lib univs tasks proofs = let ch = raw_extern_library f in try - System.marshal_out_segment f ch (sum : seg_sum); - System.marshal_out_segment f ch (lib : seg_lib); - System.marshal_out_segment f ch (univs : seg_univ option); - System.marshal_out_segment f ch (tasks : 'tasks option); - System.marshal_out_segment f ch (proofs : seg_proofs); - close_out ch + ObjFile.marshal_out_segment ch ~segment:"summary" (sum : seg_sum); + ObjFile.marshal_out_segment ch ~segment:"library" (lib : seg_lib); + ObjFile.marshal_out_segment ch ~segment:"universes" (univs : seg_univ option); + ObjFile.marshal_out_segment ch ~segment:"tasks" (tasks : 'tasks option); + ObjFile.marshal_out_segment ch ~segment:"opaques" (proofs : seg_proofs); + ObjFile.close_out ch with reraise -> let reraise = Exninfo.capture reraise in - close_out ch; + ObjFile.close_out ch; Feedback.msg_warning (str "Removed file " ++ str f); Sys.remove f; Exninfo.iraise reraise diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 7a2e6d8b03..f1aae239aa 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -168,8 +168,8 @@ open Pputils keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search sl ++ pr_in_out_modules b let pr_option_ref_value = function - | QualidRefValue id -> pr_qualid id - | StringRefValue s -> qs s + | Goptions.QualidRefValue id -> pr_qualid id + | Goptions.StringRefValue s -> qs s let pr_printoption table b = prlist_with_sep spc str table ++ @@ -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/retrieveObl.ml b/vernac/retrieveObl.ml index c529972b8d..b8564037e0 100644 --- a/vernac/retrieveObl.ml +++ b/vernac/retrieveObl.ml @@ -72,7 +72,7 @@ let subst_evar_constr evm evs n idf t = *) let args = let n = match chop with None -> 0 | Some c -> c in - let l, r = CList.chop n (List.rev (Array.to_list args)) in + let l, r = CList.chop n (List.rev args) in List.rev r in let args = 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 044e479aeb..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"]; @@ -1554,26 +1562,11 @@ let vernac_set_option ~locality table v = match v with vernac_set_option0 ~locality table v | _ -> vernac_set_option0 ~locality table v -let vernac_add_option key lv = - let f = function - | StringRefValue s -> (get_string_table key).add (Global.env()) s - | QualidRefValue locqid -> (get_ref_table key).add (Global.env()) locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key +let vernac_add_option = iter_table { aux = fun table -> table.add } -let vernac_remove_option key lv = - let f = function - | StringRefValue s -> (get_string_table key).remove (Global.env()) s - | QualidRefValue locqid -> (get_ref_table key).remove (Global.env()) locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key +let vernac_remove_option = iter_table { aux = fun table -> table.remove } -let vernac_mem_option key lv = - let f = function - | StringRefValue s -> (get_string_table key).mem (Global.env()) s - | QualidRefValue locqid -> (get_ref_table key).mem (Global.env()) locqid - in - try List.iter f lv with Not_found -> error_undeclared_key key +let vernac_mem_option = iter_table { aux = fun table -> table.mem } let vernac_print_option key = try (get_ref_table key).print () @@ -1734,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 c32ac414ba..b65a0da1cc 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -121,10 +121,6 @@ type option_setting = | OptionSetInt of int | OptionSetString of string -type option_ref_value = - | StringRefValue of string - | QualidRefValue of qualid - (** Identifier and optional list of bound universes and constraints. *) type sort_expr = Sorts.family @@ -340,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 *) @@ -391,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 @@ -406,9 +402,9 @@ type nonrec vernac_expr = | VernacSetStrategy of (Conv_oracle.level * qualid or_by_notation list) list | VernacSetOption of bool (* Export modifier? *) * Goptions.option_name * option_setting - | VernacAddOption of Goptions.option_name * option_ref_value list - | VernacRemoveOption of Goptions.option_name * option_ref_value list - | VernacMemOption of Goptions.option_name * option_ref_value list + | VernacAddOption of Goptions.option_name * Goptions.table_value list + | VernacRemoveOption of Goptions.option_name * Goptions.table_value list + | VernacMemOption of Goptions.option_name * Goptions.table_value list | VernacPrintOption of Goptions.option_name | VernacCheckMayEval of Genredexpr.raw_red_expr option * Goal_select.t option * constr_expr | VernacGlobalCheck of constr_expr |